1 /* Declaration statement matcher
2 Copyright (C) 2002-2018 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
;
59 /* The current binding label (if any). */
60 static const char* curr_binding_label
;
61 /* Need to know how many identifiers are on the current data declaration
62 line in case we're given the BIND(C) attribute with a NAME= specifier. */
63 static int num_idents_on_line
;
64 /* Need to know if a NAME= specifier was found during gfc_match_bind_c so we
65 can supply a name if the curr_binding_label is nil and NAME= was not. */
66 static int has_name_equals
= 0;
68 /* Initializer of the previous enumerator. */
70 static gfc_expr
*last_initializer
;
72 /* History of all the enumerators is maintained, so that
73 kind values of all the enumerators could be updated depending
74 upon the maximum initialized value. */
76 typedef struct enumerator_history
79 gfc_expr
*initializer
;
80 struct enumerator_history
*next
;
84 /* Header of enum history chain. */
86 static enumerator_history
*enum_history
= NULL
;
88 /* Pointer of enum history node containing largest initializer. */
90 static enumerator_history
*max_enum
= NULL
;
92 /* gfc_new_block points to the symbol of a newly matched block. */
94 gfc_symbol
*gfc_new_block
;
96 bool gfc_matching_function
;
98 /* Set upon parsing a !GCC$ unroll n directive for use in the next loop. */
99 int directive_unroll
= -1;
101 /* If a kind expression of a component of a parameterized derived type is
102 parameterized, temporarily store the expression here. */
103 static gfc_expr
*saved_kind_expr
= NULL
;
105 /* Used to store the parameter list arising in a PDT declaration and
106 in the typespec of a PDT variable or component. */
107 static gfc_actual_arglist
*decl_type_param_list
;
108 static gfc_actual_arglist
*type_param_spec_list
;
110 /********************* DATA statement subroutines *********************/
112 static bool in_match_data
= false;
115 gfc_in_match_data (void)
117 return in_match_data
;
121 set_in_match_data (bool set_value
)
123 in_match_data
= set_value
;
126 /* Free a gfc_data_variable structure and everything beneath it. */
129 free_variable (gfc_data_variable
*p
)
131 gfc_data_variable
*q
;
136 gfc_free_expr (p
->expr
);
137 gfc_free_iterator (&p
->iter
, 0);
138 free_variable (p
->list
);
144 /* Free a gfc_data_value structure and everything beneath it. */
147 free_value (gfc_data_value
*p
)
154 mpz_clear (p
->repeat
);
155 gfc_free_expr (p
->expr
);
161 /* Free a list of gfc_data structures. */
164 gfc_free_data (gfc_data
*p
)
171 free_variable (p
->var
);
172 free_value (p
->value
);
178 /* Free all data in a namespace. */
181 gfc_free_data_all (gfc_namespace
*ns
)
193 /* Reject data parsed since the last restore point was marked. */
196 gfc_reject_data (gfc_namespace
*ns
)
200 while (ns
->data
&& ns
->data
!= ns
->old_data
)
208 static match
var_element (gfc_data_variable
*);
210 /* Match a list of variables terminated by an iterator and a right
214 var_list (gfc_data_variable
*parent
)
216 gfc_data_variable
*tail
, var
;
219 m
= var_element (&var
);
220 if (m
== MATCH_ERROR
)
225 tail
= gfc_get_data_variable ();
232 if (gfc_match_char (',') != MATCH_YES
)
235 m
= gfc_match_iterator (&parent
->iter
, 1);
238 if (m
== MATCH_ERROR
)
241 m
= var_element (&var
);
242 if (m
== MATCH_ERROR
)
247 tail
->next
= gfc_get_data_variable ();
253 if (gfc_match_char (')') != MATCH_YES
)
258 gfc_syntax_error (ST_DATA
);
263 /* Match a single element in a data variable list, which can be a
264 variable-iterator list. */
267 var_element (gfc_data_variable
*new_var
)
272 memset (new_var
, 0, sizeof (gfc_data_variable
));
274 if (gfc_match_char ('(') == MATCH_YES
)
275 return var_list (new_var
);
277 m
= gfc_match_variable (&new_var
->expr
, 0);
281 sym
= new_var
->expr
->symtree
->n
.sym
;
283 /* Symbol should already have an associated type. */
284 if (!gfc_check_symbol_typed (sym
, gfc_current_ns
, false, gfc_current_locus
))
287 if (!sym
->attr
.function
&& gfc_current_ns
->parent
288 && gfc_current_ns
->parent
== sym
->ns
)
290 gfc_error ("Host associated variable %qs may not be in the DATA "
291 "statement at %C", sym
->name
);
295 if (gfc_current_state () != COMP_BLOCK_DATA
296 && sym
->attr
.in_common
297 && !gfc_notify_std (GFC_STD_GNU
, "initialization of "
298 "common block variable %qs in DATA statement at %C",
302 if (!gfc_add_data (&sym
->attr
, sym
->name
, &new_var
->expr
->where
))
309 /* Match the top-level list of data variables. */
312 top_var_list (gfc_data
*d
)
314 gfc_data_variable var
, *tail
, *new_var
;
321 m
= var_element (&var
);
324 if (m
== MATCH_ERROR
)
327 new_var
= gfc_get_data_variable ();
333 tail
->next
= new_var
;
337 if (gfc_match_char ('/') == MATCH_YES
)
339 if (gfc_match_char (',') != MATCH_YES
)
346 gfc_syntax_error (ST_DATA
);
347 gfc_free_data_all (gfc_current_ns
);
353 match_data_constant (gfc_expr
**result
)
355 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
356 gfc_symbol
*sym
, *dt_sym
= NULL
;
361 m
= gfc_match_literal_constant (&expr
, 1);
368 if (m
== MATCH_ERROR
)
371 m
= gfc_match_null (result
);
375 old_loc
= gfc_current_locus
;
377 /* Should this be a structure component, try to match it
378 before matching a name. */
379 m
= gfc_match_rvalue (result
);
380 if (m
== MATCH_ERROR
)
383 if (m
== MATCH_YES
&& (*result
)->expr_type
== EXPR_STRUCTURE
)
385 if (!gfc_simplify_expr (*result
, 0))
389 else if (m
== MATCH_YES
)
390 gfc_free_expr (*result
);
392 gfc_current_locus
= old_loc
;
394 m
= gfc_match_name (name
);
398 if (gfc_find_symbol (name
, NULL
, 1, &sym
))
401 if (sym
&& sym
->attr
.generic
)
402 dt_sym
= gfc_find_dt_in_generic (sym
);
405 || (sym
->attr
.flavor
!= FL_PARAMETER
406 && (!dt_sym
|| !gfc_fl_struct (dt_sym
->attr
.flavor
))))
408 gfc_error ("Symbol %qs must be a PARAMETER in DATA statement at %C",
413 else if (dt_sym
&& gfc_fl_struct (dt_sym
->attr
.flavor
))
414 return gfc_match_structure_constructor (dt_sym
, result
);
416 /* Check to see if the value is an initialization array expression. */
417 if (sym
->value
->expr_type
== EXPR_ARRAY
)
419 gfc_current_locus
= old_loc
;
421 m
= gfc_match_init_expr (result
);
422 if (m
== MATCH_ERROR
)
427 if (!gfc_simplify_expr (*result
, 0))
430 if ((*result
)->expr_type
== EXPR_CONSTANT
)
434 gfc_error ("Invalid initializer %s in Data statement at %C", name
);
440 *result
= gfc_copy_expr (sym
->value
);
445 /* Match a list of values in a DATA statement. The leading '/' has
446 already been seen at this point. */
449 top_val_list (gfc_data
*data
)
451 gfc_data_value
*new_val
, *tail
;
459 m
= match_data_constant (&expr
);
462 if (m
== MATCH_ERROR
)
465 new_val
= gfc_get_data_value ();
466 mpz_init (new_val
->repeat
);
469 data
->value
= new_val
;
471 tail
->next
= new_val
;
475 if (expr
->ts
.type
!= BT_INTEGER
|| gfc_match_char ('*') != MATCH_YES
)
478 mpz_set_ui (tail
->repeat
, 1);
482 mpz_set (tail
->repeat
, expr
->value
.integer
);
483 gfc_free_expr (expr
);
485 m
= match_data_constant (&tail
->expr
);
488 if (m
== MATCH_ERROR
)
492 if (gfc_match_char ('/') == MATCH_YES
)
494 if (gfc_match_char (',') == MATCH_NO
)
501 gfc_syntax_error (ST_DATA
);
502 gfc_free_data_all (gfc_current_ns
);
507 /* Matches an old style initialization. */
510 match_old_style_init (const char *name
)
517 /* Set up data structure to hold initializers. */
518 gfc_find_sym_tree (name
, NULL
, 0, &st
);
521 newdata
= gfc_get_data ();
522 newdata
->var
= gfc_get_data_variable ();
523 newdata
->var
->expr
= gfc_get_variable_expr (st
);
524 newdata
->where
= gfc_current_locus
;
526 /* Match initial value list. This also eats the terminal '/'. */
527 m
= top_val_list (newdata
);
536 gfc_error ("Initialization at %C is not allowed in a PURE procedure");
540 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
542 /* Mark the variable as having appeared in a data statement. */
543 if (!gfc_add_data (&sym
->attr
, sym
->name
, &sym
->declared_at
))
549 /* Chain in namespace list of DATA initializers. */
550 newdata
->next
= gfc_current_ns
->data
;
551 gfc_current_ns
->data
= newdata
;
557 /* Match the stuff following a DATA statement. If ERROR_FLAG is set,
558 we are matching a DATA statement and are therefore issuing an error
559 if we encounter something unexpected, if not, we're trying to match
560 an old-style initialization expression of the form INTEGER I /2/. */
563 gfc_match_data (void)
568 /* Before parsing the rest of a DATA statement, check F2008:c1206. */
569 if ((gfc_current_state () == COMP_FUNCTION
570 || gfc_current_state () == COMP_SUBROUTINE
)
571 && gfc_state_stack
->previous
->state
== COMP_INTERFACE
)
573 gfc_error ("DATA statement at %C cannot appear within an INTERFACE");
577 set_in_match_data (true);
581 new_data
= gfc_get_data ();
582 new_data
->where
= gfc_current_locus
;
584 m
= top_var_list (new_data
);
588 if (new_data
->var
->iter
.var
589 && new_data
->var
->iter
.var
->ts
.type
== BT_INTEGER
590 && new_data
->var
->iter
.var
->symtree
->n
.sym
->attr
.implied_index
== 1
591 && new_data
->var
->list
592 && new_data
->var
->list
->expr
593 && new_data
->var
->list
->expr
->ts
.type
== BT_CHARACTER
594 && new_data
->var
->list
->expr
->ref
595 && new_data
->var
->list
->expr
->ref
->type
== REF_SUBSTRING
)
597 gfc_error ("Invalid substring in data-implied-do at %L in DATA "
598 "statement", &new_data
->var
->list
->expr
->where
);
602 m
= top_val_list (new_data
);
606 new_data
->next
= gfc_current_ns
->data
;
607 gfc_current_ns
->data
= new_data
;
609 if (gfc_match_eos () == MATCH_YES
)
612 gfc_match_char (','); /* Optional comma */
615 set_in_match_data (false);
619 gfc_error ("DATA statement at %C is not allowed in a PURE procedure");
622 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
627 set_in_match_data (false);
628 gfc_free_data (new_data
);
633 /************************ Declaration statements *********************/
636 /* Like gfc_match_init_expr, but matches a 'clist' (old-style initialization
637 list). The difference here is the expression is a list of constants
638 and is surrounded by '/'.
639 The typespec ts must match the typespec of the variable which the
640 clist is initializing.
641 The arrayspec tells whether this should match a list of constants
642 corresponding to array elements or a scalar (as == NULL). */
645 match_clist_expr (gfc_expr
**result
, gfc_typespec
*ts
, gfc_array_spec
*as
)
647 gfc_constructor_base array_head
= NULL
;
648 gfc_expr
*expr
= NULL
;
651 mpz_t repeat
, cons_size
, as_size
;
657 mpz_init_set_ui (repeat
, 0);
658 scalar
= !as
|| !as
->rank
;
660 /* We have already matched '/' - now look for a constant list, as with
661 top_val_list from decl.c, but append the result to an array. */
662 if (gfc_match ("/") == MATCH_YES
)
664 gfc_error ("Empty old style initializer list at %C");
668 where
= gfc_current_locus
;
671 m
= match_data_constant (&expr
);
673 expr
= NULL
; /* match_data_constant may set expr to garbage */
676 if (m
== MATCH_ERROR
)
679 /* Found r in repeat spec r*c; look for the constant to repeat. */
680 if ( gfc_match_char ('*') == MATCH_YES
)
684 gfc_error ("Repeat spec invalid in scalar initializer at %C");
687 if (expr
->ts
.type
!= BT_INTEGER
)
689 gfc_error ("Repeat spec must be an integer at %C");
692 mpz_set (repeat
, expr
->value
.integer
);
693 gfc_free_expr (expr
);
696 m
= match_data_constant (&expr
);
698 gfc_error ("Expected data constant after repeat spec at %C");
702 /* No repeat spec, we matched the data constant itself. */
704 mpz_set_ui (repeat
, 1);
708 /* Add the constant initializer as many times as repeated. */
709 for (; mpz_cmp_ui (repeat
, 0) > 0; mpz_sub_ui (repeat
, repeat
, 1))
711 /* Make sure types of elements match */
712 if(ts
&& !gfc_compare_types (&expr
->ts
, ts
)
713 && !gfc_convert_type (expr
, ts
, 1))
716 gfc_constructor_append_expr (&array_head
,
717 gfc_copy_expr (expr
), &gfc_current_locus
);
720 gfc_free_expr (expr
);
724 /* For scalar initializers quit after one element. */
727 if(gfc_match_char ('/') != MATCH_YES
)
729 gfc_error ("End of scalar initializer expected at %C");
735 if (gfc_match_char ('/') == MATCH_YES
)
737 if (gfc_match_char (',') == MATCH_NO
)
741 /* Set up expr as an array constructor. */
744 expr
= gfc_get_array_expr (ts
->type
, ts
->kind
, &where
);
746 expr
->value
.constructor
= array_head
;
748 expr
->rank
= as
->rank
;
749 expr
->shape
= gfc_get_shape (expr
->rank
);
751 /* Validate sizes. We built expr ourselves, so cons_size will be
752 constant (we fail above for non-constant expressions).
753 We still need to verify that the array-spec has constant size. */
755 gcc_assert (gfc_array_size (expr
, &cons_size
));
756 if (!spec_size (as
, &as_size
))
758 gfc_error ("Expected constant array-spec in initializer list at %L",
759 as
->type
== AS_EXPLICIT
? &as
->upper
[0]->where
: &where
);
764 /* Make sure the specs are of the same size. */
765 cmp
= mpz_cmp (cons_size
, as_size
);
767 gfc_error ("Not enough elements in array initializer at %C");
769 gfc_error ("Too many elements in array initializer at %C");
772 mpz_clear (cons_size
);
777 /* Make sure scalar types match. */
778 else if (!gfc_compare_types (&expr
->ts
, ts
)
779 && !gfc_convert_type (expr
, ts
, 1))
783 expr
->ts
.u
.cl
->length_from_typespec
= 1;
790 gfc_error ("Syntax error in old style initializer list at %C");
794 expr
->value
.constructor
= NULL
;
795 gfc_free_expr (expr
);
796 gfc_constructor_free (array_head
);
802 /* Auxiliary function to merge DIMENSION and CODIMENSION array specs. */
805 merge_array_spec (gfc_array_spec
*from
, gfc_array_spec
*to
, bool copy
)
809 if ((from
->type
== AS_ASSUMED_RANK
&& to
->corank
)
810 || (to
->type
== AS_ASSUMED_RANK
&& from
->corank
))
812 gfc_error ("The assumed-rank array at %C shall not have a codimension");
816 if (to
->rank
== 0 && from
->rank
> 0)
818 to
->rank
= from
->rank
;
819 to
->type
= from
->type
;
820 to
->cray_pointee
= from
->cray_pointee
;
821 to
->cp_was_assumed
= from
->cp_was_assumed
;
823 for (i
= 0; i
< to
->corank
; i
++)
825 to
->lower
[from
->rank
+ i
] = to
->lower
[i
];
826 to
->upper
[from
->rank
+ i
] = to
->upper
[i
];
828 for (i
= 0; i
< from
->rank
; i
++)
832 to
->lower
[i
] = gfc_copy_expr (from
->lower
[i
]);
833 to
->upper
[i
] = gfc_copy_expr (from
->upper
[i
]);
837 to
->lower
[i
] = from
->lower
[i
];
838 to
->upper
[i
] = from
->upper
[i
];
842 else if (to
->corank
== 0 && from
->corank
> 0)
844 to
->corank
= from
->corank
;
845 to
->cotype
= from
->cotype
;
847 for (i
= 0; i
< from
->corank
; i
++)
851 to
->lower
[to
->rank
+ i
] = gfc_copy_expr (from
->lower
[i
]);
852 to
->upper
[to
->rank
+ i
] = gfc_copy_expr (from
->upper
[i
]);
856 to
->lower
[to
->rank
+ i
] = from
->lower
[i
];
857 to
->upper
[to
->rank
+ i
] = from
->upper
[i
];
866 /* Match an intent specification. Since this can only happen after an
867 INTENT word, a legal intent-spec must follow. */
870 match_intent_spec (void)
873 if (gfc_match (" ( in out )") == MATCH_YES
)
875 if (gfc_match (" ( in )") == MATCH_YES
)
877 if (gfc_match (" ( out )") == MATCH_YES
)
880 gfc_error ("Bad INTENT specification at %C");
881 return INTENT_UNKNOWN
;
885 /* Matches a character length specification, which is either a
886 specification expression, '*', or ':'. */
889 char_len_param_value (gfc_expr
**expr
, bool *deferred
)
896 if (gfc_match_char ('*') == MATCH_YES
)
899 if (gfc_match_char (':') == MATCH_YES
)
901 if (!gfc_notify_std (GFC_STD_F2003
, "deferred type parameter at %C"))
909 m
= gfc_match_expr (expr
);
911 if (m
== MATCH_NO
|| m
== MATCH_ERROR
)
914 if (!gfc_expr_check_typed (*expr
, gfc_current_ns
, false))
917 if ((*expr
)->expr_type
== EXPR_FUNCTION
)
919 if ((*expr
)->ts
.type
== BT_INTEGER
920 || ((*expr
)->ts
.type
== BT_UNKNOWN
921 && strcmp((*expr
)->symtree
->name
, "null") != 0))
926 else if ((*expr
)->expr_type
== EXPR_CONSTANT
)
928 /* F2008, 4.4.3.1: The length is a type parameter; its kind is
929 processor dependent and its value is greater than or equal to zero.
930 F2008, 4.4.3.2: If the character length parameter value evaluates
931 to a negative value, the length of character entities declared
934 if ((*expr
)->ts
.type
== BT_INTEGER
)
936 if (mpz_cmp_si ((*expr
)->value
.integer
, 0) < 0)
937 mpz_set_si ((*expr
)->value
.integer
, 0);
942 else if ((*expr
)->expr_type
== EXPR_ARRAY
)
944 else if ((*expr
)->expr_type
== EXPR_VARIABLE
)
949 e
= gfc_copy_expr (*expr
);
951 /* This catches the invalid code "[character(m(2:3)) :: 'x', 'y']",
952 which causes an ICE if gfc_reduce_init_expr() is called. */
953 if (e
->ref
&& e
->ref
->type
== REF_ARRAY
954 && e
->ref
->u
.ar
.type
== AR_UNKNOWN
955 && e
->ref
->u
.ar
.dimen_type
[0] == DIMEN_RANGE
)
958 t
= gfc_reduce_init_expr (e
);
960 if (!t
&& e
->ts
.type
== BT_UNKNOWN
961 && e
->symtree
->n
.sym
->attr
.untyped
== 1
962 && (flag_implicit_none
963 || e
->symtree
->n
.sym
->ns
->seen_implicit_none
== 1
964 || e
->symtree
->n
.sym
->ns
->parent
->seen_implicit_none
== 1))
970 if ((e
->ref
&& e
->ref
->type
== REF_ARRAY
971 && e
->ref
->u
.ar
.type
!= AR_ELEMENT
)
972 || (!e
->ref
&& e
->expr_type
== EXPR_ARRAY
))
984 gfc_error ("Scalar INTEGER expression expected at %L", &(*expr
)->where
);
989 /* A character length is a '*' followed by a literal integer or a
990 char_len_param_value in parenthesis. */
993 match_char_length (gfc_expr
**expr
, bool *deferred
, bool obsolescent_check
)
999 m
= gfc_match_char ('*');
1003 m
= gfc_match_small_literal_int (&length
, NULL
);
1004 if (m
== MATCH_ERROR
)
1009 if (obsolescent_check
1010 && !gfc_notify_std (GFC_STD_F95_OBS
, "Old-style character length at %C"))
1012 *expr
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
, length
);
1016 if (gfc_match_char ('(') == MATCH_NO
)
1019 m
= char_len_param_value (expr
, deferred
);
1020 if (m
!= MATCH_YES
&& gfc_matching_function
)
1022 gfc_undo_symbols ();
1026 if (m
== MATCH_ERROR
)
1031 if (gfc_match_char (')') == MATCH_NO
)
1033 gfc_free_expr (*expr
);
1041 gfc_error ("Syntax error in character length specification at %C");
1046 /* Special subroutine for finding a symbol. Check if the name is found
1047 in the current name space. If not, and we're compiling a function or
1048 subroutine and the parent compilation unit is an interface, then check
1049 to see if the name we've been given is the name of the interface
1050 (located in another namespace). */
1053 find_special (const char *name
, gfc_symbol
**result
, bool allow_subroutine
)
1059 i
= gfc_get_sym_tree (name
, NULL
, &st
, allow_subroutine
);
1062 *result
= st
? st
->n
.sym
: NULL
;
1066 if (gfc_current_state () != COMP_SUBROUTINE
1067 && gfc_current_state () != COMP_FUNCTION
)
1070 s
= gfc_state_stack
->previous
;
1074 if (s
->state
!= COMP_INTERFACE
)
1077 goto end
; /* Nameless interface. */
1079 if (strcmp (name
, s
->sym
->name
) == 0)
1090 /* Special subroutine for getting a symbol node associated with a
1091 procedure name, used in SUBROUTINE and FUNCTION statements. The
1092 symbol is created in the parent using with symtree node in the
1093 child unit pointing to the symbol. If the current namespace has no
1094 parent, then the symbol is just created in the current unit. */
1097 get_proc_name (const char *name
, gfc_symbol
**result
, bool module_fcn_entry
)
1103 /* Module functions have to be left in their own namespace because
1104 they have potentially (almost certainly!) already been referenced.
1105 In this sense, they are rather like external functions. This is
1106 fixed up in resolve.c(resolve_entries), where the symbol name-
1107 space is set to point to the master function, so that the fake
1108 result mechanism can work. */
1109 if (module_fcn_entry
)
1111 /* Present if entry is declared to be a module procedure. */
1112 rc
= gfc_find_symbol (name
, gfc_current_ns
->parent
, 0, result
);
1114 if (*result
== NULL
)
1115 rc
= gfc_get_symbol (name
, NULL
, result
);
1116 else if (!gfc_get_symbol (name
, NULL
, &sym
) && sym
1117 && (*result
)->ts
.type
== BT_UNKNOWN
1118 && sym
->attr
.flavor
== FL_UNKNOWN
)
1119 /* Pick up the typespec for the entry, if declared in the function
1120 body. Note that this symbol is FL_UNKNOWN because it will
1121 only have appeared in a type declaration. The local symtree
1122 is set to point to the module symbol and a unique symtree
1123 to the local version. This latter ensures a correct clearing
1126 /* If the ENTRY proceeds its specification, we need to ensure
1127 that this does not raise a "has no IMPLICIT type" error. */
1128 if (sym
->ts
.type
== BT_UNKNOWN
)
1129 sym
->attr
.untyped
= 1;
1131 (*result
)->ts
= sym
->ts
;
1133 /* Put the symbol in the procedure namespace so that, should
1134 the ENTRY precede its specification, the specification
1136 (*result
)->ns
= gfc_current_ns
;
1138 gfc_find_sym_tree (name
, gfc_current_ns
, 0, &st
);
1139 st
->n
.sym
= *result
;
1140 st
= gfc_get_unique_symtree (gfc_current_ns
);
1146 rc
= gfc_get_symbol (name
, gfc_current_ns
->parent
, result
);
1152 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
1155 if (sym
->attr
.module_procedure
1156 && sym
->attr
.if_source
== IFSRC_IFBODY
)
1158 /* Create a partially populated interface symbol to carry the
1159 characteristics of the procedure and the result. */
1160 sym
->tlink
= gfc_new_symbol (name
, sym
->ns
);
1161 gfc_add_type (sym
->tlink
, &(sym
->ts
),
1162 &gfc_current_locus
);
1163 gfc_copy_attr (&sym
->tlink
->attr
, &sym
->attr
, NULL
);
1164 if (sym
->attr
.dimension
)
1165 sym
->tlink
->as
= gfc_copy_array_spec (sym
->as
);
1167 /* Ideally, at this point, a copy would be made of the formal
1168 arguments and their namespace. However, this does not appear
1169 to be necessary, albeit at the expense of not being able to
1170 use gfc_compare_interfaces directly. */
1172 if (sym
->result
&& sym
->result
!= sym
)
1174 sym
->tlink
->result
= sym
->result
;
1177 else if (sym
->result
)
1179 sym
->tlink
->result
= sym
->tlink
;
1182 else if (sym
&& !sym
->gfc_new
1183 && gfc_current_state () != COMP_INTERFACE
)
1185 /* Trap another encompassed procedure with the same name. All
1186 these conditions are necessary to avoid picking up an entry
1187 whose name clashes with that of the encompassing procedure;
1188 this is handled using gsymbols to register unique, globally
1189 accessible names. */
1190 if (sym
->attr
.flavor
!= 0
1191 && sym
->attr
.proc
!= 0
1192 && (sym
->attr
.subroutine
|| sym
->attr
.function
)
1193 && sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
1194 gfc_error_now ("Procedure %qs at %C is already defined at %L",
1195 name
, &sym
->declared_at
);
1197 /* Trap a procedure with a name the same as interface in the
1198 encompassing scope. */
1199 if (sym
->attr
.generic
!= 0
1200 && (sym
->attr
.subroutine
|| sym
->attr
.function
)
1201 && !sym
->attr
.mod_proc
)
1202 gfc_error_now ("Name %qs at %C is already defined"
1203 " as a generic interface at %L",
1204 name
, &sym
->declared_at
);
1206 /* Trap declarations of attributes in encompassing scope. The
1207 signature for this is that ts.kind is set. Legitimate
1208 references only set ts.type. */
1209 if (sym
->ts
.kind
!= 0
1210 && !sym
->attr
.implicit_type
1211 && sym
->attr
.proc
== 0
1212 && gfc_current_ns
->parent
!= NULL
1213 && sym
->attr
.access
== 0
1214 && !module_fcn_entry
)
1215 gfc_error_now ("Procedure %qs at %C has an explicit interface "
1216 "and must not have attributes declared at %L",
1217 name
, &sym
->declared_at
);
1220 if (gfc_current_ns
->parent
== NULL
|| *result
== NULL
)
1223 /* Module function entries will already have a symtree in
1224 the current namespace but will need one at module level. */
1225 if (module_fcn_entry
)
1227 /* Present if entry is declared to be a module procedure. */
1228 rc
= gfc_find_sym_tree (name
, gfc_current_ns
->parent
, 0, &st
);
1230 st
= gfc_new_symtree (&gfc_current_ns
->parent
->sym_root
, name
);
1233 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, name
);
1238 /* See if the procedure should be a module procedure. */
1240 if (((sym
->ns
->proc_name
!= NULL
1241 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
1242 && sym
->attr
.proc
!= PROC_MODULE
)
1243 || (module_fcn_entry
&& sym
->attr
.proc
!= PROC_MODULE
))
1244 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
1251 /* Verify that the given symbol representing a parameter is C
1252 interoperable, by checking to see if it was marked as such after
1253 its declaration. If the given symbol is not interoperable, a
1254 warning is reported, thus removing the need to return the status to
1255 the calling function. The standard does not require the user use
1256 one of the iso_c_binding named constants to declare an
1257 interoperable parameter, but we can't be sure if the param is C
1258 interop or not if the user doesn't. For example, integer(4) may be
1259 legal Fortran, but doesn't have meaning in C. It may interop with
1260 a number of the C types, which causes a problem because the
1261 compiler can't know which one. This code is almost certainly not
1262 portable, and the user will get what they deserve if the C type
1263 across platforms isn't always interoperable with integer(4). If
1264 the user had used something like integer(c_int) or integer(c_long),
1265 the compiler could have automatically handled the varying sizes
1266 across platforms. */
1269 gfc_verify_c_interop_param (gfc_symbol
*sym
)
1271 int is_c_interop
= 0;
1274 /* We check implicitly typed variables in symbol.c:gfc_set_default_type().
1275 Don't repeat the checks here. */
1276 if (sym
->attr
.implicit_type
)
1279 /* For subroutines or functions that are passed to a BIND(C) procedure,
1280 they're interoperable if they're BIND(C) and their params are all
1282 if (sym
->attr
.flavor
== FL_PROCEDURE
)
1284 if (sym
->attr
.is_bind_c
== 0)
1286 gfc_error_now ("Procedure %qs at %L must have the BIND(C) "
1287 "attribute to be C interoperable", sym
->name
,
1288 &(sym
->declared_at
));
1293 if (sym
->attr
.is_c_interop
== 1)
1294 /* We've already checked this procedure; don't check it again. */
1297 return verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
1302 /* See if we've stored a reference to a procedure that owns sym. */
1303 if (sym
->ns
!= NULL
&& sym
->ns
->proc_name
!= NULL
)
1305 if (sym
->ns
->proc_name
->attr
.is_bind_c
== 1)
1307 is_c_interop
= (gfc_verify_c_interop(&(sym
->ts
)) ? 1 : 0);
1309 if (is_c_interop
!= 1)
1311 /* Make personalized messages to give better feedback. */
1312 if (sym
->ts
.type
== BT_DERIVED
)
1313 gfc_error ("Variable %qs at %L is a dummy argument to the "
1314 "BIND(C) procedure %qs but is not C interoperable "
1315 "because derived type %qs is not C interoperable",
1316 sym
->name
, &(sym
->declared_at
),
1317 sym
->ns
->proc_name
->name
,
1318 sym
->ts
.u
.derived
->name
);
1319 else if (sym
->ts
.type
== BT_CLASS
)
1320 gfc_error ("Variable %qs at %L is a dummy argument to the "
1321 "BIND(C) procedure %qs but is not C interoperable "
1322 "because it is polymorphic",
1323 sym
->name
, &(sym
->declared_at
),
1324 sym
->ns
->proc_name
->name
);
1325 else if (warn_c_binding_type
)
1326 gfc_warning (OPT_Wc_binding_type
,
1327 "Variable %qs at %L is a dummy argument of the "
1328 "BIND(C) procedure %qs but may not be C "
1330 sym
->name
, &(sym
->declared_at
),
1331 sym
->ns
->proc_name
->name
);
1334 /* Character strings are only C interoperable if they have a
1336 if (sym
->ts
.type
== BT_CHARACTER
)
1338 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
1339 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
1340 || mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
1342 gfc_error ("Character argument %qs at %L "
1343 "must be length 1 because "
1344 "procedure %qs is BIND(C)",
1345 sym
->name
, &sym
->declared_at
,
1346 sym
->ns
->proc_name
->name
);
1351 /* We have to make sure that any param to a bind(c) routine does
1352 not have the allocatable, pointer, or optional attributes,
1353 according to J3/04-007, section 5.1. */
1354 if (sym
->attr
.allocatable
== 1
1355 && !gfc_notify_std (GFC_STD_F2008_TS
, "Variable %qs at %L with "
1356 "ALLOCATABLE attribute in procedure %qs "
1357 "with BIND(C)", sym
->name
,
1358 &(sym
->declared_at
),
1359 sym
->ns
->proc_name
->name
))
1362 if (sym
->attr
.pointer
== 1
1363 && !gfc_notify_std (GFC_STD_F2008_TS
, "Variable %qs at %L with "
1364 "POINTER attribute in procedure %qs "
1365 "with BIND(C)", sym
->name
,
1366 &(sym
->declared_at
),
1367 sym
->ns
->proc_name
->name
))
1370 if ((sym
->attr
.allocatable
|| sym
->attr
.pointer
) && !sym
->as
)
1372 gfc_error ("Scalar variable %qs at %L with POINTER or "
1373 "ALLOCATABLE in procedure %qs with BIND(C) is not yet"
1374 " supported", sym
->name
, &(sym
->declared_at
),
1375 sym
->ns
->proc_name
->name
);
1379 if (sym
->attr
.optional
== 1 && sym
->attr
.value
)
1381 gfc_error ("Variable %qs at %L cannot have both the OPTIONAL "
1382 "and the VALUE attribute because procedure %qs "
1383 "is BIND(C)", sym
->name
, &(sym
->declared_at
),
1384 sym
->ns
->proc_name
->name
);
1387 else if (sym
->attr
.optional
== 1
1388 && !gfc_notify_std (GFC_STD_F2008_TS
, "Variable %qs "
1389 "at %L with OPTIONAL attribute in "
1390 "procedure %qs which is BIND(C)",
1391 sym
->name
, &(sym
->declared_at
),
1392 sym
->ns
->proc_name
->name
))
1395 /* Make sure that if it has the dimension attribute, that it is
1396 either assumed size or explicit shape. Deferred shape is already
1397 covered by the pointer/allocatable attribute. */
1398 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SHAPE
1399 && !gfc_notify_std (GFC_STD_F2008_TS
, "Assumed-shape array %qs "
1400 "at %L as dummy argument to the BIND(C) "
1401 "procedure %qs at %L", sym
->name
,
1402 &(sym
->declared_at
),
1403 sym
->ns
->proc_name
->name
,
1404 &(sym
->ns
->proc_name
->declared_at
)))
1414 /* Function called by variable_decl() that adds a name to the symbol table. */
1417 build_sym (const char *name
, gfc_charlen
*cl
, bool cl_deferred
,
1418 gfc_array_spec
**as
, locus
*var_locus
)
1420 symbol_attribute attr
;
1425 /* Symbols in a submodule are host associated from the parent module or
1426 submodules. Therefore, they can be overridden by declarations in the
1427 submodule scope. Deal with this by attaching the existing symbol to
1428 a new symtree and recycling the old symtree with a new symbol... */
1429 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
1430 if (st
!= NULL
&& gfc_state_stack
->state
== COMP_SUBMODULE
1431 && st
->n
.sym
!= NULL
1432 && st
->n
.sym
->attr
.host_assoc
&& st
->n
.sym
->attr
.used_in_submodule
)
1434 gfc_symtree
*s
= gfc_get_unique_symtree (gfc_current_ns
);
1435 s
->n
.sym
= st
->n
.sym
;
1436 sym
= gfc_new_symbol (name
, gfc_current_ns
);
1441 gfc_set_sym_referenced (sym
);
1443 /* ...Otherwise generate a new symtree and new symbol. */
1444 else if (gfc_get_symbol (name
, NULL
, &sym
))
1447 /* Check if the name has already been defined as a type. The
1448 first letter of the symtree will be in upper case then. Of
1449 course, this is only necessary if the upper case letter is
1450 actually different. */
1452 upper
= TOUPPER(name
[0]);
1453 if (upper
!= name
[0])
1455 char u_name
[GFC_MAX_SYMBOL_LEN
+ 1];
1458 gcc_assert (strlen(name
) <= GFC_MAX_SYMBOL_LEN
);
1459 strcpy (u_name
, name
);
1462 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, u_name
);
1464 /* STRUCTURE types can alias symbol names */
1465 if (st
!= 0 && st
->n
.sym
->attr
.flavor
!= FL_STRUCT
)
1467 gfc_error ("Symbol %qs at %C also declared as a type at %L", name
,
1468 &st
->n
.sym
->declared_at
);
1473 /* Start updating the symbol table. Add basic type attribute if present. */
1474 if (current_ts
.type
!= BT_UNKNOWN
1475 && (sym
->attr
.implicit_type
== 0
1476 || !gfc_compare_types (&sym
->ts
, ¤t_ts
))
1477 && !gfc_add_type (sym
, ¤t_ts
, var_locus
))
1480 if (sym
->ts
.type
== BT_CHARACTER
)
1483 sym
->ts
.deferred
= cl_deferred
;
1486 /* Add dimension attribute if present. */
1487 if (!gfc_set_array_spec (sym
, *as
, var_locus
))
1491 /* Add attribute to symbol. The copy is so that we can reset the
1492 dimension attribute. */
1493 attr
= current_attr
;
1495 attr
.codimension
= 0;
1497 if (!gfc_copy_attr (&sym
->attr
, &attr
, var_locus
))
1500 /* Finish any work that may need to be done for the binding label,
1501 if it's a bind(c). The bind(c) attr is found before the symbol
1502 is made, and before the symbol name (for data decls), so the
1503 current_ts is holding the binding label, or nothing if the
1504 name= attr wasn't given. Therefore, test here if we're dealing
1505 with a bind(c) and make sure the binding label is set correctly. */
1506 if (sym
->attr
.is_bind_c
== 1)
1508 if (!sym
->binding_label
)
1510 /* Set the binding label and verify that if a NAME= was specified
1511 then only one identifier was in the entity-decl-list. */
1512 if (!set_binding_label (&sym
->binding_label
, sym
->name
,
1513 num_idents_on_line
))
1518 /* See if we know we're in a common block, and if it's a bind(c)
1519 common then we need to make sure we're an interoperable type. */
1520 if (sym
->attr
.in_common
== 1)
1522 /* Test the common block object. */
1523 if (sym
->common_block
!= NULL
&& sym
->common_block
->is_bind_c
== 1
1524 && sym
->ts
.is_c_interop
!= 1)
1526 gfc_error_now ("Variable %qs in common block %qs at %C "
1527 "must be declared with a C interoperable "
1528 "kind since common block %qs is BIND(C)",
1529 sym
->name
, sym
->common_block
->name
,
1530 sym
->common_block
->name
);
1535 sym
->attr
.implied_index
= 0;
1537 /* Use the parameter expressions for a parameterized derived type. */
1538 if ((sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
1539 && sym
->ts
.u
.derived
->attr
.pdt_type
&& type_param_spec_list
)
1540 sym
->param_list
= gfc_copy_actual_arglist (type_param_spec_list
);
1542 if (sym
->ts
.type
== BT_CLASS
)
1543 return gfc_build_class_symbol (&sym
->ts
, &sym
->attr
, &sym
->as
);
1549 /* Set character constant to the given length. The constant will be padded or
1550 truncated. If we're inside an array constructor without a typespec, we
1551 additionally check that all elements have the same length; check_len -1
1552 means no checking. */
1555 gfc_set_constant_character_len (gfc_charlen_t len
, gfc_expr
*expr
,
1556 gfc_charlen_t check_len
)
1561 if (expr
->ts
.type
!= BT_CHARACTER
)
1564 if (expr
->expr_type
!= EXPR_CONSTANT
)
1566 gfc_error_now ("CHARACTER length must be a constant at %L", &expr
->where
);
1570 slen
= expr
->value
.character
.length
;
1573 s
= gfc_get_wide_string (len
+ 1);
1574 memcpy (s
, expr
->value
.character
.string
,
1575 MIN (len
, slen
) * sizeof (gfc_char_t
));
1577 gfc_wide_memset (&s
[slen
], ' ', len
- slen
);
1579 if (warn_character_truncation
&& slen
> len
)
1580 gfc_warning_now (OPT_Wcharacter_truncation
,
1581 "CHARACTER expression at %L is being truncated "
1582 "(%ld/%ld)", &expr
->where
,
1583 (long) slen
, (long) len
);
1585 /* Apply the standard by 'hand' otherwise it gets cleared for
1587 if (check_len
!= -1 && slen
!= check_len
1588 && !(gfc_option
.allow_std
& GFC_STD_GNU
))
1589 gfc_error_now ("The CHARACTER elements of the array constructor "
1590 "at %L must have the same length (%ld/%ld)",
1591 &expr
->where
, (long) slen
,
1595 free (expr
->value
.character
.string
);
1596 expr
->value
.character
.string
= s
;
1597 expr
->value
.character
.length
= len
;
1602 /* Function to create and update the enumerator history
1603 using the information passed as arguments.
1604 Pointer "max_enum" is also updated, to point to
1605 enum history node containing largest initializer.
1607 SYM points to the symbol node of enumerator.
1608 INIT points to its enumerator value. */
1611 create_enum_history (gfc_symbol
*sym
, gfc_expr
*init
)
1613 enumerator_history
*new_enum_history
;
1614 gcc_assert (sym
!= NULL
&& init
!= NULL
);
1616 new_enum_history
= XCNEW (enumerator_history
);
1618 new_enum_history
->sym
= sym
;
1619 new_enum_history
->initializer
= init
;
1620 new_enum_history
->next
= NULL
;
1622 if (enum_history
== NULL
)
1624 enum_history
= new_enum_history
;
1625 max_enum
= enum_history
;
1629 new_enum_history
->next
= enum_history
;
1630 enum_history
= new_enum_history
;
1632 if (mpz_cmp (max_enum
->initializer
->value
.integer
,
1633 new_enum_history
->initializer
->value
.integer
) < 0)
1634 max_enum
= new_enum_history
;
1639 /* Function to free enum kind history. */
1642 gfc_free_enum_history (void)
1644 enumerator_history
*current
= enum_history
;
1645 enumerator_history
*next
;
1647 while (current
!= NULL
)
1649 next
= current
->next
;
1654 enum_history
= NULL
;
1658 /* Function called by variable_decl() that adds an initialization
1659 expression to a symbol. */
1662 add_init_expr_to_sym (const char *name
, gfc_expr
**initp
, locus
*var_locus
)
1664 symbol_attribute attr
;
1669 if (find_special (name
, &sym
, false))
1674 /* If this symbol is confirming an implicit parameter type,
1675 then an initialization expression is not allowed. */
1676 if (attr
.flavor
== FL_PARAMETER
1677 && sym
->value
!= NULL
1680 gfc_error ("Initializer not allowed for PARAMETER %qs at %C",
1687 /* An initializer is required for PARAMETER declarations. */
1688 if (attr
.flavor
== FL_PARAMETER
)
1690 gfc_error ("PARAMETER at %L is missing an initializer", var_locus
);
1696 /* If a variable appears in a DATA block, it cannot have an
1700 gfc_error ("Variable %qs at %C with an initializer already "
1701 "appears in a DATA statement", sym
->name
);
1705 /* Check if the assignment can happen. This has to be put off
1706 until later for derived type variables and procedure pointers. */
1707 if (!gfc_bt_struct (sym
->ts
.type
) && !gfc_bt_struct (init
->ts
.type
)
1708 && sym
->ts
.type
!= BT_CLASS
&& init
->ts
.type
!= BT_CLASS
1709 && !sym
->attr
.proc_pointer
1710 && !gfc_check_assign_symbol (sym
, NULL
, init
))
1713 if (sym
->ts
.type
== BT_CHARACTER
&& sym
->ts
.u
.cl
1714 && init
->ts
.type
== BT_CHARACTER
)
1716 /* Update symbol character length according initializer. */
1717 if (!gfc_check_assign_symbol (sym
, NULL
, init
))
1720 if (sym
->ts
.u
.cl
->length
== NULL
)
1723 /* If there are multiple CHARACTER variables declared on the
1724 same line, we don't want them to share the same length. */
1725 sym
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1727 if (sym
->attr
.flavor
== FL_PARAMETER
)
1729 if (init
->expr_type
== EXPR_CONSTANT
)
1731 clen
= init
->value
.character
.length
;
1732 sym
->ts
.u
.cl
->length
1733 = gfc_get_int_expr (gfc_charlen_int_kind
,
1736 else if (init
->expr_type
== EXPR_ARRAY
)
1738 if (init
->ts
.u
.cl
&& init
->ts
.u
.cl
->length
)
1740 const gfc_expr
*length
= init
->ts
.u
.cl
->length
;
1741 if (length
->expr_type
!= EXPR_CONSTANT
)
1743 gfc_error ("Cannot initialize parameter array "
1745 "with variable length elements",
1749 clen
= mpz_get_si (length
->value
.integer
);
1751 else if (init
->value
.constructor
)
1754 c
= gfc_constructor_first (init
->value
.constructor
);
1755 clen
= c
->expr
->value
.character
.length
;
1759 sym
->ts
.u
.cl
->length
1760 = gfc_get_int_expr (gfc_charlen_int_kind
,
1763 else if (init
->ts
.u
.cl
&& init
->ts
.u
.cl
->length
)
1764 sym
->ts
.u
.cl
->length
=
1765 gfc_copy_expr (sym
->value
->ts
.u
.cl
->length
);
1768 /* Update initializer character length according symbol. */
1769 else if (sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1771 if (!gfc_specification_expr (sym
->ts
.u
.cl
->length
))
1774 int k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
,
1776 /* resolve_charlen will complain later on if the length
1777 is too large. Just skeep the initialization in that case. */
1778 if (mpz_cmp (sym
->ts
.u
.cl
->length
->value
.integer
,
1779 gfc_integer_kinds
[k
].huge
) <= 0)
1782 = gfc_mpz_get_hwi (sym
->ts
.u
.cl
->length
->value
.integer
);
1784 if (init
->expr_type
== EXPR_CONSTANT
)
1785 gfc_set_constant_character_len (len
, init
, -1);
1786 else if (init
->expr_type
== EXPR_ARRAY
)
1790 /* Build a new charlen to prevent simplification from
1791 deleting the length before it is resolved. */
1792 init
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1793 init
->ts
.u
.cl
->length
1794 = gfc_copy_expr (sym
->ts
.u
.cl
->length
);
1796 for (c
= gfc_constructor_first (init
->value
.constructor
);
1797 c
; c
= gfc_constructor_next (c
))
1798 gfc_set_constant_character_len (len
, c
->expr
, -1);
1804 /* If sym is implied-shape, set its upper bounds from init. */
1805 if (sym
->attr
.flavor
== FL_PARAMETER
&& sym
->attr
.dimension
1806 && sym
->as
->type
== AS_IMPLIED_SHAPE
)
1810 if (init
->rank
== 0)
1812 gfc_error ("Can't initialize implied-shape array at %L"
1813 " with scalar", &sym
->declared_at
);
1817 /* Shape should be present, we get an initialization expression. */
1818 gcc_assert (init
->shape
);
1820 for (dim
= 0; dim
< sym
->as
->rank
; ++dim
)
1823 gfc_expr
*e
, *lower
;
1825 lower
= sym
->as
->lower
[dim
];
1827 /* If the lower bound is an array element from another
1828 parameterized array, then it is marked with EXPR_VARIABLE and
1829 is an initialization expression. Try to reduce it. */
1830 if (lower
->expr_type
== EXPR_VARIABLE
)
1831 gfc_reduce_init_expr (lower
);
1833 if (lower
->expr_type
== EXPR_CONSTANT
)
1835 /* All dimensions must be without upper bound. */
1836 gcc_assert (!sym
->as
->upper
[dim
]);
1839 e
= gfc_get_constant_expr (BT_INTEGER
, k
, &sym
->declared_at
);
1840 mpz_add (e
->value
.integer
, lower
->value
.integer
,
1842 mpz_sub_ui (e
->value
.integer
, e
->value
.integer
, 1);
1843 sym
->as
->upper
[dim
] = e
;
1847 gfc_error ("Non-constant lower bound in implied-shape"
1848 " declaration at %L", &lower
->where
);
1853 sym
->as
->type
= AS_EXPLICIT
;
1856 /* Need to check if the expression we initialized this
1857 to was one of the iso_c_binding named constants. If so,
1858 and we're a parameter (constant), let it be iso_c.
1860 integer(c_int), parameter :: my_int = c_int
1861 integer(my_int) :: my_int_2
1862 If we mark my_int as iso_c (since we can see it's value
1863 is equal to one of the named constants), then my_int_2
1864 will be considered C interoperable. */
1865 if (sym
->ts
.type
!= BT_CHARACTER
&& !gfc_bt_struct (sym
->ts
.type
))
1867 sym
->ts
.is_iso_c
|= init
->ts
.is_iso_c
;
1868 sym
->ts
.is_c_interop
|= init
->ts
.is_c_interop
;
1869 /* attr bits needed for module files. */
1870 sym
->attr
.is_iso_c
|= init
->ts
.is_iso_c
;
1871 sym
->attr
.is_c_interop
|= init
->ts
.is_c_interop
;
1872 if (init
->ts
.is_iso_c
)
1873 sym
->ts
.f90_type
= init
->ts
.f90_type
;
1876 /* Add initializer. Make sure we keep the ranks sane. */
1877 if (sym
->attr
.dimension
&& init
->rank
== 0)
1882 if (sym
->attr
.flavor
== FL_PARAMETER
1883 && init
->expr_type
== EXPR_CONSTANT
1884 && spec_size (sym
->as
, &size
)
1885 && mpz_cmp_si (size
, 0) > 0)
1887 array
= gfc_get_array_expr (init
->ts
.type
, init
->ts
.kind
,
1889 for (n
= 0; n
< (int)mpz_get_si (size
); n
++)
1890 gfc_constructor_append_expr (&array
->value
.constructor
,
1893 : gfc_copy_expr (init
),
1896 array
->shape
= gfc_get_shape (sym
->as
->rank
);
1897 for (n
= 0; n
< sym
->as
->rank
; n
++)
1898 spec_dimen_size (sym
->as
, n
, &array
->shape
[n
]);
1903 init
->rank
= sym
->as
->rank
;
1907 if (sym
->attr
.save
== SAVE_NONE
)
1908 sym
->attr
.save
= SAVE_IMPLICIT
;
1916 /* Function called by variable_decl() that adds a name to a structure
1920 build_struct (const char *name
, gfc_charlen
*cl
, gfc_expr
**init
,
1921 gfc_array_spec
**as
)
1926 /* F03:C438/C439. If the current symbol is of the same derived type that we're
1927 constructing, it must have the pointer attribute. */
1928 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
1929 && current_ts
.u
.derived
== gfc_current_block ()
1930 && current_attr
.pointer
== 0)
1932 if (current_attr
.allocatable
1933 && !gfc_notify_std(GFC_STD_F2008
, "Component at %C "
1934 "must have the POINTER attribute"))
1938 else if (current_attr
.allocatable
== 0)
1940 gfc_error ("Component at %C must have the POINTER attribute");
1946 if (current_ts
.type
== BT_CLASS
1947 && !(current_attr
.pointer
|| current_attr
.allocatable
))
1949 gfc_error ("Component %qs with CLASS at %C must be allocatable "
1950 "or pointer", name
);
1954 if (gfc_current_block ()->attr
.pointer
&& (*as
)->rank
!= 0)
1956 if ((*as
)->type
!= AS_DEFERRED
&& (*as
)->type
!= AS_EXPLICIT
)
1958 gfc_error ("Array component of structure at %C must have explicit "
1959 "or deferred shape");
1964 /* If we are in a nested union/map definition, gfc_add_component will not
1965 properly find repeated components because:
1966 (i) gfc_add_component does a flat search, where components of unions
1967 and maps are implicity chained so nested components may conflict.
1968 (ii) Unions and maps are not linked as components of their parent
1969 structures until after they are parsed.
1970 For (i) we use gfc_find_component which searches recursively, and for (ii)
1971 we search each block directly from the parse stack until we find the top
1974 s
= gfc_state_stack
;
1975 if (s
->state
== COMP_UNION
|| s
->state
== COMP_MAP
)
1977 while (s
->state
== COMP_UNION
|| gfc_comp_struct (s
->state
))
1979 c
= gfc_find_component (s
->sym
, name
, true, true, NULL
);
1982 gfc_error_now ("Component %qs at %C already declared at %L",
1986 /* Break after we've searched the entire chain. */
1987 if (s
->state
== COMP_DERIVED
|| s
->state
== COMP_STRUCTURE
)
1993 if (!gfc_add_component (gfc_current_block(), name
, &c
))
1997 if (c
->ts
.type
== BT_CHARACTER
)
2000 if (c
->ts
.type
!= BT_CLASS
&& c
->ts
.type
!= BT_DERIVED
2001 && (c
->ts
.kind
== 0 || c
->ts
.type
== BT_CHARACTER
)
2002 && saved_kind_expr
!= NULL
)
2003 c
->kind_expr
= gfc_copy_expr (saved_kind_expr
);
2005 c
->attr
= current_attr
;
2007 c
->initializer
= *init
;
2014 c
->attr
.codimension
= 1;
2016 c
->attr
.dimension
= 1;
2020 gfc_apply_init (&c
->ts
, &c
->attr
, c
->initializer
);
2022 /* Check array components. */
2023 if (!c
->attr
.dimension
)
2026 if (c
->attr
.pointer
)
2028 if (c
->as
->type
!= AS_DEFERRED
)
2030 gfc_error ("Pointer array component of structure at %C must have a "
2035 else if (c
->attr
.allocatable
)
2037 if (c
->as
->type
!= AS_DEFERRED
)
2039 gfc_error ("Allocatable component of structure at %C must have a "
2046 if (c
->as
->type
!= AS_EXPLICIT
)
2048 gfc_error ("Array component of structure at %C must have an "
2055 if (c
->ts
.type
== BT_CLASS
)
2056 return gfc_build_class_symbol (&c
->ts
, &c
->attr
, &c
->as
);
2058 if (c
->attr
.pdt_kind
|| c
->attr
.pdt_len
)
2061 gfc_find_symbol (c
->name
, gfc_current_block ()->f2k_derived
,
2065 gfc_error ("Type parameter %qs at %C has no corresponding entry "
2066 "in the type parameter name list at %L",
2067 c
->name
, &gfc_current_block ()->declared_at
);
2071 sym
->attr
.pdt_kind
= c
->attr
.pdt_kind
;
2072 sym
->attr
.pdt_len
= c
->attr
.pdt_len
;
2074 sym
->value
= gfc_copy_expr (c
->initializer
);
2075 sym
->attr
.flavor
= FL_VARIABLE
;
2078 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
2079 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_template
2080 && decl_type_param_list
)
2081 c
->param_list
= gfc_copy_actual_arglist (decl_type_param_list
);
2087 /* Match a 'NULL()', and possibly take care of some side effects. */
2090 gfc_match_null (gfc_expr
**result
)
2093 match m
, m2
= MATCH_NO
;
2095 if ((m
= gfc_match (" null ( )")) == MATCH_ERROR
)
2101 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2103 if ((m2
= gfc_match (" null (")) != MATCH_YES
)
2106 old_loc
= gfc_current_locus
;
2107 if ((m2
= gfc_match (" %n ) ", name
)) == MATCH_ERROR
)
2110 && ((m2
= gfc_match (" mold = %n )", name
)) == MATCH_ERROR
))
2114 gfc_current_locus
= old_loc
;
2119 /* The NULL symbol now has to be/become an intrinsic function. */
2120 if (gfc_get_symbol ("null", NULL
, &sym
))
2122 gfc_error ("NULL() initialization at %C is ambiguous");
2126 gfc_intrinsic_symbol (sym
);
2128 if (sym
->attr
.proc
!= PROC_INTRINSIC
2129 && !(sym
->attr
.use_assoc
&& sym
->attr
.intrinsic
)
2130 && (!gfc_add_procedure(&sym
->attr
, PROC_INTRINSIC
, sym
->name
, NULL
)
2131 || !gfc_add_function (&sym
->attr
, sym
->name
, NULL
)))
2134 *result
= gfc_get_null_expr (&gfc_current_locus
);
2136 /* Invalid per F2008, C512. */
2137 if (m2
== MATCH_YES
)
2139 gfc_error ("NULL() initialization at %C may not have MOLD");
2147 /* Match the initialization expr for a data pointer or procedure pointer. */
2150 match_pointer_init (gfc_expr
**init
, int procptr
)
2154 if (gfc_pure (NULL
) && !gfc_comp_struct (gfc_state_stack
->state
))
2156 gfc_error ("Initialization of pointer at %C is not allowed in "
2157 "a PURE procedure");
2160 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
2162 /* Match NULL() initialization. */
2163 m
= gfc_match_null (init
);
2167 /* Match non-NULL initialization. */
2168 gfc_matching_ptr_assignment
= !procptr
;
2169 gfc_matching_procptr_assignment
= procptr
;
2170 m
= gfc_match_rvalue (init
);
2171 gfc_matching_ptr_assignment
= 0;
2172 gfc_matching_procptr_assignment
= 0;
2173 if (m
== MATCH_ERROR
)
2175 else if (m
== MATCH_NO
)
2177 gfc_error ("Error in pointer initialization at %C");
2181 if (!procptr
&& !gfc_resolve_expr (*init
))
2184 if (!gfc_notify_std (GFC_STD_F2008
, "non-NULL pointer "
2185 "initialization at %C"))
2193 check_function_name (char *name
)
2195 /* In functions that have a RESULT variable defined, the function name always
2196 refers to function calls. Therefore, the name is not allowed to appear in
2197 specification statements. When checking this, be careful about
2198 'hidden' procedure pointer results ('ppr@'). */
2200 if (gfc_current_state () == COMP_FUNCTION
)
2202 gfc_symbol
*block
= gfc_current_block ();
2203 if (block
&& block
->result
&& block
->result
!= block
2204 && strcmp (block
->result
->name
, "ppr@") != 0
2205 && strcmp (block
->name
, name
) == 0)
2207 gfc_error ("Function name %qs not allowed at %C", name
);
2216 /* Match a variable name with an optional initializer. When this
2217 subroutine is called, a variable is expected to be parsed next.
2218 Depending on what is happening at the moment, updates either the
2219 symbol table or the current interface. */
2222 variable_decl (int elem
)
2224 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2225 static unsigned int fill_id
= 0;
2226 gfc_expr
*initializer
, *char_len
;
2228 gfc_array_spec
*cp_as
; /* Extra copy for Cray Pointees. */
2240 /* When we get here, we've just matched a list of attributes and
2241 maybe a type and a double colon. The next thing we expect to see
2242 is the name of the symbol. */
2244 /* If we are parsing a structure with legacy support, we allow the symbol
2245 name to be '%FILL' which gives it an anonymous (inaccessible) name. */
2247 gfc_gobble_whitespace ();
2248 if (gfc_peek_ascii_char () == '%')
2250 gfc_next_ascii_char ();
2251 m
= gfc_match ("fill");
2256 m
= gfc_match_name (name
);
2264 if (gfc_current_state () != COMP_STRUCTURE
)
2266 if (flag_dec_structure
)
2267 gfc_error ("%qs not allowed outside STRUCTURE at %C", "%FILL");
2269 gfc_error ("%qs at %C is a DEC extension, enable with "
2270 "%<-fdec-structure%>", "%FILL");
2276 gfc_error ("%qs entity cannot have attributes at %C", "%FILL");
2280 /* %FILL components are given invalid fortran names. */
2281 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "%%FILL%u", fill_id
++);
2285 var_locus
= gfc_current_locus
;
2287 /* Now we could see the optional array spec. or character length. */
2288 m
= gfc_match_array_spec (&as
, true, true);
2289 if (m
== MATCH_ERROR
)
2293 as
= gfc_copy_array_spec (current_as
);
2295 && !merge_array_spec (current_as
, as
, true))
2301 if (flag_cray_pointer
)
2302 cp_as
= gfc_copy_array_spec (as
);
2304 /* At this point, we know for sure if the symbol is PARAMETER and can thus
2305 determine (and check) whether it can be implied-shape. If it
2306 was parsed as assumed-size, change it because PARAMETERs can not
2309 An explicit-shape-array cannot appear under several conditions.
2310 That check is done here as well. */
2313 if (as
->type
== AS_IMPLIED_SHAPE
&& current_attr
.flavor
!= FL_PARAMETER
)
2316 gfc_error ("Non-PARAMETER symbol %qs at %L can't be implied-shape",
2321 if (as
->type
== AS_ASSUMED_SIZE
&& as
->rank
== 1
2322 && current_attr
.flavor
== FL_PARAMETER
)
2323 as
->type
= AS_IMPLIED_SHAPE
;
2325 if (as
->type
== AS_IMPLIED_SHAPE
2326 && !gfc_notify_std (GFC_STD_F2008
, "Implied-shape array at %L",
2333 /* F2018:C830 (R816) An explicit-shape-spec whose bounds are not
2334 constant expressions shall appear only in a subprogram, derived
2335 type definition, BLOCK construct, or interface body. */
2336 if (as
->type
== AS_EXPLICIT
2337 && gfc_current_state () != COMP_BLOCK
2338 && gfc_current_state () != COMP_DERIVED
2339 && gfc_current_state () != COMP_FUNCTION
2340 && gfc_current_state () != COMP_INTERFACE
2341 && gfc_current_state () != COMP_SUBROUTINE
)
2344 bool not_constant
= false;
2346 for (int i
= 0; i
< as
->rank
; i
++)
2348 e
= gfc_copy_expr (as
->lower
[i
]);
2349 gfc_resolve_expr (e
);
2350 gfc_simplify_expr (e
, 0);
2351 if (e
&& (e
->expr_type
!= EXPR_CONSTANT
))
2353 not_constant
= true;
2358 e
= gfc_copy_expr (as
->upper
[i
]);
2359 gfc_resolve_expr (e
);
2360 gfc_simplify_expr (e
, 0);
2361 if (e
&& (e
->expr_type
!= EXPR_CONSTANT
))
2363 not_constant
= true;
2371 gfc_error ("Explicit shaped array with nonconstant bounds at %C");
2380 cl_deferred
= false;
2382 if (current_ts
.type
== BT_CHARACTER
)
2384 switch (match_char_length (&char_len
, &cl_deferred
, false))
2387 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2389 cl
->length
= char_len
;
2392 /* Non-constant lengths need to be copied after the first
2393 element. Also copy assumed lengths. */
2396 && (current_ts
.u
.cl
->length
== NULL
2397 || current_ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
2399 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2400 cl
->length
= gfc_copy_expr (current_ts
.u
.cl
->length
);
2403 cl
= current_ts
.u
.cl
;
2405 cl_deferred
= current_ts
.deferred
;
2414 /* The dummy arguments and result of the abreviated form of MODULE
2415 PROCEDUREs, used in SUBMODULES should not be redefined. */
2416 if (gfc_current_ns
->proc_name
2417 && gfc_current_ns
->proc_name
->abr_modproc_decl
)
2419 gfc_find_symbol (name
, gfc_current_ns
, 1, &sym
);
2420 if (sym
!= NULL
&& (sym
->attr
.dummy
|| sym
->attr
.result
))
2423 gfc_error ("%qs at %C is a redefinition of the declaration "
2424 "in the corresponding interface for MODULE "
2425 "PROCEDURE %qs", sym
->name
,
2426 gfc_current_ns
->proc_name
->name
);
2431 /* %FILL components may not have initializers. */
2432 if (strncmp (name
, "%FILL", 5) == 0 && gfc_match_eos () != MATCH_YES
)
2434 gfc_error ("%qs entity cannot have an initializer at %C", "%FILL");
2439 /* If this symbol has already shown up in a Cray Pointer declaration,
2440 and this is not a component declaration,
2441 then we want to set the type & bail out. */
2442 if (flag_cray_pointer
&& !gfc_comp_struct (gfc_current_state ()))
2444 gfc_find_symbol (name
, gfc_current_ns
, 1, &sym
);
2445 if (sym
!= NULL
&& sym
->attr
.cray_pointee
)
2447 sym
->ts
.type
= current_ts
.type
;
2448 sym
->ts
.kind
= current_ts
.kind
;
2450 sym
->ts
.u
.derived
= current_ts
.u
.derived
;
2451 sym
->ts
.is_c_interop
= current_ts
.is_c_interop
;
2452 sym
->ts
.is_iso_c
= current_ts
.is_iso_c
;
2455 /* Check to see if we have an array specification. */
2458 if (sym
->as
!= NULL
)
2460 gfc_error ("Duplicate array spec for Cray pointee at %C");
2461 gfc_free_array_spec (cp_as
);
2467 if (!gfc_set_array_spec (sym
, cp_as
, &var_locus
))
2468 gfc_internal_error ("Couldn't set pointee array spec.");
2470 /* Fix the array spec. */
2471 m
= gfc_mod_pointee_as (sym
->as
);
2472 if (m
== MATCH_ERROR
)
2480 gfc_free_array_spec (cp_as
);
2484 /* Procedure pointer as function result. */
2485 if (gfc_current_state () == COMP_FUNCTION
2486 && strcmp ("ppr@", gfc_current_block ()->name
) == 0
2487 && strcmp (name
, gfc_current_block ()->ns
->proc_name
->name
) == 0)
2488 strcpy (name
, "ppr@");
2490 if (gfc_current_state () == COMP_FUNCTION
2491 && strcmp (name
, gfc_current_block ()->name
) == 0
2492 && gfc_current_block ()->result
2493 && strcmp ("ppr@", gfc_current_block ()->result
->name
) == 0)
2494 strcpy (name
, "ppr@");
2496 /* OK, we've successfully matched the declaration. Now put the
2497 symbol in the current namespace, because it might be used in the
2498 optional initialization expression for this symbol, e.g. this is
2501 integer, parameter :: i = huge(i)
2503 This is only true for parameters or variables of a basic type.
2504 For components of derived types, it is not true, so we don't
2505 create a symbol for those yet. If we fail to create the symbol,
2507 if (!gfc_comp_struct (gfc_current_state ())
2508 && !build_sym (name
, cl
, cl_deferred
, &as
, &var_locus
))
2514 if (!check_function_name (name
))
2520 /* We allow old-style initializations of the form
2521 integer i /2/, j(4) /3*3, 1/
2522 (if no colon has been seen). These are different from data
2523 statements in that initializers are only allowed to apply to the
2524 variable immediately preceding, i.e.
2526 is not allowed. Therefore we have to do some work manually, that
2527 could otherwise be left to the matchers for DATA statements. */
2529 if (!colon_seen
&& gfc_match (" /") == MATCH_YES
)
2531 if (!gfc_notify_std (GFC_STD_GNU
, "Old-style "
2532 "initialization at %C"))
2535 /* Allow old style initializations for components of STRUCTUREs and MAPs
2536 but not components of derived types. */
2537 else if (gfc_current_state () == COMP_DERIVED
)
2539 gfc_error ("Invalid old style initialization for derived type "
2545 /* For structure components, read the initializer as a special
2546 expression and let the rest of this function apply the initializer
2548 else if (gfc_comp_struct (gfc_current_state ()))
2550 m
= match_clist_expr (&initializer
, ¤t_ts
, as
);
2552 gfc_error ("Syntax error in old style initialization of %s at %C",
2558 /* Otherwise we treat the old style initialization just like a
2559 DATA declaration for the current variable. */
2561 return match_old_style_init (name
);
2564 /* The double colon must be present in order to have initializers.
2565 Otherwise the statement is ambiguous with an assignment statement. */
2568 if (gfc_match (" =>") == MATCH_YES
)
2570 if (!current_attr
.pointer
)
2572 gfc_error ("Initialization at %C isn't for a pointer variable");
2577 m
= match_pointer_init (&initializer
, 0);
2581 else if (gfc_match_char ('=') == MATCH_YES
)
2583 if (current_attr
.pointer
)
2585 gfc_error ("Pointer initialization at %C requires %<=>%>, "
2591 m
= gfc_match_init_expr (&initializer
);
2594 gfc_error ("Expected an initialization expression at %C");
2598 if (current_attr
.flavor
!= FL_PARAMETER
&& gfc_pure (NULL
)
2599 && !gfc_comp_struct (gfc_state_stack
->state
))
2601 gfc_error ("Initialization of variable at %C is not allowed in "
2602 "a PURE procedure");
2606 if (current_attr
.flavor
!= FL_PARAMETER
2607 && !gfc_comp_struct (gfc_state_stack
->state
))
2608 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
2615 if (initializer
!= NULL
&& current_attr
.allocatable
2616 && gfc_comp_struct (gfc_current_state ()))
2618 gfc_error ("Initialization of allocatable component at %C is not "
2624 if (gfc_current_state () == COMP_DERIVED
2625 && gfc_current_block ()->attr
.pdt_template
)
2628 gfc_find_symbol (name
, gfc_current_block ()->f2k_derived
,
2630 if (!param
&& (current_attr
.pdt_kind
|| current_attr
.pdt_len
))
2632 gfc_error ("The component with KIND or LEN attribute at %C does not "
2633 "not appear in the type parameter list at %L",
2634 &gfc_current_block ()->declared_at
);
2638 else if (param
&& !(current_attr
.pdt_kind
|| current_attr
.pdt_len
))
2640 gfc_error ("The component at %C that appears in the type parameter "
2641 "list at %L has neither the KIND nor LEN attribute",
2642 &gfc_current_block ()->declared_at
);
2646 else if (as
&& (current_attr
.pdt_kind
|| current_attr
.pdt_len
))
2648 gfc_error ("The component at %C which is a type parameter must be "
2653 else if (param
&& initializer
)
2654 param
->value
= gfc_copy_expr (initializer
);
2657 /* Add the initializer. Note that it is fine if initializer is
2658 NULL here, because we sometimes also need to check if a
2659 declaration *must* have an initialization expression. */
2660 if (!gfc_comp_struct (gfc_current_state ()))
2661 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
2664 if (current_ts
.type
== BT_DERIVED
2665 && !current_attr
.pointer
&& !initializer
)
2666 initializer
= gfc_default_initializer (¤t_ts
);
2667 t
= build_struct (name
, cl
, &initializer
, &as
);
2669 /* If we match a nested structure definition we expect to see the
2670 * body even if the variable declarations blow up, so we need to keep
2671 * the structure declaration around. */
2672 if (gfc_new_block
&& gfc_new_block
->attr
.flavor
== FL_STRUCT
)
2673 gfc_commit_symbol (gfc_new_block
);
2676 m
= (t
) ? MATCH_YES
: MATCH_ERROR
;
2679 /* Free stuff up and return. */
2680 gfc_free_expr (initializer
);
2681 gfc_free_array_spec (as
);
2687 /* Match an extended-f77 "TYPESPEC*bytesize"-style kind specification.
2688 This assumes that the byte size is equal to the kind number for
2689 non-COMPLEX types, and equal to twice the kind number for COMPLEX. */
2692 gfc_match_old_kind_spec (gfc_typespec
*ts
)
2697 if (gfc_match_char ('*') != MATCH_YES
)
2700 m
= gfc_match_small_literal_int (&ts
->kind
, NULL
);
2704 original_kind
= ts
->kind
;
2706 /* Massage the kind numbers for complex types. */
2707 if (ts
->type
== BT_COMPLEX
)
2711 gfc_error ("Old-style type declaration %s*%d not supported at %C",
2712 gfc_basic_typename (ts
->type
), original_kind
);
2719 if (ts
->type
== BT_INTEGER
&& ts
->kind
== 4 && flag_integer4_kind
== 8)
2722 if (ts
->type
== BT_REAL
|| ts
->type
== BT_COMPLEX
)
2726 if (flag_real4_kind
== 8)
2728 if (flag_real4_kind
== 10)
2730 if (flag_real4_kind
== 16)
2736 if (flag_real8_kind
== 4)
2738 if (flag_real8_kind
== 10)
2740 if (flag_real8_kind
== 16)
2745 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
2747 gfc_error ("Old-style type declaration %s*%d not supported at %C",
2748 gfc_basic_typename (ts
->type
), original_kind
);
2752 if (!gfc_notify_std (GFC_STD_GNU
,
2753 "Nonstandard type declaration %s*%d at %C",
2754 gfc_basic_typename(ts
->type
), original_kind
))
2761 /* Match a kind specification. Since kinds are generally optional, we
2762 usually return MATCH_NO if something goes wrong. If a "kind="
2763 string is found, then we know we have an error. */
2766 gfc_match_kind_spec (gfc_typespec
*ts
, bool kind_expr_only
)
2776 saved_kind_expr
= NULL
;
2778 where
= loc
= gfc_current_locus
;
2783 if (gfc_match_char ('(') == MATCH_NO
)
2786 /* Also gobbles optional text. */
2787 if (gfc_match (" kind = ") == MATCH_YES
)
2790 loc
= gfc_current_locus
;
2794 n
= gfc_match_init_expr (&e
);
2796 if (gfc_derived_parameter_expr (e
))
2799 saved_kind_expr
= gfc_copy_expr (e
);
2800 goto close_brackets
;
2805 if (gfc_matching_function
)
2807 /* The function kind expression might include use associated or
2808 imported parameters and try again after the specification
2810 if (gfc_match_char (')') != MATCH_YES
)
2812 gfc_error ("Missing right parenthesis at %C");
2818 gfc_undo_symbols ();
2823 /* ....or else, the match is real. */
2825 gfc_error ("Expected initialization expression at %C");
2833 gfc_error ("Expected scalar initialization expression at %C");
2838 if (gfc_extract_int (e
, &ts
->kind
, 1))
2844 /* Before throwing away the expression, let's see if we had a
2845 C interoperable kind (and store the fact). */
2846 if (e
->ts
.is_c_interop
== 1)
2848 /* Mark this as C interoperable if being declared with one
2849 of the named constants from iso_c_binding. */
2850 ts
->is_c_interop
= e
->ts
.is_iso_c
;
2851 ts
->f90_type
= e
->ts
.f90_type
;
2853 ts
->interop_kind
= e
->symtree
->n
.sym
;
2859 /* Ignore errors to this point, if we've gotten here. This means
2860 we ignore the m=MATCH_ERROR from above. */
2861 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
2863 gfc_error ("Kind %d not supported for type %s at %C", ts
->kind
,
2864 gfc_basic_typename (ts
->type
));
2865 gfc_current_locus
= where
;
2869 /* Warn if, e.g., c_int is used for a REAL variable, but not
2870 if, e.g., c_double is used for COMPLEX as the standard
2871 explicitly says that the kind type parameter for complex and real
2872 variable is the same, i.e. c_float == c_float_complex. */
2873 if (ts
->f90_type
!= BT_UNKNOWN
&& ts
->f90_type
!= ts
->type
2874 && !((ts
->f90_type
== BT_REAL
&& ts
->type
== BT_COMPLEX
)
2875 || (ts
->f90_type
== BT_COMPLEX
&& ts
->type
== BT_REAL
)))
2876 gfc_warning_now (0, "C kind type parameter is for type %s but type at %L "
2877 "is %s", gfc_basic_typename (ts
->f90_type
), &where
,
2878 gfc_basic_typename (ts
->type
));
2882 gfc_gobble_whitespace ();
2883 if ((c
= gfc_next_ascii_char ()) != ')'
2884 && (ts
->type
!= BT_CHARACTER
|| c
!= ','))
2886 if (ts
->type
== BT_CHARACTER
)
2887 gfc_error ("Missing right parenthesis or comma at %C");
2889 gfc_error ("Missing right parenthesis at %C");
2893 /* All tests passed. */
2896 if(m
== MATCH_ERROR
)
2897 gfc_current_locus
= where
;
2899 if (ts
->type
== BT_INTEGER
&& ts
->kind
== 4 && flag_integer4_kind
== 8)
2902 if (ts
->type
== BT_REAL
|| ts
->type
== BT_COMPLEX
)
2906 if (flag_real4_kind
== 8)
2908 if (flag_real4_kind
== 10)
2910 if (flag_real4_kind
== 16)
2916 if (flag_real8_kind
== 4)
2918 if (flag_real8_kind
== 10)
2920 if (flag_real8_kind
== 16)
2925 /* Return what we know from the test(s). */
2930 gfc_current_locus
= where
;
2936 match_char_kind (int * kind
, int * is_iso_c
)
2945 where
= gfc_current_locus
;
2947 n
= gfc_match_init_expr (&e
);
2949 if (n
!= MATCH_YES
&& gfc_matching_function
)
2951 /* The expression might include use-associated or imported
2952 parameters and try again after the specification
2955 gfc_undo_symbols ();
2960 gfc_error ("Expected initialization expression at %C");
2966 gfc_error ("Expected scalar initialization expression at %C");
2971 if (gfc_derived_parameter_expr (e
))
2973 saved_kind_expr
= e
;
2978 fail
= gfc_extract_int (e
, kind
, 1);
2979 *is_iso_c
= e
->ts
.is_iso_c
;
2988 /* Ignore errors to this point, if we've gotten here. This means
2989 we ignore the m=MATCH_ERROR from above. */
2990 if (gfc_validate_kind (BT_CHARACTER
, *kind
, true) < 0)
2992 gfc_error ("Kind %d is not supported for CHARACTER at %C", *kind
);
2996 /* All tests passed. */
2999 if (m
== MATCH_ERROR
)
3000 gfc_current_locus
= where
;
3002 /* Return what we know from the test(s). */
3007 gfc_current_locus
= where
;
3012 /* Match the various kind/length specifications in a CHARACTER
3013 declaration. We don't return MATCH_NO. */
3016 gfc_match_char_spec (gfc_typespec
*ts
)
3018 int kind
, seen_length
, is_iso_c
;
3030 /* Try the old-style specification first. */
3031 old_char_selector
= 0;
3033 m
= match_char_length (&len
, &deferred
, true);
3037 old_char_selector
= 1;
3042 m
= gfc_match_char ('(');
3045 m
= MATCH_YES
; /* Character without length is a single char. */
3049 /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ). */
3050 if (gfc_match (" kind =") == MATCH_YES
)
3052 m
= match_char_kind (&kind
, &is_iso_c
);
3054 if (m
== MATCH_ERROR
)
3059 if (gfc_match (" , len =") == MATCH_NO
)
3062 m
= char_len_param_value (&len
, &deferred
);
3065 if (m
== MATCH_ERROR
)
3072 /* Try to match "LEN = <len-param>" or "LEN = <len-param>, KIND = <int>". */
3073 if (gfc_match (" len =") == MATCH_YES
)
3075 m
= char_len_param_value (&len
, &deferred
);
3078 if (m
== MATCH_ERROR
)
3082 if (gfc_match_char (')') == MATCH_YES
)
3085 if (gfc_match (" , kind =") != MATCH_YES
)
3088 if (match_char_kind (&kind
, &is_iso_c
) == MATCH_ERROR
)
3094 /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ). */
3095 m
= char_len_param_value (&len
, &deferred
);
3098 if (m
== MATCH_ERROR
)
3102 m
= gfc_match_char (')');
3106 if (gfc_match_char (',') != MATCH_YES
)
3109 gfc_match (" kind ="); /* Gobble optional text. */
3111 m
= match_char_kind (&kind
, &is_iso_c
);
3112 if (m
== MATCH_ERROR
)
3118 /* Require a right-paren at this point. */
3119 m
= gfc_match_char (')');
3124 gfc_error ("Syntax error in CHARACTER declaration at %C");
3126 gfc_free_expr (len
);
3130 /* Deal with character functions after USE and IMPORT statements. */
3131 if (gfc_matching_function
)
3133 gfc_free_expr (len
);
3134 gfc_undo_symbols ();
3140 gfc_free_expr (len
);
3144 /* Do some final massaging of the length values. */
3145 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
3147 if (seen_length
== 0)
3148 cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
, 1);
3151 /* If gfortran ends up here, then the len may be reducible to a
3152 constant. Try to do that here. If it does not reduce, simply
3153 assign len to the charlen. */
3154 if (len
&& len
->expr_type
!= EXPR_CONSTANT
)
3157 e
= gfc_copy_expr (len
);
3158 gfc_reduce_init_expr (e
);
3159 if (e
->expr_type
== EXPR_CONSTANT
)
3160 gfc_replace_expr (len
, e
);
3170 ts
->kind
= kind
== 0 ? gfc_default_character_kind
: kind
;
3171 ts
->deferred
= deferred
;
3173 /* We have to know if it was a C interoperable kind so we can
3174 do accurate type checking of bind(c) procs, etc. */
3176 /* Mark this as C interoperable if being declared with one
3177 of the named constants from iso_c_binding. */
3178 ts
->is_c_interop
= is_iso_c
;
3179 else if (len
!= NULL
)
3180 /* Here, we might have parsed something such as: character(c_char)
3181 In this case, the parsing code above grabs the c_char when
3182 looking for the length (line 1690, roughly). it's the last
3183 testcase for parsing the kind params of a character variable.
3184 However, it's not actually the length. this seems like it
3186 To see if the user used a C interop kind, test the expr
3187 of the so called length, and see if it's C interoperable. */
3188 ts
->is_c_interop
= len
->ts
.is_iso_c
;
3194 /* Matches a RECORD declaration. */
3197 match_record_decl (char *name
)
3200 old_loc
= gfc_current_locus
;
3203 m
= gfc_match (" record /");
3206 if (!flag_dec_structure
)
3208 gfc_current_locus
= old_loc
;
3209 gfc_error ("RECORD at %C is an extension, enable it with "
3213 m
= gfc_match (" %n/", name
);
3218 gfc_current_locus
= old_loc
;
3219 if (flag_dec_structure
3220 && (gfc_match (" record% ") == MATCH_YES
3221 || gfc_match (" record%t") == MATCH_YES
))
3222 gfc_error ("Structure name expected after RECORD at %C");
3230 /* This function uses the gfc_actual_arglist 'type_param_spec_list' as a source
3231 of expressions to substitute into the possibly parameterized expression
3232 'e'. Using a list is inefficient but should not be too bad since the
3233 number of type parameters is not likely to be large. */
3235 insert_parameter_exprs (gfc_expr
* e
, gfc_symbol
* sym ATTRIBUTE_UNUSED
,
3238 gfc_actual_arglist
*param
;
3241 if (e
->expr_type
!= EXPR_VARIABLE
)
3244 gcc_assert (e
->symtree
);
3245 if (e
->symtree
->n
.sym
->attr
.pdt_kind
3246 || (*f
!= 0 && e
->symtree
->n
.sym
->attr
.pdt_len
))
3248 for (param
= type_param_spec_list
; param
; param
= param
->next
)
3249 if (strcmp (e
->symtree
->n
.sym
->name
, param
->name
) == 0)
3254 copy
= gfc_copy_expr (param
->expr
);
3265 gfc_insert_kind_parameter_exprs (gfc_expr
*e
)
3267 return gfc_traverse_expr (e
, NULL
, &insert_parameter_exprs
, 0);
3272 gfc_insert_parameter_exprs (gfc_expr
*e
, gfc_actual_arglist
*param_list
)
3274 gfc_actual_arglist
*old_param_spec_list
= type_param_spec_list
;
3275 type_param_spec_list
= param_list
;
3276 return gfc_traverse_expr (e
, NULL
, &insert_parameter_exprs
, 1);
3277 type_param_spec_list
= NULL
;
3278 type_param_spec_list
= old_param_spec_list
;
3281 /* Determines the instance of a parameterized derived type to be used by
3282 matching determining the values of the kind parameters and using them
3283 in the name of the instance. If the instance exists, it is used, otherwise
3284 a new derived type is created. */
3286 gfc_get_pdt_instance (gfc_actual_arglist
*param_list
, gfc_symbol
**sym
,
3287 gfc_actual_arglist
**ext_param_list
)
3289 /* The PDT template symbol. */
3290 gfc_symbol
*pdt
= *sym
;
3291 /* The symbol for the parameter in the template f2k_namespace. */
3293 /* The hoped for instance of the PDT. */
3294 gfc_symbol
*instance
;
3295 /* The list of parameters appearing in the PDT declaration. */
3296 gfc_formal_arglist
*type_param_name_list
;
3297 /* Used to store the parameter specification list during recursive calls. */
3298 gfc_actual_arglist
*old_param_spec_list
;
3299 /* Pointers to the parameter specification being used. */
3300 gfc_actual_arglist
*actual_param
;
3301 gfc_actual_arglist
*tail
= NULL
;
3302 /* Used to build up the name of the PDT instance. The prefix uses 4
3303 characters and each KIND parameter 2 more. Allow 8 of the latter. */
3304 char name
[GFC_MAX_SYMBOL_LEN
+ 21];
3306 bool name_seen
= (param_list
== NULL
);
3307 bool assumed_seen
= false;
3308 bool deferred_seen
= false;
3309 bool spec_error
= false;
3311 gfc_expr
*kind_expr
;
3312 gfc_component
*c1
, *c2
;
3315 type_param_spec_list
= NULL
;
3317 type_param_name_list
= pdt
->formal
;
3318 actual_param
= param_list
;
3319 sprintf (name
, "Pdt%s", pdt
->name
);
3321 /* Run through the parameter name list and pick up the actual
3322 parameter values or use the default values in the PDT declaration. */
3323 for (; type_param_name_list
;
3324 type_param_name_list
= type_param_name_list
->next
)
3326 if (actual_param
&& actual_param
->spec_type
!= SPEC_EXPLICIT
)
3328 if (actual_param
->spec_type
== SPEC_ASSUMED
)
3329 spec_error
= deferred_seen
;
3331 spec_error
= assumed_seen
;
3335 gfc_error ("The type parameter spec list at %C cannot contain "
3336 "both ASSUMED and DEFERRED parameters");
3341 if (actual_param
&& actual_param
->name
)
3343 param
= type_param_name_list
->sym
;
3345 if (!param
|| !param
->name
)
3348 c1
= gfc_find_component (pdt
, param
->name
, false, true, NULL
);
3349 /* An error should already have been thrown in resolve.c
3350 (resolve_fl_derived0). */
3351 if (!pdt
->attr
.use_assoc
&& !c1
)
3357 if (!actual_param
&& !(c1
&& c1
->initializer
))
3359 gfc_error ("The type parameter spec list at %C does not contain "
3360 "enough parameter expressions");
3363 else if (!actual_param
&& c1
&& c1
->initializer
)
3364 kind_expr
= gfc_copy_expr (c1
->initializer
);
3365 else if (actual_param
&& actual_param
->spec_type
== SPEC_EXPLICIT
)
3366 kind_expr
= gfc_copy_expr (actual_param
->expr
);
3370 actual_param
= param_list
;
3371 for (;actual_param
; actual_param
= actual_param
->next
)
3372 if (actual_param
->name
3373 && strcmp (actual_param
->name
, param
->name
) == 0)
3375 if (actual_param
&& actual_param
->spec_type
== SPEC_EXPLICIT
)
3376 kind_expr
= gfc_copy_expr (actual_param
->expr
);
3379 if (c1
->initializer
)
3380 kind_expr
= gfc_copy_expr (c1
->initializer
);
3381 else if (!(actual_param
&& param
->attr
.pdt_len
))
3383 gfc_error ("The derived parameter %qs at %C does not "
3384 "have a default value", param
->name
);
3390 /* Store the current parameter expressions in a temporary actual
3391 arglist 'list' so that they can be substituted in the corresponding
3392 expressions in the PDT instance. */
3393 if (type_param_spec_list
== NULL
)
3395 type_param_spec_list
= gfc_get_actual_arglist ();
3396 tail
= type_param_spec_list
;
3400 tail
->next
= gfc_get_actual_arglist ();
3403 tail
->name
= param
->name
;
3407 /* Try simplification even for LEN expressions. */
3408 gfc_resolve_expr (kind_expr
);
3409 gfc_simplify_expr (kind_expr
, 1);
3410 /* Variable expressions seem to default to BT_PROCEDURE.
3411 TODO find out why this is and fix it. */
3412 if (kind_expr
->ts
.type
!= BT_INTEGER
3413 && kind_expr
->ts
.type
!= BT_PROCEDURE
)
3415 gfc_error ("The parameter expression at %C must be of "
3416 "INTEGER type and not %s type",
3417 gfc_basic_typename (kind_expr
->ts
.type
));
3421 tail
->expr
= gfc_copy_expr (kind_expr
);
3425 tail
->spec_type
= actual_param
->spec_type
;
3427 if (!param
->attr
.pdt_kind
)
3429 if (!name_seen
&& actual_param
)
3430 actual_param
= actual_param
->next
;
3433 gfc_free_expr (kind_expr
);
3440 && (actual_param
->spec_type
== SPEC_ASSUMED
3441 || actual_param
->spec_type
== SPEC_DEFERRED
))
3443 gfc_error ("The KIND parameter %qs at %C cannot either be "
3444 "ASSUMED or DEFERRED", param
->name
);
3448 if (!kind_expr
|| !gfc_is_constant_expr (kind_expr
))
3450 gfc_error ("The value for the KIND parameter %qs at %C does not "
3451 "reduce to a constant expression", param
->name
);
3455 gfc_extract_int (kind_expr
, &kind_value
);
3456 sprintf (name
+ strlen (name
), "_%d", kind_value
);
3458 if (!name_seen
&& actual_param
)
3459 actual_param
= actual_param
->next
;
3460 gfc_free_expr (kind_expr
);
3463 if (!name_seen
&& actual_param
)
3465 gfc_error ("The type parameter spec list at %C contains too many "
3466 "parameter expressions");
3470 /* Now we search for the PDT instance 'name'. If it doesn't exist, we
3471 build it, using 'pdt' as a template. */
3472 if (gfc_get_symbol (name
, pdt
->ns
, &instance
))
3474 gfc_error ("Parameterized derived type at %C is ambiguous");
3480 if (instance
->attr
.flavor
== FL_DERIVED
3481 && instance
->attr
.pdt_type
)
3485 *ext_param_list
= type_param_spec_list
;
3487 gfc_commit_symbols ();
3491 /* Start building the new instance of the parameterized type. */
3492 gfc_copy_attr (&instance
->attr
, &pdt
->attr
, &pdt
->declared_at
);
3493 instance
->attr
.pdt_template
= 0;
3494 instance
->attr
.pdt_type
= 1;
3495 instance
->declared_at
= gfc_current_locus
;
3497 /* Add the components, replacing the parameters in all expressions
3498 with the expressions for their values in 'type_param_spec_list'. */
3499 c1
= pdt
->components
;
3500 tail
= type_param_spec_list
;
3501 for (; c1
; c1
= c1
->next
)
3503 gfc_add_component (instance
, c1
->name
, &c2
);
3506 c2
->attr
= c1
->attr
;
3508 /* The order of declaration of the type_specs might not be the
3509 same as that of the components. */
3510 if (c1
->attr
.pdt_kind
|| c1
->attr
.pdt_len
)
3512 for (tail
= type_param_spec_list
; tail
; tail
= tail
->next
)
3513 if (strcmp (c1
->name
, tail
->name
) == 0)
3517 /* Deal with type extension by recursively calling this function
3518 to obtain the instance of the extended type. */
3519 if (gfc_current_state () != COMP_DERIVED
3520 && c1
== pdt
->components
3521 && (c1
->ts
.type
== BT_DERIVED
|| c1
->ts
.type
== BT_CLASS
)
3522 && c1
->ts
.u
.derived
&& c1
->ts
.u
.derived
->attr
.pdt_template
3523 && gfc_get_derived_super_type (*sym
) == c2
->ts
.u
.derived
)
3525 gfc_formal_arglist
*f
;
3527 old_param_spec_list
= type_param_spec_list
;
3529 /* Obtain a spec list appropriate to the extended type..*/
3530 actual_param
= gfc_copy_actual_arglist (type_param_spec_list
);
3531 type_param_spec_list
= actual_param
;
3532 for (f
= c1
->ts
.u
.derived
->formal
; f
&& f
->next
; f
= f
->next
)
3533 actual_param
= actual_param
->next
;
3536 gfc_free_actual_arglist (actual_param
->next
);
3537 actual_param
->next
= NULL
;
3540 /* Now obtain the PDT instance for the extended type. */
3541 c2
->param_list
= type_param_spec_list
;
3542 m
= gfc_get_pdt_instance (type_param_spec_list
, &c2
->ts
.u
.derived
,
3544 type_param_spec_list
= old_param_spec_list
;
3546 c2
->ts
.u
.derived
->refs
++;
3547 gfc_set_sym_referenced (c2
->ts
.u
.derived
);
3549 /* Set extension level. */
3550 if (c2
->ts
.u
.derived
->attr
.extension
== 255)
3552 /* Since the extension field is 8 bit wide, we can only have
3553 up to 255 extension levels. */
3554 gfc_error ("Maximum extension level reached with type %qs at %L",
3555 c2
->ts
.u
.derived
->name
,
3556 &c2
->ts
.u
.derived
->declared_at
);
3559 instance
->attr
.extension
= c2
->ts
.u
.derived
->attr
.extension
+ 1;
3564 /* Set the component kind using the parameterized expression. */
3565 if ((c1
->ts
.kind
== 0 || c1
->ts
.type
== BT_CHARACTER
)
3566 && c1
->kind_expr
!= NULL
)
3568 gfc_expr
*e
= gfc_copy_expr (c1
->kind_expr
);
3569 gfc_insert_kind_parameter_exprs (e
);
3570 gfc_simplify_expr (e
, 1);
3571 gfc_extract_int (e
, &c2
->ts
.kind
);
3573 if (gfc_validate_kind (c2
->ts
.type
, c2
->ts
.kind
, true) < 0)
3575 gfc_error ("Kind %d not supported for type %s at %C",
3576 c2
->ts
.kind
, gfc_basic_typename (c2
->ts
.type
));
3581 /* Similarly, set the string length if parameterized. */
3582 if (c1
->ts
.type
== BT_CHARACTER
3583 && c1
->ts
.u
.cl
->length
3584 && gfc_derived_parameter_expr (c1
->ts
.u
.cl
->length
))
3587 e
= gfc_copy_expr (c1
->ts
.u
.cl
->length
);
3588 gfc_insert_kind_parameter_exprs (e
);
3589 gfc_simplify_expr (e
, 1);
3590 c2
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
3591 c2
->ts
.u
.cl
->length
= e
;
3592 c2
->attr
.pdt_string
= 1;
3595 /* Set up either the KIND/LEN initializer, if constant,
3596 or the parameterized expression. Use the template
3597 initializer if one is not already set in this instance. */
3598 if (c2
->attr
.pdt_kind
|| c2
->attr
.pdt_len
)
3600 if (tail
&& tail
->expr
&& gfc_is_constant_expr (tail
->expr
))
3601 c2
->initializer
= gfc_copy_expr (tail
->expr
);
3602 else if (tail
&& tail
->expr
)
3604 c2
->param_list
= gfc_get_actual_arglist ();
3605 c2
->param_list
->name
= tail
->name
;
3606 c2
->param_list
->expr
= gfc_copy_expr (tail
->expr
);
3607 c2
->param_list
->next
= NULL
;
3610 if (!c2
->initializer
&& c1
->initializer
)
3611 c2
->initializer
= gfc_copy_expr (c1
->initializer
);
3614 /* Copy the array spec. */
3615 c2
->as
= gfc_copy_array_spec (c1
->as
);
3616 if (c1
->ts
.type
== BT_CLASS
)
3617 CLASS_DATA (c2
)->as
= gfc_copy_array_spec (CLASS_DATA (c1
)->as
);
3619 /* Determine if an array spec is parameterized. If so, substitute
3620 in the parameter expressions for the bounds and set the pdt_array
3621 attribute. Notice that this attribute must be unconditionally set
3622 if this is an array of parameterized character length. */
3623 if (c1
->as
&& c1
->as
->type
== AS_EXPLICIT
)
3625 bool pdt_array
= false;
3627 /* Are the bounds of the array parameterized? */
3628 for (i
= 0; i
< c1
->as
->rank
; i
++)
3630 if (gfc_derived_parameter_expr (c1
->as
->lower
[i
]))
3632 if (gfc_derived_parameter_expr (c1
->as
->upper
[i
]))
3636 /* If they are, free the expressions for the bounds and
3637 replace them with the template expressions with substitute
3639 for (i
= 0; pdt_array
&& i
< c1
->as
->rank
; i
++)
3642 e
= gfc_copy_expr (c1
->as
->lower
[i
]);
3643 gfc_insert_kind_parameter_exprs (e
);
3644 gfc_simplify_expr (e
, 1);
3645 gfc_free_expr (c2
->as
->lower
[i
]);
3646 c2
->as
->lower
[i
] = e
;
3647 e
= gfc_copy_expr (c1
->as
->upper
[i
]);
3648 gfc_insert_kind_parameter_exprs (e
);
3649 gfc_simplify_expr (e
, 1);
3650 gfc_free_expr (c2
->as
->upper
[i
]);
3651 c2
->as
->upper
[i
] = e
;
3653 c2
->attr
.pdt_array
= pdt_array
? 1 : c2
->attr
.pdt_string
;
3654 if (c1
->initializer
)
3656 c2
->initializer
= gfc_copy_expr (c1
->initializer
);
3657 gfc_insert_kind_parameter_exprs (c2
->initializer
);
3658 gfc_simplify_expr (c2
->initializer
, 1);
3662 /* Recurse into this function for PDT components. */
3663 if ((c1
->ts
.type
== BT_DERIVED
|| c1
->ts
.type
== BT_CLASS
)
3664 && c1
->ts
.u
.derived
&& c1
->ts
.u
.derived
->attr
.pdt_template
)
3666 gfc_actual_arglist
*params
;
3667 /* The component in the template has a list of specification
3668 expressions derived from its declaration. */
3669 params
= gfc_copy_actual_arglist (c1
->param_list
);
3670 actual_param
= params
;
3671 /* Substitute the template parameters with the expressions
3672 from the specification list. */
3673 for (;actual_param
; actual_param
= actual_param
->next
)
3674 gfc_insert_parameter_exprs (actual_param
->expr
,
3675 type_param_spec_list
);
3677 /* Now obtain the PDT instance for the component. */
3678 old_param_spec_list
= type_param_spec_list
;
3679 m
= gfc_get_pdt_instance (params
, &c2
->ts
.u
.derived
, NULL
);
3680 type_param_spec_list
= old_param_spec_list
;
3682 c2
->param_list
= params
;
3683 if (!(c2
->attr
.pointer
|| c2
->attr
.allocatable
))
3684 c2
->initializer
= gfc_default_initializer (&c2
->ts
);
3686 if (c2
->attr
.allocatable
)
3687 instance
->attr
.alloc_comp
= 1;
3691 gfc_commit_symbol (instance
);
3693 *ext_param_list
= type_param_spec_list
;
3698 gfc_free_actual_arglist (type_param_spec_list
);
3703 /* Matches a declaration-type-spec (F03:R502). If successful, sets the ts
3704 structure to the matched specification. This is necessary for FUNCTION and
3705 IMPLICIT statements.
3707 If implicit_flag is nonzero, then we don't check for the optional
3708 kind specification. Not doing so is needed for matching an IMPLICIT
3709 statement correctly. */
3712 gfc_match_decl_type_spec (gfc_typespec
*ts
, int implicit_flag
)
3714 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3715 gfc_symbol
*sym
, *dt_sym
;
3718 bool seen_deferred_kind
, matched_type
;
3719 const char *dt_name
;
3721 decl_type_param_list
= NULL
;
3723 /* A belt and braces check that the typespec is correctly being treated
3724 as a deferred characteristic association. */
3725 seen_deferred_kind
= (gfc_current_state () == COMP_FUNCTION
)
3726 && (gfc_current_block ()->result
->ts
.kind
== -1)
3727 && (ts
->kind
== -1);
3729 if (seen_deferred_kind
)
3732 /* Clear the current binding label, in case one is given. */
3733 curr_binding_label
= NULL
;
3735 if (gfc_match (" byte") == MATCH_YES
)
3737 if (!gfc_notify_std (GFC_STD_GNU
, "BYTE type at %C"))
3740 if (gfc_validate_kind (BT_INTEGER
, 1, true) < 0)
3742 gfc_error ("BYTE type used at %C "
3743 "is not available on the target machine");
3747 ts
->type
= BT_INTEGER
;
3753 m
= gfc_match (" type (");
3754 matched_type
= (m
== MATCH_YES
);
3757 gfc_gobble_whitespace ();
3758 if (gfc_peek_ascii_char () == '*')
3760 if ((m
= gfc_match ("*)")) != MATCH_YES
)
3762 if (gfc_comp_struct (gfc_current_state ()))
3764 gfc_error ("Assumed type at %C is not allowed for components");
3767 if (!gfc_notify_std (GFC_STD_F2008_TS
, "Assumed type "
3770 ts
->type
= BT_ASSUMED
;
3774 m
= gfc_match ("%n", name
);
3775 matched_type
= (m
== MATCH_YES
);
3778 if ((matched_type
&& strcmp ("integer", name
) == 0)
3779 || (!matched_type
&& gfc_match (" integer") == MATCH_YES
))
3781 ts
->type
= BT_INTEGER
;
3782 ts
->kind
= gfc_default_integer_kind
;
3786 if ((matched_type
&& strcmp ("character", name
) == 0)
3787 || (!matched_type
&& gfc_match (" character") == MATCH_YES
))
3790 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
3791 "intrinsic-type-spec at %C"))
3794 ts
->type
= BT_CHARACTER
;
3795 if (implicit_flag
== 0)
3796 m
= gfc_match_char_spec (ts
);
3800 if (matched_type
&& m
== MATCH_YES
&& gfc_match_char (')') != MATCH_YES
)
3806 if ((matched_type
&& strcmp ("real", name
) == 0)
3807 || (!matched_type
&& gfc_match (" real") == MATCH_YES
))
3810 ts
->kind
= gfc_default_real_kind
;
3815 && (strcmp ("doubleprecision", name
) == 0
3816 || (strcmp ("double", name
) == 0
3817 && gfc_match (" precision") == MATCH_YES
)))
3818 || (!matched_type
&& gfc_match (" double precision") == MATCH_YES
))
3821 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
3822 "intrinsic-type-spec at %C"))
3824 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
3828 ts
->kind
= gfc_default_double_kind
;
3832 if ((matched_type
&& strcmp ("complex", name
) == 0)
3833 || (!matched_type
&& gfc_match (" complex") == MATCH_YES
))
3835 ts
->type
= BT_COMPLEX
;
3836 ts
->kind
= gfc_default_complex_kind
;
3841 && (strcmp ("doublecomplex", name
) == 0
3842 || (strcmp ("double", name
) == 0
3843 && gfc_match (" complex") == MATCH_YES
)))
3844 || (!matched_type
&& gfc_match (" double complex") == MATCH_YES
))
3846 if (!gfc_notify_std (GFC_STD_GNU
, "DOUBLE COMPLEX at %C"))
3850 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
3851 "intrinsic-type-spec at %C"))
3854 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
3857 ts
->type
= BT_COMPLEX
;
3858 ts
->kind
= gfc_default_double_kind
;
3862 if ((matched_type
&& strcmp ("logical", name
) == 0)
3863 || (!matched_type
&& gfc_match (" logical") == MATCH_YES
))
3865 ts
->type
= BT_LOGICAL
;
3866 ts
->kind
= gfc_default_logical_kind
;
3872 m
= gfc_match_actual_arglist (1, &decl_type_param_list
, true);
3873 if (m
== MATCH_ERROR
)
3876 m
= gfc_match_char (')');
3880 m
= match_record_decl (name
);
3882 if (matched_type
|| m
== MATCH_YES
)
3884 ts
->type
= BT_DERIVED
;
3885 /* We accept record/s/ or type(s) where s is a structure, but we
3886 * don't need all the extra derived-type stuff for structures. */
3887 if (gfc_find_symbol (gfc_dt_upper_string (name
), NULL
, 1, &sym
))
3889 gfc_error ("Type name %qs at %C is ambiguous", name
);
3893 if (sym
&& sym
->attr
.flavor
== FL_DERIVED
3894 && sym
->attr
.pdt_template
3895 && gfc_current_state () != COMP_DERIVED
)
3897 m
= gfc_get_pdt_instance (decl_type_param_list
, &sym
, NULL
);
3900 gcc_assert (!sym
->attr
.pdt_template
&& sym
->attr
.pdt_type
);
3901 ts
->u
.derived
= sym
;
3902 strcpy (name
, gfc_dt_lower_string (sym
->name
));
3905 if (sym
&& sym
->attr
.flavor
== FL_STRUCT
)
3907 ts
->u
.derived
= sym
;
3910 /* Actually a derived type. */
3915 /* Match nested STRUCTURE declarations; only valid within another
3916 structure declaration. */
3917 if (flag_dec_structure
3918 && (gfc_current_state () == COMP_STRUCTURE
3919 || gfc_current_state () == COMP_MAP
))
3921 m
= gfc_match (" structure");
3924 m
= gfc_match_structure_decl ();
3927 /* gfc_new_block is updated by match_structure_decl. */
3928 ts
->type
= BT_DERIVED
;
3929 ts
->u
.derived
= gfc_new_block
;
3933 if (m
== MATCH_ERROR
)
3937 /* Match CLASS declarations. */
3938 m
= gfc_match (" class ( * )");
3939 if (m
== MATCH_ERROR
)
3941 else if (m
== MATCH_YES
)
3945 ts
->type
= BT_CLASS
;
3946 gfc_find_symbol ("STAR", gfc_current_ns
, 1, &upe
);
3949 upe
= gfc_new_symbol ("STAR", gfc_current_ns
);
3950 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "STAR");
3952 gfc_set_sym_referenced (upe
);
3954 upe
->ts
.type
= BT_VOID
;
3955 upe
->attr
.unlimited_polymorphic
= 1;
3956 /* This is essential to force the construction of
3957 unlimited polymorphic component class containers. */
3958 upe
->attr
.zero_comp
= 1;
3959 if (!gfc_add_flavor (&upe
->attr
, FL_DERIVED
, NULL
,
3960 &gfc_current_locus
))
3965 st
= gfc_get_tbp_symtree (&gfc_current_ns
->sym_root
, "STAR");
3969 ts
->u
.derived
= upe
;
3973 m
= gfc_match (" class (");
3976 m
= gfc_match ("%n", name
);
3982 ts
->type
= BT_CLASS
;
3984 if (!gfc_notify_std (GFC_STD_F2003
, "CLASS statement at %C"))
3987 m
= gfc_match_actual_arglist (1, &decl_type_param_list
, true);
3988 if (m
== MATCH_ERROR
)
3991 m
= gfc_match_char (')');
3996 /* Defer association of the derived type until the end of the
3997 specification block. However, if the derived type can be
3998 found, add it to the typespec. */
3999 if (gfc_matching_function
)
4001 ts
->u
.derived
= NULL
;
4002 if (gfc_current_state () != COMP_INTERFACE
4003 && !gfc_find_symbol (name
, NULL
, 1, &sym
) && sym
)
4005 sym
= gfc_find_dt_in_generic (sym
);
4006 ts
->u
.derived
= sym
;
4011 /* Search for the name but allow the components to be defined later. If
4012 type = -1, this typespec has been seen in a function declaration but
4013 the type could not be accessed at that point. The actual derived type is
4014 stored in a symtree with the first letter of the name capitalized; the
4015 symtree with the all lower-case name contains the associated
4016 generic function. */
4017 dt_name
= gfc_dt_upper_string (name
);
4022 gfc_get_ha_symbol (name
, &sym
);
4023 if (sym
->generic
&& gfc_find_symbol (dt_name
, NULL
, 0, &dt_sym
))
4025 gfc_error ("Type name %qs at %C is ambiguous", name
);
4028 if (sym
->generic
&& !dt_sym
)
4029 dt_sym
= gfc_find_dt_in_generic (sym
);
4031 /* Host associated PDTs can get confused with their constructors
4032 because they ar instantiated in the template's namespace. */
4035 if (gfc_find_symbol (dt_name
, NULL
, 1, &dt_sym
))
4037 gfc_error ("Type name %qs at %C is ambiguous", name
);
4040 if (dt_sym
&& !dt_sym
->attr
.pdt_type
)
4044 else if (ts
->kind
== -1)
4046 int iface
= gfc_state_stack
->previous
->state
!= COMP_INTERFACE
4047 || gfc_current_ns
->has_import_set
;
4048 gfc_find_symbol (name
, NULL
, iface
, &sym
);
4049 if (sym
&& sym
->generic
&& gfc_find_symbol (dt_name
, NULL
, 1, &dt_sym
))
4051 gfc_error ("Type name %qs at %C is ambiguous", name
);
4054 if (sym
&& sym
->generic
&& !dt_sym
)
4055 dt_sym
= gfc_find_dt_in_generic (sym
);
4062 if ((sym
->attr
.flavor
!= FL_UNKNOWN
&& sym
->attr
.flavor
!= FL_STRUCT
4063 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.generic
))
4064 || sym
->attr
.subroutine
)
4066 gfc_error ("Type name %qs at %C conflicts with previously declared "
4067 "entity at %L, which has the same name", name
,
4072 if (sym
&& sym
->attr
.flavor
== FL_DERIVED
4073 && sym
->attr
.pdt_template
4074 && gfc_current_state () != COMP_DERIVED
)
4076 m
= gfc_get_pdt_instance (decl_type_param_list
, &sym
, NULL
);
4079 gcc_assert (!sym
->attr
.pdt_template
&& sym
->attr
.pdt_type
);
4080 ts
->u
.derived
= sym
;
4081 strcpy (name
, gfc_dt_lower_string (sym
->name
));
4084 gfc_save_symbol_data (sym
);
4085 gfc_set_sym_referenced (sym
);
4086 if (!sym
->attr
.generic
4087 && !gfc_add_generic (&sym
->attr
, sym
->name
, NULL
))
4090 if (!sym
->attr
.function
4091 && !gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
4094 if (dt_sym
&& dt_sym
->attr
.flavor
== FL_DERIVED
4095 && dt_sym
->attr
.pdt_template
4096 && gfc_current_state () != COMP_DERIVED
)
4098 m
= gfc_get_pdt_instance (decl_type_param_list
, &dt_sym
, NULL
);
4101 gcc_assert (!dt_sym
->attr
.pdt_template
&& dt_sym
->attr
.pdt_type
);
4106 gfc_interface
*intr
, *head
;
4108 /* Use upper case to save the actual derived-type symbol. */
4109 gfc_get_symbol (dt_name
, NULL
, &dt_sym
);
4110 dt_sym
->name
= gfc_get_string ("%s", sym
->name
);
4111 head
= sym
->generic
;
4112 intr
= gfc_get_interface ();
4114 intr
->where
= gfc_current_locus
;
4116 sym
->generic
= intr
;
4117 sym
->attr
.if_source
= IFSRC_DECL
;
4120 gfc_save_symbol_data (dt_sym
);
4122 gfc_set_sym_referenced (dt_sym
);
4124 if (dt_sym
->attr
.flavor
!= FL_DERIVED
&& dt_sym
->attr
.flavor
!= FL_STRUCT
4125 && !gfc_add_flavor (&dt_sym
->attr
, FL_DERIVED
, sym
->name
, NULL
))
4128 ts
->u
.derived
= dt_sym
;
4134 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
4135 "intrinsic-type-spec at %C"))
4138 /* For all types except double, derived and character, look for an
4139 optional kind specifier. MATCH_NO is actually OK at this point. */
4140 if (implicit_flag
== 1)
4142 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
4148 if (gfc_current_form
== FORM_FREE
)
4150 c
= gfc_peek_ascii_char ();
4151 if (!gfc_is_whitespace (c
) && c
!= '*' && c
!= '('
4152 && c
!= ':' && c
!= ',')
4154 if (matched_type
&& c
== ')')
4156 gfc_next_ascii_char ();
4163 m
= gfc_match_kind_spec (ts
, false);
4164 if (m
== MATCH_NO
&& ts
->type
!= BT_CHARACTER
)
4166 m
= gfc_match_old_kind_spec (ts
);
4167 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) == -1)
4171 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
4174 /* Defer association of the KIND expression of function results
4175 until after USE and IMPORT statements. */
4176 if ((gfc_current_state () == COMP_NONE
&& gfc_error_flag_test ())
4177 || gfc_matching_function
)
4181 m
= MATCH_YES
; /* No kind specifier found. */
4187 /* Match an IMPLICIT NONE statement. Actually, this statement is
4188 already matched in parse.c, or we would not end up here in the
4189 first place. So the only thing we need to check, is if there is
4190 trailing garbage. If not, the match is successful. */
4193 gfc_match_implicit_none (void)
4197 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4199 bool external
= false;
4200 locus cur_loc
= gfc_current_locus
;
4202 if (gfc_current_ns
->seen_implicit_none
4203 || gfc_current_ns
->has_implicit_none_export
)
4205 gfc_error ("Duplicate IMPLICIT NONE statement at %C");
4209 gfc_gobble_whitespace ();
4210 c
= gfc_peek_ascii_char ();
4213 (void) gfc_next_ascii_char ();
4214 if (!gfc_notify_std (GFC_STD_F2018
, "IMPORT NONE with spec list at %C"))
4217 gfc_gobble_whitespace ();
4218 if (gfc_peek_ascii_char () == ')')
4220 (void) gfc_next_ascii_char ();
4226 m
= gfc_match (" %n", name
);
4230 if (strcmp (name
, "type") == 0)
4232 else if (strcmp (name
, "external") == 0)
4237 gfc_gobble_whitespace ();
4238 c
= gfc_next_ascii_char ();
4249 if (gfc_match_eos () != MATCH_YES
)
4252 gfc_set_implicit_none (type
, external
, &cur_loc
);
4258 /* Match the letter range(s) of an IMPLICIT statement. */
4261 match_implicit_range (void)
4267 cur_loc
= gfc_current_locus
;
4269 gfc_gobble_whitespace ();
4270 c
= gfc_next_ascii_char ();
4273 gfc_error ("Missing character range in IMPLICIT at %C");
4280 gfc_gobble_whitespace ();
4281 c1
= gfc_next_ascii_char ();
4285 gfc_gobble_whitespace ();
4286 c
= gfc_next_ascii_char ();
4291 inner
= 0; /* Fall through. */
4298 gfc_gobble_whitespace ();
4299 c2
= gfc_next_ascii_char ();
4303 gfc_gobble_whitespace ();
4304 c
= gfc_next_ascii_char ();
4306 if ((c
!= ',') && (c
!= ')'))
4319 gfc_error ("Letters must be in alphabetic order in "
4320 "IMPLICIT statement at %C");
4324 /* See if we can add the newly matched range to the pending
4325 implicits from this IMPLICIT statement. We do not check for
4326 conflicts with whatever earlier IMPLICIT statements may have
4327 set. This is done when we've successfully finished matching
4329 if (!gfc_add_new_implicit_range (c1
, c2
))
4336 gfc_syntax_error (ST_IMPLICIT
);
4338 gfc_current_locus
= cur_loc
;
4343 /* Match an IMPLICIT statement, storing the types for
4344 gfc_set_implicit() if the statement is accepted by the parser.
4345 There is a strange looking, but legal syntactic construction
4346 possible. It looks like:
4348 IMPLICIT INTEGER (a-b) (c-d)
4350 This is legal if "a-b" is a constant expression that happens to
4351 equal one of the legal kinds for integers. The real problem
4352 happens with an implicit specification that looks like:
4354 IMPLICIT INTEGER (a-b)
4356 In this case, a typespec matcher that is "greedy" (as most of the
4357 matchers are) gobbles the character range as a kindspec, leaving
4358 nothing left. We therefore have to go a bit more slowly in the
4359 matching process by inhibiting the kindspec checking during
4360 typespec matching and checking for a kind later. */
4363 gfc_match_implicit (void)
4370 if (gfc_current_ns
->seen_implicit_none
)
4372 gfc_error ("IMPLICIT statement at %C following an IMPLICIT NONE (type) "
4379 /* We don't allow empty implicit statements. */
4380 if (gfc_match_eos () == MATCH_YES
)
4382 gfc_error ("Empty IMPLICIT statement at %C");
4388 /* First cleanup. */
4389 gfc_clear_new_implicit ();
4391 /* A basic type is mandatory here. */
4392 m
= gfc_match_decl_type_spec (&ts
, 1);
4393 if (m
== MATCH_ERROR
)
4398 cur_loc
= gfc_current_locus
;
4399 m
= match_implicit_range ();
4403 /* We may have <TYPE> (<RANGE>). */
4404 gfc_gobble_whitespace ();
4405 c
= gfc_peek_ascii_char ();
4406 if (c
== ',' || c
== '\n' || c
== ';' || c
== '!')
4408 /* Check for CHARACTER with no length parameter. */
4409 if (ts
.type
== BT_CHARACTER
&& !ts
.u
.cl
)
4411 ts
.kind
= gfc_default_character_kind
;
4412 ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4413 ts
.u
.cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
,
4417 /* Record the Successful match. */
4418 if (!gfc_merge_new_implicit (&ts
))
4421 c
= gfc_next_ascii_char ();
4422 else if (gfc_match_eos () == MATCH_ERROR
)
4427 gfc_current_locus
= cur_loc
;
4430 /* Discard the (incorrectly) matched range. */
4431 gfc_clear_new_implicit ();
4433 /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
4434 if (ts
.type
== BT_CHARACTER
)
4435 m
= gfc_match_char_spec (&ts
);
4438 m
= gfc_match_kind_spec (&ts
, false);
4441 m
= gfc_match_old_kind_spec (&ts
);
4442 if (m
== MATCH_ERROR
)
4448 if (m
== MATCH_ERROR
)
4451 m
= match_implicit_range ();
4452 if (m
== MATCH_ERROR
)
4457 gfc_gobble_whitespace ();
4458 c
= gfc_next_ascii_char ();
4459 if (c
!= ',' && gfc_match_eos () != MATCH_YES
)
4462 if (!gfc_merge_new_implicit (&ts
))
4470 gfc_syntax_error (ST_IMPLICIT
);
4478 gfc_match_import (void)
4480 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4485 if (gfc_current_ns
->proc_name
== NULL
4486 || gfc_current_ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
4488 gfc_error ("IMPORT statement at %C only permitted in "
4489 "an INTERFACE body");
4493 if (gfc_current_ns
->proc_name
->attr
.module_procedure
)
4495 gfc_error ("F2008: C1210 IMPORT statement at %C is not permitted "
4496 "in a module procedure interface body");
4500 if (!gfc_notify_std (GFC_STD_F2003
, "IMPORT statement at %C"))
4503 if (gfc_match_eos () == MATCH_YES
)
4505 /* All host variables should be imported. */
4506 gfc_current_ns
->has_import_set
= 1;
4510 if (gfc_match (" ::") == MATCH_YES
)
4512 if (gfc_match_eos () == MATCH_YES
)
4514 gfc_error ("Expecting list of named entities at %C");
4522 m
= gfc_match (" %n", name
);
4526 if (gfc_current_ns
->parent
!= NULL
4527 && gfc_find_symbol (name
, gfc_current_ns
->parent
, 1, &sym
))
4529 gfc_error ("Type name %qs at %C is ambiguous", name
);
4532 else if (!sym
&& gfc_current_ns
->proc_name
->ns
->parent
!= NULL
4533 && gfc_find_symbol (name
,
4534 gfc_current_ns
->proc_name
->ns
->parent
,
4537 gfc_error ("Type name %qs at %C is ambiguous", name
);
4543 gfc_error ("Cannot IMPORT %qs from host scoping unit "
4544 "at %C - does not exist.", name
);
4548 if (gfc_find_symtree (gfc_current_ns
->sym_root
, name
))
4550 gfc_warning (0, "%qs is already IMPORTed from host scoping unit "
4555 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, name
);
4558 sym
->attr
.imported
= 1;
4560 if (sym
->attr
.generic
&& (sym
= gfc_find_dt_in_generic (sym
)))
4562 /* The actual derived type is stored in a symtree with the first
4563 letter of the name capitalized; the symtree with the all
4564 lower-case name contains the associated generic function. */
4565 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
,
4566 gfc_dt_upper_string (name
));
4569 sym
->attr
.imported
= 1;
4582 if (gfc_match_eos () == MATCH_YES
)
4584 if (gfc_match_char (',') != MATCH_YES
)
4591 gfc_error ("Syntax error in IMPORT statement at %C");
4596 /* A minimal implementation of gfc_match without whitespace, escape
4597 characters or variable arguments. Returns true if the next
4598 characters match the TARGET template exactly. */
4601 match_string_p (const char *target
)
4605 for (p
= target
; *p
; p
++)
4606 if ((char) gfc_next_ascii_char () != *p
)
4611 /* Matches an attribute specification including array specs. If
4612 successful, leaves the variables current_attr and current_as
4613 holding the specification. Also sets the colon_seen variable for
4614 later use by matchers associated with initializations.
4616 This subroutine is a little tricky in the sense that we don't know
4617 if we really have an attr-spec until we hit the double colon.
4618 Until that time, we can only return MATCH_NO. This forces us to
4619 check for duplicate specification at this level. */
4622 match_attr_spec (void)
4624 /* Modifiers that can exist in a type statement. */
4626 { GFC_DECL_BEGIN
= 0,
4627 DECL_ALLOCATABLE
= GFC_DECL_BEGIN
, DECL_DIMENSION
, DECL_EXTERNAL
,
4628 DECL_IN
, DECL_OUT
, DECL_INOUT
, DECL_INTRINSIC
, DECL_OPTIONAL
,
4629 DECL_PARAMETER
, DECL_POINTER
, DECL_PROTECTED
, DECL_PRIVATE
,
4630 DECL_STATIC
, DECL_AUTOMATIC
,
4631 DECL_PUBLIC
, DECL_SAVE
, DECL_TARGET
, DECL_VALUE
, DECL_VOLATILE
,
4632 DECL_IS_BIND_C
, DECL_CODIMENSION
, DECL_ASYNCHRONOUS
, DECL_CONTIGUOUS
,
4633 DECL_LEN
, DECL_KIND
, DECL_NONE
, GFC_DECL_END
/* Sentinel */
4636 /* GFC_DECL_END is the sentinel, index starts at 0. */
4637 #define NUM_DECL GFC_DECL_END
4639 locus start
, seen_at
[NUM_DECL
];
4646 gfc_clear_attr (¤t_attr
);
4647 start
= gfc_current_locus
;
4653 /* See if we get all of the keywords up to the final double colon. */
4654 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
4662 gfc_gobble_whitespace ();
4664 ch
= gfc_next_ascii_char ();
4667 /* This is the successful exit condition for the loop. */
4668 if (gfc_next_ascii_char () == ':')
4673 gfc_gobble_whitespace ();
4674 switch (gfc_peek_ascii_char ())
4677 gfc_next_ascii_char ();
4678 switch (gfc_next_ascii_char ())
4681 if (match_string_p ("locatable"))
4683 /* Matched "allocatable". */
4684 d
= DECL_ALLOCATABLE
;
4689 if (match_string_p ("ynchronous"))
4691 /* Matched "asynchronous". */
4692 d
= DECL_ASYNCHRONOUS
;
4697 if (match_string_p ("tomatic"))
4699 /* Matched "automatic". */
4707 /* Try and match the bind(c). */
4708 m
= gfc_match_bind_c (NULL
, true);
4711 else if (m
== MATCH_ERROR
)
4716 gfc_next_ascii_char ();
4717 if ('o' != gfc_next_ascii_char ())
4719 switch (gfc_next_ascii_char ())
4722 if (match_string_p ("imension"))
4724 d
= DECL_CODIMENSION
;
4729 if (match_string_p ("tiguous"))
4731 d
= DECL_CONTIGUOUS
;
4738 if (match_string_p ("dimension"))
4743 if (match_string_p ("external"))
4748 if (match_string_p ("int"))
4750 ch
= gfc_next_ascii_char ();
4753 if (match_string_p ("nt"))
4755 /* Matched "intent". */
4756 /* TODO: Call match_intent_spec from here. */
4757 if (gfc_match (" ( in out )") == MATCH_YES
)
4759 else if (gfc_match (" ( in )") == MATCH_YES
)
4761 else if (gfc_match (" ( out )") == MATCH_YES
)
4767 if (match_string_p ("insic"))
4769 /* Matched "intrinsic". */
4777 if (match_string_p ("kind"))
4782 if (match_string_p ("len"))
4787 if (match_string_p ("optional"))
4792 gfc_next_ascii_char ();
4793 switch (gfc_next_ascii_char ())
4796 if (match_string_p ("rameter"))
4798 /* Matched "parameter". */
4804 if (match_string_p ("inter"))
4806 /* Matched "pointer". */
4812 ch
= gfc_next_ascii_char ();
4815 if (match_string_p ("vate"))
4817 /* Matched "private". */
4823 if (match_string_p ("tected"))
4825 /* Matched "protected". */
4832 if (match_string_p ("blic"))
4834 /* Matched "public". */
4842 gfc_next_ascii_char ();
4843 switch (gfc_next_ascii_char ())
4846 if (match_string_p ("ve"))
4848 /* Matched "save". */
4854 if (match_string_p ("atic"))
4856 /* Matched "static". */
4864 if (match_string_p ("target"))
4869 gfc_next_ascii_char ();
4870 ch
= gfc_next_ascii_char ();
4873 if (match_string_p ("lue"))
4875 /* Matched "value". */
4881 if (match_string_p ("latile"))
4883 /* Matched "volatile". */
4891 /* No double colon and no recognizable decl_type, so assume that
4892 we've been looking at something else the whole time. */
4899 /* Check to make sure any parens are paired up correctly. */
4900 if (gfc_match_parens () == MATCH_ERROR
)
4907 seen_at
[d
] = gfc_current_locus
;
4909 if (d
== DECL_DIMENSION
|| d
== DECL_CODIMENSION
)
4911 gfc_array_spec
*as
= NULL
;
4913 m
= gfc_match_array_spec (&as
, d
== DECL_DIMENSION
,
4914 d
== DECL_CODIMENSION
);
4916 if (current_as
== NULL
)
4918 else if (m
== MATCH_YES
)
4920 if (!merge_array_spec (as
, current_as
, false))
4927 if (d
== DECL_CODIMENSION
)
4928 gfc_error ("Missing codimension specification at %C");
4930 gfc_error ("Missing dimension specification at %C");
4934 if (m
== MATCH_ERROR
)
4939 /* Since we've seen a double colon, we have to be looking at an
4940 attr-spec. This means that we can now issue errors. */
4941 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
4946 case DECL_ALLOCATABLE
:
4947 attr
= "ALLOCATABLE";
4949 case DECL_ASYNCHRONOUS
:
4950 attr
= "ASYNCHRONOUS";
4952 case DECL_CODIMENSION
:
4953 attr
= "CODIMENSION";
4955 case DECL_CONTIGUOUS
:
4956 attr
= "CONTIGUOUS";
4958 case DECL_DIMENSION
:
4965 attr
= "INTENT (IN)";
4968 attr
= "INTENT (OUT)";
4971 attr
= "INTENT (IN OUT)";
4973 case DECL_INTRINSIC
:
4985 case DECL_PARAMETER
:
4991 case DECL_PROTECTED
:
5006 case DECL_AUTOMATIC
:
5012 case DECL_IS_BIND_C
:
5022 attr
= NULL
; /* This shouldn't happen. */
5025 gfc_error ("Duplicate %s attribute at %L", attr
, &seen_at
[d
]);
5030 /* Now that we've dealt with duplicate attributes, add the attributes
5031 to the current attribute. */
5032 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
5039 if ((d
== DECL_STATIC
|| d
== DECL_AUTOMATIC
)
5040 && !flag_dec_static
)
5042 gfc_error ("%s at %L is a DEC extension, enable with "
5044 d
== DECL_STATIC
? "STATIC" : "AUTOMATIC", &seen_at
[d
]);
5048 /* Allow SAVE with STATIC, but don't complain. */
5049 if (d
== DECL_STATIC
&& seen
[DECL_SAVE
])
5052 if (gfc_current_state () == COMP_DERIVED
5053 && d
!= DECL_DIMENSION
&& d
!= DECL_CODIMENSION
5054 && d
!= DECL_POINTER
&& d
!= DECL_PRIVATE
5055 && d
!= DECL_PUBLIC
&& d
!= DECL_CONTIGUOUS
&& d
!= DECL_NONE
)
5057 if (d
== DECL_ALLOCATABLE
)
5059 if (!gfc_notify_std (GFC_STD_F2003
, "ALLOCATABLE "
5060 "attribute at %C in a TYPE definition"))
5066 else if (d
== DECL_KIND
)
5068 if (!gfc_notify_std (GFC_STD_F2003
, "KIND "
5069 "attribute at %C in a TYPE definition"))
5074 if (current_ts
.type
!= BT_INTEGER
)
5076 gfc_error ("Component with KIND attribute at %C must be "
5081 if (current_ts
.kind
!= gfc_default_integer_kind
)
5083 gfc_error ("Component with KIND attribute at %C must be "
5084 "default integer kind (%d)",
5085 gfc_default_integer_kind
);
5090 else if (d
== DECL_LEN
)
5092 if (!gfc_notify_std (GFC_STD_F2003
, "LEN "
5093 "attribute at %C in a TYPE definition"))
5098 if (current_ts
.type
!= BT_INTEGER
)
5100 gfc_error ("Component with LEN attribute at %C must be "
5105 if (current_ts
.kind
!= gfc_default_integer_kind
)
5107 gfc_error ("Component with LEN attribute at %C must be "
5108 "default integer kind (%d)",
5109 gfc_default_integer_kind
);
5116 gfc_error ("Attribute at %L is not allowed in a TYPE definition",
5123 if ((d
== DECL_PRIVATE
|| d
== DECL_PUBLIC
)
5124 && gfc_current_state () != COMP_MODULE
)
5126 if (d
== DECL_PRIVATE
)
5130 if (gfc_current_state () == COMP_DERIVED
5131 && gfc_state_stack
->previous
5132 && gfc_state_stack
->previous
->state
== COMP_MODULE
)
5134 if (!gfc_notify_std (GFC_STD_F2003
, "Attribute %s "
5135 "at %L in a TYPE definition", attr
,
5144 gfc_error ("%s attribute at %L is not allowed outside of the "
5145 "specification part of a module", attr
, &seen_at
[d
]);
5151 if (gfc_current_state () != COMP_DERIVED
5152 && (d
== DECL_KIND
|| d
== DECL_LEN
))
5154 gfc_error ("Attribute at %L is not allowed outside a TYPE "
5155 "definition", &seen_at
[d
]);
5162 case DECL_ALLOCATABLE
:
5163 t
= gfc_add_allocatable (¤t_attr
, &seen_at
[d
]);
5166 case DECL_ASYNCHRONOUS
:
5167 if (!gfc_notify_std (GFC_STD_F2003
, "ASYNCHRONOUS attribute at %C"))
5170 t
= gfc_add_asynchronous (¤t_attr
, NULL
, &seen_at
[d
]);
5173 case DECL_CODIMENSION
:
5174 t
= gfc_add_codimension (¤t_attr
, NULL
, &seen_at
[d
]);
5177 case DECL_CONTIGUOUS
:
5178 if (!gfc_notify_std (GFC_STD_F2008
, "CONTIGUOUS attribute at %C"))
5181 t
= gfc_add_contiguous (¤t_attr
, NULL
, &seen_at
[d
]);
5184 case DECL_DIMENSION
:
5185 t
= gfc_add_dimension (¤t_attr
, NULL
, &seen_at
[d
]);
5189 t
= gfc_add_external (¤t_attr
, &seen_at
[d
]);
5193 t
= gfc_add_intent (¤t_attr
, INTENT_IN
, &seen_at
[d
]);
5197 t
= gfc_add_intent (¤t_attr
, INTENT_OUT
, &seen_at
[d
]);
5201 t
= gfc_add_intent (¤t_attr
, INTENT_INOUT
, &seen_at
[d
]);
5204 case DECL_INTRINSIC
:
5205 t
= gfc_add_intrinsic (¤t_attr
, &seen_at
[d
]);
5209 t
= gfc_add_optional (¤t_attr
, &seen_at
[d
]);
5213 t
= gfc_add_kind (¤t_attr
, &seen_at
[d
]);
5217 t
= gfc_add_len (¤t_attr
, &seen_at
[d
]);
5220 case DECL_PARAMETER
:
5221 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, &seen_at
[d
]);
5225 t
= gfc_add_pointer (¤t_attr
, &seen_at
[d
]);
5228 case DECL_PROTECTED
:
5229 if (gfc_current_state () != COMP_MODULE
5230 || (gfc_current_ns
->proc_name
5231 && gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
))
5233 gfc_error ("PROTECTED at %C only allowed in specification "
5234 "part of a module");
5239 if (!gfc_notify_std (GFC_STD_F2003
, "PROTECTED attribute at %C"))
5242 t
= gfc_add_protected (¤t_attr
, NULL
, &seen_at
[d
]);
5246 t
= gfc_add_access (¤t_attr
, ACCESS_PRIVATE
, NULL
,
5251 t
= gfc_add_access (¤t_attr
, ACCESS_PUBLIC
, NULL
,
5257 t
= gfc_add_save (¤t_attr
, SAVE_EXPLICIT
, NULL
, &seen_at
[d
]);
5260 case DECL_AUTOMATIC
:
5261 t
= gfc_add_automatic (¤t_attr
, NULL
, &seen_at
[d
]);
5265 t
= gfc_add_target (¤t_attr
, &seen_at
[d
]);
5268 case DECL_IS_BIND_C
:
5269 t
= gfc_add_is_bind_c(¤t_attr
, NULL
, &seen_at
[d
], 0);
5273 if (!gfc_notify_std (GFC_STD_F2003
, "VALUE attribute at %C"))
5276 t
= gfc_add_value (¤t_attr
, NULL
, &seen_at
[d
]);
5280 if (!gfc_notify_std (GFC_STD_F2003
, "VOLATILE attribute at %C"))
5283 t
= gfc_add_volatile (¤t_attr
, NULL
, &seen_at
[d
]);
5287 gfc_internal_error ("match_attr_spec(): Bad attribute");
5297 /* Since Fortran 2008 module variables implicitly have the SAVE attribute. */
5298 if ((gfc_current_state () == COMP_MODULE
5299 || gfc_current_state () == COMP_SUBMODULE
)
5300 && !current_attr
.save
5301 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
5302 current_attr
.save
= SAVE_IMPLICIT
;
5308 gfc_current_locus
= start
;
5309 gfc_free_array_spec (current_as
);
5316 /* Set the binding label, dest_label, either with the binding label
5317 stored in the given gfc_typespec, ts, or if none was provided, it
5318 will be the symbol name in all lower case, as required by the draft
5319 (J3/04-007, section 15.4.1). If a binding label was given and
5320 there is more than one argument (num_idents), it is an error. */
5323 set_binding_label (const char **dest_label
, const char *sym_name
,
5326 if (num_idents
> 1 && has_name_equals
)
5328 gfc_error ("Multiple identifiers provided with "
5329 "single NAME= specifier at %C");
5333 if (curr_binding_label
)
5334 /* Binding label given; store in temp holder till have sym. */
5335 *dest_label
= curr_binding_label
;
5338 /* No binding label given, and the NAME= specifier did not exist,
5339 which means there was no NAME="". */
5340 if (sym_name
!= NULL
&& has_name_equals
== 0)
5341 *dest_label
= IDENTIFIER_POINTER (get_identifier (sym_name
));
5348 /* Set the status of the given common block as being BIND(C) or not,
5349 depending on the given parameter, is_bind_c. */
5352 set_com_block_bind_c (gfc_common_head
*com_block
, int is_bind_c
)
5354 com_block
->is_bind_c
= is_bind_c
;
5359 /* Verify that the given gfc_typespec is for a C interoperable type. */
5362 gfc_verify_c_interop (gfc_typespec
*ts
)
5364 if (ts
->type
== BT_DERIVED
&& ts
->u
.derived
!= NULL
)
5365 return (ts
->u
.derived
->ts
.is_c_interop
|| ts
->u
.derived
->attr
.is_bind_c
)
5367 else if (ts
->type
== BT_CLASS
)
5369 else if (ts
->is_c_interop
!= 1 && ts
->type
!= BT_ASSUMED
)
5376 /* Verify that the variables of a given common block, which has been
5377 defined with the attribute specifier bind(c), to be of a C
5378 interoperable type. Errors will be reported here, if
5382 verify_com_block_vars_c_interop (gfc_common_head
*com_block
)
5384 gfc_symbol
*curr_sym
= NULL
;
5387 curr_sym
= com_block
->head
;
5389 /* Make sure we have at least one symbol. */
5390 if (curr_sym
== NULL
)
5393 /* Here we know we have a symbol, so we'll execute this loop
5397 /* The second to last param, 1, says this is in a common block. */
5398 retval
= verify_bind_c_sym (curr_sym
, &(curr_sym
->ts
), 1, com_block
);
5399 curr_sym
= curr_sym
->common_next
;
5400 } while (curr_sym
!= NULL
);
5406 /* Verify that a given BIND(C) symbol is C interoperable. If it is not,
5407 an appropriate error message is reported. */
5410 verify_bind_c_sym (gfc_symbol
*tmp_sym
, gfc_typespec
*ts
,
5411 int is_in_common
, gfc_common_head
*com_block
)
5413 bool bind_c_function
= false;
5416 if (tmp_sym
->attr
.function
&& tmp_sym
->attr
.is_bind_c
)
5417 bind_c_function
= true;
5419 if (tmp_sym
->attr
.function
&& tmp_sym
->result
!= NULL
)
5421 tmp_sym
= tmp_sym
->result
;
5422 /* Make sure it wasn't an implicitly typed result. */
5423 if (tmp_sym
->attr
.implicit_type
&& warn_c_binding_type
)
5425 gfc_warning (OPT_Wc_binding_type
,
5426 "Implicitly declared BIND(C) function %qs at "
5427 "%L may not be C interoperable", tmp_sym
->name
,
5428 &tmp_sym
->declared_at
);
5429 tmp_sym
->ts
.f90_type
= tmp_sym
->ts
.type
;
5430 /* Mark it as C interoperable to prevent duplicate warnings. */
5431 tmp_sym
->ts
.is_c_interop
= 1;
5432 tmp_sym
->attr
.is_c_interop
= 1;
5436 /* Here, we know we have the bind(c) attribute, so if we have
5437 enough type info, then verify that it's a C interop kind.
5438 The info could be in the symbol already, or possibly still in
5439 the given ts (current_ts), so look in both. */
5440 if (tmp_sym
->ts
.type
!= BT_UNKNOWN
|| ts
->type
!= BT_UNKNOWN
)
5442 if (!gfc_verify_c_interop (&(tmp_sym
->ts
)))
5444 /* See if we're dealing with a sym in a common block or not. */
5445 if (is_in_common
== 1 && warn_c_binding_type
)
5447 gfc_warning (OPT_Wc_binding_type
,
5448 "Variable %qs in common block %qs at %L "
5449 "may not be a C interoperable "
5450 "kind though common block %qs is BIND(C)",
5451 tmp_sym
->name
, com_block
->name
,
5452 &(tmp_sym
->declared_at
), com_block
->name
);
5456 if (tmp_sym
->ts
.type
== BT_DERIVED
|| ts
->type
== BT_DERIVED
)
5457 gfc_error ("Type declaration %qs at %L is not C "
5458 "interoperable but it is BIND(C)",
5459 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5460 else if (warn_c_binding_type
)
5461 gfc_warning (OPT_Wc_binding_type
, "Variable %qs at %L "
5462 "may not be a C interoperable "
5463 "kind but it is BIND(C)",
5464 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5468 /* Variables declared w/in a common block can't be bind(c)
5469 since there's no way for C to see these variables, so there's
5470 semantically no reason for the attribute. */
5471 if (is_in_common
== 1 && tmp_sym
->attr
.is_bind_c
== 1)
5473 gfc_error ("Variable %qs in common block %qs at "
5474 "%L cannot be declared with BIND(C) "
5475 "since it is not a global",
5476 tmp_sym
->name
, com_block
->name
,
5477 &(tmp_sym
->declared_at
));
5481 /* Scalar variables that are bind(c) can not have the pointer
5482 or allocatable attributes. */
5483 if (tmp_sym
->attr
.is_bind_c
== 1)
5485 if (tmp_sym
->attr
.pointer
== 1)
5487 gfc_error ("Variable %qs at %L cannot have both the "
5488 "POINTER and BIND(C) attributes",
5489 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5493 if (tmp_sym
->attr
.allocatable
== 1)
5495 gfc_error ("Variable %qs at %L cannot have both the "
5496 "ALLOCATABLE and BIND(C) attributes",
5497 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5503 /* If it is a BIND(C) function, make sure the return value is a
5504 scalar value. The previous tests in this function made sure
5505 the type is interoperable. */
5506 if (bind_c_function
&& tmp_sym
->as
!= NULL
)
5507 gfc_error ("Return type of BIND(C) function %qs at %L cannot "
5508 "be an array", tmp_sym
->name
, &(tmp_sym
->declared_at
));
5510 /* BIND(C) functions can not return a character string. */
5511 if (bind_c_function
&& tmp_sym
->ts
.type
== BT_CHARACTER
)
5512 if (tmp_sym
->ts
.u
.cl
== NULL
|| tmp_sym
->ts
.u
.cl
->length
== NULL
5513 || tmp_sym
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
5514 || mpz_cmp_si (tmp_sym
->ts
.u
.cl
->length
->value
.integer
, 1) != 0)
5515 gfc_error ("Return type of BIND(C) function %qs at %L cannot "
5516 "be a character string", tmp_sym
->name
,
5517 &(tmp_sym
->declared_at
));
5520 /* See if the symbol has been marked as private. If it has, make sure
5521 there is no binding label and warn the user if there is one. */
5522 if (tmp_sym
->attr
.access
== ACCESS_PRIVATE
5523 && tmp_sym
->binding_label
)
5524 /* Use gfc_warning_now because we won't say that the symbol fails
5525 just because of this. */
5526 gfc_warning_now (0, "Symbol %qs at %L is marked PRIVATE but has been "
5527 "given the binding label %qs", tmp_sym
->name
,
5528 &(tmp_sym
->declared_at
), tmp_sym
->binding_label
);
5534 /* Set the appropriate fields for a symbol that's been declared as
5535 BIND(C) (the is_bind_c flag and the binding label), and verify that
5536 the type is C interoperable. Errors are reported by the functions
5537 used to set/test these fields. */
5540 set_verify_bind_c_sym (gfc_symbol
*tmp_sym
, int num_idents
)
5544 /* TODO: Do we need to make sure the vars aren't marked private? */
5546 /* Set the is_bind_c bit in symbol_attribute. */
5547 gfc_add_is_bind_c (&(tmp_sym
->attr
), tmp_sym
->name
, &gfc_current_locus
, 0);
5549 if (!set_binding_label (&tmp_sym
->binding_label
, tmp_sym
->name
, num_idents
))
5556 /* Set the fields marking the given common block as BIND(C), including
5557 a binding label, and report any errors encountered. */
5560 set_verify_bind_c_com_block (gfc_common_head
*com_block
, int num_idents
)
5564 /* destLabel, common name, typespec (which may have binding label). */
5565 if (!set_binding_label (&com_block
->binding_label
, com_block
->name
,
5569 /* Set the given common block (com_block) to being bind(c) (1). */
5570 set_com_block_bind_c (com_block
, 1);
5576 /* Retrieve the list of one or more identifiers that the given bind(c)
5577 attribute applies to. */
5580 get_bind_c_idents (void)
5582 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5584 gfc_symbol
*tmp_sym
= NULL
;
5586 gfc_common_head
*com_block
= NULL
;
5588 if (gfc_match_name (name
) == MATCH_YES
)
5590 found_id
= MATCH_YES
;
5591 gfc_get_ha_symbol (name
, &tmp_sym
);
5593 else if (match_common_name (name
) == MATCH_YES
)
5595 found_id
= MATCH_YES
;
5596 com_block
= gfc_get_common (name
, 0);
5600 gfc_error ("Need either entity or common block name for "
5601 "attribute specification statement at %C");
5605 /* Save the current identifier and look for more. */
5608 /* Increment the number of identifiers found for this spec stmt. */
5611 /* Make sure we have a sym or com block, and verify that it can
5612 be bind(c). Set the appropriate field(s) and look for more
5614 if (tmp_sym
!= NULL
|| com_block
!= NULL
)
5616 if (tmp_sym
!= NULL
)
5618 if (!set_verify_bind_c_sym (tmp_sym
, num_idents
))
5623 if (!set_verify_bind_c_com_block (com_block
, num_idents
))
5627 /* Look to see if we have another identifier. */
5629 if (gfc_match_eos () == MATCH_YES
)
5630 found_id
= MATCH_NO
;
5631 else if (gfc_match_char (',') != MATCH_YES
)
5632 found_id
= MATCH_NO
;
5633 else if (gfc_match_name (name
) == MATCH_YES
)
5635 found_id
= MATCH_YES
;
5636 gfc_get_ha_symbol (name
, &tmp_sym
);
5638 else if (match_common_name (name
) == MATCH_YES
)
5640 found_id
= MATCH_YES
;
5641 com_block
= gfc_get_common (name
, 0);
5645 gfc_error ("Missing entity or common block name for "
5646 "attribute specification statement at %C");
5652 gfc_internal_error ("Missing symbol");
5654 } while (found_id
== MATCH_YES
);
5656 /* if we get here we were successful */
5661 /* Try and match a BIND(C) attribute specification statement. */
5664 gfc_match_bind_c_stmt (void)
5666 match found_match
= MATCH_NO
;
5671 /* This may not be necessary. */
5673 /* Clear the temporary binding label holder. */
5674 curr_binding_label
= NULL
;
5676 /* Look for the bind(c). */
5677 found_match
= gfc_match_bind_c (NULL
, true);
5679 if (found_match
== MATCH_YES
)
5681 if (!gfc_notify_std (GFC_STD_F2003
, "BIND(C) statement at %C"))
5684 /* Look for the :: now, but it is not required. */
5687 /* Get the identifier(s) that needs to be updated. This may need to
5688 change to hand the flag(s) for the attr specified so all identifiers
5689 found can have all appropriate parts updated (assuming that the same
5690 spec stmt can have multiple attrs, such as both bind(c) and
5692 if (!get_bind_c_idents ())
5693 /* Error message should have printed already. */
5701 /* Match a data declaration statement. */
5704 gfc_match_data_decl (void)
5710 type_param_spec_list
= NULL
;
5711 decl_type_param_list
= NULL
;
5713 num_idents_on_line
= 0;
5715 m
= gfc_match_decl_type_spec (¤t_ts
, 0);
5719 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
5720 && !gfc_comp_struct (gfc_current_state ()))
5722 sym
= gfc_use_derived (current_ts
.u
.derived
);
5730 current_ts
.u
.derived
= sym
;
5733 m
= match_attr_spec ();
5734 if (m
== MATCH_ERROR
)
5740 if (current_ts
.type
== BT_CLASS
5741 && current_ts
.u
.derived
->attr
.unlimited_polymorphic
)
5744 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
5745 && current_ts
.u
.derived
->components
== NULL
5746 && !current_ts
.u
.derived
->attr
.zero_comp
)
5749 if (current_attr
.pointer
&& gfc_comp_struct (gfc_current_state ()))
5752 if (current_attr
.allocatable
&& gfc_current_state () == COMP_DERIVED
5753 && current_ts
.u
.derived
== gfc_current_block ())
5756 gfc_find_symbol (current_ts
.u
.derived
->name
,
5757 current_ts
.u
.derived
->ns
, 1, &sym
);
5759 /* Any symbol that we find had better be a type definition
5760 which has its components defined, or be a structure definition
5761 actively being parsed. */
5762 if (sym
!= NULL
&& gfc_fl_struct (sym
->attr
.flavor
)
5763 && (current_ts
.u
.derived
->components
!= NULL
5764 || current_ts
.u
.derived
->attr
.zero_comp
5765 || current_ts
.u
.derived
== gfc_new_block
))
5768 gfc_error ("Derived type at %C has not been previously defined "
5769 "and so cannot appear in a derived type definition");
5775 /* If we have an old-style character declaration, and no new-style
5776 attribute specifications, then there a comma is optional between
5777 the type specification and the variable list. */
5778 if (m
== MATCH_NO
&& current_ts
.type
== BT_CHARACTER
&& old_char_selector
)
5779 gfc_match_char (',');
5781 /* Give the types/attributes to symbols that follow. Give the element
5782 a number so that repeat character length expressions can be copied. */
5786 num_idents_on_line
++;
5787 m
= variable_decl (elem
++);
5788 if (m
== MATCH_ERROR
)
5793 if (gfc_match_eos () == MATCH_YES
)
5795 if (gfc_match_char (',') != MATCH_YES
)
5799 if (!gfc_error_flag_test ())
5801 /* An anonymous structure declaration is unambiguous; if we matched one
5802 according to gfc_match_structure_decl, we need to return MATCH_YES
5803 here to avoid confusing the remaining matchers, even if there was an
5804 error during variable_decl. We must flush any such errors. Note this
5805 causes the parser to gracefully continue parsing the remaining input
5806 as a structure body, which likely follows. */
5807 if (current_ts
.type
== BT_DERIVED
&& current_ts
.u
.derived
5808 && gfc_fl_struct (current_ts
.u
.derived
->attr
.flavor
))
5810 gfc_error_now ("Syntax error in anonymous structure declaration"
5812 /* Skip the bad variable_decl and line up for the start of the
5814 gfc_error_recovery ();
5819 gfc_error ("Syntax error in data declaration at %C");
5824 gfc_free_data_all (gfc_current_ns
);
5827 if (saved_kind_expr
)
5828 gfc_free_expr (saved_kind_expr
);
5829 if (type_param_spec_list
)
5830 gfc_free_actual_arglist (type_param_spec_list
);
5831 if (decl_type_param_list
)
5832 gfc_free_actual_arglist (decl_type_param_list
);
5833 saved_kind_expr
= NULL
;
5834 gfc_free_array_spec (current_as
);
5840 /* Match a prefix associated with a function or subroutine
5841 declaration. If the typespec pointer is nonnull, then a typespec
5842 can be matched. Note that if nothing matches, MATCH_YES is
5843 returned (the null string was matched). */
5846 gfc_match_prefix (gfc_typespec
*ts
)
5852 gfc_clear_attr (¤t_attr
);
5854 seen_impure
= false;
5856 gcc_assert (!gfc_matching_prefix
);
5857 gfc_matching_prefix
= true;
5861 found_prefix
= false;
5863 /* MODULE is a prefix like PURE, ELEMENTAL, etc., having a
5864 corresponding attribute seems natural and distinguishes these
5865 procedures from procedure types of PROC_MODULE, which these are
5867 if (gfc_match ("module% ") == MATCH_YES
)
5869 if (!gfc_notify_std (GFC_STD_F2008
, "MODULE prefix at %C"))
5872 current_attr
.module_procedure
= 1;
5873 found_prefix
= true;
5876 if (!seen_type
&& ts
!= NULL
5877 && gfc_match_decl_type_spec (ts
, 0) == MATCH_YES
5878 && gfc_match_space () == MATCH_YES
)
5882 found_prefix
= true;
5885 if (gfc_match ("elemental% ") == MATCH_YES
)
5887 if (!gfc_add_elemental (¤t_attr
, NULL
))
5890 found_prefix
= true;
5893 if (gfc_match ("pure% ") == MATCH_YES
)
5895 if (!gfc_add_pure (¤t_attr
, NULL
))
5898 found_prefix
= true;
5901 if (gfc_match ("recursive% ") == MATCH_YES
)
5903 if (!gfc_add_recursive (¤t_attr
, NULL
))
5906 found_prefix
= true;
5909 /* IMPURE is a somewhat special case, as it needs not set an actual
5910 attribute but rather only prevents ELEMENTAL routines from being
5911 automatically PURE. */
5912 if (gfc_match ("impure% ") == MATCH_YES
)
5914 if (!gfc_notify_std (GFC_STD_F2008
, "IMPURE procedure at %C"))
5918 found_prefix
= true;
5921 while (found_prefix
);
5923 /* IMPURE and PURE must not both appear, of course. */
5924 if (seen_impure
&& current_attr
.pure
)
5926 gfc_error ("PURE and IMPURE must not appear both at %C");
5930 /* If IMPURE it not seen but the procedure is ELEMENTAL, mark it as PURE. */
5931 if (!seen_impure
&& current_attr
.elemental
&& !current_attr
.pure
)
5933 if (!gfc_add_pure (¤t_attr
, NULL
))
5937 /* At this point, the next item is not a prefix. */
5938 gcc_assert (gfc_matching_prefix
);
5940 gfc_matching_prefix
= false;
5944 gcc_assert (gfc_matching_prefix
);
5945 gfc_matching_prefix
= false;
5950 /* Copy attributes matched by gfc_match_prefix() to attributes on a symbol. */
5953 copy_prefix (symbol_attribute
*dest
, locus
*where
)
5955 if (dest
->module_procedure
)
5957 if (current_attr
.elemental
)
5958 dest
->elemental
= 1;
5960 if (current_attr
.pure
)
5963 if (current_attr
.recursive
)
5964 dest
->recursive
= 1;
5966 /* Module procedures are unusual in that the 'dest' is copied from
5967 the interface declaration. However, this is an oportunity to
5968 check that the submodule declaration is compliant with the
5970 if (dest
->elemental
&& !current_attr
.elemental
)
5972 gfc_error ("ELEMENTAL prefix in MODULE PROCEDURE interface is "
5973 "missing at %L", where
);
5977 if (dest
->pure
&& !current_attr
.pure
)
5979 gfc_error ("PURE prefix in MODULE PROCEDURE interface is "
5980 "missing at %L", where
);
5984 if (dest
->recursive
&& !current_attr
.recursive
)
5986 gfc_error ("RECURSIVE prefix in MODULE PROCEDURE interface is "
5987 "missing at %L", where
);
5994 if (current_attr
.elemental
&& !gfc_add_elemental (dest
, where
))
5997 if (current_attr
.pure
&& !gfc_add_pure (dest
, where
))
6000 if (current_attr
.recursive
&& !gfc_add_recursive (dest
, where
))
6007 /* Match a formal argument list or, if typeparam is true, a
6008 type_param_name_list. */
6011 gfc_match_formal_arglist (gfc_symbol
*progname
, int st_flag
,
6012 int null_flag
, bool typeparam
)
6014 gfc_formal_arglist
*head
, *tail
, *p
, *q
;
6015 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6018 gfc_formal_arglist
*formal
= NULL
;
6022 /* Keep the interface formal argument list and null it so that the
6023 matching for the new declaration can be done. The numbers and
6024 names of the arguments are checked here. The interface formal
6025 arguments are retained in formal_arglist and the characteristics
6026 are compared in resolve.c(resolve_fl_procedure). See the remark
6027 in get_proc_name about the eventual need to copy the formal_arglist
6028 and populate the formal namespace of the interface symbol. */
6029 if (progname
->attr
.module_procedure
6030 && progname
->attr
.host_assoc
)
6032 formal
= progname
->formal
;
6033 progname
->formal
= NULL
;
6036 if (gfc_match_char ('(') != MATCH_YES
)
6043 if (gfc_match_char (')') == MATCH_YES
)
6048 if (gfc_match_char ('*') == MATCH_YES
)
6051 if (!typeparam
&& !gfc_notify_std (GFC_STD_F95_OBS
,
6052 "Alternate-return argument at %C"))
6058 gfc_error_now ("A parameter name is required at %C");
6062 m
= gfc_match_name (name
);
6066 gfc_error_now ("A parameter name is required at %C");
6070 if (!typeparam
&& gfc_get_symbol (name
, NULL
, &sym
))
6073 && gfc_get_symbol (name
, progname
->f2k_derived
, &sym
))
6077 p
= gfc_get_formal_arglist ();
6089 /* We don't add the VARIABLE flavor because the name could be a
6090 dummy procedure. We don't apply these attributes to formal
6091 arguments of statement functions. */
6092 if (sym
!= NULL
&& !st_flag
6093 && (!gfc_add_dummy(&sym
->attr
, sym
->name
, NULL
)
6094 || !gfc_missing_attr (&sym
->attr
, NULL
)))
6100 /* The name of a program unit can be in a different namespace,
6101 so check for it explicitly. After the statement is accepted,
6102 the name is checked for especially in gfc_get_symbol(). */
6103 if (gfc_new_block
!= NULL
&& sym
!= NULL
&& !typeparam
6104 && strcmp (sym
->name
, gfc_new_block
->name
) == 0)
6106 gfc_error ("Name %qs at %C is the name of the procedure",
6112 if (gfc_match_char (')') == MATCH_YES
)
6115 m
= gfc_match_char (',');
6119 gfc_error_now ("Expected parameter list in type declaration "
6122 gfc_error ("Unexpected junk in formal argument list at %C");
6128 /* Check for duplicate symbols in the formal argument list. */
6131 for (p
= head
; p
->next
; p
= p
->next
)
6136 for (q
= p
->next
; q
; q
= q
->next
)
6137 if (p
->sym
== q
->sym
)
6140 gfc_error_now ("Duplicate name %qs in parameter "
6141 "list at %C", p
->sym
->name
);
6143 gfc_error ("Duplicate symbol %qs in formal argument "
6144 "list at %C", p
->sym
->name
);
6152 if (!gfc_add_explicit_interface (progname
, IFSRC_DECL
, head
, NULL
))
6158 /* gfc_error_now used in following and return with MATCH_YES because
6159 doing otherwise results in a cascade of extraneous errors and in
6160 some cases an ICE in symbol.c(gfc_release_symbol). */
6161 if (progname
->attr
.module_procedure
&& progname
->attr
.host_assoc
)
6163 bool arg_count_mismatch
= false;
6165 if (!formal
&& head
)
6166 arg_count_mismatch
= true;
6168 /* Abbreviated module procedure declaration is not meant to have any
6169 formal arguments! */
6170 if (!progname
->abr_modproc_decl
&& formal
&& !head
)
6171 arg_count_mismatch
= true;
6173 for (p
= formal
, q
= head
; p
&& q
; p
= p
->next
, q
= q
->next
)
6175 if ((p
->next
!= NULL
&& q
->next
== NULL
)
6176 || (p
->next
== NULL
&& q
->next
!= NULL
))
6177 arg_count_mismatch
= true;
6178 else if ((p
->sym
== NULL
&& q
->sym
== NULL
)
6179 || strcmp (p
->sym
->name
, q
->sym
->name
) == 0)
6182 gfc_error_now ("Mismatch in MODULE PROCEDURE formal "
6183 "argument names (%s/%s) at %C",
6184 p
->sym
->name
, q
->sym
->name
);
6187 if (arg_count_mismatch
)
6188 gfc_error_now ("Mismatch in number of MODULE PROCEDURE "
6189 "formal arguments at %C");
6195 gfc_free_formal_arglist (head
);
6200 /* Match a RESULT specification following a function declaration or
6201 ENTRY statement. Also matches the end-of-statement. */
6204 match_result (gfc_symbol
*function
, gfc_symbol
**result
)
6206 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6210 if (gfc_match (" result (") != MATCH_YES
)
6213 m
= gfc_match_name (name
);
6217 /* Get the right paren, and that's it because there could be the
6218 bind(c) attribute after the result clause. */
6219 if (gfc_match_char (')') != MATCH_YES
)
6221 /* TODO: should report the missing right paren here. */
6225 if (strcmp (function
->name
, name
) == 0)
6227 gfc_error ("RESULT variable at %C must be different than function name");
6231 if (gfc_get_symbol (name
, NULL
, &r
))
6234 if (!gfc_add_result (&r
->attr
, r
->name
, NULL
))
6243 /* Match a function suffix, which could be a combination of a result
6244 clause and BIND(C), either one, or neither. The draft does not
6245 require them to come in a specific order. */
6248 gfc_match_suffix (gfc_symbol
*sym
, gfc_symbol
**result
)
6250 match is_bind_c
; /* Found bind(c). */
6251 match is_result
; /* Found result clause. */
6252 match found_match
; /* Status of whether we've found a good match. */
6253 char peek_char
; /* Character we're going to peek at. */
6254 bool allow_binding_name
;
6256 /* Initialize to having found nothing. */
6257 found_match
= MATCH_NO
;
6258 is_bind_c
= MATCH_NO
;
6259 is_result
= MATCH_NO
;
6261 /* Get the next char to narrow between result and bind(c). */
6262 gfc_gobble_whitespace ();
6263 peek_char
= gfc_peek_ascii_char ();
6265 /* C binding names are not allowed for internal procedures. */
6266 if (gfc_current_state () == COMP_CONTAINS
6267 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
6268 allow_binding_name
= false;
6270 allow_binding_name
= true;
6275 /* Look for result clause. */
6276 is_result
= match_result (sym
, result
);
6277 if (is_result
== MATCH_YES
)
6279 /* Now see if there is a bind(c) after it. */
6280 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
6281 /* We've found the result clause and possibly bind(c). */
6282 found_match
= MATCH_YES
;
6285 /* This should only be MATCH_ERROR. */
6286 found_match
= is_result
;
6289 /* Look for bind(c) first. */
6290 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
6291 if (is_bind_c
== MATCH_YES
)
6293 /* Now see if a result clause followed it. */
6294 is_result
= match_result (sym
, result
);
6295 found_match
= MATCH_YES
;
6299 /* Should only be a MATCH_ERROR if we get here after seeing 'b'. */
6300 found_match
= MATCH_ERROR
;
6304 gfc_error ("Unexpected junk after function declaration at %C");
6305 found_match
= MATCH_ERROR
;
6309 if (is_bind_c
== MATCH_YES
)
6311 /* Fortran 2008 draft allows BIND(C) for internal procedures. */
6312 if (gfc_current_state () == COMP_CONTAINS
6313 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
6314 && !gfc_notify_std (GFC_STD_F2008
, "BIND(C) attribute "
6315 "at %L may not be specified for an internal "
6316 "procedure", &gfc_current_locus
))
6319 if (!gfc_add_is_bind_c (&(sym
->attr
), sym
->name
, &gfc_current_locus
, 1))
6327 /* Procedure pointer return value without RESULT statement:
6328 Add "hidden" result variable named "ppr@". */
6331 add_hidden_procptr_result (gfc_symbol
*sym
)
6335 if (gfc_notification_std (GFC_STD_F2003
) == ERROR
)
6338 /* First usage case: PROCEDURE and EXTERNAL statements. */
6339 case1
= gfc_current_state () == COMP_FUNCTION
&& gfc_current_block ()
6340 && strcmp (gfc_current_block ()->name
, sym
->name
) == 0
6341 && sym
->attr
.external
;
6342 /* Second usage case: INTERFACE statements. */
6343 case2
= gfc_current_state () == COMP_INTERFACE
&& gfc_state_stack
->previous
6344 && gfc_state_stack
->previous
->state
== COMP_FUNCTION
6345 && strcmp (gfc_state_stack
->previous
->sym
->name
, sym
->name
) == 0;
6351 gfc_get_sym_tree ("ppr@", gfc_current_ns
, &stree
, false);
6355 gfc_get_sym_tree ("ppr@", gfc_current_ns
->parent
, &stree
, false);
6356 st2
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "ppr@");
6357 st2
->n
.sym
= stree
->n
.sym
;
6358 stree
->n
.sym
->refs
++;
6360 sym
->result
= stree
->n
.sym
;
6362 sym
->result
->attr
.proc_pointer
= sym
->attr
.proc_pointer
;
6363 sym
->result
->attr
.pointer
= sym
->attr
.pointer
;
6364 sym
->result
->attr
.external
= sym
->attr
.external
;
6365 sym
->result
->attr
.referenced
= sym
->attr
.referenced
;
6366 sym
->result
->ts
= sym
->ts
;
6367 sym
->attr
.proc_pointer
= 0;
6368 sym
->attr
.pointer
= 0;
6369 sym
->attr
.external
= 0;
6370 if (sym
->result
->attr
.external
&& sym
->result
->attr
.pointer
)
6372 sym
->result
->attr
.pointer
= 0;
6373 sym
->result
->attr
.proc_pointer
= 1;
6376 return gfc_add_result (&sym
->result
->attr
, sym
->result
->name
, NULL
);
6378 /* POINTER after PROCEDURE/EXTERNAL/INTERFACE statement. */
6379 else if (sym
->attr
.function
&& !sym
->attr
.external
&& sym
->attr
.pointer
6380 && sym
->result
&& sym
->result
!= sym
&& sym
->result
->attr
.external
6381 && sym
== gfc_current_ns
->proc_name
6382 && sym
== sym
->result
->ns
->proc_name
6383 && strcmp ("ppr@", sym
->result
->name
) == 0)
6385 sym
->result
->attr
.proc_pointer
= 1;
6386 sym
->attr
.pointer
= 0;
6394 /* Match the interface for a PROCEDURE declaration,
6395 including brackets (R1212). */
6398 match_procedure_interface (gfc_symbol
**proc_if
)
6402 locus old_loc
, entry_loc
;
6403 gfc_namespace
*old_ns
= gfc_current_ns
;
6404 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6406 old_loc
= entry_loc
= gfc_current_locus
;
6407 gfc_clear_ts (¤t_ts
);
6409 if (gfc_match (" (") != MATCH_YES
)
6411 gfc_current_locus
= entry_loc
;
6415 /* Get the type spec. for the procedure interface. */
6416 old_loc
= gfc_current_locus
;
6417 m
= gfc_match_decl_type_spec (¤t_ts
, 0);
6418 gfc_gobble_whitespace ();
6419 if (m
== MATCH_YES
|| (m
== MATCH_NO
&& gfc_peek_ascii_char () == ')'))
6422 if (m
== MATCH_ERROR
)
6425 /* Procedure interface is itself a procedure. */
6426 gfc_current_locus
= old_loc
;
6427 m
= gfc_match_name (name
);
6429 /* First look to see if it is already accessible in the current
6430 namespace because it is use associated or contained. */
6432 if (gfc_find_sym_tree (name
, NULL
, 0, &st
))
6435 /* If it is still not found, then try the parent namespace, if it
6436 exists and create the symbol there if it is still not found. */
6437 if (gfc_current_ns
->parent
)
6438 gfc_current_ns
= gfc_current_ns
->parent
;
6439 if (st
== NULL
&& gfc_get_ha_sym_tree (name
, &st
))
6442 gfc_current_ns
= old_ns
;
6443 *proc_if
= st
->n
.sym
;
6448 /* Resolve interface if possible. That way, attr.procedure is only set
6449 if it is declared by a later procedure-declaration-stmt, which is
6450 invalid per F08:C1216 (cf. resolve_procedure_interface). */
6451 while ((*proc_if
)->ts
.interface
6452 && *proc_if
!= (*proc_if
)->ts
.interface
)
6453 *proc_if
= (*proc_if
)->ts
.interface
;
6455 if ((*proc_if
)->attr
.flavor
== FL_UNKNOWN
6456 && (*proc_if
)->ts
.type
== BT_UNKNOWN
6457 && !gfc_add_flavor (&(*proc_if
)->attr
, FL_PROCEDURE
,
6458 (*proc_if
)->name
, NULL
))
6463 if (gfc_match (" )") != MATCH_YES
)
6465 gfc_current_locus
= entry_loc
;
6473 /* Match a PROCEDURE declaration (R1211). */
6476 match_procedure_decl (void)
6479 gfc_symbol
*sym
, *proc_if
= NULL
;
6481 gfc_expr
*initializer
= NULL
;
6483 /* Parse interface (with brackets). */
6484 m
= match_procedure_interface (&proc_if
);
6488 /* Parse attributes (with colons). */
6489 m
= match_attr_spec();
6490 if (m
== MATCH_ERROR
)
6493 if (proc_if
&& proc_if
->attr
.is_bind_c
&& !current_attr
.is_bind_c
)
6495 current_attr
.is_bind_c
= 1;
6496 has_name_equals
= 0;
6497 curr_binding_label
= NULL
;
6500 /* Get procedure symbols. */
6503 m
= gfc_match_symbol (&sym
, 0);
6506 else if (m
== MATCH_ERROR
)
6509 /* Add current_attr to the symbol attributes. */
6510 if (!gfc_copy_attr (&sym
->attr
, ¤t_attr
, NULL
))
6513 if (sym
->attr
.is_bind_c
)
6515 /* Check for C1218. */
6516 if (!proc_if
|| !proc_if
->attr
.is_bind_c
)
6518 gfc_error ("BIND(C) attribute at %C requires "
6519 "an interface with BIND(C)");
6522 /* Check for C1217. */
6523 if (has_name_equals
&& sym
->attr
.pointer
)
6525 gfc_error ("BIND(C) procedure with NAME may not have "
6526 "POINTER attribute at %C");
6529 if (has_name_equals
&& sym
->attr
.dummy
)
6531 gfc_error ("Dummy procedure at %C may not have "
6532 "BIND(C) attribute with NAME");
6535 /* Set binding label for BIND(C). */
6536 if (!set_binding_label (&sym
->binding_label
, sym
->name
, num
))
6540 if (!gfc_add_external (&sym
->attr
, NULL
))
6543 if (add_hidden_procptr_result (sym
))
6546 if (!gfc_add_proc (&sym
->attr
, sym
->name
, NULL
))
6549 /* Set interface. */
6550 if (proc_if
!= NULL
)
6552 if (sym
->ts
.type
!= BT_UNKNOWN
)
6554 gfc_error ("Procedure %qs at %L already has basic type of %s",
6555 sym
->name
, &gfc_current_locus
,
6556 gfc_basic_typename (sym
->ts
.type
));
6559 sym
->ts
.interface
= proc_if
;
6560 sym
->attr
.untyped
= 1;
6561 sym
->attr
.if_source
= IFSRC_IFBODY
;
6563 else if (current_ts
.type
!= BT_UNKNOWN
)
6565 if (!gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
6567 sym
->ts
.interface
= gfc_new_symbol ("", gfc_current_ns
);
6568 sym
->ts
.interface
->ts
= current_ts
;
6569 sym
->ts
.interface
->attr
.flavor
= FL_PROCEDURE
;
6570 sym
->ts
.interface
->attr
.function
= 1;
6571 sym
->attr
.function
= 1;
6572 sym
->attr
.if_source
= IFSRC_UNKNOWN
;
6575 if (gfc_match (" =>") == MATCH_YES
)
6577 if (!current_attr
.pointer
)
6579 gfc_error ("Initialization at %C isn't for a pointer variable");
6584 m
= match_pointer_init (&initializer
, 1);
6588 if (!add_init_expr_to_sym (sym
->name
, &initializer
, &gfc_current_locus
))
6593 if (gfc_match_eos () == MATCH_YES
)
6595 if (gfc_match_char (',') != MATCH_YES
)
6600 gfc_error ("Syntax error in PROCEDURE statement at %C");
6604 /* Free stuff up and return. */
6605 gfc_free_expr (initializer
);
6611 match_binding_attributes (gfc_typebound_proc
* ba
, bool generic
, bool ppc
);
6614 /* Match a procedure pointer component declaration (R445). */
6617 match_ppc_decl (void)
6620 gfc_symbol
*proc_if
= NULL
;
6624 gfc_expr
*initializer
= NULL
;
6625 gfc_typebound_proc
* tb
;
6626 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6628 /* Parse interface (with brackets). */
6629 m
= match_procedure_interface (&proc_if
);
6633 /* Parse attributes. */
6634 tb
= XCNEW (gfc_typebound_proc
);
6635 tb
->where
= gfc_current_locus
;
6636 m
= match_binding_attributes (tb
, false, true);
6637 if (m
== MATCH_ERROR
)
6640 gfc_clear_attr (¤t_attr
);
6641 current_attr
.procedure
= 1;
6642 current_attr
.proc_pointer
= 1;
6643 current_attr
.access
= tb
->access
;
6644 current_attr
.flavor
= FL_PROCEDURE
;
6646 /* Match the colons (required). */
6647 if (gfc_match (" ::") != MATCH_YES
)
6649 gfc_error ("Expected %<::%> after binding-attributes at %C");
6653 /* Check for C450. */
6654 if (!tb
->nopass
&& proc_if
== NULL
)
6656 gfc_error("NOPASS or explicit interface required at %C");
6660 if (!gfc_notify_std (GFC_STD_F2003
, "Procedure pointer component at %C"))
6663 /* Match PPC names. */
6667 m
= gfc_match_name (name
);
6670 else if (m
== MATCH_ERROR
)
6673 if (!gfc_add_component (gfc_current_block(), name
, &c
))
6676 /* Add current_attr to the symbol attributes. */
6677 if (!gfc_copy_attr (&c
->attr
, ¤t_attr
, NULL
))
6680 if (!gfc_add_external (&c
->attr
, NULL
))
6683 if (!gfc_add_proc (&c
->attr
, name
, NULL
))
6690 c
->tb
= XCNEW (gfc_typebound_proc
);
6691 c
->tb
->where
= gfc_current_locus
;
6695 /* Set interface. */
6696 if (proc_if
!= NULL
)
6698 c
->ts
.interface
= proc_if
;
6699 c
->attr
.untyped
= 1;
6700 c
->attr
.if_source
= IFSRC_IFBODY
;
6702 else if (ts
.type
!= BT_UNKNOWN
)
6705 c
->ts
.interface
= gfc_new_symbol ("", gfc_current_ns
);
6706 c
->ts
.interface
->result
= c
->ts
.interface
;
6707 c
->ts
.interface
->ts
= ts
;
6708 c
->ts
.interface
->attr
.flavor
= FL_PROCEDURE
;
6709 c
->ts
.interface
->attr
.function
= 1;
6710 c
->attr
.function
= 1;
6711 c
->attr
.if_source
= IFSRC_UNKNOWN
;
6714 if (gfc_match (" =>") == MATCH_YES
)
6716 m
= match_pointer_init (&initializer
, 1);
6719 gfc_free_expr (initializer
);
6722 c
->initializer
= initializer
;
6725 if (gfc_match_eos () == MATCH_YES
)
6727 if (gfc_match_char (',') != MATCH_YES
)
6732 gfc_error ("Syntax error in procedure pointer component at %C");
6737 /* Match a PROCEDURE declaration inside an interface (R1206). */
6740 match_procedure_in_interface (void)
6744 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6747 if (current_interface
.type
== INTERFACE_NAMELESS
6748 || current_interface
.type
== INTERFACE_ABSTRACT
)
6750 gfc_error ("PROCEDURE at %C must be in a generic interface");
6754 /* Check if the F2008 optional double colon appears. */
6755 gfc_gobble_whitespace ();
6756 old_locus
= gfc_current_locus
;
6757 if (gfc_match ("::") == MATCH_YES
)
6759 if (!gfc_notify_std (GFC_STD_F2008
, "double colon in "
6760 "MODULE PROCEDURE statement at %L", &old_locus
))
6764 gfc_current_locus
= old_locus
;
6768 m
= gfc_match_name (name
);
6771 else if (m
== MATCH_ERROR
)
6773 if (gfc_get_symbol (name
, gfc_current_ns
->parent
, &sym
))
6776 if (!gfc_add_interface (sym
))
6779 if (gfc_match_eos () == MATCH_YES
)
6781 if (gfc_match_char (',') != MATCH_YES
)
6788 gfc_error ("Syntax error in PROCEDURE statement at %C");
6793 /* General matcher for PROCEDURE declarations. */
6795 static match
match_procedure_in_type (void);
6798 gfc_match_procedure (void)
6802 switch (gfc_current_state ())
6807 case COMP_SUBMODULE
:
6808 case COMP_SUBROUTINE
:
6811 m
= match_procedure_decl ();
6813 case COMP_INTERFACE
:
6814 m
= match_procedure_in_interface ();
6817 m
= match_ppc_decl ();
6819 case COMP_DERIVED_CONTAINS
:
6820 m
= match_procedure_in_type ();
6829 if (!gfc_notify_std (GFC_STD_F2003
, "PROCEDURE statement at %C"))
6836 /* Warn if a matched procedure has the same name as an intrinsic; this is
6837 simply a wrapper around gfc_warn_intrinsic_shadow that interprets the current
6838 parser-state-stack to find out whether we're in a module. */
6841 do_warn_intrinsic_shadow (const gfc_symbol
* sym
, bool func
)
6845 in_module
= (gfc_state_stack
->previous
6846 && (gfc_state_stack
->previous
->state
== COMP_MODULE
6847 || gfc_state_stack
->previous
->state
== COMP_SUBMODULE
));
6849 gfc_warn_intrinsic_shadow (sym
, in_module
, func
);
6853 /* Match a function declaration. */
6856 gfc_match_function_decl (void)
6858 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6859 gfc_symbol
*sym
, *result
;
6863 match found_match
; /* Status returned by match func. */
6865 if (gfc_current_state () != COMP_NONE
6866 && gfc_current_state () != COMP_INTERFACE
6867 && gfc_current_state () != COMP_CONTAINS
)
6870 gfc_clear_ts (¤t_ts
);
6872 old_loc
= gfc_current_locus
;
6874 m
= gfc_match_prefix (¤t_ts
);
6877 gfc_current_locus
= old_loc
;
6881 if (gfc_match ("function% %n", name
) != MATCH_YES
)
6883 gfc_current_locus
= old_loc
;
6887 if (get_proc_name (name
, &sym
, false))
6890 if (add_hidden_procptr_result (sym
))
6893 if (current_attr
.module_procedure
)
6894 sym
->attr
.module_procedure
= 1;
6896 gfc_new_block
= sym
;
6898 m
= gfc_match_formal_arglist (sym
, 0, 0);
6901 gfc_error ("Expected formal argument list in function "
6902 "definition at %C");
6906 else if (m
== MATCH_ERROR
)
6911 /* According to the draft, the bind(c) and result clause can
6912 come in either order after the formal_arg_list (i.e., either
6913 can be first, both can exist together or by themselves or neither
6914 one). Therefore, the match_result can't match the end of the
6915 string, and check for the bind(c) or result clause in either order. */
6916 found_match
= gfc_match_eos ();
6918 /* Make sure that it isn't already declared as BIND(C). If it is, it
6919 must have been marked BIND(C) with a BIND(C) attribute and that is
6920 not allowed for procedures. */
6921 if (sym
->attr
.is_bind_c
== 1)
6923 sym
->attr
.is_bind_c
= 0;
6924 if (sym
->old_symbol
!= NULL
)
6925 gfc_error_now ("BIND(C) attribute at %L can only be used for "
6926 "variables or common blocks",
6927 &(sym
->old_symbol
->declared_at
));
6929 gfc_error_now ("BIND(C) attribute at %L can only be used for "
6930 "variables or common blocks", &gfc_current_locus
);
6933 if (found_match
!= MATCH_YES
)
6935 /* If we haven't found the end-of-statement, look for a suffix. */
6936 suffix_match
= gfc_match_suffix (sym
, &result
);
6937 if (suffix_match
== MATCH_YES
)
6938 /* Need to get the eos now. */
6939 found_match
= gfc_match_eos ();
6941 found_match
= suffix_match
;
6944 if(found_match
!= MATCH_YES
)
6948 /* Make changes to the symbol. */
6951 if (!gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
6954 if (!gfc_missing_attr (&sym
->attr
, NULL
))
6957 if (!copy_prefix (&sym
->attr
, &sym
->declared_at
))
6959 if(!sym
->attr
.module_procedure
)
6965 /* Delay matching the function characteristics until after the
6966 specification block by signalling kind=-1. */
6967 sym
->declared_at
= old_loc
;
6968 if (current_ts
.type
!= BT_UNKNOWN
)
6969 current_ts
.kind
= -1;
6971 current_ts
.kind
= 0;
6975 if (current_ts
.type
!= BT_UNKNOWN
6976 && !gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
6982 if (current_ts
.type
!= BT_UNKNOWN
6983 && !gfc_add_type (result
, ¤t_ts
, &gfc_current_locus
))
6985 sym
->result
= result
;
6988 /* Warn if this procedure has the same name as an intrinsic. */
6989 do_warn_intrinsic_shadow (sym
, true);
6995 gfc_current_locus
= old_loc
;
7000 /* This is mostly a copy of parse.c(add_global_procedure) but modified to
7001 pass the name of the entry, rather than the gfc_current_block name, and
7002 to return false upon finding an existing global entry. */
7005 add_global_entry (const char *name
, const char *binding_label
, bool sub
,
7009 enum gfc_symbol_type type
;
7011 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
7013 /* Only in Fortran 2003: For procedures with a binding label also the Fortran
7014 name is a global identifier. */
7015 if (!binding_label
|| gfc_notification_std (GFC_STD_F2008
))
7017 s
= gfc_get_gsymbol (name
);
7019 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= type
))
7021 gfc_global_used (s
, where
);
7030 s
->ns
= gfc_current_ns
;
7034 /* Don't add the symbol multiple times. */
7036 && (!gfc_notification_std (GFC_STD_F2008
)
7037 || strcmp (name
, binding_label
) != 0))
7039 s
= gfc_get_gsymbol (binding_label
);
7041 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= type
))
7043 gfc_global_used (s
, where
);
7050 s
->binding_label
= binding_label
;
7053 s
->ns
= gfc_current_ns
;
7061 /* Match an ENTRY statement. */
7064 gfc_match_entry (void)
7069 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7070 gfc_compile_state state
;
7074 bool module_procedure
;
7078 m
= gfc_match_name (name
);
7082 if (!gfc_notify_std (GFC_STD_F2008_OBS
, "ENTRY statement at %C"))
7085 state
= gfc_current_state ();
7086 if (state
!= COMP_SUBROUTINE
&& state
!= COMP_FUNCTION
)
7091 gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
7094 gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
7096 case COMP_SUBMODULE
:
7097 gfc_error ("ENTRY statement at %C cannot appear within a SUBMODULE");
7099 case COMP_BLOCK_DATA
:
7100 gfc_error ("ENTRY statement at %C cannot appear within "
7103 case COMP_INTERFACE
:
7104 gfc_error ("ENTRY statement at %C cannot appear within "
7107 case COMP_STRUCTURE
:
7108 gfc_error ("ENTRY statement at %C cannot appear within "
7109 "a STRUCTURE block");
7112 gfc_error ("ENTRY statement at %C cannot appear within "
7113 "a DERIVED TYPE block");
7116 gfc_error ("ENTRY statement at %C cannot appear within "
7117 "an IF-THEN block");
7120 case COMP_DO_CONCURRENT
:
7121 gfc_error ("ENTRY statement at %C cannot appear within "
7125 gfc_error ("ENTRY statement at %C cannot appear within "
7129 gfc_error ("ENTRY statement at %C cannot appear within "
7133 gfc_error ("ENTRY statement at %C cannot appear within "
7137 gfc_error ("ENTRY statement at %C cannot appear within "
7138 "a contained subprogram");
7141 gfc_error ("Unexpected ENTRY statement at %C");
7146 if ((state
== COMP_SUBROUTINE
|| state
== COMP_FUNCTION
)
7147 && gfc_state_stack
->previous
->state
== COMP_INTERFACE
)
7149 gfc_error ("ENTRY statement at %C cannot appear within an INTERFACE");
7153 module_procedure
= gfc_current_ns
->parent
!= NULL
7154 && gfc_current_ns
->parent
->proc_name
7155 && gfc_current_ns
->parent
->proc_name
->attr
.flavor
7158 if (gfc_current_ns
->parent
!= NULL
7159 && gfc_current_ns
->parent
->proc_name
7160 && !module_procedure
)
7162 gfc_error("ENTRY statement at %C cannot appear in a "
7163 "contained procedure");
7167 /* Module function entries need special care in get_proc_name
7168 because previous references within the function will have
7169 created symbols attached to the current namespace. */
7170 if (get_proc_name (name
, &entry
,
7171 gfc_current_ns
->parent
!= NULL
7172 && module_procedure
))
7175 proc
= gfc_current_block ();
7177 /* Make sure that it isn't already declared as BIND(C). If it is, it
7178 must have been marked BIND(C) with a BIND(C) attribute and that is
7179 not allowed for procedures. */
7180 if (entry
->attr
.is_bind_c
== 1)
7182 entry
->attr
.is_bind_c
= 0;
7183 if (entry
->old_symbol
!= NULL
)
7184 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7185 "variables or common blocks",
7186 &(entry
->old_symbol
->declared_at
));
7188 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7189 "variables or common blocks", &gfc_current_locus
);
7192 /* Check what next non-whitespace character is so we can tell if there
7193 is the required parens if we have a BIND(C). */
7194 old_loc
= gfc_current_locus
;
7195 gfc_gobble_whitespace ();
7196 peek_char
= gfc_peek_ascii_char ();
7198 if (state
== COMP_SUBROUTINE
)
7200 m
= gfc_match_formal_arglist (entry
, 0, 1);
7204 /* Call gfc_match_bind_c with allow_binding_name = true as ENTRY can
7205 never be an internal procedure. */
7206 is_bind_c
= gfc_match_bind_c (entry
, true);
7207 if (is_bind_c
== MATCH_ERROR
)
7209 if (is_bind_c
== MATCH_YES
)
7211 if (peek_char
!= '(')
7213 gfc_error ("Missing required parentheses before BIND(C) at %C");
7216 if (!gfc_add_is_bind_c (&(entry
->attr
), entry
->name
,
7217 &(entry
->declared_at
), 1))
7221 if (!gfc_current_ns
->parent
7222 && !add_global_entry (name
, entry
->binding_label
, true,
7226 /* An entry in a subroutine. */
7227 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
7228 || !gfc_add_subroutine (&entry
->attr
, entry
->name
, NULL
))
7233 /* An entry in a function.
7234 We need to take special care because writing
7239 ENTRY f() RESULT (r)
7241 ENTRY f RESULT (r). */
7242 if (gfc_match_eos () == MATCH_YES
)
7244 gfc_current_locus
= old_loc
;
7245 /* Match the empty argument list, and add the interface to
7247 m
= gfc_match_formal_arglist (entry
, 0, 1);
7250 m
= gfc_match_formal_arglist (entry
, 0, 0);
7257 if (gfc_match_eos () == MATCH_YES
)
7259 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
7260 || !gfc_add_function (&entry
->attr
, entry
->name
, NULL
))
7263 entry
->result
= entry
;
7267 m
= gfc_match_suffix (entry
, &result
);
7269 gfc_syntax_error (ST_ENTRY
);
7275 if (!gfc_add_result (&result
->attr
, result
->name
, NULL
)
7276 || !gfc_add_entry (&entry
->attr
, result
->name
, NULL
)
7277 || !gfc_add_function (&entry
->attr
, result
->name
, NULL
))
7279 entry
->result
= result
;
7283 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
7284 || !gfc_add_function (&entry
->attr
, entry
->name
, NULL
))
7286 entry
->result
= entry
;
7290 if (!gfc_current_ns
->parent
7291 && !add_global_entry (name
, entry
->binding_label
, false,
7296 if (gfc_match_eos () != MATCH_YES
)
7298 gfc_syntax_error (ST_ENTRY
);
7302 entry
->attr
.recursive
= proc
->attr
.recursive
;
7303 entry
->attr
.elemental
= proc
->attr
.elemental
;
7304 entry
->attr
.pure
= proc
->attr
.pure
;
7306 el
= gfc_get_entry_list ();
7308 el
->next
= gfc_current_ns
->entries
;
7309 gfc_current_ns
->entries
= el
;
7311 el
->id
= el
->next
->id
+ 1;
7315 new_st
.op
= EXEC_ENTRY
;
7316 new_st
.ext
.entry
= el
;
7322 /* Match a subroutine statement, including optional prefixes. */
7325 gfc_match_subroutine (void)
7327 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7332 bool allow_binding_name
;
7334 if (gfc_current_state () != COMP_NONE
7335 && gfc_current_state () != COMP_INTERFACE
7336 && gfc_current_state () != COMP_CONTAINS
)
7339 m
= gfc_match_prefix (NULL
);
7343 m
= gfc_match ("subroutine% %n", name
);
7347 if (get_proc_name (name
, &sym
, false))
7350 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
7351 the symbol existed before. */
7352 sym
->declared_at
= gfc_current_locus
;
7354 if (current_attr
.module_procedure
)
7355 sym
->attr
.module_procedure
= 1;
7357 if (add_hidden_procptr_result (sym
))
7360 gfc_new_block
= sym
;
7362 /* Check what next non-whitespace character is so we can tell if there
7363 is the required parens if we have a BIND(C). */
7364 gfc_gobble_whitespace ();
7365 peek_char
= gfc_peek_ascii_char ();
7367 if (!gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
))
7370 if (gfc_match_formal_arglist (sym
, 0, 1) != MATCH_YES
)
7373 /* Make sure that it isn't already declared as BIND(C). If it is, it
7374 must have been marked BIND(C) with a BIND(C) attribute and that is
7375 not allowed for procedures. */
7376 if (sym
->attr
.is_bind_c
== 1)
7378 sym
->attr
.is_bind_c
= 0;
7379 if (sym
->old_symbol
!= NULL
)
7380 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7381 "variables or common blocks",
7382 &(sym
->old_symbol
->declared_at
));
7384 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7385 "variables or common blocks", &gfc_current_locus
);
7388 /* C binding names are not allowed for internal procedures. */
7389 if (gfc_current_state () == COMP_CONTAINS
7390 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
7391 allow_binding_name
= false;
7393 allow_binding_name
= true;
7395 /* Here, we are just checking if it has the bind(c) attribute, and if
7396 so, then we need to make sure it's all correct. If it doesn't,
7397 we still need to continue matching the rest of the subroutine line. */
7398 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
7399 if (is_bind_c
== MATCH_ERROR
)
7401 /* There was an attempt at the bind(c), but it was wrong. An
7402 error message should have been printed w/in the gfc_match_bind_c
7403 so here we'll just return the MATCH_ERROR. */
7407 if (is_bind_c
== MATCH_YES
)
7409 /* The following is allowed in the Fortran 2008 draft. */
7410 if (gfc_current_state () == COMP_CONTAINS
7411 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
7412 && !gfc_notify_std (GFC_STD_F2008
, "BIND(C) attribute "
7413 "at %L may not be specified for an internal "
7414 "procedure", &gfc_current_locus
))
7417 if (peek_char
!= '(')
7419 gfc_error ("Missing required parentheses before BIND(C) at %C");
7422 if (!gfc_add_is_bind_c (&(sym
->attr
), sym
->name
,
7423 &(sym
->declared_at
), 1))
7427 if (gfc_match_eos () != MATCH_YES
)
7429 gfc_syntax_error (ST_SUBROUTINE
);
7433 if (!copy_prefix (&sym
->attr
, &sym
->declared_at
))
7435 if(!sym
->attr
.module_procedure
)
7441 /* Warn if it has the same name as an intrinsic. */
7442 do_warn_intrinsic_shadow (sym
, false);
7448 /* Check that the NAME identifier in a BIND attribute or statement
7449 is conform to C identifier rules. */
7452 check_bind_name_identifier (char **name
)
7454 char *n
= *name
, *p
;
7456 /* Remove leading spaces. */
7460 /* On an empty string, free memory and set name to NULL. */
7468 /* Remove trailing spaces. */
7469 p
= n
+ strlen(n
) - 1;
7473 /* Insert the identifier into the symbol table. */
7478 /* Now check that identifier is valid under C rules. */
7481 gfc_error ("Invalid C identifier in NAME= specifier at %C");
7486 if (!(ISALNUM (*p
) || *p
== '_' || *p
== '$'))
7488 gfc_error ("Invalid C identifier in NAME= specifier at %C");
7496 /* Match a BIND(C) specifier, with the optional 'name=' specifier if
7497 given, and set the binding label in either the given symbol (if not
7498 NULL), or in the current_ts. The symbol may be NULL because we may
7499 encounter the BIND(C) before the declaration itself. Return
7500 MATCH_NO if what we're looking at isn't a BIND(C) specifier,
7501 MATCH_ERROR if it is a BIND(C) clause but an error was encountered,
7502 or MATCH_YES if the specifier was correct and the binding label and
7503 bind(c) fields were set correctly for the given symbol or the
7504 current_ts. If allow_binding_name is false, no binding name may be
7508 gfc_match_bind_c (gfc_symbol
*sym
, bool allow_binding_name
)
7510 char *binding_label
= NULL
;
7513 /* Initialize the flag that specifies whether we encountered a NAME=
7514 specifier or not. */
7515 has_name_equals
= 0;
7517 /* This much we have to be able to match, in this order, if
7518 there is a bind(c) label. */
7519 if (gfc_match (" bind ( c ") != MATCH_YES
)
7522 /* Now see if there is a binding label, or if we've reached the
7523 end of the bind(c) attribute without one. */
7524 if (gfc_match_char (',') == MATCH_YES
)
7526 if (gfc_match (" name = ") != MATCH_YES
)
7528 gfc_error ("Syntax error in NAME= specifier for binding label "
7530 /* should give an error message here */
7534 has_name_equals
= 1;
7536 if (gfc_match_init_expr (&e
) != MATCH_YES
)
7542 if (!gfc_simplify_expr(e
, 0))
7544 gfc_error ("NAME= specifier at %C should be a constant expression");
7549 if (e
->expr_type
!= EXPR_CONSTANT
|| e
->ts
.type
!= BT_CHARACTER
7550 || e
->ts
.kind
!= gfc_default_character_kind
|| e
->rank
!= 0)
7552 gfc_error ("NAME= specifier at %C should be a scalar of "
7553 "default character kind");
7558 // Get a C string from the Fortran string constant
7559 binding_label
= gfc_widechar_to_char (e
->value
.character
.string
,
7560 e
->value
.character
.length
);
7563 // Check that it is valid (old gfc_match_name_C)
7564 if (check_bind_name_identifier (&binding_label
) != MATCH_YES
)
7568 /* Get the required right paren. */
7569 if (gfc_match_char (')') != MATCH_YES
)
7571 gfc_error ("Missing closing paren for binding label at %C");
7575 if (has_name_equals
&& !allow_binding_name
)
7577 gfc_error ("No binding name is allowed in BIND(C) at %C");
7581 if (has_name_equals
&& sym
!= NULL
&& sym
->attr
.dummy
)
7583 gfc_error ("For dummy procedure %s, no binding name is "
7584 "allowed in BIND(C) at %C", sym
->name
);
7589 /* Save the binding label to the symbol. If sym is null, we're
7590 probably matching the typespec attributes of a declaration and
7591 haven't gotten the name yet, and therefore, no symbol yet. */
7595 sym
->binding_label
= binding_label
;
7597 curr_binding_label
= binding_label
;
7599 else if (allow_binding_name
)
7601 /* No binding label, but if symbol isn't null, we
7602 can set the label for it here.
7603 If name="" or allow_binding_name is false, no C binding name is
7605 if (sym
!= NULL
&& sym
->name
!= NULL
&& has_name_equals
== 0)
7606 sym
->binding_label
= IDENTIFIER_POINTER (get_identifier (sym
->name
));
7609 if (has_name_equals
&& gfc_current_state () == COMP_INTERFACE
7610 && current_interface
.type
== INTERFACE_ABSTRACT
)
7612 gfc_error ("NAME not allowed on BIND(C) for ABSTRACT INTERFACE at %C");
7620 /* Return nonzero if we're currently compiling a contained procedure. */
7623 contained_procedure (void)
7625 gfc_state_data
*s
= gfc_state_stack
;
7627 if ((s
->state
== COMP_SUBROUTINE
|| s
->state
== COMP_FUNCTION
)
7628 && s
->previous
!= NULL
&& s
->previous
->state
== COMP_CONTAINS
)
7634 /* Set the kind of each enumerator. The kind is selected such that it is
7635 interoperable with the corresponding C enumeration type, making
7636 sure that -fshort-enums is honored. */
7641 enumerator_history
*current_history
= NULL
;
7645 if (max_enum
== NULL
|| enum_history
== NULL
)
7648 if (!flag_short_enums
)
7654 kind
= gfc_integer_kinds
[i
++].kind
;
7656 while (kind
< gfc_c_int_kind
7657 && gfc_check_integer_range (max_enum
->initializer
->value
.integer
,
7660 current_history
= enum_history
;
7661 while (current_history
!= NULL
)
7663 current_history
->sym
->ts
.kind
= kind
;
7664 current_history
= current_history
->next
;
7669 /* Match any of the various end-block statements. Returns the type of
7670 END to the caller. The END INTERFACE, END IF, END DO, END SELECT
7671 and END BLOCK statements cannot be replaced by a single END statement. */
7674 gfc_match_end (gfc_statement
*st
)
7676 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7677 gfc_compile_state state
;
7679 const char *block_name
;
7683 gfc_namespace
*parent_ns
, *ns
, *prev_ns
;
7684 gfc_namespace
**nsp
;
7685 bool abreviated_modproc_decl
= false;
7686 bool got_matching_end
= false;
7688 old_loc
= gfc_current_locus
;
7689 if (gfc_match ("end") != MATCH_YES
)
7692 state
= gfc_current_state ();
7693 block_name
= gfc_current_block () == NULL
7694 ? NULL
: gfc_current_block ()->name
;
7698 case COMP_ASSOCIATE
:
7700 if (!strncmp (block_name
, "block@", strlen("block@")))
7705 case COMP_DERIVED_CONTAINS
:
7706 state
= gfc_state_stack
->previous
->state
;
7707 block_name
= gfc_state_stack
->previous
->sym
== NULL
7708 ? NULL
: gfc_state_stack
->previous
->sym
->name
;
7709 abreviated_modproc_decl
= gfc_state_stack
->previous
->sym
7710 && gfc_state_stack
->previous
->sym
->abr_modproc_decl
;
7717 if (!abreviated_modproc_decl
)
7718 abreviated_modproc_decl
= gfc_current_block ()
7719 && gfc_current_block ()->abr_modproc_decl
;
7725 *st
= ST_END_PROGRAM
;
7726 target
= " program";
7730 case COMP_SUBROUTINE
:
7731 *st
= ST_END_SUBROUTINE
;
7732 if (!abreviated_modproc_decl
)
7733 target
= " subroutine";
7735 target
= " procedure";
7736 eos_ok
= !contained_procedure ();
7740 *st
= ST_END_FUNCTION
;
7741 if (!abreviated_modproc_decl
)
7742 target
= " function";
7744 target
= " procedure";
7745 eos_ok
= !contained_procedure ();
7748 case COMP_BLOCK_DATA
:
7749 *st
= ST_END_BLOCK_DATA
;
7750 target
= " block data";
7755 *st
= ST_END_MODULE
;
7760 case COMP_SUBMODULE
:
7761 *st
= ST_END_SUBMODULE
;
7762 target
= " submodule";
7766 case COMP_INTERFACE
:
7767 *st
= ST_END_INTERFACE
;
7768 target
= " interface";
7784 case COMP_STRUCTURE
:
7785 *st
= ST_END_STRUCTURE
;
7786 target
= " structure";
7791 case COMP_DERIVED_CONTAINS
:
7797 case COMP_ASSOCIATE
:
7798 *st
= ST_END_ASSOCIATE
;
7799 target
= " associate";
7816 case COMP_DO_CONCURRENT
:
7823 *st
= ST_END_CRITICAL
;
7824 target
= " critical";
7829 case COMP_SELECT_TYPE
:
7830 *st
= ST_END_SELECT
;
7836 *st
= ST_END_FORALL
;
7851 last_initializer
= NULL
;
7853 gfc_free_enum_history ();
7857 gfc_error ("Unexpected END statement at %C");
7861 old_loc
= gfc_current_locus
;
7862 if (gfc_match_eos () == MATCH_YES
)
7864 if (!eos_ok
&& (*st
== ST_END_SUBROUTINE
|| *st
== ST_END_FUNCTION
))
7866 if (!gfc_notify_std (GFC_STD_F2008
, "END statement "
7867 "instead of %s statement at %L",
7868 abreviated_modproc_decl
? "END PROCEDURE"
7869 : gfc_ascii_statement(*st
), &old_loc
))
7874 /* We would have required END [something]. */
7875 gfc_error ("%s statement expected at %L",
7876 gfc_ascii_statement (*st
), &old_loc
);
7883 /* Verify that we've got the sort of end-block that we're expecting. */
7884 if (gfc_match (target
) != MATCH_YES
)
7886 gfc_error ("Expecting %s statement at %L", abreviated_modproc_decl
7887 ? "END PROCEDURE" : gfc_ascii_statement(*st
), &old_loc
);
7891 got_matching_end
= true;
7893 old_loc
= gfc_current_locus
;
7894 /* If we're at the end, make sure a block name wasn't required. */
7895 if (gfc_match_eos () == MATCH_YES
)
7898 if (*st
!= ST_ENDDO
&& *st
!= ST_ENDIF
&& *st
!= ST_END_SELECT
7899 && *st
!= ST_END_FORALL
&& *st
!= ST_END_WHERE
&& *st
!= ST_END_BLOCK
7900 && *st
!= ST_END_ASSOCIATE
&& *st
!= ST_END_CRITICAL
)
7906 gfc_error ("Expected block name of %qs in %s statement at %L",
7907 block_name
, gfc_ascii_statement (*st
), &old_loc
);
7912 /* END INTERFACE has a special handler for its several possible endings. */
7913 if (*st
== ST_END_INTERFACE
)
7914 return gfc_match_end_interface ();
7916 /* We haven't hit the end of statement, so what is left must be an
7918 m
= gfc_match_space ();
7920 m
= gfc_match_name (name
);
7923 gfc_error ("Expected terminating name at %C");
7927 if (block_name
== NULL
)
7930 /* We have to pick out the declared submodule name from the composite
7931 required by F2008:11.2.3 para 2, which ends in the declared name. */
7932 if (state
== COMP_SUBMODULE
)
7933 block_name
= strchr (block_name
, '.') + 1;
7935 if (strcmp (name
, block_name
) != 0 && strcmp (block_name
, "ppr@") != 0)
7937 gfc_error ("Expected label %qs for %s statement at %C", block_name
,
7938 gfc_ascii_statement (*st
));
7941 /* Procedure pointer as function result. */
7942 else if (strcmp (block_name
, "ppr@") == 0
7943 && strcmp (name
, gfc_current_block ()->ns
->proc_name
->name
) != 0)
7945 gfc_error ("Expected label %qs for %s statement at %C",
7946 gfc_current_block ()->ns
->proc_name
->name
,
7947 gfc_ascii_statement (*st
));
7951 if (gfc_match_eos () == MATCH_YES
)
7955 gfc_syntax_error (*st
);
7958 gfc_current_locus
= old_loc
;
7960 /* If we are missing an END BLOCK, we created a half-ready namespace.
7961 Remove it from the parent namespace's sibling list. */
7963 while (state
== COMP_BLOCK
&& !got_matching_end
)
7965 parent_ns
= gfc_current_ns
->parent
;
7967 nsp
= &(gfc_state_stack
->previous
->tail
->ext
.block
.ns
);
7973 if (ns
== gfc_current_ns
)
7975 if (prev_ns
== NULL
)
7978 prev_ns
->sibling
= ns
->sibling
;
7984 gfc_free_namespace (gfc_current_ns
);
7985 gfc_current_ns
= parent_ns
;
7986 gfc_state_stack
= gfc_state_stack
->previous
;
7987 state
= gfc_current_state ();
7995 /***************** Attribute declaration statements ****************/
7997 /* Set the attribute of a single variable. */
8002 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8005 /* Workaround -Wmaybe-uninitialized false positive during
8006 profiledbootstrap by initializing them. */
8007 gfc_symbol
*sym
= NULL
;
8013 m
= gfc_match_name (name
);
8017 if (find_special (name
, &sym
, false))
8020 if (!check_function_name (name
))
8026 var_locus
= gfc_current_locus
;
8028 /* Deal with possible array specification for certain attributes. */
8029 if (current_attr
.dimension
8030 || current_attr
.codimension
8031 || current_attr
.allocatable
8032 || current_attr
.pointer
8033 || current_attr
.target
)
8035 m
= gfc_match_array_spec (&as
, !current_attr
.codimension
,
8036 !current_attr
.dimension
8037 && !current_attr
.pointer
8038 && !current_attr
.target
);
8039 if (m
== MATCH_ERROR
)
8042 if (current_attr
.dimension
&& m
== MATCH_NO
)
8044 gfc_error ("Missing array specification at %L in DIMENSION "
8045 "statement", &var_locus
);
8050 if (current_attr
.dimension
&& sym
->value
)
8052 gfc_error ("Dimensions specified for %s at %L after its "
8053 "initialization", sym
->name
, &var_locus
);
8058 if (current_attr
.codimension
&& m
== MATCH_NO
)
8060 gfc_error ("Missing array specification at %L in CODIMENSION "
8061 "statement", &var_locus
);
8066 if ((current_attr
.allocatable
|| current_attr
.pointer
)
8067 && (m
== MATCH_YES
) && (as
->type
!= AS_DEFERRED
))
8069 gfc_error ("Array specification must be deferred at %L", &var_locus
);
8075 /* Update symbol table. DIMENSION attribute is set in
8076 gfc_set_array_spec(). For CLASS variables, this must be applied
8077 to the first component, or '_data' field. */
8078 if (sym
->ts
.type
== BT_CLASS
&& sym
->ts
.u
.derived
->attr
.is_class
)
8080 if (!gfc_copy_attr (&CLASS_DATA(sym
)->attr
, ¤t_attr
, &var_locus
))
8088 if (current_attr
.dimension
== 0 && current_attr
.codimension
== 0
8089 && !gfc_copy_attr (&sym
->attr
, ¤t_attr
, &var_locus
))
8096 if (sym
->ts
.type
== BT_CLASS
8097 && !gfc_build_class_symbol (&sym
->ts
, &sym
->attr
, &sym
->as
))
8103 if (!gfc_set_array_spec (sym
, as
, &var_locus
))
8109 if (sym
->attr
.cray_pointee
&& sym
->as
!= NULL
)
8111 /* Fix the array spec. */
8112 m
= gfc_mod_pointee_as (sym
->as
);
8113 if (m
== MATCH_ERROR
)
8117 if (!gfc_add_attribute (&sym
->attr
, &var_locus
))
8123 if ((current_attr
.external
|| current_attr
.intrinsic
)
8124 && sym
->attr
.flavor
!= FL_PROCEDURE
8125 && !gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, NULL
))
8131 add_hidden_procptr_result (sym
);
8136 gfc_free_array_spec (as
);
8141 /* Generic attribute declaration subroutine. Used for attributes that
8142 just have a list of names. */
8149 /* Gobble the optional double colon, by simply ignoring the result
8159 if (gfc_match_eos () == MATCH_YES
)
8165 if (gfc_match_char (',') != MATCH_YES
)
8167 gfc_error ("Unexpected character in variable list at %C");
8177 /* This routine matches Cray Pointer declarations of the form:
8178 pointer ( <pointer>, <pointee> )
8180 pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...
8181 The pointer, if already declared, should be an integer. Otherwise, we
8182 set it as BT_INTEGER with kind gfc_index_integer_kind. The pointee may
8183 be either a scalar, or an array declaration. No space is allocated for
8184 the pointee. For the statement
8185 pointer (ipt, ar(10))
8186 any subsequent uses of ar will be translated (in C-notation) as
8187 ar(i) => ((<type> *) ipt)(i)
8188 After gimplification, pointee variable will disappear in the code. */
8191 cray_pointer_decl (void)
8194 gfc_array_spec
*as
= NULL
;
8195 gfc_symbol
*cptr
; /* Pointer symbol. */
8196 gfc_symbol
*cpte
; /* Pointee symbol. */
8202 if (gfc_match_char ('(') != MATCH_YES
)
8204 gfc_error ("Expected %<(%> at %C");
8208 /* Match pointer. */
8209 var_locus
= gfc_current_locus
;
8210 gfc_clear_attr (¤t_attr
);
8211 gfc_add_cray_pointer (¤t_attr
, &var_locus
);
8212 current_ts
.type
= BT_INTEGER
;
8213 current_ts
.kind
= gfc_index_integer_kind
;
8215 m
= gfc_match_symbol (&cptr
, 0);
8218 gfc_error ("Expected variable name at %C");
8222 if (!gfc_add_cray_pointer (&cptr
->attr
, &var_locus
))
8225 gfc_set_sym_referenced (cptr
);
8227 if (cptr
->ts
.type
== BT_UNKNOWN
) /* Override the type, if necessary. */
8229 cptr
->ts
.type
= BT_INTEGER
;
8230 cptr
->ts
.kind
= gfc_index_integer_kind
;
8232 else if (cptr
->ts
.type
!= BT_INTEGER
)
8234 gfc_error ("Cray pointer at %C must be an integer");
8237 else if (cptr
->ts
.kind
< gfc_index_integer_kind
)
8238 gfc_warning (0, "Cray pointer at %C has %d bytes of precision;"
8239 " memory addresses require %d bytes",
8240 cptr
->ts
.kind
, gfc_index_integer_kind
);
8242 if (gfc_match_char (',') != MATCH_YES
)
8244 gfc_error ("Expected \",\" at %C");
8248 /* Match Pointee. */
8249 var_locus
= gfc_current_locus
;
8250 gfc_clear_attr (¤t_attr
);
8251 gfc_add_cray_pointee (¤t_attr
, &var_locus
);
8252 current_ts
.type
= BT_UNKNOWN
;
8253 current_ts
.kind
= 0;
8255 m
= gfc_match_symbol (&cpte
, 0);
8258 gfc_error ("Expected variable name at %C");
8262 /* Check for an optional array spec. */
8263 m
= gfc_match_array_spec (&as
, true, false);
8264 if (m
== MATCH_ERROR
)
8266 gfc_free_array_spec (as
);
8269 else if (m
== MATCH_NO
)
8271 gfc_free_array_spec (as
);
8275 if (!gfc_add_cray_pointee (&cpte
->attr
, &var_locus
))
8278 gfc_set_sym_referenced (cpte
);
8280 if (cpte
->as
== NULL
)
8282 if (!gfc_set_array_spec (cpte
, as
, &var_locus
))
8283 gfc_internal_error ("Couldn't set Cray pointee array spec.");
8285 else if (as
!= NULL
)
8287 gfc_error ("Duplicate array spec for Cray pointee at %C");
8288 gfc_free_array_spec (as
);
8294 if (cpte
->as
!= NULL
)
8296 /* Fix array spec. */
8297 m
= gfc_mod_pointee_as (cpte
->as
);
8298 if (m
== MATCH_ERROR
)
8302 /* Point the Pointee at the Pointer. */
8303 cpte
->cp_pointer
= cptr
;
8305 if (gfc_match_char (')') != MATCH_YES
)
8307 gfc_error ("Expected \")\" at %C");
8310 m
= gfc_match_char (',');
8312 done
= true; /* Stop searching for more declarations. */
8316 if (m
== MATCH_ERROR
/* Failed when trying to find ',' above. */
8317 || gfc_match_eos () != MATCH_YES
)
8319 gfc_error ("Expected %<,%> or end of statement at %C");
8327 gfc_match_external (void)
8330 gfc_clear_attr (¤t_attr
);
8331 current_attr
.external
= 1;
8333 return attr_decl ();
8338 gfc_match_intent (void)
8342 /* This is not allowed within a BLOCK construct! */
8343 if (gfc_current_state () == COMP_BLOCK
)
8345 gfc_error ("INTENT is not allowed inside of BLOCK at %C");
8349 intent
= match_intent_spec ();
8350 if (intent
== INTENT_UNKNOWN
)
8353 gfc_clear_attr (¤t_attr
);
8354 current_attr
.intent
= intent
;
8356 return attr_decl ();
8361 gfc_match_intrinsic (void)
8364 gfc_clear_attr (¤t_attr
);
8365 current_attr
.intrinsic
= 1;
8367 return attr_decl ();
8372 gfc_match_optional (void)
8374 /* This is not allowed within a BLOCK construct! */
8375 if (gfc_current_state () == COMP_BLOCK
)
8377 gfc_error ("OPTIONAL is not allowed inside of BLOCK at %C");
8381 gfc_clear_attr (¤t_attr
);
8382 current_attr
.optional
= 1;
8384 return attr_decl ();
8389 gfc_match_pointer (void)
8391 gfc_gobble_whitespace ();
8392 if (gfc_peek_ascii_char () == '(')
8394 if (!flag_cray_pointer
)
8396 gfc_error ("Cray pointer declaration at %C requires -fcray-pointer "
8400 return cray_pointer_decl ();
8404 gfc_clear_attr (¤t_attr
);
8405 current_attr
.pointer
= 1;
8407 return attr_decl ();
8413 gfc_match_allocatable (void)
8415 gfc_clear_attr (¤t_attr
);
8416 current_attr
.allocatable
= 1;
8418 return attr_decl ();
8423 gfc_match_codimension (void)
8425 gfc_clear_attr (¤t_attr
);
8426 current_attr
.codimension
= 1;
8428 return attr_decl ();
8433 gfc_match_contiguous (void)
8435 if (!gfc_notify_std (GFC_STD_F2008
, "CONTIGUOUS statement at %C"))
8438 gfc_clear_attr (¤t_attr
);
8439 current_attr
.contiguous
= 1;
8441 return attr_decl ();
8446 gfc_match_dimension (void)
8448 gfc_clear_attr (¤t_attr
);
8449 current_attr
.dimension
= 1;
8451 return attr_decl ();
8456 gfc_match_target (void)
8458 gfc_clear_attr (¤t_attr
);
8459 current_attr
.target
= 1;
8461 return attr_decl ();
8465 /* Match the list of entities being specified in a PUBLIC or PRIVATE
8469 access_attr_decl (gfc_statement st
)
8471 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8472 interface_type type
;
8474 gfc_symbol
*sym
, *dt_sym
;
8475 gfc_intrinsic_op op
;
8478 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
8483 m
= gfc_match_generic_spec (&type
, name
, &op
);
8486 if (m
== MATCH_ERROR
)
8491 case INTERFACE_NAMELESS
:
8492 case INTERFACE_ABSTRACT
:
8495 case INTERFACE_GENERIC
:
8496 case INTERFACE_DTIO
:
8498 if (gfc_get_symbol (name
, NULL
, &sym
))
8501 if (type
== INTERFACE_DTIO
8502 && gfc_current_ns
->proc_name
8503 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
8504 && sym
->attr
.flavor
== FL_UNKNOWN
)
8505 sym
->attr
.flavor
= FL_PROCEDURE
;
8507 if (!gfc_add_access (&sym
->attr
,
8509 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
,
8513 if (sym
->attr
.generic
&& (dt_sym
= gfc_find_dt_in_generic (sym
))
8514 && !gfc_add_access (&dt_sym
->attr
,
8516 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
,
8522 case INTERFACE_INTRINSIC_OP
:
8523 if (gfc_current_ns
->operator_access
[op
] == ACCESS_UNKNOWN
)
8525 gfc_intrinsic_op other_op
;
8527 gfc_current_ns
->operator_access
[op
] =
8528 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
8530 /* Handle the case if there is another op with the same
8531 function, for INTRINSIC_EQ vs. INTRINSIC_EQ_OS and so on. */
8532 other_op
= gfc_equivalent_op (op
);
8534 if (other_op
!= INTRINSIC_NONE
)
8535 gfc_current_ns
->operator_access
[other_op
] =
8536 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
8541 gfc_error ("Access specification of the %s operator at %C has "
8542 "already been specified", gfc_op2string (op
));
8548 case INTERFACE_USER_OP
:
8549 uop
= gfc_get_uop (name
);
8551 if (uop
->access
== ACCESS_UNKNOWN
)
8553 uop
->access
= (st
== ST_PUBLIC
)
8554 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
8558 gfc_error ("Access specification of the .%s. operator at %C "
8559 "has already been specified", sym
->name
);
8566 if (gfc_match_char (',') == MATCH_NO
)
8570 if (gfc_match_eos () != MATCH_YES
)
8575 gfc_syntax_error (st
);
8583 gfc_match_protected (void)
8588 if (!gfc_current_ns
->proc_name
8589 || gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
8591 gfc_error ("PROTECTED at %C only allowed in specification "
8592 "part of a module");
8597 if (!gfc_notify_std (GFC_STD_F2003
, "PROTECTED statement at %C"))
8600 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
8605 if (gfc_match_eos () == MATCH_YES
)
8610 m
= gfc_match_symbol (&sym
, 0);
8614 if (!gfc_add_protected (&sym
->attr
, sym
->name
, &gfc_current_locus
))
8626 if (gfc_match_eos () == MATCH_YES
)
8628 if (gfc_match_char (',') != MATCH_YES
)
8635 gfc_error ("Syntax error in PROTECTED statement at %C");
8640 /* The PRIVATE statement is a bit weird in that it can be an attribute
8641 declaration, but also works as a standalone statement inside of a
8642 type declaration or a module. */
8645 gfc_match_private (gfc_statement
*st
)
8648 if (gfc_match ("private") != MATCH_YES
)
8651 if (gfc_current_state () != COMP_MODULE
8652 && !(gfc_current_state () == COMP_DERIVED
8653 && gfc_state_stack
->previous
8654 && gfc_state_stack
->previous
->state
== COMP_MODULE
)
8655 && !(gfc_current_state () == COMP_DERIVED_CONTAINS
8656 && gfc_state_stack
->previous
&& gfc_state_stack
->previous
->previous
8657 && gfc_state_stack
->previous
->previous
->state
== COMP_MODULE
))
8659 gfc_error ("PRIVATE statement at %C is only allowed in the "
8660 "specification part of a module");
8664 if (gfc_current_state () == COMP_DERIVED
)
8666 if (gfc_match_eos () == MATCH_YES
)
8672 gfc_syntax_error (ST_PRIVATE
);
8676 if (gfc_match_eos () == MATCH_YES
)
8683 return access_attr_decl (ST_PRIVATE
);
8688 gfc_match_public (gfc_statement
*st
)
8691 if (gfc_match ("public") != MATCH_YES
)
8694 if (gfc_current_state () != COMP_MODULE
)
8696 gfc_error ("PUBLIC statement at %C is only allowed in the "
8697 "specification part of a module");
8701 if (gfc_match_eos () == MATCH_YES
)
8708 return access_attr_decl (ST_PUBLIC
);
8712 /* Workhorse for gfc_match_parameter. */
8722 m
= gfc_match_symbol (&sym
, 0);
8724 gfc_error ("Expected variable name at %C in PARAMETER statement");
8729 if (gfc_match_char ('=') == MATCH_NO
)
8731 gfc_error ("Expected = sign in PARAMETER statement at %C");
8735 m
= gfc_match_init_expr (&init
);
8737 gfc_error ("Expected expression at %C in PARAMETER statement");
8741 if (sym
->ts
.type
== BT_UNKNOWN
8742 && !gfc_set_default_type (sym
, 1, NULL
))
8748 if (!gfc_check_assign_symbol (sym
, NULL
, init
)
8749 || !gfc_add_flavor (&sym
->attr
, FL_PARAMETER
, sym
->name
, NULL
))
8757 gfc_error ("Initializing already initialized variable at %C");
8762 t
= add_init_expr_to_sym (sym
->name
, &init
, &gfc_current_locus
);
8763 return (t
) ? MATCH_YES
: MATCH_ERROR
;
8766 gfc_free_expr (init
);
8771 /* Match a parameter statement, with the weird syntax that these have. */
8774 gfc_match_parameter (void)
8776 const char *term
= " )%t";
8779 if (gfc_match_char ('(') == MATCH_NO
)
8781 /* With legacy PARAMETER statements, don't expect a terminating ')'. */
8782 if (!gfc_notify_std (GFC_STD_LEGACY
, "PARAMETER without '()' at %C"))
8793 if (gfc_match (term
) == MATCH_YES
)
8796 if (gfc_match_char (',') != MATCH_YES
)
8798 gfc_error ("Unexpected characters in PARAMETER statement at %C");
8809 gfc_match_automatic (void)
8813 bool seen_symbol
= false;
8815 if (!flag_dec_static
)
8817 gfc_error ("%s at %C is a DEC extension, enable with "
8828 m
= gfc_match_symbol (&sym
, 0);
8838 if (!gfc_add_automatic (&sym
->attr
, sym
->name
, &gfc_current_locus
))
8844 if (gfc_match_eos () == MATCH_YES
)
8846 if (gfc_match_char (',') != MATCH_YES
)
8852 gfc_error ("Expected entity-list in AUTOMATIC statement at %C");
8859 gfc_error ("Syntax error in AUTOMATIC statement at %C");
8865 gfc_match_static (void)
8869 bool seen_symbol
= false;
8871 if (!flag_dec_static
)
8873 gfc_error ("%s at %C is a DEC extension, enable with "
8883 m
= gfc_match_symbol (&sym
, 0);
8893 if (!gfc_add_save (&sym
->attr
, SAVE_EXPLICIT
, sym
->name
,
8894 &gfc_current_locus
))
8900 if (gfc_match_eos () == MATCH_YES
)
8902 if (gfc_match_char (',') != MATCH_YES
)
8908 gfc_error ("Expected entity-list in STATIC statement at %C");
8915 gfc_error ("Syntax error in STATIC statement at %C");
8920 /* Save statements have a special syntax. */
8923 gfc_match_save (void)
8925 char n
[GFC_MAX_SYMBOL_LEN
+1];
8930 if (gfc_match_eos () == MATCH_YES
)
8932 if (gfc_current_ns
->seen_save
)
8934 if (!gfc_notify_std (GFC_STD_LEGACY
, "Blanket SAVE statement at %C "
8935 "follows previous SAVE statement"))
8939 gfc_current_ns
->save_all
= gfc_current_ns
->seen_save
= 1;
8943 if (gfc_current_ns
->save_all
)
8945 if (!gfc_notify_std (GFC_STD_LEGACY
, "SAVE statement at %C follows "
8946 "blanket SAVE statement"))
8954 m
= gfc_match_symbol (&sym
, 0);
8958 if (!gfc_add_save (&sym
->attr
, SAVE_EXPLICIT
, sym
->name
,
8959 &gfc_current_locus
))
8970 m
= gfc_match (" / %n /", &n
);
8971 if (m
== MATCH_ERROR
)
8976 c
= gfc_get_common (n
, 0);
8979 gfc_current_ns
->seen_save
= 1;
8982 if (gfc_match_eos () == MATCH_YES
)
8984 if (gfc_match_char (',') != MATCH_YES
)
8991 gfc_error ("Syntax error in SAVE statement at %C");
8997 gfc_match_value (void)
9002 /* This is not allowed within a BLOCK construct! */
9003 if (gfc_current_state () == COMP_BLOCK
)
9005 gfc_error ("VALUE is not allowed inside of BLOCK at %C");
9009 if (!gfc_notify_std (GFC_STD_F2003
, "VALUE statement at %C"))
9012 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
9017 if (gfc_match_eos () == MATCH_YES
)
9022 m
= gfc_match_symbol (&sym
, 0);
9026 if (!gfc_add_value (&sym
->attr
, sym
->name
, &gfc_current_locus
))
9038 if (gfc_match_eos () == MATCH_YES
)
9040 if (gfc_match_char (',') != MATCH_YES
)
9047 gfc_error ("Syntax error in VALUE statement at %C");
9053 gfc_match_volatile (void)
9058 if (!gfc_notify_std (GFC_STD_F2003
, "VOLATILE statement at %C"))
9061 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
9066 if (gfc_match_eos () == MATCH_YES
)
9071 /* VOLATILE is special because it can be added to host-associated
9072 symbols locally. Except for coarrays. */
9073 m
= gfc_match_symbol (&sym
, 1);
9077 /* F2008, C560+C561. VOLATILE for host-/use-associated variable or
9078 for variable in a BLOCK which is defined outside of the BLOCK. */
9079 if (sym
->ns
!= gfc_current_ns
&& sym
->attr
.codimension
)
9081 gfc_error ("Specifying VOLATILE for coarray variable %qs at "
9082 "%C, which is use-/host-associated", sym
->name
);
9085 if (!gfc_add_volatile (&sym
->attr
, sym
->name
, &gfc_current_locus
))
9097 if (gfc_match_eos () == MATCH_YES
)
9099 if (gfc_match_char (',') != MATCH_YES
)
9106 gfc_error ("Syntax error in VOLATILE statement at %C");
9112 gfc_match_asynchronous (void)
9117 if (!gfc_notify_std (GFC_STD_F2003
, "ASYNCHRONOUS statement at %C"))
9120 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
9125 if (gfc_match_eos () == MATCH_YES
)
9130 /* ASYNCHRONOUS is special because it can be added to host-associated
9132 m
= gfc_match_symbol (&sym
, 1);
9136 if (!gfc_add_asynchronous (&sym
->attr
, sym
->name
, &gfc_current_locus
))
9148 if (gfc_match_eos () == MATCH_YES
)
9150 if (gfc_match_char (',') != MATCH_YES
)
9157 gfc_error ("Syntax error in ASYNCHRONOUS statement at %C");
9162 /* Match a module procedure statement in a submodule. */
9165 gfc_match_submod_proc (void)
9167 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9168 gfc_symbol
*sym
, *fsym
;
9170 gfc_formal_arglist
*formal
, *head
, *tail
;
9172 if (gfc_current_state () != COMP_CONTAINS
9173 || !(gfc_state_stack
->previous
9174 && (gfc_state_stack
->previous
->state
== COMP_SUBMODULE
9175 || gfc_state_stack
->previous
->state
== COMP_MODULE
)))
9178 m
= gfc_match (" module% procedure% %n", name
);
9182 if (!gfc_notify_std (GFC_STD_F2008
, "MODULE PROCEDURE declaration "
9186 if (get_proc_name (name
, &sym
, false))
9189 /* Make sure that the result field is appropriately filled, even though
9190 the result symbol will be replaced later on. */
9191 if (sym
->tlink
&& sym
->tlink
->attr
.function
)
9193 if (sym
->tlink
->result
9194 && sym
->tlink
->result
!= sym
->tlink
)
9195 sym
->result
= sym
->tlink
->result
;
9200 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
9201 the symbol existed before. */
9202 sym
->declared_at
= gfc_current_locus
;
9204 if (!sym
->attr
.module_procedure
)
9207 /* Signal match_end to expect "end procedure". */
9208 sym
->abr_modproc_decl
= 1;
9210 /* Change from IFSRC_IFBODY coming from the interface declaration. */
9211 sym
->attr
.if_source
= IFSRC_DECL
;
9213 gfc_new_block
= sym
;
9215 /* Make a new formal arglist with the symbols in the procedure
9218 for (formal
= sym
->formal
; formal
&& formal
->sym
; formal
= formal
->next
)
9220 if (formal
== sym
->formal
)
9221 head
= tail
= gfc_get_formal_arglist ();
9224 tail
->next
= gfc_get_formal_arglist ();
9228 if (gfc_copy_dummy_sym (&fsym
, formal
->sym
, 0))
9232 gfc_set_sym_referenced (fsym
);
9235 /* The dummy symbols get cleaned up, when the formal_namespace of the
9236 interface declaration is cleared. This allows us to add the
9237 explicit interface as is done for other type of procedure. */
9238 if (!gfc_add_explicit_interface (sym
, IFSRC_DECL
, head
,
9239 &gfc_current_locus
))
9242 if (gfc_match_eos () != MATCH_YES
)
9244 gfc_syntax_error (ST_MODULE_PROC
);
9251 gfc_free_formal_arglist (head
);
9256 /* Match a module procedure statement. Note that we have to modify
9257 symbols in the parent's namespace because the current one was there
9258 to receive symbols that are in an interface's formal argument list. */
9261 gfc_match_modproc (void)
9263 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9267 gfc_namespace
*module_ns
;
9268 gfc_interface
*old_interface_head
, *interface
;
9270 if (gfc_state_stack
->state
!= COMP_INTERFACE
9271 || gfc_state_stack
->previous
== NULL
9272 || current_interface
.type
== INTERFACE_NAMELESS
9273 || current_interface
.type
== INTERFACE_ABSTRACT
)
9275 gfc_error ("MODULE PROCEDURE at %C must be in a generic module "
9280 module_ns
= gfc_current_ns
->parent
;
9281 for (; module_ns
; module_ns
= module_ns
->parent
)
9282 if (module_ns
->proc_name
->attr
.flavor
== FL_MODULE
9283 || module_ns
->proc_name
->attr
.flavor
== FL_PROGRAM
9284 || (module_ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
9285 && !module_ns
->proc_name
->attr
.contained
))
9288 if (module_ns
== NULL
)
9291 /* Store the current state of the interface. We will need it if we
9292 end up with a syntax error and need to recover. */
9293 old_interface_head
= gfc_current_interface_head ();
9295 /* Check if the F2008 optional double colon appears. */
9296 gfc_gobble_whitespace ();
9297 old_locus
= gfc_current_locus
;
9298 if (gfc_match ("::") == MATCH_YES
)
9300 if (!gfc_notify_std (GFC_STD_F2008
, "double colon in "
9301 "MODULE PROCEDURE statement at %L", &old_locus
))
9305 gfc_current_locus
= old_locus
;
9310 old_locus
= gfc_current_locus
;
9312 m
= gfc_match_name (name
);
9318 /* Check for syntax error before starting to add symbols to the
9319 current namespace. */
9320 if (gfc_match_eos () == MATCH_YES
)
9323 if (!last
&& gfc_match_char (',') != MATCH_YES
)
9326 /* Now we're sure the syntax is valid, we process this item
9328 if (gfc_get_symbol (name
, module_ns
, &sym
))
9331 if (sym
->attr
.intrinsic
)
9333 gfc_error ("Intrinsic procedure at %L cannot be a MODULE "
9334 "PROCEDURE", &old_locus
);
9338 if (sym
->attr
.proc
!= PROC_MODULE
9339 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
9342 if (!gfc_add_interface (sym
))
9345 sym
->attr
.mod_proc
= 1;
9346 sym
->declared_at
= old_locus
;
9355 /* Restore the previous state of the interface. */
9356 interface
= gfc_current_interface_head ();
9357 gfc_set_current_interface_head (old_interface_head
);
9359 /* Free the new interfaces. */
9360 while (interface
!= old_interface_head
)
9362 gfc_interface
*i
= interface
->next
;
9367 /* And issue a syntax error. */
9368 gfc_syntax_error (ST_MODULE_PROC
);
9373 /* Check a derived type that is being extended. */
9376 check_extended_derived_type (char *name
)
9378 gfc_symbol
*extended
;
9380 if (gfc_find_symbol (name
, gfc_current_ns
, 1, &extended
))
9382 gfc_error ("Ambiguous symbol in TYPE definition at %C");
9386 extended
= gfc_find_dt_in_generic (extended
);
9391 gfc_error ("Symbol %qs at %C has not been previously defined", name
);
9395 if (extended
->attr
.flavor
!= FL_DERIVED
)
9397 gfc_error ("%qs in EXTENDS expression at %C is not a "
9398 "derived type", name
);
9402 if (extended
->attr
.is_bind_c
)
9404 gfc_error ("%qs cannot be extended at %C because it "
9405 "is BIND(C)", extended
->name
);
9409 if (extended
->attr
.sequence
)
9411 gfc_error ("%qs cannot be extended at %C because it "
9412 "is a SEQUENCE type", extended
->name
);
9420 /* Match the optional attribute specifiers for a type declaration.
9421 Return MATCH_ERROR if an error is encountered in one of the handled
9422 attributes (public, private, bind(c)), MATCH_NO if what's found is
9423 not a handled attribute, and MATCH_YES otherwise. TODO: More error
9424 checking on attribute conflicts needs to be done. */
9427 gfc_get_type_attr_spec (symbol_attribute
*attr
, char *name
)
9429 /* See if the derived type is marked as private. */
9430 if (gfc_match (" , private") == MATCH_YES
)
9432 if (gfc_current_state () != COMP_MODULE
)
9434 gfc_error ("Derived type at %C can only be PRIVATE in the "
9435 "specification part of a module");
9439 if (!gfc_add_access (attr
, ACCESS_PRIVATE
, NULL
, NULL
))
9442 else if (gfc_match (" , public") == MATCH_YES
)
9444 if (gfc_current_state () != COMP_MODULE
)
9446 gfc_error ("Derived type at %C can only be PUBLIC in the "
9447 "specification part of a module");
9451 if (!gfc_add_access (attr
, ACCESS_PUBLIC
, NULL
, NULL
))
9454 else if (gfc_match (" , bind ( c )") == MATCH_YES
)
9456 /* If the type is defined to be bind(c) it then needs to make
9457 sure that all fields are interoperable. This will
9458 need to be a semantic check on the finished derived type.
9459 See 15.2.3 (lines 9-12) of F2003 draft. */
9460 if (!gfc_add_is_bind_c (attr
, NULL
, &gfc_current_locus
, 0))
9463 /* TODO: attr conflicts need to be checked, probably in symbol.c. */
9465 else if (gfc_match (" , abstract") == MATCH_YES
)
9467 if (!gfc_notify_std (GFC_STD_F2003
, "ABSTRACT type at %C"))
9470 if (!gfc_add_abstract (attr
, &gfc_current_locus
))
9473 else if (name
&& gfc_match (" , extends ( %n )", name
) == MATCH_YES
)
9475 if (!gfc_add_extension (attr
, &gfc_current_locus
))
9481 /* If we get here, something matched. */
9486 /* Common function for type declaration blocks similar to derived types, such
9487 as STRUCTURES and MAPs. Unlike derived types, a structure type
9488 does NOT have a generic symbol matching the name given by the user.
9489 STRUCTUREs can share names with variables and PARAMETERs so we must allow
9490 for the creation of an independent symbol.
9491 Other parameters are a message to prefix errors with, the name of the new
9492 type to be created, and the flavor to add to the resulting symbol. */
9495 get_struct_decl (const char *name
, sym_flavor fl
, locus
*decl
,
9496 gfc_symbol
**result
)
9501 gcc_assert (name
[0] == (char) TOUPPER (name
[0]));
9506 where
= gfc_current_locus
;
9508 if (gfc_get_symbol (name
, NULL
, &sym
))
9513 gfc_internal_error ("Failed to create structure type '%s' at %C", name
);
9517 if (sym
->components
!= NULL
|| sym
->attr
.zero_comp
)
9519 gfc_error ("Type definition of %qs at %C was already defined at %L",
9520 sym
->name
, &sym
->declared_at
);
9524 sym
->declared_at
= where
;
9526 if (sym
->attr
.flavor
!= fl
9527 && !gfc_add_flavor (&sym
->attr
, fl
, sym
->name
, NULL
))
9530 if (!sym
->hash_value
)
9531 /* Set the hash for the compound name for this type. */
9532 sym
->hash_value
= gfc_hash_value (sym
);
9534 /* Normally the type is expected to have been completely parsed by the time
9535 a field declaration with this type is seen. For unions, maps, and nested
9536 structure declarations, we need to indicate that it is okay that we
9537 haven't seen any components yet. This will be updated after the structure
9539 sym
->attr
.zero_comp
= 0;
9541 /* Structures always act like derived-types with the SEQUENCE attribute */
9542 gfc_add_sequence (&sym
->attr
, sym
->name
, NULL
);
9544 if (result
) *result
= sym
;
9550 /* Match the opening of a MAP block. Like a struct within a union in C;
9551 behaves identical to STRUCTURE blocks. */
9554 gfc_match_map (void)
9556 /* Counter used to give unique internal names to map structures. */
9557 static unsigned int gfc_map_id
= 0;
9558 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9562 old_loc
= gfc_current_locus
;
9564 if (gfc_match_eos () != MATCH_YES
)
9566 gfc_error ("Junk after MAP statement at %C");
9567 gfc_current_locus
= old_loc
;
9571 /* Map blocks are anonymous so we make up unique names for the symbol table
9572 which are invalid Fortran identifiers. */
9573 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "MM$%u", gfc_map_id
++);
9575 if (!get_struct_decl (name
, FL_STRUCT
, &old_loc
, &sym
))
9578 gfc_new_block
= sym
;
9584 /* Match the opening of a UNION block. */
9587 gfc_match_union (void)
9589 /* Counter used to give unique internal names to union types. */
9590 static unsigned int gfc_union_id
= 0;
9591 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9595 old_loc
= gfc_current_locus
;
9597 if (gfc_match_eos () != MATCH_YES
)
9599 gfc_error ("Junk after UNION statement at %C");
9600 gfc_current_locus
= old_loc
;
9604 /* Unions are anonymous so we make up unique names for the symbol table
9605 which are invalid Fortran identifiers. */
9606 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "UU$%u", gfc_union_id
++);
9608 if (!get_struct_decl (name
, FL_UNION
, &old_loc
, &sym
))
9611 gfc_new_block
= sym
;
9617 /* Match the beginning of a STRUCTURE declaration. This is similar to
9618 matching the beginning of a derived type declaration with a few
9619 twists. The resulting type symbol has no access control or other
9620 interesting attributes. */
9623 gfc_match_structure_decl (void)
9625 /* Counter used to give unique internal names to anonymous structures. */
9626 static unsigned int gfc_structure_id
= 0;
9627 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9632 if (!flag_dec_structure
)
9634 gfc_error ("%s at %C is a DEC extension, enable with "
9635 "%<-fdec-structure%>",
9642 m
= gfc_match (" /%n/", name
);
9645 /* Non-nested structure declarations require a structure name. */
9646 if (!gfc_comp_struct (gfc_current_state ()))
9648 gfc_error ("Structure name expected in non-nested structure "
9649 "declaration at %C");
9652 /* This is an anonymous structure; make up a unique name for it
9653 (upper-case letters never make it to symbol names from the source).
9654 The important thing is initializing the type variable
9655 and setting gfc_new_symbol, which is immediately used by
9656 parse_structure () and variable_decl () to add components of
9658 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "SS$%u", gfc_structure_id
++);
9661 where
= gfc_current_locus
;
9662 /* No field list allowed after non-nested structure declaration. */
9663 if (!gfc_comp_struct (gfc_current_state ())
9664 && gfc_match_eos () != MATCH_YES
)
9666 gfc_error ("Junk after non-nested STRUCTURE statement at %C");
9670 /* Make sure the name is not the name of an intrinsic type. */
9671 if (gfc_is_intrinsic_typename (name
))
9673 gfc_error ("Structure name %qs at %C cannot be the same as an"
9674 " intrinsic type", name
);
9678 /* Store the actual type symbol for the structure with an upper-case first
9679 letter (an invalid Fortran identifier). */
9681 if (!get_struct_decl (gfc_dt_upper_string (name
), FL_STRUCT
, &where
, &sym
))
9684 gfc_new_block
= sym
;
9689 /* This function does some work to determine which matcher should be used to
9690 * match a statement beginning with "TYPE". This is used to disambiguate TYPE
9691 * as an alias for PRINT from derived type declarations, TYPE IS statements,
9692 * and derived type data declarations. */
9695 gfc_match_type (gfc_statement
*st
)
9697 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9701 /* Requires -fdec. */
9705 m
= gfc_match ("type");
9708 /* If we already have an error in the buffer, it is probably from failing to
9709 * match a derived type data declaration. Let it happen. */
9710 else if (gfc_error_flag_test ())
9713 old_loc
= gfc_current_locus
;
9716 /* If we see an attribute list before anything else it's definitely a derived
9717 * type declaration. */
9718 if (gfc_match (" ,") == MATCH_YES
|| gfc_match (" ::") == MATCH_YES
)
9720 gfc_current_locus
= old_loc
;
9721 *st
= ST_DERIVED_DECL
;
9722 return gfc_match_derived_decl ();
9725 /* By now "TYPE" has already been matched. If we do not see a name, this may
9726 * be something like "TYPE *" or "TYPE <fmt>". */
9727 m
= gfc_match_name (name
);
9730 /* Let print match if it can, otherwise throw an error from
9731 * gfc_match_derived_decl. */
9732 gfc_current_locus
= old_loc
;
9733 if (gfc_match_print () == MATCH_YES
)
9738 gfc_current_locus
= old_loc
;
9739 *st
= ST_DERIVED_DECL
;
9740 return gfc_match_derived_decl ();
9743 /* A derived type declaration requires an EOS. Without it, assume print. */
9744 m
= gfc_match_eos ();
9747 /* Check manually for TYPE IS (... - this is invalid print syntax. */
9748 if (strncmp ("is", name
, 3) == 0
9749 && gfc_match (" (", name
) == MATCH_YES
)
9751 gfc_current_locus
= old_loc
;
9752 gcc_assert (gfc_match (" is") == MATCH_YES
);
9754 return gfc_match_type_is ();
9756 gfc_current_locus
= old_loc
;
9758 return gfc_match_print ();
9762 /* By now we have "TYPE <name> <EOS>". Check first if the name is an
9763 * intrinsic typename - if so let gfc_match_derived_decl dump an error.
9764 * Otherwise if gfc_match_derived_decl fails it's probably an existing
9765 * symbol which can be printed. */
9766 gfc_current_locus
= old_loc
;
9767 m
= gfc_match_derived_decl ();
9768 if (gfc_is_intrinsic_typename (name
) || m
== MATCH_YES
)
9770 *st
= ST_DERIVED_DECL
;
9773 gfc_current_locus
= old_loc
;
9775 return gfc_match_print ();
9782 /* Match the beginning of a derived type declaration. If a type name
9783 was the result of a function, then it is possible to have a symbol
9784 already to be known as a derived type yet have no components. */
9787 gfc_match_derived_decl (void)
9789 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9790 char parent
[GFC_MAX_SYMBOL_LEN
+ 1];
9791 symbol_attribute attr
;
9792 gfc_symbol
*sym
, *gensym
;
9793 gfc_symbol
*extended
;
9795 match is_type_attr_spec
= MATCH_NO
;
9796 bool seen_attr
= false;
9797 gfc_interface
*intr
= NULL
, *head
;
9798 bool parameterized_type
= false;
9799 bool seen_colons
= false;
9801 if (gfc_comp_struct (gfc_current_state ()))
9806 gfc_clear_attr (&attr
);
9811 is_type_attr_spec
= gfc_get_type_attr_spec (&attr
, parent
);
9812 if (is_type_attr_spec
== MATCH_ERROR
)
9814 if (is_type_attr_spec
== MATCH_YES
)
9816 } while (is_type_attr_spec
== MATCH_YES
);
9818 /* Deal with derived type extensions. The extension attribute has
9819 been added to 'attr' but now the parent type must be found and
9822 extended
= check_extended_derived_type (parent
);
9824 if (parent
[0] && !extended
)
9827 m
= gfc_match (" ::");
9834 gfc_error ("Expected :: in TYPE definition at %C");
9838 m
= gfc_match (" %n ", name
);
9842 /* Make sure that we don't identify TYPE IS (...) as a parameterized
9843 derived type named 'is'.
9844 TODO Expand the check, when 'name' = "is" by matching " (tname) "
9845 and checking if this is a(n intrinsic) typename. his picks up
9846 misplaced TYPE IS statements such as in select_type_1.f03. */
9847 if (gfc_peek_ascii_char () == '(')
9849 if (gfc_current_state () == COMP_SELECT_TYPE
9850 || (!seen_colons
&& !strcmp (name
, "is")))
9852 parameterized_type
= true;
9855 m
= gfc_match_eos ();
9856 if (m
!= MATCH_YES
&& !parameterized_type
)
9859 /* Make sure the name is not the name of an intrinsic type. */
9860 if (gfc_is_intrinsic_typename (name
))
9862 gfc_error ("Type name %qs at %C cannot be the same as an intrinsic "
9867 if (gfc_get_symbol (name
, NULL
, &gensym
))
9870 if (!gensym
->attr
.generic
&& gensym
->ts
.type
!= BT_UNKNOWN
)
9872 gfc_error ("Derived type name %qs at %C already has a basic type "
9873 "of %s", gensym
->name
, gfc_typename (&gensym
->ts
));
9877 if (!gensym
->attr
.generic
9878 && !gfc_add_generic (&gensym
->attr
, gensym
->name
, NULL
))
9881 if (!gensym
->attr
.function
9882 && !gfc_add_function (&gensym
->attr
, gensym
->name
, NULL
))
9885 sym
= gfc_find_dt_in_generic (gensym
);
9887 if (sym
&& (sym
->components
!= NULL
|| sym
->attr
.zero_comp
))
9889 gfc_error ("Derived type definition of %qs at %C has already been "
9890 "defined", sym
->name
);
9896 /* Use upper case to save the actual derived-type symbol. */
9897 gfc_get_symbol (gfc_dt_upper_string (gensym
->name
), NULL
, &sym
);
9898 sym
->name
= gfc_get_string ("%s", gensym
->name
);
9899 head
= gensym
->generic
;
9900 intr
= gfc_get_interface ();
9902 intr
->where
= gfc_current_locus
;
9903 intr
->sym
->declared_at
= gfc_current_locus
;
9905 gensym
->generic
= intr
;
9906 gensym
->attr
.if_source
= IFSRC_DECL
;
9909 /* The symbol may already have the derived attribute without the
9910 components. The ways this can happen is via a function
9911 definition, an INTRINSIC statement or a subtype in another
9912 derived type that is a pointer. The first part of the AND clause
9913 is true if the symbol is not the return value of a function. */
9914 if (sym
->attr
.flavor
!= FL_DERIVED
9915 && !gfc_add_flavor (&sym
->attr
, FL_DERIVED
, sym
->name
, NULL
))
9918 if (attr
.access
!= ACCESS_UNKNOWN
9919 && !gfc_add_access (&sym
->attr
, attr
.access
, sym
->name
, NULL
))
9921 else if (sym
->attr
.access
== ACCESS_UNKNOWN
9922 && gensym
->attr
.access
!= ACCESS_UNKNOWN
9923 && !gfc_add_access (&sym
->attr
, gensym
->attr
.access
,
9927 if (sym
->attr
.access
!= ACCESS_UNKNOWN
9928 && gensym
->attr
.access
== ACCESS_UNKNOWN
)
9929 gensym
->attr
.access
= sym
->attr
.access
;
9931 /* See if the derived type was labeled as bind(c). */
9932 if (attr
.is_bind_c
!= 0)
9933 sym
->attr
.is_bind_c
= attr
.is_bind_c
;
9935 /* Construct the f2k_derived namespace if it is not yet there. */
9936 if (!sym
->f2k_derived
)
9937 sym
->f2k_derived
= gfc_get_namespace (NULL
, 0);
9939 if (parameterized_type
)
9941 /* Ignore error or mismatches by going to the end of the statement
9942 in order to avoid the component declarations causing problems. */
9943 m
= gfc_match_formal_arglist (sym
, 0, 0, true);
9945 gfc_error_recovery ();
9946 m
= gfc_match_eos ();
9949 gfc_error_recovery ();
9950 gfc_error_now ("Garbage after PARAMETERIZED TYPE declaration at %C");
9952 sym
->attr
.pdt_template
= 1;
9955 if (extended
&& !sym
->components
)
9958 gfc_formal_arglist
*f
, *g
, *h
;
9960 /* Add the extended derived type as the first component. */
9961 gfc_add_component (sym
, parent
, &p
);
9963 gfc_set_sym_referenced (extended
);
9965 p
->ts
.type
= BT_DERIVED
;
9966 p
->ts
.u
.derived
= extended
;
9967 p
->initializer
= gfc_default_initializer (&p
->ts
);
9969 /* Set extension level. */
9970 if (extended
->attr
.extension
== 255)
9972 /* Since the extension field is 8 bit wide, we can only have
9973 up to 255 extension levels. */
9974 gfc_error ("Maximum extension level reached with type %qs at %L",
9975 extended
->name
, &extended
->declared_at
);
9978 sym
->attr
.extension
= extended
->attr
.extension
+ 1;
9980 /* Provide the links between the extended type and its extension. */
9981 if (!extended
->f2k_derived
)
9982 extended
->f2k_derived
= gfc_get_namespace (NULL
, 0);
9984 /* Copy the extended type-param-name-list from the extended type,
9985 append those of the extension and add the whole lot to the
9987 if (extended
->attr
.pdt_template
)
9990 sym
->attr
.pdt_template
= 1;
9991 for (f
= extended
->formal
; f
; f
= f
->next
)
9993 if (f
== extended
->formal
)
9995 g
= gfc_get_formal_arglist ();
10000 g
->next
= gfc_get_formal_arglist ();
10005 g
->next
= sym
->formal
;
10010 if (!sym
->hash_value
)
10011 /* Set the hash for the compound name for this type. */
10012 sym
->hash_value
= gfc_hash_value (sym
);
10014 /* Take over the ABSTRACT attribute. */
10015 sym
->attr
.abstract
= attr
.abstract
;
10017 gfc_new_block
= sym
;
10023 /* Cray Pointees can be declared as:
10024 pointer (ipt, a (n,m,...,*)) */
10027 gfc_mod_pointee_as (gfc_array_spec
*as
)
10029 as
->cray_pointee
= true; /* This will be useful to know later. */
10030 if (as
->type
== AS_ASSUMED_SIZE
)
10031 as
->cp_was_assumed
= true;
10032 else if (as
->type
== AS_ASSUMED_SHAPE
)
10034 gfc_error ("Cray Pointee at %C cannot be assumed shape array");
10035 return MATCH_ERROR
;
10041 /* Match the enum definition statement, here we are trying to match
10042 the first line of enum definition statement.
10043 Returns MATCH_YES if match is found. */
10046 gfc_match_enum (void)
10050 m
= gfc_match_eos ();
10051 if (m
!= MATCH_YES
)
10054 if (!gfc_notify_std (GFC_STD_F2003
, "ENUM and ENUMERATOR at %C"))
10055 return MATCH_ERROR
;
10061 /* Returns an initializer whose value is one higher than the value of the
10062 LAST_INITIALIZER argument. If the argument is NULL, the
10063 initializers value will be set to zero. The initializer's kind
10064 will be set to gfc_c_int_kind.
10066 If -fshort-enums is given, the appropriate kind will be selected
10067 later after all enumerators have been parsed. A warning is issued
10068 here if an initializer exceeds gfc_c_int_kind. */
10071 enum_initializer (gfc_expr
*last_initializer
, locus where
)
10074 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_c_int_kind
, &where
);
10076 mpz_init (result
->value
.integer
);
10078 if (last_initializer
!= NULL
)
10080 mpz_add_ui (result
->value
.integer
, last_initializer
->value
.integer
, 1);
10081 result
->where
= last_initializer
->where
;
10083 if (gfc_check_integer_range (result
->value
.integer
,
10084 gfc_c_int_kind
) != ARITH_OK
)
10086 gfc_error ("Enumerator exceeds the C integer type at %C");
10092 /* Control comes here, if it's the very first enumerator and no
10093 initializer has been given. It will be initialized to zero. */
10094 mpz_set_si (result
->value
.integer
, 0);
10101 /* Match a variable name with an optional initializer. When this
10102 subroutine is called, a variable is expected to be parsed next.
10103 Depending on what is happening at the moment, updates either the
10104 symbol table or the current interface. */
10107 enumerator_decl (void)
10109 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10110 gfc_expr
*initializer
;
10111 gfc_array_spec
*as
= NULL
;
10118 initializer
= NULL
;
10119 old_locus
= gfc_current_locus
;
10121 /* When we get here, we've just matched a list of attributes and
10122 maybe a type and a double colon. The next thing we expect to see
10123 is the name of the symbol. */
10124 m
= gfc_match_name (name
);
10125 if (m
!= MATCH_YES
)
10128 var_locus
= gfc_current_locus
;
10130 /* OK, we've successfully matched the declaration. Now put the
10131 symbol in the current namespace. If we fail to create the symbol,
10133 if (!build_sym (name
, NULL
, false, &as
, &var_locus
))
10139 /* The double colon must be present in order to have initializers.
10140 Otherwise the statement is ambiguous with an assignment statement. */
10143 if (gfc_match_char ('=') == MATCH_YES
)
10145 m
= gfc_match_init_expr (&initializer
);
10148 gfc_error ("Expected an initialization expression at %C");
10152 if (m
!= MATCH_YES
)
10157 /* If we do not have an initializer, the initialization value of the
10158 previous enumerator (stored in last_initializer) is incremented
10159 by 1 and is used to initialize the current enumerator. */
10160 if (initializer
== NULL
)
10161 initializer
= enum_initializer (last_initializer
, old_locus
);
10163 if (initializer
== NULL
|| initializer
->ts
.type
!= BT_INTEGER
)
10165 gfc_error ("ENUMERATOR %L not initialized with integer expression",
10171 /* Store this current initializer, for the next enumerator variable
10172 to be parsed. add_init_expr_to_sym() zeros initializer, so we
10173 use last_initializer below. */
10174 last_initializer
= initializer
;
10175 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
10177 /* Maintain enumerator history. */
10178 gfc_find_symbol (name
, NULL
, 0, &sym
);
10179 create_enum_history (sym
, last_initializer
);
10181 return (t
) ? MATCH_YES
: MATCH_ERROR
;
10184 /* Free stuff up and return. */
10185 gfc_free_expr (initializer
);
10191 /* Match the enumerator definition statement. */
10194 gfc_match_enumerator_def (void)
10199 gfc_clear_ts (¤t_ts
);
10201 m
= gfc_match (" enumerator");
10202 if (m
!= MATCH_YES
)
10205 m
= gfc_match (" :: ");
10206 if (m
== MATCH_ERROR
)
10209 colon_seen
= (m
== MATCH_YES
);
10211 if (gfc_current_state () != COMP_ENUM
)
10213 gfc_error ("ENUM definition statement expected before %C");
10214 gfc_free_enum_history ();
10215 return MATCH_ERROR
;
10218 (¤t_ts
)->type
= BT_INTEGER
;
10219 (¤t_ts
)->kind
= gfc_c_int_kind
;
10221 gfc_clear_attr (¤t_attr
);
10222 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, NULL
);
10231 m
= enumerator_decl ();
10232 if (m
== MATCH_ERROR
)
10234 gfc_free_enum_history ();
10240 if (gfc_match_eos () == MATCH_YES
)
10242 if (gfc_match_char (',') != MATCH_YES
)
10246 if (gfc_current_state () == COMP_ENUM
)
10248 gfc_free_enum_history ();
10249 gfc_error ("Syntax error in ENUMERATOR definition at %C");
10254 gfc_free_array_spec (current_as
);
10261 /* Match binding attributes. */
10264 match_binding_attributes (gfc_typebound_proc
* ba
, bool generic
, bool ppc
)
10266 bool found_passing
= false;
10267 bool seen_ptr
= false;
10268 match m
= MATCH_YES
;
10270 /* Initialize to defaults. Do so even before the MATCH_NO check so that in
10271 this case the defaults are in there. */
10272 ba
->access
= ACCESS_UNKNOWN
;
10273 ba
->pass_arg
= NULL
;
10274 ba
->pass_arg_num
= 0;
10276 ba
->non_overridable
= 0;
10280 /* If we find a comma, we believe there are binding attributes. */
10281 m
= gfc_match_char (',');
10287 /* Access specifier. */
10289 m
= gfc_match (" public");
10290 if (m
== MATCH_ERROR
)
10292 if (m
== MATCH_YES
)
10294 if (ba
->access
!= ACCESS_UNKNOWN
)
10296 gfc_error ("Duplicate access-specifier at %C");
10300 ba
->access
= ACCESS_PUBLIC
;
10304 m
= gfc_match (" private");
10305 if (m
== MATCH_ERROR
)
10307 if (m
== MATCH_YES
)
10309 if (ba
->access
!= ACCESS_UNKNOWN
)
10311 gfc_error ("Duplicate access-specifier at %C");
10315 ba
->access
= ACCESS_PRIVATE
;
10319 /* If inside GENERIC, the following is not allowed. */
10324 m
= gfc_match (" nopass");
10325 if (m
== MATCH_ERROR
)
10327 if (m
== MATCH_YES
)
10331 gfc_error ("Binding attributes already specify passing,"
10332 " illegal NOPASS at %C");
10336 found_passing
= true;
10341 /* PASS possibly including argument. */
10342 m
= gfc_match (" pass");
10343 if (m
== MATCH_ERROR
)
10345 if (m
== MATCH_YES
)
10347 char arg
[GFC_MAX_SYMBOL_LEN
+ 1];
10351 gfc_error ("Binding attributes already specify passing,"
10352 " illegal PASS at %C");
10356 m
= gfc_match (" ( %n )", arg
);
10357 if (m
== MATCH_ERROR
)
10359 if (m
== MATCH_YES
)
10360 ba
->pass_arg
= gfc_get_string ("%s", arg
);
10361 gcc_assert ((m
== MATCH_YES
) == (ba
->pass_arg
!= NULL
));
10363 found_passing
= true;
10370 /* POINTER flag. */
10371 m
= gfc_match (" pointer");
10372 if (m
== MATCH_ERROR
)
10374 if (m
== MATCH_YES
)
10378 gfc_error ("Duplicate POINTER attribute at %C");
10388 /* NON_OVERRIDABLE flag. */
10389 m
= gfc_match (" non_overridable");
10390 if (m
== MATCH_ERROR
)
10392 if (m
== MATCH_YES
)
10394 if (ba
->non_overridable
)
10396 gfc_error ("Duplicate NON_OVERRIDABLE at %C");
10400 ba
->non_overridable
= 1;
10404 /* DEFERRED flag. */
10405 m
= gfc_match (" deferred");
10406 if (m
== MATCH_ERROR
)
10408 if (m
== MATCH_YES
)
10412 gfc_error ("Duplicate DEFERRED at %C");
10423 /* Nothing matching found. */
10425 gfc_error ("Expected access-specifier at %C");
10427 gfc_error ("Expected binding attribute at %C");
10430 while (gfc_match_char (',') == MATCH_YES
);
10432 /* NON_OVERRIDABLE and DEFERRED exclude themselves. */
10433 if (ba
->non_overridable
&& ba
->deferred
)
10435 gfc_error ("NON_OVERRIDABLE and DEFERRED can't both appear at %C");
10442 if (ba
->access
== ACCESS_UNKNOWN
)
10443 ba
->access
= gfc_typebound_default_access
;
10445 if (ppc
&& !seen_ptr
)
10447 gfc_error ("POINTER attribute is required for procedure pointer component"
10455 return MATCH_ERROR
;
10459 /* Match a PROCEDURE specific binding inside a derived type. */
10462 match_procedure_in_type (void)
10464 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10465 char target_buf
[GFC_MAX_SYMBOL_LEN
+ 1];
10466 char* target
= NULL
, *ifc
= NULL
;
10467 gfc_typebound_proc tb
;
10471 gfc_symtree
* stree
;
10476 /* Check current state. */
10477 gcc_assert (gfc_state_stack
->state
== COMP_DERIVED_CONTAINS
);
10478 block
= gfc_state_stack
->previous
->sym
;
10479 gcc_assert (block
);
10481 /* Try to match PROCEDURE(interface). */
10482 if (gfc_match (" (") == MATCH_YES
)
10484 m
= gfc_match_name (target_buf
);
10485 if (m
== MATCH_ERROR
)
10487 if (m
!= MATCH_YES
)
10489 gfc_error ("Interface-name expected after %<(%> at %C");
10490 return MATCH_ERROR
;
10493 if (gfc_match (" )") != MATCH_YES
)
10495 gfc_error ("%<)%> expected at %C");
10496 return MATCH_ERROR
;
10502 /* Construct the data structure. */
10503 memset (&tb
, 0, sizeof (tb
));
10504 tb
.where
= gfc_current_locus
;
10506 /* Match binding attributes. */
10507 m
= match_binding_attributes (&tb
, false, false);
10508 if (m
== MATCH_ERROR
)
10510 seen_attrs
= (m
== MATCH_YES
);
10512 /* Check that attribute DEFERRED is given if an interface is specified. */
10513 if (tb
.deferred
&& !ifc
)
10515 gfc_error ("Interface must be specified for DEFERRED binding at %C");
10516 return MATCH_ERROR
;
10518 if (ifc
&& !tb
.deferred
)
10520 gfc_error ("PROCEDURE(interface) at %C should be declared DEFERRED");
10521 return MATCH_ERROR
;
10524 /* Match the colons. */
10525 m
= gfc_match (" ::");
10526 if (m
== MATCH_ERROR
)
10528 seen_colons
= (m
== MATCH_YES
);
10529 if (seen_attrs
&& !seen_colons
)
10531 gfc_error ("Expected %<::%> after binding-attributes at %C");
10532 return MATCH_ERROR
;
10535 /* Match the binding names. */
10538 m
= gfc_match_name (name
);
10539 if (m
== MATCH_ERROR
)
10543 gfc_error ("Expected binding name at %C");
10544 return MATCH_ERROR
;
10547 if (num
>1 && !gfc_notify_std (GFC_STD_F2008
, "PROCEDURE list at %C"))
10548 return MATCH_ERROR
;
10550 /* Try to match the '=> target', if it's there. */
10552 m
= gfc_match (" =>");
10553 if (m
== MATCH_ERROR
)
10555 if (m
== MATCH_YES
)
10559 gfc_error ("%<=> target%> is invalid for DEFERRED binding at %C");
10560 return MATCH_ERROR
;
10565 gfc_error ("%<::%> needed in PROCEDURE binding with explicit target"
10567 return MATCH_ERROR
;
10570 m
= gfc_match_name (target_buf
);
10571 if (m
== MATCH_ERROR
)
10575 gfc_error ("Expected binding target after %<=>%> at %C");
10576 return MATCH_ERROR
;
10578 target
= target_buf
;
10581 /* If no target was found, it has the same name as the binding. */
10585 /* Get the namespace to insert the symbols into. */
10586 ns
= block
->f2k_derived
;
10589 /* If the binding is DEFERRED, check that the containing type is ABSTRACT. */
10590 if (tb
.deferred
&& !block
->attr
.abstract
)
10592 gfc_error ("Type %qs containing DEFERRED binding at %C "
10593 "is not ABSTRACT", block
->name
);
10594 return MATCH_ERROR
;
10597 /* See if we already have a binding with this name in the symtree which
10598 would be an error. If a GENERIC already targeted this binding, it may
10599 be already there but then typebound is still NULL. */
10600 stree
= gfc_find_symtree (ns
->tb_sym_root
, name
);
10601 if (stree
&& stree
->n
.tb
)
10603 gfc_error ("There is already a procedure with binding name %qs for "
10604 "the derived type %qs at %C", name
, block
->name
);
10605 return MATCH_ERROR
;
10608 /* Insert it and set attributes. */
10612 stree
= gfc_new_symtree (&ns
->tb_sym_root
, name
);
10613 gcc_assert (stree
);
10615 stree
->n
.tb
= gfc_get_typebound_proc (&tb
);
10617 if (gfc_get_sym_tree (target
, gfc_current_ns
, &stree
->n
.tb
->u
.specific
,
10619 return MATCH_ERROR
;
10620 gfc_set_sym_referenced (stree
->n
.tb
->u
.specific
->n
.sym
);
10621 gfc_add_flavor(&stree
->n
.tb
->u
.specific
->n
.sym
->attr
, FL_PROCEDURE
,
10622 target
, &stree
->n
.tb
->u
.specific
->n
.sym
->declared_at
);
10624 if (gfc_match_eos () == MATCH_YES
)
10626 if (gfc_match_char (',') != MATCH_YES
)
10631 gfc_error ("Syntax error in PROCEDURE statement at %C");
10632 return MATCH_ERROR
;
10636 /* Match a GENERIC procedure binding inside a derived type. */
10639 gfc_match_generic (void)
10641 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10642 char bind_name
[GFC_MAX_SYMBOL_LEN
+ 16]; /* Allow space for OPERATOR(...). */
10644 gfc_typebound_proc tbattr
; /* Used for match_binding_attributes. */
10645 gfc_typebound_proc
* tb
;
10647 interface_type op_type
;
10648 gfc_intrinsic_op op
;
10651 /* Check current state. */
10652 if (gfc_current_state () == COMP_DERIVED
)
10654 gfc_error ("GENERIC at %C must be inside a derived-type CONTAINS");
10655 return MATCH_ERROR
;
10657 if (gfc_current_state () != COMP_DERIVED_CONTAINS
)
10659 block
= gfc_state_stack
->previous
->sym
;
10660 ns
= block
->f2k_derived
;
10661 gcc_assert (block
&& ns
);
10663 memset (&tbattr
, 0, sizeof (tbattr
));
10664 tbattr
.where
= gfc_current_locus
;
10666 /* See if we get an access-specifier. */
10667 m
= match_binding_attributes (&tbattr
, true, false);
10668 if (m
== MATCH_ERROR
)
10671 /* Now the colons, those are required. */
10672 if (gfc_match (" ::") != MATCH_YES
)
10674 gfc_error ("Expected %<::%> at %C");
10678 /* Match the binding name; depending on type (operator / generic) format
10679 it for future error messages into bind_name. */
10681 m
= gfc_match_generic_spec (&op_type
, name
, &op
);
10682 if (m
== MATCH_ERROR
)
10683 return MATCH_ERROR
;
10686 gfc_error ("Expected generic name or operator descriptor at %C");
10692 case INTERFACE_GENERIC
:
10693 case INTERFACE_DTIO
:
10694 snprintf (bind_name
, sizeof (bind_name
), "%s", name
);
10697 case INTERFACE_USER_OP
:
10698 snprintf (bind_name
, sizeof (bind_name
), "OPERATOR(.%s.)", name
);
10701 case INTERFACE_INTRINSIC_OP
:
10702 snprintf (bind_name
, sizeof (bind_name
), "OPERATOR(%s)",
10703 gfc_op2string (op
));
10706 case INTERFACE_NAMELESS
:
10707 gfc_error ("Malformed GENERIC statement at %C");
10712 gcc_unreachable ();
10715 /* Match the required =>. */
10716 if (gfc_match (" =>") != MATCH_YES
)
10718 gfc_error ("Expected %<=>%> at %C");
10722 /* Try to find existing GENERIC binding with this name / for this operator;
10723 if there is something, check that it is another GENERIC and then extend
10724 it rather than building a new node. Otherwise, create it and put it
10725 at the right position. */
10729 case INTERFACE_DTIO
:
10730 case INTERFACE_USER_OP
:
10731 case INTERFACE_GENERIC
:
10733 const bool is_op
= (op_type
== INTERFACE_USER_OP
);
10736 st
= gfc_find_symtree (is_op
? ns
->tb_uop_root
: ns
->tb_sym_root
, name
);
10737 tb
= st
? st
->n
.tb
: NULL
;
10741 case INTERFACE_INTRINSIC_OP
:
10742 tb
= ns
->tb_op
[op
];
10746 gcc_unreachable ();
10751 if (!tb
->is_generic
)
10753 gcc_assert (op_type
== INTERFACE_GENERIC
);
10754 gfc_error ("There's already a non-generic procedure with binding name"
10755 " %qs for the derived type %qs at %C",
10756 bind_name
, block
->name
);
10760 if (tb
->access
!= tbattr
.access
)
10762 gfc_error ("Binding at %C must have the same access as already"
10763 " defined binding %qs", bind_name
);
10769 tb
= gfc_get_typebound_proc (NULL
);
10770 tb
->where
= gfc_current_locus
;
10771 tb
->access
= tbattr
.access
;
10772 tb
->is_generic
= 1;
10773 tb
->u
.generic
= NULL
;
10777 case INTERFACE_DTIO
:
10778 case INTERFACE_GENERIC
:
10779 case INTERFACE_USER_OP
:
10781 const bool is_op
= (op_type
== INTERFACE_USER_OP
);
10782 gfc_symtree
* st
= gfc_get_tbp_symtree (is_op
? &ns
->tb_uop_root
:
10783 &ns
->tb_sym_root
, name
);
10790 case INTERFACE_INTRINSIC_OP
:
10791 ns
->tb_op
[op
] = tb
;
10795 gcc_unreachable ();
10799 /* Now, match all following names as specific targets. */
10802 gfc_symtree
* target_st
;
10803 gfc_tbp_generic
* target
;
10805 m
= gfc_match_name (name
);
10806 if (m
== MATCH_ERROR
)
10810 gfc_error ("Expected specific binding name at %C");
10814 target_st
= gfc_get_tbp_symtree (&ns
->tb_sym_root
, name
);
10816 /* See if this is a duplicate specification. */
10817 for (target
= tb
->u
.generic
; target
; target
= target
->next
)
10818 if (target_st
== target
->specific_st
)
10820 gfc_error ("%qs already defined as specific binding for the"
10821 " generic %qs at %C", name
, bind_name
);
10825 target
= gfc_get_tbp_generic ();
10826 target
->specific_st
= target_st
;
10827 target
->specific
= NULL
;
10828 target
->next
= tb
->u
.generic
;
10829 target
->is_operator
= ((op_type
== INTERFACE_USER_OP
)
10830 || (op_type
== INTERFACE_INTRINSIC_OP
));
10831 tb
->u
.generic
= target
;
10833 while (gfc_match (" ,") == MATCH_YES
);
10835 /* Here should be the end. */
10836 if (gfc_match_eos () != MATCH_YES
)
10838 gfc_error ("Junk after GENERIC binding at %C");
10845 return MATCH_ERROR
;
10849 /* Match a FINAL declaration inside a derived type. */
10852 gfc_match_final_decl (void)
10854 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10857 gfc_namespace
* module_ns
;
10861 if (gfc_current_form
== FORM_FREE
)
10863 char c
= gfc_peek_ascii_char ();
10864 if (!gfc_is_whitespace (c
) && c
!= ':')
10868 if (gfc_state_stack
->state
!= COMP_DERIVED_CONTAINS
)
10870 if (gfc_current_form
== FORM_FIXED
)
10873 gfc_error ("FINAL declaration at %C must be inside a derived type "
10874 "CONTAINS section");
10875 return MATCH_ERROR
;
10878 block
= gfc_state_stack
->previous
->sym
;
10879 gcc_assert (block
);
10881 if (!gfc_state_stack
->previous
|| !gfc_state_stack
->previous
->previous
10882 || gfc_state_stack
->previous
->previous
->state
!= COMP_MODULE
)
10884 gfc_error ("Derived type declaration with FINAL at %C must be in the"
10885 " specification part of a MODULE");
10886 return MATCH_ERROR
;
10889 module_ns
= gfc_current_ns
;
10890 gcc_assert (module_ns
);
10891 gcc_assert (module_ns
->proc_name
->attr
.flavor
== FL_MODULE
);
10893 /* Match optional ::, don't care about MATCH_YES or MATCH_NO. */
10894 if (gfc_match (" ::") == MATCH_ERROR
)
10895 return MATCH_ERROR
;
10897 /* Match the sequence of procedure names. */
10904 if (first
&& gfc_match_eos () == MATCH_YES
)
10906 gfc_error ("Empty FINAL at %C");
10907 return MATCH_ERROR
;
10910 m
= gfc_match_name (name
);
10913 gfc_error ("Expected module procedure name at %C");
10914 return MATCH_ERROR
;
10916 else if (m
!= MATCH_YES
)
10917 return MATCH_ERROR
;
10919 if (gfc_match_eos () == MATCH_YES
)
10921 if (!last
&& gfc_match_char (',') != MATCH_YES
)
10923 gfc_error ("Expected %<,%> at %C");
10924 return MATCH_ERROR
;
10927 if (gfc_get_symbol (name
, module_ns
, &sym
))
10929 gfc_error ("Unknown procedure name %qs at %C", name
);
10930 return MATCH_ERROR
;
10933 /* Mark the symbol as module procedure. */
10934 if (sym
->attr
.proc
!= PROC_MODULE
10935 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
10936 return MATCH_ERROR
;
10938 /* Check if we already have this symbol in the list, this is an error. */
10939 for (f
= block
->f2k_derived
->finalizers
; f
; f
= f
->next
)
10940 if (f
->proc_sym
== sym
)
10942 gfc_error ("%qs at %C is already defined as FINAL procedure",
10944 return MATCH_ERROR
;
10947 /* Add this symbol to the list of finalizers. */
10948 gcc_assert (block
->f2k_derived
);
10950 f
= XCNEW (gfc_finalizer
);
10952 f
->proc_tree
= NULL
;
10953 f
->where
= gfc_current_locus
;
10954 f
->next
= block
->f2k_derived
->finalizers
;
10955 block
->f2k_derived
->finalizers
= f
;
10965 const ext_attr_t ext_attr_list
[] = {
10966 { "dllimport", EXT_ATTR_DLLIMPORT
, "dllimport" },
10967 { "dllexport", EXT_ATTR_DLLEXPORT
, "dllexport" },
10968 { "cdecl", EXT_ATTR_CDECL
, "cdecl" },
10969 { "stdcall", EXT_ATTR_STDCALL
, "stdcall" },
10970 { "fastcall", EXT_ATTR_FASTCALL
, "fastcall" },
10971 { "no_arg_check", EXT_ATTR_NO_ARG_CHECK
, NULL
},
10972 { NULL
, EXT_ATTR_LAST
, NULL
}
10975 /* Match a !GCC$ ATTRIBUTES statement of the form:
10976 !GCC$ ATTRIBUTES attribute-list :: var-name [, var-name] ...
10977 When we come here, we have already matched the !GCC$ ATTRIBUTES string.
10979 TODO: We should support all GCC attributes using the same syntax for
10980 the attribute list, i.e. the list in C
10981 __attributes(( attribute-list ))
10983 !GCC$ ATTRIBUTES attribute-list ::
10984 Cf. c-parser.c's c_parser_attributes; the data can then directly be
10987 As there is absolutely no risk of confusion, we should never return
10990 gfc_match_gcc_attributes (void)
10992 symbol_attribute attr
;
10993 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10998 gfc_clear_attr (&attr
);
11003 if (gfc_match_name (name
) != MATCH_YES
)
11004 return MATCH_ERROR
;
11006 for (id
= 0; id
< EXT_ATTR_LAST
; id
++)
11007 if (strcmp (name
, ext_attr_list
[id
].name
) == 0)
11010 if (id
== EXT_ATTR_LAST
)
11012 gfc_error ("Unknown attribute in !GCC$ ATTRIBUTES statement at %C");
11013 return MATCH_ERROR
;
11016 if (!gfc_add_ext_attribute (&attr
, (ext_attr_id_t
)id
, &gfc_current_locus
))
11017 return MATCH_ERROR
;
11019 gfc_gobble_whitespace ();
11020 ch
= gfc_next_ascii_char ();
11023 /* This is the successful exit condition for the loop. */
11024 if (gfc_next_ascii_char () == ':')
11034 if (gfc_match_eos () == MATCH_YES
)
11039 m
= gfc_match_name (name
);
11040 if (m
!= MATCH_YES
)
11043 if (find_special (name
, &sym
, true))
11044 return MATCH_ERROR
;
11046 sym
->attr
.ext_attr
|= attr
.ext_attr
;
11048 if (gfc_match_eos () == MATCH_YES
)
11051 if (gfc_match_char (',') != MATCH_YES
)
11058 gfc_error ("Syntax error in !GCC$ ATTRIBUTES statement at %C");
11059 return MATCH_ERROR
;
11063 /* Match a !GCC$ UNROLL statement of the form:
11066 The parameter n is the number of times we are supposed to unroll.
11068 When we come here, we have already matched the !GCC$ UNROLL string. */
11070 gfc_match_gcc_unroll (void)
11074 if (gfc_match_small_int (&value
) == MATCH_YES
)
11076 if (value
< 0 || value
> USHRT_MAX
)
11078 gfc_error ("%<GCC unroll%> directive requires a"
11079 " non-negative integral constant"
11080 " less than or equal to %u at %C",
11083 return MATCH_ERROR
;
11085 if (gfc_match_eos () == MATCH_YES
)
11087 directive_unroll
= value
== 0 ? 1 : value
;
11092 gfc_error ("Syntax error in !GCC$ UNROLL directive at %C");
11093 return MATCH_ERROR
;