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 /* Do not exceed the limits on lower[] and upper[]. gfortran
826 cleans up elsewhere. */
828 if (j
>= GFC_MAX_DIMENSIONS
)
831 to
->lower
[j
] = to
->lower
[i
];
832 to
->upper
[j
] = to
->upper
[i
];
834 for (i
= 0; i
< from
->rank
; i
++)
838 to
->lower
[i
] = gfc_copy_expr (from
->lower
[i
]);
839 to
->upper
[i
] = gfc_copy_expr (from
->upper
[i
]);
843 to
->lower
[i
] = from
->lower
[i
];
844 to
->upper
[i
] = from
->upper
[i
];
848 else if (to
->corank
== 0 && from
->corank
> 0)
850 to
->corank
= from
->corank
;
851 to
->cotype
= from
->cotype
;
853 for (i
= 0; i
< from
->corank
; i
++)
855 /* Do not exceed the limits on lower[] and upper[]. gfortran
856 cleans up elsewhere. */
858 if (j
>= GFC_MAX_DIMENSIONS
)
863 to
->lower
[j
] = gfc_copy_expr (from
->lower
[i
]);
864 to
->upper
[j
] = gfc_copy_expr (from
->upper
[i
]);
868 to
->lower
[j
] = from
->lower
[i
];
869 to
->upper
[j
] = from
->upper
[i
];
874 if (to
->rank
+ to
->corank
> GFC_MAX_DIMENSIONS
)
876 gfc_error ("Sum of array rank %d and corank %d at %C exceeds maximum "
877 "allowed dimensions of %d",
878 to
->rank
, to
->corank
, GFC_MAX_DIMENSIONS
);
879 to
->corank
= GFC_MAX_DIMENSIONS
- to
->rank
;
886 /* Match an intent specification. Since this can only happen after an
887 INTENT word, a legal intent-spec must follow. */
890 match_intent_spec (void)
893 if (gfc_match (" ( in out )") == MATCH_YES
)
895 if (gfc_match (" ( in )") == MATCH_YES
)
897 if (gfc_match (" ( out )") == MATCH_YES
)
900 gfc_error ("Bad INTENT specification at %C");
901 return INTENT_UNKNOWN
;
905 /* Matches a character length specification, which is either a
906 specification expression, '*', or ':'. */
909 char_len_param_value (gfc_expr
**expr
, bool *deferred
)
916 if (gfc_match_char ('*') == MATCH_YES
)
919 if (gfc_match_char (':') == MATCH_YES
)
921 if (!gfc_notify_std (GFC_STD_F2003
, "deferred type parameter at %C"))
929 m
= gfc_match_expr (expr
);
931 if (m
== MATCH_NO
|| m
== MATCH_ERROR
)
934 if (!gfc_expr_check_typed (*expr
, gfc_current_ns
, false))
937 if ((*expr
)->expr_type
== EXPR_FUNCTION
)
939 if ((*expr
)->ts
.type
== BT_INTEGER
940 || ((*expr
)->ts
.type
== BT_UNKNOWN
941 && strcmp((*expr
)->symtree
->name
, "null") != 0))
946 else if ((*expr
)->expr_type
== EXPR_CONSTANT
)
948 /* F2008, 4.4.3.1: The length is a type parameter; its kind is
949 processor dependent and its value is greater than or equal to zero.
950 F2008, 4.4.3.2: If the character length parameter value evaluates
951 to a negative value, the length of character entities declared
954 if ((*expr
)->ts
.type
== BT_INTEGER
)
956 if (mpz_cmp_si ((*expr
)->value
.integer
, 0) < 0)
957 mpz_set_si ((*expr
)->value
.integer
, 0);
962 else if ((*expr
)->expr_type
== EXPR_ARRAY
)
964 else if ((*expr
)->expr_type
== EXPR_VARIABLE
)
969 e
= gfc_copy_expr (*expr
);
971 /* This catches the invalid code "[character(m(2:3)) :: 'x', 'y']",
972 which causes an ICE if gfc_reduce_init_expr() is called. */
973 if (e
->ref
&& e
->ref
->type
== REF_ARRAY
974 && e
->ref
->u
.ar
.type
== AR_UNKNOWN
975 && e
->ref
->u
.ar
.dimen_type
[0] == DIMEN_RANGE
)
978 t
= gfc_reduce_init_expr (e
);
980 if (!t
&& e
->ts
.type
== BT_UNKNOWN
981 && e
->symtree
->n
.sym
->attr
.untyped
== 1
982 && (flag_implicit_none
983 || e
->symtree
->n
.sym
->ns
->seen_implicit_none
== 1
984 || e
->symtree
->n
.sym
->ns
->parent
->seen_implicit_none
== 1))
990 if ((e
->ref
&& e
->ref
->type
== REF_ARRAY
991 && e
->ref
->u
.ar
.type
!= AR_ELEMENT
)
992 || (!e
->ref
&& e
->expr_type
== EXPR_ARRAY
))
1004 gfc_error ("Scalar INTEGER expression expected at %L", &(*expr
)->where
);
1009 /* A character length is a '*' followed by a literal integer or a
1010 char_len_param_value in parenthesis. */
1013 match_char_length (gfc_expr
**expr
, bool *deferred
, bool obsolescent_check
)
1019 m
= gfc_match_char ('*');
1023 m
= gfc_match_small_literal_int (&length
, NULL
);
1024 if (m
== MATCH_ERROR
)
1029 if (obsolescent_check
1030 && !gfc_notify_std (GFC_STD_F95_OBS
, "Old-style character length at %C"))
1032 *expr
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
, length
);
1036 if (gfc_match_char ('(') == MATCH_NO
)
1039 m
= char_len_param_value (expr
, deferred
);
1040 if (m
!= MATCH_YES
&& gfc_matching_function
)
1042 gfc_undo_symbols ();
1046 if (m
== MATCH_ERROR
)
1051 if (gfc_match_char (')') == MATCH_NO
)
1053 gfc_free_expr (*expr
);
1061 gfc_error ("Syntax error in character length specification at %C");
1066 /* Special subroutine for finding a symbol. Check if the name is found
1067 in the current name space. If not, and we're compiling a function or
1068 subroutine and the parent compilation unit is an interface, then check
1069 to see if the name we've been given is the name of the interface
1070 (located in another namespace). */
1073 find_special (const char *name
, gfc_symbol
**result
, bool allow_subroutine
)
1079 i
= gfc_get_sym_tree (name
, NULL
, &st
, allow_subroutine
);
1082 *result
= st
? st
->n
.sym
: NULL
;
1086 if (gfc_current_state () != COMP_SUBROUTINE
1087 && gfc_current_state () != COMP_FUNCTION
)
1090 s
= gfc_state_stack
->previous
;
1094 if (s
->state
!= COMP_INTERFACE
)
1097 goto end
; /* Nameless interface. */
1099 if (strcmp (name
, s
->sym
->name
) == 0)
1110 /* Special subroutine for getting a symbol node associated with a
1111 procedure name, used in SUBROUTINE and FUNCTION statements. The
1112 symbol is created in the parent using with symtree node in the
1113 child unit pointing to the symbol. If the current namespace has no
1114 parent, then the symbol is just created in the current unit. */
1117 get_proc_name (const char *name
, gfc_symbol
**result
, bool module_fcn_entry
)
1123 /* Module functions have to be left in their own namespace because
1124 they have potentially (almost certainly!) already been referenced.
1125 In this sense, they are rather like external functions. This is
1126 fixed up in resolve.c(resolve_entries), where the symbol name-
1127 space is set to point to the master function, so that the fake
1128 result mechanism can work. */
1129 if (module_fcn_entry
)
1131 /* Present if entry is declared to be a module procedure. */
1132 rc
= gfc_find_symbol (name
, gfc_current_ns
->parent
, 0, result
);
1134 if (*result
== NULL
)
1135 rc
= gfc_get_symbol (name
, NULL
, result
);
1136 else if (!gfc_get_symbol (name
, NULL
, &sym
) && sym
1137 && (*result
)->ts
.type
== BT_UNKNOWN
1138 && sym
->attr
.flavor
== FL_UNKNOWN
)
1139 /* Pick up the typespec for the entry, if declared in the function
1140 body. Note that this symbol is FL_UNKNOWN because it will
1141 only have appeared in a type declaration. The local symtree
1142 is set to point to the module symbol and a unique symtree
1143 to the local version. This latter ensures a correct clearing
1146 /* If the ENTRY proceeds its specification, we need to ensure
1147 that this does not raise a "has no IMPLICIT type" error. */
1148 if (sym
->ts
.type
== BT_UNKNOWN
)
1149 sym
->attr
.untyped
= 1;
1151 (*result
)->ts
= sym
->ts
;
1153 /* Put the symbol in the procedure namespace so that, should
1154 the ENTRY precede its specification, the specification
1156 (*result
)->ns
= gfc_current_ns
;
1158 gfc_find_sym_tree (name
, gfc_current_ns
, 0, &st
);
1159 st
->n
.sym
= *result
;
1160 st
= gfc_get_unique_symtree (gfc_current_ns
);
1166 rc
= gfc_get_symbol (name
, gfc_current_ns
->parent
, result
);
1172 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
1175 if (sym
->attr
.module_procedure
&& sym
->attr
.if_source
== IFSRC_IFBODY
)
1177 /* Create a partially populated interface symbol to carry the
1178 characteristics of the procedure and the result. */
1179 sym
->tlink
= gfc_new_symbol (name
, sym
->ns
);
1180 gfc_add_type (sym
->tlink
, &(sym
->ts
), &gfc_current_locus
);
1181 gfc_copy_attr (&sym
->tlink
->attr
, &sym
->attr
, NULL
);
1182 if (sym
->attr
.dimension
)
1183 sym
->tlink
->as
= gfc_copy_array_spec (sym
->as
);
1185 /* Ideally, at this point, a copy would be made of the formal
1186 arguments and their namespace. However, this does not appear
1187 to be necessary, albeit at the expense of not being able to
1188 use gfc_compare_interfaces directly. */
1190 if (sym
->result
&& sym
->result
!= sym
)
1192 sym
->tlink
->result
= sym
->result
;
1195 else if (sym
->result
)
1197 sym
->tlink
->result
= sym
->tlink
;
1200 else if (sym
&& !sym
->gfc_new
1201 && gfc_current_state () != COMP_INTERFACE
)
1203 /* Trap another encompassed procedure with the same name. All
1204 these conditions are necessary to avoid picking up an entry
1205 whose name clashes with that of the encompassing procedure;
1206 this is handled using gsymbols to register unique, globally
1207 accessible names. */
1208 if (sym
->attr
.flavor
!= 0
1209 && sym
->attr
.proc
!= 0
1210 && (sym
->attr
.subroutine
|| sym
->attr
.function
|| sym
->attr
.entry
)
1211 && sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
1212 gfc_error_now ("Procedure %qs at %C is already defined at %L",
1213 name
, &sym
->declared_at
);
1215 if (sym
->attr
.flavor
!= 0
1216 && sym
->attr
.entry
&& sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
1217 gfc_error_now ("Procedure %qs at %C is already defined at %L",
1218 name
, &sym
->declared_at
);
1220 if (sym
->attr
.external
&& sym
->attr
.procedure
1221 && gfc_current_state () == COMP_CONTAINS
)
1222 gfc_error_now ("Contained procedure %qs at %C clashes with "
1223 "procedure defined at %L",
1224 name
, &sym
->declared_at
);
1226 /* Trap a procedure with a name the same as interface in the
1227 encompassing scope. */
1228 if (sym
->attr
.generic
!= 0
1229 && (sym
->attr
.subroutine
|| sym
->attr
.function
)
1230 && !sym
->attr
.mod_proc
)
1231 gfc_error_now ("Name %qs at %C is already defined"
1232 " as a generic interface at %L",
1233 name
, &sym
->declared_at
);
1235 /* Trap declarations of attributes in encompassing scope. The
1236 signature for this is that ts.kind is set. Legitimate
1237 references only set ts.type. */
1238 if (sym
->ts
.kind
!= 0
1239 && !sym
->attr
.implicit_type
1240 && sym
->attr
.proc
== 0
1241 && gfc_current_ns
->parent
!= NULL
1242 && sym
->attr
.access
== 0
1243 && !module_fcn_entry
)
1244 gfc_error_now ("Procedure %qs at %C has an explicit interface "
1245 "from a previous declaration", name
);
1248 /* C1246 (R1225) MODULE shall appear only in the function-stmt or
1249 subroutine-stmt of a module subprogram or of a nonabstract interface
1250 body that is declared in the scoping unit of a module or submodule. */
1251 if (sym
->attr
.external
1252 && (sym
->attr
.subroutine
|| sym
->attr
.function
)
1253 && sym
->attr
.if_source
== IFSRC_IFBODY
1254 && !current_attr
.module_procedure
1255 && sym
->attr
.proc
== PROC_MODULE
1256 && gfc_state_stack
->state
== COMP_CONTAINS
)
1257 gfc_error_now ("Procedure %qs defined in interface body at %L "
1258 "clashes with internal procedure defined at %C",
1259 name
, &sym
->declared_at
);
1261 if (sym
&& !sym
->gfc_new
1262 && sym
->attr
.flavor
!= FL_UNKNOWN
1263 && sym
->attr
.referenced
== 0 && sym
->attr
.subroutine
== 1
1264 && gfc_state_stack
->state
== COMP_CONTAINS
1265 && gfc_state_stack
->previous
->state
== COMP_SUBROUTINE
)
1266 gfc_error_now ("Procedure %qs at %C is already defined at %L",
1267 name
, &sym
->declared_at
);
1269 if (gfc_current_ns
->parent
== NULL
|| *result
== NULL
)
1272 /* Module function entries will already have a symtree in
1273 the current namespace but will need one at module level. */
1274 if (module_fcn_entry
)
1276 /* Present if entry is declared to be a module procedure. */
1277 rc
= gfc_find_sym_tree (name
, gfc_current_ns
->parent
, 0, &st
);
1279 st
= gfc_new_symtree (&gfc_current_ns
->parent
->sym_root
, name
);
1282 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, name
);
1287 /* See if the procedure should be a module procedure. */
1289 if (((sym
->ns
->proc_name
!= NULL
1290 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
1291 && sym
->attr
.proc
!= PROC_MODULE
)
1292 || (module_fcn_entry
&& sym
->attr
.proc
!= PROC_MODULE
))
1293 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
1300 /* Verify that the given symbol representing a parameter is C
1301 interoperable, by checking to see if it was marked as such after
1302 its declaration. If the given symbol is not interoperable, a
1303 warning is reported, thus removing the need to return the status to
1304 the calling function. The standard does not require the user use
1305 one of the iso_c_binding named constants to declare an
1306 interoperable parameter, but we can't be sure if the param is C
1307 interop or not if the user doesn't. For example, integer(4) may be
1308 legal Fortran, but doesn't have meaning in C. It may interop with
1309 a number of the C types, which causes a problem because the
1310 compiler can't know which one. This code is almost certainly not
1311 portable, and the user will get what they deserve if the C type
1312 across platforms isn't always interoperable with integer(4). If
1313 the user had used something like integer(c_int) or integer(c_long),
1314 the compiler could have automatically handled the varying sizes
1315 across platforms. */
1318 gfc_verify_c_interop_param (gfc_symbol
*sym
)
1320 int is_c_interop
= 0;
1323 /* We check implicitly typed variables in symbol.c:gfc_set_default_type().
1324 Don't repeat the checks here. */
1325 if (sym
->attr
.implicit_type
)
1328 /* For subroutines or functions that are passed to a BIND(C) procedure,
1329 they're interoperable if they're BIND(C) and their params are all
1331 if (sym
->attr
.flavor
== FL_PROCEDURE
)
1333 if (sym
->attr
.is_bind_c
== 0)
1335 gfc_error_now ("Procedure %qs at %L must have the BIND(C) "
1336 "attribute to be C interoperable", sym
->name
,
1337 &(sym
->declared_at
));
1342 if (sym
->attr
.is_c_interop
== 1)
1343 /* We've already checked this procedure; don't check it again. */
1346 return verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
1351 /* See if we've stored a reference to a procedure that owns sym. */
1352 if (sym
->ns
!= NULL
&& sym
->ns
->proc_name
!= NULL
)
1354 if (sym
->ns
->proc_name
->attr
.is_bind_c
== 1)
1356 is_c_interop
= (gfc_verify_c_interop(&(sym
->ts
)) ? 1 : 0);
1358 if (is_c_interop
!= 1)
1360 /* Make personalized messages to give better feedback. */
1361 if (sym
->ts
.type
== BT_DERIVED
)
1362 gfc_error ("Variable %qs at %L is a dummy argument to the "
1363 "BIND(C) procedure %qs but is not C interoperable "
1364 "because derived type %qs is not C interoperable",
1365 sym
->name
, &(sym
->declared_at
),
1366 sym
->ns
->proc_name
->name
,
1367 sym
->ts
.u
.derived
->name
);
1368 else if (sym
->ts
.type
== BT_CLASS
)
1369 gfc_error ("Variable %qs at %L is a dummy argument to the "
1370 "BIND(C) procedure %qs but is not C interoperable "
1371 "because it is polymorphic",
1372 sym
->name
, &(sym
->declared_at
),
1373 sym
->ns
->proc_name
->name
);
1374 else if (warn_c_binding_type
)
1375 gfc_warning (OPT_Wc_binding_type
,
1376 "Variable %qs at %L is a dummy argument of the "
1377 "BIND(C) procedure %qs but may not be C "
1379 sym
->name
, &(sym
->declared_at
),
1380 sym
->ns
->proc_name
->name
);
1383 /* Character strings are only C interoperable if they have a
1385 if (sym
->ts
.type
== BT_CHARACTER
)
1387 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
1388 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
1389 || mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
1391 gfc_error ("Character argument %qs at %L "
1392 "must be length 1 because "
1393 "procedure %qs is BIND(C)",
1394 sym
->name
, &sym
->declared_at
,
1395 sym
->ns
->proc_name
->name
);
1400 /* We have to make sure that any param to a bind(c) routine does
1401 not have the allocatable, pointer, or optional attributes,
1402 according to J3/04-007, section 5.1. */
1403 if (sym
->attr
.allocatable
== 1
1404 && !gfc_notify_std (GFC_STD_F2008_TS
, "Variable %qs at %L with "
1405 "ALLOCATABLE attribute in procedure %qs "
1406 "with BIND(C)", sym
->name
,
1407 &(sym
->declared_at
),
1408 sym
->ns
->proc_name
->name
))
1411 if (sym
->attr
.pointer
== 1
1412 && !gfc_notify_std (GFC_STD_F2008_TS
, "Variable %qs at %L with "
1413 "POINTER attribute in procedure %qs "
1414 "with BIND(C)", sym
->name
,
1415 &(sym
->declared_at
),
1416 sym
->ns
->proc_name
->name
))
1419 if ((sym
->attr
.allocatable
|| sym
->attr
.pointer
) && !sym
->as
)
1421 gfc_error ("Scalar variable %qs at %L with POINTER or "
1422 "ALLOCATABLE in procedure %qs with BIND(C) is not yet"
1423 " supported", sym
->name
, &(sym
->declared_at
),
1424 sym
->ns
->proc_name
->name
);
1428 if (sym
->attr
.optional
== 1 && sym
->attr
.value
)
1430 gfc_error ("Variable %qs at %L cannot have both the OPTIONAL "
1431 "and the VALUE attribute because procedure %qs "
1432 "is BIND(C)", sym
->name
, &(sym
->declared_at
),
1433 sym
->ns
->proc_name
->name
);
1436 else if (sym
->attr
.optional
== 1
1437 && !gfc_notify_std (GFC_STD_F2008_TS
, "Variable %qs "
1438 "at %L with OPTIONAL attribute in "
1439 "procedure %qs which is BIND(C)",
1440 sym
->name
, &(sym
->declared_at
),
1441 sym
->ns
->proc_name
->name
))
1444 /* Make sure that if it has the dimension attribute, that it is
1445 either assumed size or explicit shape. Deferred shape is already
1446 covered by the pointer/allocatable attribute. */
1447 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SHAPE
1448 && !gfc_notify_std (GFC_STD_F2008_TS
, "Assumed-shape array %qs "
1449 "at %L as dummy argument to the BIND(C) "
1450 "procedure %qs at %L", sym
->name
,
1451 &(sym
->declared_at
),
1452 sym
->ns
->proc_name
->name
,
1453 &(sym
->ns
->proc_name
->declared_at
)))
1463 /* Function called by variable_decl() that adds a name to the symbol table. */
1466 build_sym (const char *name
, gfc_charlen
*cl
, bool cl_deferred
,
1467 gfc_array_spec
**as
, locus
*var_locus
)
1469 symbol_attribute attr
;
1474 /* Symbols in a submodule are host associated from the parent module or
1475 submodules. Therefore, they can be overridden by declarations in the
1476 submodule scope. Deal with this by attaching the existing symbol to
1477 a new symtree and recycling the old symtree with a new symbol... */
1478 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
1479 if (st
!= NULL
&& gfc_state_stack
->state
== COMP_SUBMODULE
1480 && st
->n
.sym
!= NULL
1481 && st
->n
.sym
->attr
.host_assoc
&& st
->n
.sym
->attr
.used_in_submodule
)
1483 gfc_symtree
*s
= gfc_get_unique_symtree (gfc_current_ns
);
1484 s
->n
.sym
= st
->n
.sym
;
1485 sym
= gfc_new_symbol (name
, gfc_current_ns
);
1490 gfc_set_sym_referenced (sym
);
1492 /* ...Otherwise generate a new symtree and new symbol. */
1493 else if (gfc_get_symbol (name
, NULL
, &sym
))
1496 /* Check if the name has already been defined as a type. The
1497 first letter of the symtree will be in upper case then. Of
1498 course, this is only necessary if the upper case letter is
1499 actually different. */
1501 upper
= TOUPPER(name
[0]);
1502 if (upper
!= name
[0])
1504 char u_name
[GFC_MAX_SYMBOL_LEN
+ 1];
1507 gcc_assert (strlen(name
) <= GFC_MAX_SYMBOL_LEN
);
1508 strcpy (u_name
, name
);
1511 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, u_name
);
1513 /* STRUCTURE types can alias symbol names */
1514 if (st
!= 0 && st
->n
.sym
->attr
.flavor
!= FL_STRUCT
)
1516 gfc_error ("Symbol %qs at %C also declared as a type at %L", name
,
1517 &st
->n
.sym
->declared_at
);
1522 /* Start updating the symbol table. Add basic type attribute if present. */
1523 if (current_ts
.type
!= BT_UNKNOWN
1524 && (sym
->attr
.implicit_type
== 0
1525 || !gfc_compare_types (&sym
->ts
, ¤t_ts
))
1526 && !gfc_add_type (sym
, ¤t_ts
, var_locus
))
1529 if (sym
->ts
.type
== BT_CHARACTER
)
1532 sym
->ts
.deferred
= cl_deferred
;
1535 /* Add dimension attribute if present. */
1536 if (!gfc_set_array_spec (sym
, *as
, var_locus
))
1540 /* Add attribute to symbol. The copy is so that we can reset the
1541 dimension attribute. */
1542 attr
= current_attr
;
1544 attr
.codimension
= 0;
1546 if (!gfc_copy_attr (&sym
->attr
, &attr
, var_locus
))
1549 /* Finish any work that may need to be done for the binding label,
1550 if it's a bind(c). The bind(c) attr is found before the symbol
1551 is made, and before the symbol name (for data decls), so the
1552 current_ts is holding the binding label, or nothing if the
1553 name= attr wasn't given. Therefore, test here if we're dealing
1554 with a bind(c) and make sure the binding label is set correctly. */
1555 if (sym
->attr
.is_bind_c
== 1)
1557 if (!sym
->binding_label
)
1559 /* Set the binding label and verify that if a NAME= was specified
1560 then only one identifier was in the entity-decl-list. */
1561 if (!set_binding_label (&sym
->binding_label
, sym
->name
,
1562 num_idents_on_line
))
1567 /* See if we know we're in a common block, and if it's a bind(c)
1568 common then we need to make sure we're an interoperable type. */
1569 if (sym
->attr
.in_common
== 1)
1571 /* Test the common block object. */
1572 if (sym
->common_block
!= NULL
&& sym
->common_block
->is_bind_c
== 1
1573 && sym
->ts
.is_c_interop
!= 1)
1575 gfc_error_now ("Variable %qs in common block %qs at %C "
1576 "must be declared with a C interoperable "
1577 "kind since common block %qs is BIND(C)",
1578 sym
->name
, sym
->common_block
->name
,
1579 sym
->common_block
->name
);
1584 sym
->attr
.implied_index
= 0;
1586 /* Use the parameter expressions for a parameterized derived type. */
1587 if ((sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
1588 && sym
->ts
.u
.derived
->attr
.pdt_type
&& type_param_spec_list
)
1589 sym
->param_list
= gfc_copy_actual_arglist (type_param_spec_list
);
1591 if (sym
->ts
.type
== BT_CLASS
)
1592 return gfc_build_class_symbol (&sym
->ts
, &sym
->attr
, &sym
->as
);
1598 /* Set character constant to the given length. The constant will be padded or
1599 truncated. If we're inside an array constructor without a typespec, we
1600 additionally check that all elements have the same length; check_len -1
1601 means no checking. */
1604 gfc_set_constant_character_len (gfc_charlen_t len
, gfc_expr
*expr
,
1605 gfc_charlen_t check_len
)
1610 if (expr
->ts
.type
!= BT_CHARACTER
)
1613 if (expr
->expr_type
!= EXPR_CONSTANT
)
1615 gfc_error_now ("CHARACTER length must be a constant at %L", &expr
->where
);
1619 slen
= expr
->value
.character
.length
;
1622 s
= gfc_get_wide_string (len
+ 1);
1623 memcpy (s
, expr
->value
.character
.string
,
1624 MIN (len
, slen
) * sizeof (gfc_char_t
));
1626 gfc_wide_memset (&s
[slen
], ' ', len
- slen
);
1628 if (warn_character_truncation
&& slen
> len
)
1629 gfc_warning_now (OPT_Wcharacter_truncation
,
1630 "CHARACTER expression at %L is being truncated "
1631 "(%ld/%ld)", &expr
->where
,
1632 (long) slen
, (long) len
);
1634 /* Apply the standard by 'hand' otherwise it gets cleared for
1636 if (check_len
!= -1 && slen
!= check_len
1637 && !(gfc_option
.allow_std
& GFC_STD_GNU
))
1638 gfc_error_now ("The CHARACTER elements of the array constructor "
1639 "at %L must have the same length (%ld/%ld)",
1640 &expr
->where
, (long) slen
,
1644 free (expr
->value
.character
.string
);
1645 expr
->value
.character
.string
= s
;
1646 expr
->value
.character
.length
= len
;
1651 /* Function to create and update the enumerator history
1652 using the information passed as arguments.
1653 Pointer "max_enum" is also updated, to point to
1654 enum history node containing largest initializer.
1656 SYM points to the symbol node of enumerator.
1657 INIT points to its enumerator value. */
1660 create_enum_history (gfc_symbol
*sym
, gfc_expr
*init
)
1662 enumerator_history
*new_enum_history
;
1663 gcc_assert (sym
!= NULL
&& init
!= NULL
);
1665 new_enum_history
= XCNEW (enumerator_history
);
1667 new_enum_history
->sym
= sym
;
1668 new_enum_history
->initializer
= init
;
1669 new_enum_history
->next
= NULL
;
1671 if (enum_history
== NULL
)
1673 enum_history
= new_enum_history
;
1674 max_enum
= enum_history
;
1678 new_enum_history
->next
= enum_history
;
1679 enum_history
= new_enum_history
;
1681 if (mpz_cmp (max_enum
->initializer
->value
.integer
,
1682 new_enum_history
->initializer
->value
.integer
) < 0)
1683 max_enum
= new_enum_history
;
1688 /* Function to free enum kind history. */
1691 gfc_free_enum_history (void)
1693 enumerator_history
*current
= enum_history
;
1694 enumerator_history
*next
;
1696 while (current
!= NULL
)
1698 next
= current
->next
;
1703 enum_history
= NULL
;
1707 /* Function called by variable_decl() that adds an initialization
1708 expression to a symbol. */
1711 add_init_expr_to_sym (const char *name
, gfc_expr
**initp
, locus
*var_locus
)
1713 symbol_attribute attr
;
1718 if (find_special (name
, &sym
, false))
1723 /* If this symbol is confirming an implicit parameter type,
1724 then an initialization expression is not allowed. */
1725 if (attr
.flavor
== FL_PARAMETER
1726 && sym
->value
!= NULL
1729 gfc_error ("Initializer not allowed for PARAMETER %qs at %C",
1736 /* An initializer is required for PARAMETER declarations. */
1737 if (attr
.flavor
== FL_PARAMETER
)
1739 gfc_error ("PARAMETER at %L is missing an initializer", var_locus
);
1745 /* If a variable appears in a DATA block, it cannot have an
1749 gfc_error ("Variable %qs at %C with an initializer already "
1750 "appears in a DATA statement", sym
->name
);
1754 /* Check if the assignment can happen. This has to be put off
1755 until later for derived type variables and procedure pointers. */
1756 if (!gfc_bt_struct (sym
->ts
.type
) && !gfc_bt_struct (init
->ts
.type
)
1757 && sym
->ts
.type
!= BT_CLASS
&& init
->ts
.type
!= BT_CLASS
1758 && !sym
->attr
.proc_pointer
1759 && !gfc_check_assign_symbol (sym
, NULL
, init
))
1762 if (sym
->ts
.type
== BT_CHARACTER
&& sym
->ts
.u
.cl
1763 && init
->ts
.type
== BT_CHARACTER
)
1765 /* Update symbol character length according initializer. */
1766 if (!gfc_check_assign_symbol (sym
, NULL
, init
))
1769 if (sym
->ts
.u
.cl
->length
== NULL
)
1772 /* If there are multiple CHARACTER variables declared on the
1773 same line, we don't want them to share the same length. */
1774 sym
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1776 if (sym
->attr
.flavor
== FL_PARAMETER
)
1778 if (init
->expr_type
== EXPR_CONSTANT
)
1780 clen
= init
->value
.character
.length
;
1781 sym
->ts
.u
.cl
->length
1782 = gfc_get_int_expr (gfc_charlen_int_kind
,
1785 else if (init
->expr_type
== EXPR_ARRAY
)
1787 if (init
->ts
.u
.cl
&& init
->ts
.u
.cl
->length
)
1789 const gfc_expr
*length
= init
->ts
.u
.cl
->length
;
1790 if (length
->expr_type
!= EXPR_CONSTANT
)
1792 gfc_error ("Cannot initialize parameter array "
1794 "with variable length elements",
1798 clen
= mpz_get_si (length
->value
.integer
);
1800 else if (init
->value
.constructor
)
1803 c
= gfc_constructor_first (init
->value
.constructor
);
1804 clen
= c
->expr
->value
.character
.length
;
1808 sym
->ts
.u
.cl
->length
1809 = gfc_get_int_expr (gfc_charlen_int_kind
,
1812 else if (init
->ts
.u
.cl
&& init
->ts
.u
.cl
->length
)
1813 sym
->ts
.u
.cl
->length
=
1814 gfc_copy_expr (sym
->value
->ts
.u
.cl
->length
);
1817 /* Update initializer character length according symbol. */
1818 else if (sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1820 if (!gfc_specification_expr (sym
->ts
.u
.cl
->length
))
1823 int k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
,
1825 /* resolve_charlen will complain later on if the length
1826 is too large. Just skeep the initialization in that case. */
1827 if (mpz_cmp (sym
->ts
.u
.cl
->length
->value
.integer
,
1828 gfc_integer_kinds
[k
].huge
) <= 0)
1831 = gfc_mpz_get_hwi (sym
->ts
.u
.cl
->length
->value
.integer
);
1833 if (init
->expr_type
== EXPR_CONSTANT
)
1834 gfc_set_constant_character_len (len
, init
, -1);
1835 else if (init
->expr_type
== EXPR_ARRAY
)
1839 /* Build a new charlen to prevent simplification from
1840 deleting the length before it is resolved. */
1841 init
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1842 init
->ts
.u
.cl
->length
1843 = gfc_copy_expr (sym
->ts
.u
.cl
->length
);
1845 for (c
= gfc_constructor_first (init
->value
.constructor
);
1846 c
; c
= gfc_constructor_next (c
))
1847 gfc_set_constant_character_len (len
, c
->expr
, -1);
1853 /* If sym is implied-shape, set its upper bounds from init. */
1854 if (sym
->attr
.flavor
== FL_PARAMETER
&& sym
->attr
.dimension
1855 && sym
->as
->type
== AS_IMPLIED_SHAPE
)
1859 if (init
->rank
== 0)
1861 gfc_error ("Can't initialize implied-shape array at %L"
1862 " with scalar", &sym
->declared_at
);
1866 /* Shape should be present, we get an initialization expression. */
1867 gcc_assert (init
->shape
);
1869 for (dim
= 0; dim
< sym
->as
->rank
; ++dim
)
1872 gfc_expr
*e
, *lower
;
1874 lower
= sym
->as
->lower
[dim
];
1876 /* If the lower bound is an array element from another
1877 parameterized array, then it is marked with EXPR_VARIABLE and
1878 is an initialization expression. Try to reduce it. */
1879 if (lower
->expr_type
== EXPR_VARIABLE
)
1880 gfc_reduce_init_expr (lower
);
1882 if (lower
->expr_type
== EXPR_CONSTANT
)
1884 /* All dimensions must be without upper bound. */
1885 gcc_assert (!sym
->as
->upper
[dim
]);
1888 e
= gfc_get_constant_expr (BT_INTEGER
, k
, &sym
->declared_at
);
1889 mpz_add (e
->value
.integer
, lower
->value
.integer
,
1891 mpz_sub_ui (e
->value
.integer
, e
->value
.integer
, 1);
1892 sym
->as
->upper
[dim
] = e
;
1896 gfc_error ("Non-constant lower bound in implied-shape"
1897 " declaration at %L", &lower
->where
);
1902 sym
->as
->type
= AS_EXPLICIT
;
1905 /* Need to check if the expression we initialized this
1906 to was one of the iso_c_binding named constants. If so,
1907 and we're a parameter (constant), let it be iso_c.
1909 integer(c_int), parameter :: my_int = c_int
1910 integer(my_int) :: my_int_2
1911 If we mark my_int as iso_c (since we can see it's value
1912 is equal to one of the named constants), then my_int_2
1913 will be considered C interoperable. */
1914 if (sym
->ts
.type
!= BT_CHARACTER
&& !gfc_bt_struct (sym
->ts
.type
))
1916 sym
->ts
.is_iso_c
|= init
->ts
.is_iso_c
;
1917 sym
->ts
.is_c_interop
|= init
->ts
.is_c_interop
;
1918 /* attr bits needed for module files. */
1919 sym
->attr
.is_iso_c
|= init
->ts
.is_iso_c
;
1920 sym
->attr
.is_c_interop
|= init
->ts
.is_c_interop
;
1921 if (init
->ts
.is_iso_c
)
1922 sym
->ts
.f90_type
= init
->ts
.f90_type
;
1925 /* Add initializer. Make sure we keep the ranks sane. */
1926 if (sym
->attr
.dimension
&& init
->rank
== 0)
1931 if (sym
->attr
.flavor
== FL_PARAMETER
1932 && init
->expr_type
== EXPR_CONSTANT
1933 && spec_size (sym
->as
, &size
)
1934 && mpz_cmp_si (size
, 0) > 0)
1936 array
= gfc_get_array_expr (init
->ts
.type
, init
->ts
.kind
,
1938 for (n
= 0; n
< (int)mpz_get_si (size
); n
++)
1939 gfc_constructor_append_expr (&array
->value
.constructor
,
1942 : gfc_copy_expr (init
),
1945 array
->shape
= gfc_get_shape (sym
->as
->rank
);
1946 for (n
= 0; n
< sym
->as
->rank
; n
++)
1947 spec_dimen_size (sym
->as
, n
, &array
->shape
[n
]);
1952 init
->rank
= sym
->as
->rank
;
1956 if (sym
->attr
.save
== SAVE_NONE
)
1957 sym
->attr
.save
= SAVE_IMPLICIT
;
1965 /* Function called by variable_decl() that adds a name to a structure
1969 build_struct (const char *name
, gfc_charlen
*cl
, gfc_expr
**init
,
1970 gfc_array_spec
**as
)
1975 /* F03:C438/C439. If the current symbol is of the same derived type that we're
1976 constructing, it must have the pointer attribute. */
1977 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
1978 && current_ts
.u
.derived
== gfc_current_block ()
1979 && current_attr
.pointer
== 0)
1981 if (current_attr
.allocatable
1982 && !gfc_notify_std(GFC_STD_F2008
, "Component at %C "
1983 "must have the POINTER attribute"))
1987 else if (current_attr
.allocatable
== 0)
1989 gfc_error ("Component at %C must have the POINTER attribute");
1995 if (current_ts
.type
== BT_CLASS
1996 && !(current_attr
.pointer
|| current_attr
.allocatable
))
1998 gfc_error ("Component %qs with CLASS at %C must be allocatable "
1999 "or pointer", name
);
2003 if (gfc_current_block ()->attr
.pointer
&& (*as
)->rank
!= 0)
2005 if ((*as
)->type
!= AS_DEFERRED
&& (*as
)->type
!= AS_EXPLICIT
)
2007 gfc_error ("Array component of structure at %C must have explicit "
2008 "or deferred shape");
2013 /* If we are in a nested union/map definition, gfc_add_component will not
2014 properly find repeated components because:
2015 (i) gfc_add_component does a flat search, where components of unions
2016 and maps are implicity chained so nested components may conflict.
2017 (ii) Unions and maps are not linked as components of their parent
2018 structures until after they are parsed.
2019 For (i) we use gfc_find_component which searches recursively, and for (ii)
2020 we search each block directly from the parse stack until we find the top
2023 s
= gfc_state_stack
;
2024 if (s
->state
== COMP_UNION
|| s
->state
== COMP_MAP
)
2026 while (s
->state
== COMP_UNION
|| gfc_comp_struct (s
->state
))
2028 c
= gfc_find_component (s
->sym
, name
, true, true, NULL
);
2031 gfc_error_now ("Component %qs at %C already declared at %L",
2035 /* Break after we've searched the entire chain. */
2036 if (s
->state
== COMP_DERIVED
|| s
->state
== COMP_STRUCTURE
)
2042 if (!gfc_add_component (gfc_current_block(), name
, &c
))
2046 if (c
->ts
.type
== BT_CHARACTER
)
2049 if (c
->ts
.type
!= BT_CLASS
&& c
->ts
.type
!= BT_DERIVED
2050 && (c
->ts
.kind
== 0 || c
->ts
.type
== BT_CHARACTER
)
2051 && saved_kind_expr
!= NULL
)
2052 c
->kind_expr
= gfc_copy_expr (saved_kind_expr
);
2054 c
->attr
= current_attr
;
2056 c
->initializer
= *init
;
2063 c
->attr
.codimension
= 1;
2065 c
->attr
.dimension
= 1;
2069 gfc_apply_init (&c
->ts
, &c
->attr
, c
->initializer
);
2071 /* Check array components. */
2072 if (!c
->attr
.dimension
)
2075 if (c
->attr
.pointer
)
2077 if (c
->as
->type
!= AS_DEFERRED
)
2079 gfc_error ("Pointer array component of structure at %C must have a "
2084 else if (c
->attr
.allocatable
)
2086 if (c
->as
->type
!= AS_DEFERRED
)
2088 gfc_error ("Allocatable component of structure at %C must have a "
2095 if (c
->as
->type
!= AS_EXPLICIT
)
2097 gfc_error ("Array component of structure at %C must have an "
2104 if (c
->ts
.type
== BT_CLASS
)
2105 return gfc_build_class_symbol (&c
->ts
, &c
->attr
, &c
->as
);
2107 if (c
->attr
.pdt_kind
|| c
->attr
.pdt_len
)
2110 gfc_find_symbol (c
->name
, gfc_current_block ()->f2k_derived
,
2114 gfc_error ("Type parameter %qs at %C has no corresponding entry "
2115 "in the type parameter name list at %L",
2116 c
->name
, &gfc_current_block ()->declared_at
);
2120 sym
->attr
.pdt_kind
= c
->attr
.pdt_kind
;
2121 sym
->attr
.pdt_len
= c
->attr
.pdt_len
;
2123 sym
->value
= gfc_copy_expr (c
->initializer
);
2124 sym
->attr
.flavor
= FL_VARIABLE
;
2127 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
2128 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_template
2129 && decl_type_param_list
)
2130 c
->param_list
= gfc_copy_actual_arglist (decl_type_param_list
);
2136 /* Match a 'NULL()', and possibly take care of some side effects. */
2139 gfc_match_null (gfc_expr
**result
)
2142 match m
, m2
= MATCH_NO
;
2144 if ((m
= gfc_match (" null ( )")) == MATCH_ERROR
)
2150 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2152 if ((m2
= gfc_match (" null (")) != MATCH_YES
)
2155 old_loc
= gfc_current_locus
;
2156 if ((m2
= gfc_match (" %n ) ", name
)) == MATCH_ERROR
)
2159 && ((m2
= gfc_match (" mold = %n )", name
)) == MATCH_ERROR
))
2163 gfc_current_locus
= old_loc
;
2168 /* The NULL symbol now has to be/become an intrinsic function. */
2169 if (gfc_get_symbol ("null", NULL
, &sym
))
2171 gfc_error ("NULL() initialization at %C is ambiguous");
2175 gfc_intrinsic_symbol (sym
);
2177 if (sym
->attr
.proc
!= PROC_INTRINSIC
2178 && !(sym
->attr
.use_assoc
&& sym
->attr
.intrinsic
)
2179 && (!gfc_add_procedure(&sym
->attr
, PROC_INTRINSIC
, sym
->name
, NULL
)
2180 || !gfc_add_function (&sym
->attr
, sym
->name
, NULL
)))
2183 *result
= gfc_get_null_expr (&gfc_current_locus
);
2185 /* Invalid per F2008, C512. */
2186 if (m2
== MATCH_YES
)
2188 gfc_error ("NULL() initialization at %C may not have MOLD");
2196 /* Match the initialization expr for a data pointer or procedure pointer. */
2199 match_pointer_init (gfc_expr
**init
, int procptr
)
2203 if (gfc_pure (NULL
) && !gfc_comp_struct (gfc_state_stack
->state
))
2205 gfc_error ("Initialization of pointer at %C is not allowed in "
2206 "a PURE procedure");
2209 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
2211 /* Match NULL() initialization. */
2212 m
= gfc_match_null (init
);
2216 /* Match non-NULL initialization. */
2217 gfc_matching_ptr_assignment
= !procptr
;
2218 gfc_matching_procptr_assignment
= procptr
;
2219 m
= gfc_match_rvalue (init
);
2220 gfc_matching_ptr_assignment
= 0;
2221 gfc_matching_procptr_assignment
= 0;
2222 if (m
== MATCH_ERROR
)
2224 else if (m
== MATCH_NO
)
2226 gfc_error ("Error in pointer initialization at %C");
2230 if (!procptr
&& !gfc_resolve_expr (*init
))
2233 if (!gfc_notify_std (GFC_STD_F2008
, "non-NULL pointer "
2234 "initialization at %C"))
2242 check_function_name (char *name
)
2244 /* In functions that have a RESULT variable defined, the function name always
2245 refers to function calls. Therefore, the name is not allowed to appear in
2246 specification statements. When checking this, be careful about
2247 'hidden' procedure pointer results ('ppr@'). */
2249 if (gfc_current_state () == COMP_FUNCTION
)
2251 gfc_symbol
*block
= gfc_current_block ();
2252 if (block
&& block
->result
&& block
->result
!= block
2253 && strcmp (block
->result
->name
, "ppr@") != 0
2254 && strcmp (block
->name
, name
) == 0)
2256 gfc_error ("Function name %qs not allowed at %C", name
);
2265 /* Match a variable name with an optional initializer. When this
2266 subroutine is called, a variable is expected to be parsed next.
2267 Depending on what is happening at the moment, updates either the
2268 symbol table or the current interface. */
2271 variable_decl (int elem
)
2273 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2274 static unsigned int fill_id
= 0;
2275 gfc_expr
*initializer
, *char_len
;
2277 gfc_array_spec
*cp_as
; /* Extra copy for Cray Pointees. */
2289 /* When we get here, we've just matched a list of attributes and
2290 maybe a type and a double colon. The next thing we expect to see
2291 is the name of the symbol. */
2293 /* If we are parsing a structure with legacy support, we allow the symbol
2294 name to be '%FILL' which gives it an anonymous (inaccessible) name. */
2296 gfc_gobble_whitespace ();
2297 if (gfc_peek_ascii_char () == '%')
2299 gfc_next_ascii_char ();
2300 m
= gfc_match ("fill");
2305 m
= gfc_match_name (name
);
2313 if (gfc_current_state () != COMP_STRUCTURE
)
2315 if (flag_dec_structure
)
2316 gfc_error ("%qs not allowed outside STRUCTURE at %C", "%FILL");
2318 gfc_error ("%qs at %C is a DEC extension, enable with "
2319 "%<-fdec-structure%>", "%FILL");
2325 gfc_error ("%qs entity cannot have attributes at %C", "%FILL");
2329 /* %FILL components are given invalid fortran names. */
2330 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "%%FILL%u", fill_id
++);
2334 var_locus
= gfc_current_locus
;
2336 /* Now we could see the optional array spec. or character length. */
2337 m
= gfc_match_array_spec (&as
, true, true);
2338 if (m
== MATCH_ERROR
)
2342 as
= gfc_copy_array_spec (current_as
);
2344 && !merge_array_spec (current_as
, as
, true))
2350 if (flag_cray_pointer
)
2351 cp_as
= gfc_copy_array_spec (as
);
2353 /* At this point, we know for sure if the symbol is PARAMETER and can thus
2354 determine (and check) whether it can be implied-shape. If it
2355 was parsed as assumed-size, change it because PARAMETERs can not
2358 An explicit-shape-array cannot appear under several conditions.
2359 That check is done here as well. */
2362 if (as
->type
== AS_IMPLIED_SHAPE
&& current_attr
.flavor
!= FL_PARAMETER
)
2365 gfc_error ("Non-PARAMETER symbol %qs at %L can't be implied-shape",
2370 if (as
->type
== AS_ASSUMED_SIZE
&& as
->rank
== 1
2371 && current_attr
.flavor
== FL_PARAMETER
)
2372 as
->type
= AS_IMPLIED_SHAPE
;
2374 if (as
->type
== AS_IMPLIED_SHAPE
2375 && !gfc_notify_std (GFC_STD_F2008
, "Implied-shape array at %L",
2382 /* F2018:C830 (R816) An explicit-shape-spec whose bounds are not
2383 constant expressions shall appear only in a subprogram, derived
2384 type definition, BLOCK construct, or interface body. */
2385 if (as
->type
== AS_EXPLICIT
2386 && gfc_current_state () != COMP_BLOCK
2387 && gfc_current_state () != COMP_DERIVED
2388 && gfc_current_state () != COMP_FUNCTION
2389 && gfc_current_state () != COMP_INTERFACE
2390 && gfc_current_state () != COMP_SUBROUTINE
)
2393 bool not_constant
= false;
2395 for (int i
= 0; i
< as
->rank
; i
++)
2397 e
= gfc_copy_expr (as
->lower
[i
]);
2398 gfc_resolve_expr (e
);
2399 gfc_simplify_expr (e
, 0);
2400 if (e
&& (e
->expr_type
!= EXPR_CONSTANT
))
2402 not_constant
= true;
2407 e
= gfc_copy_expr (as
->upper
[i
]);
2408 gfc_resolve_expr (e
);
2409 gfc_simplify_expr (e
, 0);
2410 if (e
&& (e
->expr_type
!= EXPR_CONSTANT
))
2412 not_constant
= true;
2420 gfc_error ("Explicit shaped array with nonconstant bounds at %C");
2429 cl_deferred
= false;
2431 if (current_ts
.type
== BT_CHARACTER
)
2433 switch (match_char_length (&char_len
, &cl_deferred
, false))
2436 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2438 cl
->length
= char_len
;
2441 /* Non-constant lengths need to be copied after the first
2442 element. Also copy assumed lengths. */
2445 && (current_ts
.u
.cl
->length
== NULL
2446 || current_ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
2448 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2449 cl
->length
= gfc_copy_expr (current_ts
.u
.cl
->length
);
2452 cl
= current_ts
.u
.cl
;
2454 cl_deferred
= current_ts
.deferred
;
2463 /* The dummy arguments and result of the abreviated form of MODULE
2464 PROCEDUREs, used in SUBMODULES should not be redefined. */
2465 if (gfc_current_ns
->proc_name
2466 && gfc_current_ns
->proc_name
->abr_modproc_decl
)
2468 gfc_find_symbol (name
, gfc_current_ns
, 1, &sym
);
2469 if (sym
!= NULL
&& (sym
->attr
.dummy
|| sym
->attr
.result
))
2472 gfc_error ("%qs at %C is a redefinition of the declaration "
2473 "in the corresponding interface for MODULE "
2474 "PROCEDURE %qs", sym
->name
,
2475 gfc_current_ns
->proc_name
->name
);
2480 /* %FILL components may not have initializers. */
2481 if (strncmp (name
, "%FILL", 5) == 0 && gfc_match_eos () != MATCH_YES
)
2483 gfc_error ("%qs entity cannot have an initializer at %C", "%FILL");
2488 /* If this symbol has already shown up in a Cray Pointer declaration,
2489 and this is not a component declaration,
2490 then we want to set the type & bail out. */
2491 if (flag_cray_pointer
&& !gfc_comp_struct (gfc_current_state ()))
2493 gfc_find_symbol (name
, gfc_current_ns
, 1, &sym
);
2494 if (sym
!= NULL
&& sym
->attr
.cray_pointee
)
2496 sym
->ts
.type
= current_ts
.type
;
2497 sym
->ts
.kind
= current_ts
.kind
;
2499 sym
->ts
.u
.derived
= current_ts
.u
.derived
;
2500 sym
->ts
.is_c_interop
= current_ts
.is_c_interop
;
2501 sym
->ts
.is_iso_c
= current_ts
.is_iso_c
;
2504 /* Check to see if we have an array specification. */
2507 if (sym
->as
!= NULL
)
2509 gfc_error ("Duplicate array spec for Cray pointee at %C");
2510 gfc_free_array_spec (cp_as
);
2516 if (!gfc_set_array_spec (sym
, cp_as
, &var_locus
))
2517 gfc_internal_error ("Couldn't set pointee array spec.");
2519 /* Fix the array spec. */
2520 m
= gfc_mod_pointee_as (sym
->as
);
2521 if (m
== MATCH_ERROR
)
2529 gfc_free_array_spec (cp_as
);
2533 /* Procedure pointer as function result. */
2534 if (gfc_current_state () == COMP_FUNCTION
2535 && strcmp ("ppr@", gfc_current_block ()->name
) == 0
2536 && strcmp (name
, gfc_current_block ()->ns
->proc_name
->name
) == 0)
2537 strcpy (name
, "ppr@");
2539 if (gfc_current_state () == COMP_FUNCTION
2540 && strcmp (name
, gfc_current_block ()->name
) == 0
2541 && gfc_current_block ()->result
2542 && strcmp ("ppr@", gfc_current_block ()->result
->name
) == 0)
2543 strcpy (name
, "ppr@");
2545 /* OK, we've successfully matched the declaration. Now put the
2546 symbol in the current namespace, because it might be used in the
2547 optional initialization expression for this symbol, e.g. this is
2550 integer, parameter :: i = huge(i)
2552 This is only true for parameters or variables of a basic type.
2553 For components of derived types, it is not true, so we don't
2554 create a symbol for those yet. If we fail to create the symbol,
2556 if (!gfc_comp_struct (gfc_current_state ())
2557 && !build_sym (name
, cl
, cl_deferred
, &as
, &var_locus
))
2563 if (!check_function_name (name
))
2569 /* We allow old-style initializations of the form
2570 integer i /2/, j(4) /3*3, 1/
2571 (if no colon has been seen). These are different from data
2572 statements in that initializers are only allowed to apply to the
2573 variable immediately preceding, i.e.
2575 is not allowed. Therefore we have to do some work manually, that
2576 could otherwise be left to the matchers for DATA statements. */
2578 if (!colon_seen
&& gfc_match (" /") == MATCH_YES
)
2580 if (!gfc_notify_std (GFC_STD_GNU
, "Old-style "
2581 "initialization at %C"))
2584 /* Allow old style initializations for components of STRUCTUREs and MAPs
2585 but not components of derived types. */
2586 else if (gfc_current_state () == COMP_DERIVED
)
2588 gfc_error ("Invalid old style initialization for derived type "
2594 /* For structure components, read the initializer as a special
2595 expression and let the rest of this function apply the initializer
2597 else if (gfc_comp_struct (gfc_current_state ()))
2599 m
= match_clist_expr (&initializer
, ¤t_ts
, as
);
2601 gfc_error ("Syntax error in old style initialization of %s at %C",
2607 /* Otherwise we treat the old style initialization just like a
2608 DATA declaration for the current variable. */
2610 return match_old_style_init (name
);
2613 /* The double colon must be present in order to have initializers.
2614 Otherwise the statement is ambiguous with an assignment statement. */
2617 if (gfc_match (" =>") == MATCH_YES
)
2619 if (!current_attr
.pointer
)
2621 gfc_error ("Initialization at %C isn't for a pointer variable");
2626 m
= match_pointer_init (&initializer
, 0);
2630 else if (gfc_match_char ('=') == MATCH_YES
)
2632 if (current_attr
.pointer
)
2634 gfc_error ("Pointer initialization at %C requires %<=>%>, "
2640 m
= gfc_match_init_expr (&initializer
);
2643 gfc_error ("Expected an initialization expression at %C");
2647 if (current_attr
.flavor
!= FL_PARAMETER
&& gfc_pure (NULL
)
2648 && !gfc_comp_struct (gfc_state_stack
->state
))
2650 gfc_error ("Initialization of variable at %C is not allowed in "
2651 "a PURE procedure");
2655 if (current_attr
.flavor
!= FL_PARAMETER
2656 && !gfc_comp_struct (gfc_state_stack
->state
))
2657 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
2664 if (initializer
!= NULL
&& current_attr
.allocatable
2665 && gfc_comp_struct (gfc_current_state ()))
2667 gfc_error ("Initialization of allocatable component at %C is not "
2673 if (gfc_current_state () == COMP_DERIVED
2674 && gfc_current_block ()->attr
.pdt_template
)
2677 gfc_find_symbol (name
, gfc_current_block ()->f2k_derived
,
2679 if (!param
&& (current_attr
.pdt_kind
|| current_attr
.pdt_len
))
2681 gfc_error ("The component with KIND or LEN attribute at %C does not "
2682 "not appear in the type parameter list at %L",
2683 &gfc_current_block ()->declared_at
);
2687 else if (param
&& !(current_attr
.pdt_kind
|| current_attr
.pdt_len
))
2689 gfc_error ("The component at %C that appears in the type parameter "
2690 "list at %L has neither the KIND nor LEN attribute",
2691 &gfc_current_block ()->declared_at
);
2695 else if (as
&& (current_attr
.pdt_kind
|| current_attr
.pdt_len
))
2697 gfc_error ("The component at %C which is a type parameter must be "
2702 else if (param
&& initializer
)
2703 param
->value
= gfc_copy_expr (initializer
);
2706 /* Add the initializer. Note that it is fine if initializer is
2707 NULL here, because we sometimes also need to check if a
2708 declaration *must* have an initialization expression. */
2709 if (!gfc_comp_struct (gfc_current_state ()))
2710 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
2713 if (current_ts
.type
== BT_DERIVED
2714 && !current_attr
.pointer
&& !initializer
)
2715 initializer
= gfc_default_initializer (¤t_ts
);
2716 t
= build_struct (name
, cl
, &initializer
, &as
);
2718 /* If we match a nested structure definition we expect to see the
2719 * body even if the variable declarations blow up, so we need to keep
2720 * the structure declaration around. */
2721 if (gfc_new_block
&& gfc_new_block
->attr
.flavor
== FL_STRUCT
)
2722 gfc_commit_symbol (gfc_new_block
);
2725 m
= (t
) ? MATCH_YES
: MATCH_ERROR
;
2728 /* Free stuff up and return. */
2729 gfc_free_expr (initializer
);
2730 gfc_free_array_spec (as
);
2736 /* Match an extended-f77 "TYPESPEC*bytesize"-style kind specification.
2737 This assumes that the byte size is equal to the kind number for
2738 non-COMPLEX types, and equal to twice the kind number for COMPLEX. */
2741 gfc_match_old_kind_spec (gfc_typespec
*ts
)
2746 if (gfc_match_char ('*') != MATCH_YES
)
2749 m
= gfc_match_small_literal_int (&ts
->kind
, NULL
);
2753 original_kind
= ts
->kind
;
2755 /* Massage the kind numbers for complex types. */
2756 if (ts
->type
== BT_COMPLEX
)
2760 gfc_error ("Old-style type declaration %s*%d not supported at %C",
2761 gfc_basic_typename (ts
->type
), original_kind
);
2768 if (ts
->type
== BT_INTEGER
&& ts
->kind
== 4 && flag_integer4_kind
== 8)
2771 if (ts
->type
== BT_REAL
|| ts
->type
== BT_COMPLEX
)
2775 if (flag_real4_kind
== 8)
2777 if (flag_real4_kind
== 10)
2779 if (flag_real4_kind
== 16)
2785 if (flag_real8_kind
== 4)
2787 if (flag_real8_kind
== 10)
2789 if (flag_real8_kind
== 16)
2794 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
2796 gfc_error ("Old-style type declaration %s*%d not supported at %C",
2797 gfc_basic_typename (ts
->type
), original_kind
);
2801 if (!gfc_notify_std (GFC_STD_GNU
,
2802 "Nonstandard type declaration %s*%d at %C",
2803 gfc_basic_typename(ts
->type
), original_kind
))
2810 /* Match a kind specification. Since kinds are generally optional, we
2811 usually return MATCH_NO if something goes wrong. If a "kind="
2812 string is found, then we know we have an error. */
2815 gfc_match_kind_spec (gfc_typespec
*ts
, bool kind_expr_only
)
2825 saved_kind_expr
= NULL
;
2827 where
= loc
= gfc_current_locus
;
2832 if (gfc_match_char ('(') == MATCH_NO
)
2835 /* Also gobbles optional text. */
2836 if (gfc_match (" kind = ") == MATCH_YES
)
2839 loc
= gfc_current_locus
;
2843 n
= gfc_match_init_expr (&e
);
2845 if (gfc_derived_parameter_expr (e
))
2848 saved_kind_expr
= gfc_copy_expr (e
);
2849 goto close_brackets
;
2854 if (gfc_matching_function
)
2856 /* The function kind expression might include use associated or
2857 imported parameters and try again after the specification
2859 if (gfc_match_char (')') != MATCH_YES
)
2861 gfc_error ("Missing right parenthesis at %C");
2867 gfc_undo_symbols ();
2872 /* ....or else, the match is real. */
2874 gfc_error ("Expected initialization expression at %C");
2882 gfc_error ("Expected scalar initialization expression at %C");
2887 if (gfc_extract_int (e
, &ts
->kind
, 1))
2893 /* Before throwing away the expression, let's see if we had a
2894 C interoperable kind (and store the fact). */
2895 if (e
->ts
.is_c_interop
== 1)
2897 /* Mark this as C interoperable if being declared with one
2898 of the named constants from iso_c_binding. */
2899 ts
->is_c_interop
= e
->ts
.is_iso_c
;
2900 ts
->f90_type
= e
->ts
.f90_type
;
2902 ts
->interop_kind
= e
->symtree
->n
.sym
;
2908 /* Ignore errors to this point, if we've gotten here. This means
2909 we ignore the m=MATCH_ERROR from above. */
2910 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
2912 gfc_error ("Kind %d not supported for type %s at %C", ts
->kind
,
2913 gfc_basic_typename (ts
->type
));
2914 gfc_current_locus
= where
;
2918 /* Warn if, e.g., c_int is used for a REAL variable, but not
2919 if, e.g., c_double is used for COMPLEX as the standard
2920 explicitly says that the kind type parameter for complex and real
2921 variable is the same, i.e. c_float == c_float_complex. */
2922 if (ts
->f90_type
!= BT_UNKNOWN
&& ts
->f90_type
!= ts
->type
2923 && !((ts
->f90_type
== BT_REAL
&& ts
->type
== BT_COMPLEX
)
2924 || (ts
->f90_type
== BT_COMPLEX
&& ts
->type
== BT_REAL
)))
2925 gfc_warning_now (0, "C kind type parameter is for type %s but type at %L "
2926 "is %s", gfc_basic_typename (ts
->f90_type
), &where
,
2927 gfc_basic_typename (ts
->type
));
2931 gfc_gobble_whitespace ();
2932 if ((c
= gfc_next_ascii_char ()) != ')'
2933 && (ts
->type
!= BT_CHARACTER
|| c
!= ','))
2935 if (ts
->type
== BT_CHARACTER
)
2936 gfc_error ("Missing right parenthesis or comma at %C");
2938 gfc_error ("Missing right parenthesis at %C");
2942 /* All tests passed. */
2945 if(m
== MATCH_ERROR
)
2946 gfc_current_locus
= where
;
2948 if (ts
->type
== BT_INTEGER
&& ts
->kind
== 4 && flag_integer4_kind
== 8)
2951 if (ts
->type
== BT_REAL
|| ts
->type
== BT_COMPLEX
)
2955 if (flag_real4_kind
== 8)
2957 if (flag_real4_kind
== 10)
2959 if (flag_real4_kind
== 16)
2965 if (flag_real8_kind
== 4)
2967 if (flag_real8_kind
== 10)
2969 if (flag_real8_kind
== 16)
2974 /* Return what we know from the test(s). */
2979 gfc_current_locus
= where
;
2985 match_char_kind (int * kind
, int * is_iso_c
)
2994 where
= gfc_current_locus
;
2996 n
= gfc_match_init_expr (&e
);
2998 if (n
!= MATCH_YES
&& gfc_matching_function
)
3000 /* The expression might include use-associated or imported
3001 parameters and try again after the specification
3004 gfc_undo_symbols ();
3009 gfc_error ("Expected initialization expression at %C");
3015 gfc_error ("Expected scalar initialization expression at %C");
3020 if (gfc_derived_parameter_expr (e
))
3022 saved_kind_expr
= e
;
3027 fail
= gfc_extract_int (e
, kind
, 1);
3028 *is_iso_c
= e
->ts
.is_iso_c
;
3037 /* Ignore errors to this point, if we've gotten here. This means
3038 we ignore the m=MATCH_ERROR from above. */
3039 if (gfc_validate_kind (BT_CHARACTER
, *kind
, true) < 0)
3041 gfc_error ("Kind %d is not supported for CHARACTER at %C", *kind
);
3045 /* All tests passed. */
3048 if (m
== MATCH_ERROR
)
3049 gfc_current_locus
= where
;
3051 /* Return what we know from the test(s). */
3056 gfc_current_locus
= where
;
3061 /* Match the various kind/length specifications in a CHARACTER
3062 declaration. We don't return MATCH_NO. */
3065 gfc_match_char_spec (gfc_typespec
*ts
)
3067 int kind
, seen_length
, is_iso_c
;
3079 /* Try the old-style specification first. */
3080 old_char_selector
= 0;
3082 m
= match_char_length (&len
, &deferred
, true);
3086 old_char_selector
= 1;
3091 m
= gfc_match_char ('(');
3094 m
= MATCH_YES
; /* Character without length is a single char. */
3098 /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ). */
3099 if (gfc_match (" kind =") == MATCH_YES
)
3101 m
= match_char_kind (&kind
, &is_iso_c
);
3103 if (m
== MATCH_ERROR
)
3108 if (gfc_match (" , len =") == MATCH_NO
)
3111 m
= char_len_param_value (&len
, &deferred
);
3114 if (m
== MATCH_ERROR
)
3121 /* Try to match "LEN = <len-param>" or "LEN = <len-param>, KIND = <int>". */
3122 if (gfc_match (" len =") == MATCH_YES
)
3124 m
= char_len_param_value (&len
, &deferred
);
3127 if (m
== MATCH_ERROR
)
3131 if (gfc_match_char (')') == MATCH_YES
)
3134 if (gfc_match (" , kind =") != MATCH_YES
)
3137 if (match_char_kind (&kind
, &is_iso_c
) == MATCH_ERROR
)
3143 /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ). */
3144 m
= char_len_param_value (&len
, &deferred
);
3147 if (m
== MATCH_ERROR
)
3151 m
= gfc_match_char (')');
3155 if (gfc_match_char (',') != MATCH_YES
)
3158 gfc_match (" kind ="); /* Gobble optional text. */
3160 m
= match_char_kind (&kind
, &is_iso_c
);
3161 if (m
== MATCH_ERROR
)
3167 /* Require a right-paren at this point. */
3168 m
= gfc_match_char (')');
3173 gfc_error ("Syntax error in CHARACTER declaration at %C");
3175 gfc_free_expr (len
);
3179 /* Deal with character functions after USE and IMPORT statements. */
3180 if (gfc_matching_function
)
3182 gfc_free_expr (len
);
3183 gfc_undo_symbols ();
3189 gfc_free_expr (len
);
3193 /* Do some final massaging of the length values. */
3194 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
3196 if (seen_length
== 0)
3197 cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
, 1);
3200 /* If gfortran ends up here, then the len may be reducible to a
3201 constant. Try to do that here. If it does not reduce, simply
3202 assign len to the charlen. */
3203 if (len
&& len
->expr_type
!= EXPR_CONSTANT
)
3206 e
= gfc_copy_expr (len
);
3207 gfc_reduce_init_expr (e
);
3208 if (e
->expr_type
== EXPR_CONSTANT
)
3209 gfc_replace_expr (len
, e
);
3219 ts
->kind
= kind
== 0 ? gfc_default_character_kind
: kind
;
3220 ts
->deferred
= deferred
;
3222 /* We have to know if it was a C interoperable kind so we can
3223 do accurate type checking of bind(c) procs, etc. */
3225 /* Mark this as C interoperable if being declared with one
3226 of the named constants from iso_c_binding. */
3227 ts
->is_c_interop
= is_iso_c
;
3228 else if (len
!= NULL
)
3229 /* Here, we might have parsed something such as: character(c_char)
3230 In this case, the parsing code above grabs the c_char when
3231 looking for the length (line 1690, roughly). it's the last
3232 testcase for parsing the kind params of a character variable.
3233 However, it's not actually the length. this seems like it
3235 To see if the user used a C interop kind, test the expr
3236 of the so called length, and see if it's C interoperable. */
3237 ts
->is_c_interop
= len
->ts
.is_iso_c
;
3243 /* Matches a RECORD declaration. */
3246 match_record_decl (char *name
)
3249 old_loc
= gfc_current_locus
;
3252 m
= gfc_match (" record /");
3255 if (!flag_dec_structure
)
3257 gfc_current_locus
= old_loc
;
3258 gfc_error ("RECORD at %C is an extension, enable it with "
3262 m
= gfc_match (" %n/", name
);
3267 gfc_current_locus
= old_loc
;
3268 if (flag_dec_structure
3269 && (gfc_match (" record% ") == MATCH_YES
3270 || gfc_match (" record%t") == MATCH_YES
))
3271 gfc_error ("Structure name expected after RECORD at %C");
3279 /* This function uses the gfc_actual_arglist 'type_param_spec_list' as a source
3280 of expressions to substitute into the possibly parameterized expression
3281 'e'. Using a list is inefficient but should not be too bad since the
3282 number of type parameters is not likely to be large. */
3284 insert_parameter_exprs (gfc_expr
* e
, gfc_symbol
* sym ATTRIBUTE_UNUSED
,
3287 gfc_actual_arglist
*param
;
3290 if (e
->expr_type
!= EXPR_VARIABLE
)
3293 gcc_assert (e
->symtree
);
3294 if (e
->symtree
->n
.sym
->attr
.pdt_kind
3295 || (*f
!= 0 && e
->symtree
->n
.sym
->attr
.pdt_len
))
3297 for (param
= type_param_spec_list
; param
; param
= param
->next
)
3298 if (strcmp (e
->symtree
->n
.sym
->name
, param
->name
) == 0)
3303 copy
= gfc_copy_expr (param
->expr
);
3314 gfc_insert_kind_parameter_exprs (gfc_expr
*e
)
3316 return gfc_traverse_expr (e
, NULL
, &insert_parameter_exprs
, 0);
3321 gfc_insert_parameter_exprs (gfc_expr
*e
, gfc_actual_arglist
*param_list
)
3323 gfc_actual_arglist
*old_param_spec_list
= type_param_spec_list
;
3324 type_param_spec_list
= param_list
;
3325 return gfc_traverse_expr (e
, NULL
, &insert_parameter_exprs
, 1);
3326 type_param_spec_list
= NULL
;
3327 type_param_spec_list
= old_param_spec_list
;
3330 /* Determines the instance of a parameterized derived type to be used by
3331 matching determining the values of the kind parameters and using them
3332 in the name of the instance. If the instance exists, it is used, otherwise
3333 a new derived type is created. */
3335 gfc_get_pdt_instance (gfc_actual_arglist
*param_list
, gfc_symbol
**sym
,
3336 gfc_actual_arglist
**ext_param_list
)
3338 /* The PDT template symbol. */
3339 gfc_symbol
*pdt
= *sym
;
3340 /* The symbol for the parameter in the template f2k_namespace. */
3342 /* The hoped for instance of the PDT. */
3343 gfc_symbol
*instance
;
3344 /* The list of parameters appearing in the PDT declaration. */
3345 gfc_formal_arglist
*type_param_name_list
;
3346 /* Used to store the parameter specification list during recursive calls. */
3347 gfc_actual_arglist
*old_param_spec_list
;
3348 /* Pointers to the parameter specification being used. */
3349 gfc_actual_arglist
*actual_param
;
3350 gfc_actual_arglist
*tail
= NULL
;
3351 /* Used to build up the name of the PDT instance. The prefix uses 4
3352 characters and each KIND parameter 2 more. Allow 8 of the latter. */
3353 char name
[GFC_MAX_SYMBOL_LEN
+ 21];
3355 bool name_seen
= (param_list
== NULL
);
3356 bool assumed_seen
= false;
3357 bool deferred_seen
= false;
3358 bool spec_error
= false;
3360 gfc_expr
*kind_expr
;
3361 gfc_component
*c1
, *c2
;
3364 type_param_spec_list
= NULL
;
3366 type_param_name_list
= pdt
->formal
;
3367 actual_param
= param_list
;
3368 sprintf (name
, "Pdt%s", pdt
->name
);
3370 /* Run through the parameter name list and pick up the actual
3371 parameter values or use the default values in the PDT declaration. */
3372 for (; type_param_name_list
;
3373 type_param_name_list
= type_param_name_list
->next
)
3375 if (actual_param
&& actual_param
->spec_type
!= SPEC_EXPLICIT
)
3377 if (actual_param
->spec_type
== SPEC_ASSUMED
)
3378 spec_error
= deferred_seen
;
3380 spec_error
= assumed_seen
;
3384 gfc_error ("The type parameter spec list at %C cannot contain "
3385 "both ASSUMED and DEFERRED parameters");
3390 if (actual_param
&& actual_param
->name
)
3392 param
= type_param_name_list
->sym
;
3394 if (!param
|| !param
->name
)
3397 c1
= gfc_find_component (pdt
, param
->name
, false, true, NULL
);
3398 /* An error should already have been thrown in resolve.c
3399 (resolve_fl_derived0). */
3400 if (!pdt
->attr
.use_assoc
&& !c1
)
3406 if (!actual_param
&& !(c1
&& c1
->initializer
))
3408 gfc_error ("The type parameter spec list at %C does not contain "
3409 "enough parameter expressions");
3412 else if (!actual_param
&& c1
&& c1
->initializer
)
3413 kind_expr
= gfc_copy_expr (c1
->initializer
);
3414 else if (actual_param
&& actual_param
->spec_type
== SPEC_EXPLICIT
)
3415 kind_expr
= gfc_copy_expr (actual_param
->expr
);
3419 actual_param
= param_list
;
3420 for (;actual_param
; actual_param
= actual_param
->next
)
3421 if (actual_param
->name
3422 && strcmp (actual_param
->name
, param
->name
) == 0)
3424 if (actual_param
&& actual_param
->spec_type
== SPEC_EXPLICIT
)
3425 kind_expr
= gfc_copy_expr (actual_param
->expr
);
3428 if (c1
->initializer
)
3429 kind_expr
= gfc_copy_expr (c1
->initializer
);
3430 else if (!(actual_param
&& param
->attr
.pdt_len
))
3432 gfc_error ("The derived parameter %qs at %C does not "
3433 "have a default value", param
->name
);
3439 /* Store the current parameter expressions in a temporary actual
3440 arglist 'list' so that they can be substituted in the corresponding
3441 expressions in the PDT instance. */
3442 if (type_param_spec_list
== NULL
)
3444 type_param_spec_list
= gfc_get_actual_arglist ();
3445 tail
= type_param_spec_list
;
3449 tail
->next
= gfc_get_actual_arglist ();
3452 tail
->name
= param
->name
;
3456 /* Try simplification even for LEN expressions. */
3457 gfc_resolve_expr (kind_expr
);
3458 gfc_simplify_expr (kind_expr
, 1);
3459 /* Variable expressions seem to default to BT_PROCEDURE.
3460 TODO find out why this is and fix it. */
3461 if (kind_expr
->ts
.type
!= BT_INTEGER
3462 && kind_expr
->ts
.type
!= BT_PROCEDURE
)
3464 gfc_error ("The parameter expression at %C must be of "
3465 "INTEGER type and not %s type",
3466 gfc_basic_typename (kind_expr
->ts
.type
));
3470 tail
->expr
= gfc_copy_expr (kind_expr
);
3474 tail
->spec_type
= actual_param
->spec_type
;
3476 if (!param
->attr
.pdt_kind
)
3478 if (!name_seen
&& actual_param
)
3479 actual_param
= actual_param
->next
;
3482 gfc_free_expr (kind_expr
);
3489 && (actual_param
->spec_type
== SPEC_ASSUMED
3490 || actual_param
->spec_type
== SPEC_DEFERRED
))
3492 gfc_error ("The KIND parameter %qs at %C cannot either be "
3493 "ASSUMED or DEFERRED", param
->name
);
3497 if (!kind_expr
|| !gfc_is_constant_expr (kind_expr
))
3499 gfc_error ("The value for the KIND parameter %qs at %C does not "
3500 "reduce to a constant expression", param
->name
);
3504 gfc_extract_int (kind_expr
, &kind_value
);
3505 sprintf (name
+ strlen (name
), "_%d", kind_value
);
3507 if (!name_seen
&& actual_param
)
3508 actual_param
= actual_param
->next
;
3509 gfc_free_expr (kind_expr
);
3512 if (!name_seen
&& actual_param
)
3514 gfc_error ("The type parameter spec list at %C contains too many "
3515 "parameter expressions");
3519 /* Now we search for the PDT instance 'name'. If it doesn't exist, we
3520 build it, using 'pdt' as a template. */
3521 if (gfc_get_symbol (name
, pdt
->ns
, &instance
))
3523 gfc_error ("Parameterized derived type at %C is ambiguous");
3529 if (instance
->attr
.flavor
== FL_DERIVED
3530 && instance
->attr
.pdt_type
)
3534 *ext_param_list
= type_param_spec_list
;
3536 gfc_commit_symbols ();
3540 /* Start building the new instance of the parameterized type. */
3541 gfc_copy_attr (&instance
->attr
, &pdt
->attr
, &pdt
->declared_at
);
3542 instance
->attr
.pdt_template
= 0;
3543 instance
->attr
.pdt_type
= 1;
3544 instance
->declared_at
= gfc_current_locus
;
3546 /* Add the components, replacing the parameters in all expressions
3547 with the expressions for their values in 'type_param_spec_list'. */
3548 c1
= pdt
->components
;
3549 tail
= type_param_spec_list
;
3550 for (; c1
; c1
= c1
->next
)
3552 gfc_add_component (instance
, c1
->name
, &c2
);
3555 c2
->attr
= c1
->attr
;
3557 /* The order of declaration of the type_specs might not be the
3558 same as that of the components. */
3559 if (c1
->attr
.pdt_kind
|| c1
->attr
.pdt_len
)
3561 for (tail
= type_param_spec_list
; tail
; tail
= tail
->next
)
3562 if (strcmp (c1
->name
, tail
->name
) == 0)
3566 /* Deal with type extension by recursively calling this function
3567 to obtain the instance of the extended type. */
3568 if (gfc_current_state () != COMP_DERIVED
3569 && c1
== pdt
->components
3570 && (c1
->ts
.type
== BT_DERIVED
|| c1
->ts
.type
== BT_CLASS
)
3571 && c1
->ts
.u
.derived
&& c1
->ts
.u
.derived
->attr
.pdt_template
3572 && gfc_get_derived_super_type (*sym
) == c2
->ts
.u
.derived
)
3574 gfc_formal_arglist
*f
;
3576 old_param_spec_list
= type_param_spec_list
;
3578 /* Obtain a spec list appropriate to the extended type..*/
3579 actual_param
= gfc_copy_actual_arglist (type_param_spec_list
);
3580 type_param_spec_list
= actual_param
;
3581 for (f
= c1
->ts
.u
.derived
->formal
; f
&& f
->next
; f
= f
->next
)
3582 actual_param
= actual_param
->next
;
3585 gfc_free_actual_arglist (actual_param
->next
);
3586 actual_param
->next
= NULL
;
3589 /* Now obtain the PDT instance for the extended type. */
3590 c2
->param_list
= type_param_spec_list
;
3591 m
= gfc_get_pdt_instance (type_param_spec_list
, &c2
->ts
.u
.derived
,
3593 type_param_spec_list
= old_param_spec_list
;
3595 c2
->ts
.u
.derived
->refs
++;
3596 gfc_set_sym_referenced (c2
->ts
.u
.derived
);
3598 /* Set extension level. */
3599 if (c2
->ts
.u
.derived
->attr
.extension
== 255)
3601 /* Since the extension field is 8 bit wide, we can only have
3602 up to 255 extension levels. */
3603 gfc_error ("Maximum extension level reached with type %qs at %L",
3604 c2
->ts
.u
.derived
->name
,
3605 &c2
->ts
.u
.derived
->declared_at
);
3608 instance
->attr
.extension
= c2
->ts
.u
.derived
->attr
.extension
+ 1;
3613 /* Set the component kind using the parameterized expression. */
3614 if ((c1
->ts
.kind
== 0 || c1
->ts
.type
== BT_CHARACTER
)
3615 && c1
->kind_expr
!= NULL
)
3617 gfc_expr
*e
= gfc_copy_expr (c1
->kind_expr
);
3618 gfc_insert_kind_parameter_exprs (e
);
3619 gfc_simplify_expr (e
, 1);
3620 gfc_extract_int (e
, &c2
->ts
.kind
);
3622 if (gfc_validate_kind (c2
->ts
.type
, c2
->ts
.kind
, true) < 0)
3624 gfc_error ("Kind %d not supported for type %s at %C",
3625 c2
->ts
.kind
, gfc_basic_typename (c2
->ts
.type
));
3630 /* Similarly, set the string length if parameterized. */
3631 if (c1
->ts
.type
== BT_CHARACTER
3632 && c1
->ts
.u
.cl
->length
3633 && gfc_derived_parameter_expr (c1
->ts
.u
.cl
->length
))
3636 e
= gfc_copy_expr (c1
->ts
.u
.cl
->length
);
3637 gfc_insert_kind_parameter_exprs (e
);
3638 gfc_simplify_expr (e
, 1);
3639 c2
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
3640 c2
->ts
.u
.cl
->length
= e
;
3641 c2
->attr
.pdt_string
= 1;
3644 /* Set up either the KIND/LEN initializer, if constant,
3645 or the parameterized expression. Use the template
3646 initializer if one is not already set in this instance. */
3647 if (c2
->attr
.pdt_kind
|| c2
->attr
.pdt_len
)
3649 if (tail
&& tail
->expr
&& gfc_is_constant_expr (tail
->expr
))
3650 c2
->initializer
= gfc_copy_expr (tail
->expr
);
3651 else if (tail
&& tail
->expr
)
3653 c2
->param_list
= gfc_get_actual_arglist ();
3654 c2
->param_list
->name
= tail
->name
;
3655 c2
->param_list
->expr
= gfc_copy_expr (tail
->expr
);
3656 c2
->param_list
->next
= NULL
;
3659 if (!c2
->initializer
&& c1
->initializer
)
3660 c2
->initializer
= gfc_copy_expr (c1
->initializer
);
3663 /* Copy the array spec. */
3664 c2
->as
= gfc_copy_array_spec (c1
->as
);
3665 if (c1
->ts
.type
== BT_CLASS
)
3666 CLASS_DATA (c2
)->as
= gfc_copy_array_spec (CLASS_DATA (c1
)->as
);
3668 /* Determine if an array spec is parameterized. If so, substitute
3669 in the parameter expressions for the bounds and set the pdt_array
3670 attribute. Notice that this attribute must be unconditionally set
3671 if this is an array of parameterized character length. */
3672 if (c1
->as
&& c1
->as
->type
== AS_EXPLICIT
)
3674 bool pdt_array
= false;
3676 /* Are the bounds of the array parameterized? */
3677 for (i
= 0; i
< c1
->as
->rank
; i
++)
3679 if (gfc_derived_parameter_expr (c1
->as
->lower
[i
]))
3681 if (gfc_derived_parameter_expr (c1
->as
->upper
[i
]))
3685 /* If they are, free the expressions for the bounds and
3686 replace them with the template expressions with substitute
3688 for (i
= 0; pdt_array
&& i
< c1
->as
->rank
; i
++)
3691 e
= gfc_copy_expr (c1
->as
->lower
[i
]);
3692 gfc_insert_kind_parameter_exprs (e
);
3693 gfc_simplify_expr (e
, 1);
3694 gfc_free_expr (c2
->as
->lower
[i
]);
3695 c2
->as
->lower
[i
] = e
;
3696 e
= gfc_copy_expr (c1
->as
->upper
[i
]);
3697 gfc_insert_kind_parameter_exprs (e
);
3698 gfc_simplify_expr (e
, 1);
3699 gfc_free_expr (c2
->as
->upper
[i
]);
3700 c2
->as
->upper
[i
] = e
;
3702 c2
->attr
.pdt_array
= pdt_array
? 1 : c2
->attr
.pdt_string
;
3703 if (c1
->initializer
)
3705 c2
->initializer
= gfc_copy_expr (c1
->initializer
);
3706 gfc_insert_kind_parameter_exprs (c2
->initializer
);
3707 gfc_simplify_expr (c2
->initializer
, 1);
3711 /* Recurse into this function for PDT components. */
3712 if ((c1
->ts
.type
== BT_DERIVED
|| c1
->ts
.type
== BT_CLASS
)
3713 && c1
->ts
.u
.derived
&& c1
->ts
.u
.derived
->attr
.pdt_template
)
3715 gfc_actual_arglist
*params
;
3716 /* The component in the template has a list of specification
3717 expressions derived from its declaration. */
3718 params
= gfc_copy_actual_arglist (c1
->param_list
);
3719 actual_param
= params
;
3720 /* Substitute the template parameters with the expressions
3721 from the specification list. */
3722 for (;actual_param
; actual_param
= actual_param
->next
)
3723 gfc_insert_parameter_exprs (actual_param
->expr
,
3724 type_param_spec_list
);
3726 /* Now obtain the PDT instance for the component. */
3727 old_param_spec_list
= type_param_spec_list
;
3728 m
= gfc_get_pdt_instance (params
, &c2
->ts
.u
.derived
, NULL
);
3729 type_param_spec_list
= old_param_spec_list
;
3731 c2
->param_list
= params
;
3732 if (!(c2
->attr
.pointer
|| c2
->attr
.allocatable
))
3733 c2
->initializer
= gfc_default_initializer (&c2
->ts
);
3735 if (c2
->attr
.allocatable
)
3736 instance
->attr
.alloc_comp
= 1;
3740 gfc_commit_symbol (instance
);
3742 *ext_param_list
= type_param_spec_list
;
3747 gfc_free_actual_arglist (type_param_spec_list
);
3752 /* Matches a declaration-type-spec (F03:R502). If successful, sets the ts
3753 structure to the matched specification. This is necessary for FUNCTION and
3754 IMPLICIT statements.
3756 If implicit_flag is nonzero, then we don't check for the optional
3757 kind specification. Not doing so is needed for matching an IMPLICIT
3758 statement correctly. */
3761 gfc_match_decl_type_spec (gfc_typespec
*ts
, int implicit_flag
)
3763 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3764 gfc_symbol
*sym
, *dt_sym
;
3767 bool seen_deferred_kind
, matched_type
;
3768 const char *dt_name
;
3770 decl_type_param_list
= NULL
;
3772 /* A belt and braces check that the typespec is correctly being treated
3773 as a deferred characteristic association. */
3774 seen_deferred_kind
= (gfc_current_state () == COMP_FUNCTION
)
3775 && (gfc_current_block ()->result
->ts
.kind
== -1)
3776 && (ts
->kind
== -1);
3778 if (seen_deferred_kind
)
3781 /* Clear the current binding label, in case one is given. */
3782 curr_binding_label
= NULL
;
3784 if (gfc_match (" byte") == MATCH_YES
)
3786 if (!gfc_notify_std (GFC_STD_GNU
, "BYTE type at %C"))
3789 if (gfc_validate_kind (BT_INTEGER
, 1, true) < 0)
3791 gfc_error ("BYTE type used at %C "
3792 "is not available on the target machine");
3796 ts
->type
= BT_INTEGER
;
3802 m
= gfc_match (" type (");
3803 matched_type
= (m
== MATCH_YES
);
3806 gfc_gobble_whitespace ();
3807 if (gfc_peek_ascii_char () == '*')
3809 if ((m
= gfc_match ("*)")) != MATCH_YES
)
3811 if (gfc_comp_struct (gfc_current_state ()))
3813 gfc_error ("Assumed type at %C is not allowed for components");
3816 if (!gfc_notify_std (GFC_STD_F2008_TS
, "Assumed type "
3819 ts
->type
= BT_ASSUMED
;
3823 m
= gfc_match ("%n", name
);
3824 matched_type
= (m
== MATCH_YES
);
3827 if ((matched_type
&& strcmp ("integer", name
) == 0)
3828 || (!matched_type
&& gfc_match (" integer") == MATCH_YES
))
3830 ts
->type
= BT_INTEGER
;
3831 ts
->kind
= gfc_default_integer_kind
;
3835 if ((matched_type
&& strcmp ("character", name
) == 0)
3836 || (!matched_type
&& gfc_match (" character") == MATCH_YES
))
3839 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
3840 "intrinsic-type-spec at %C"))
3843 ts
->type
= BT_CHARACTER
;
3844 if (implicit_flag
== 0)
3845 m
= gfc_match_char_spec (ts
);
3849 if (matched_type
&& m
== MATCH_YES
&& gfc_match_char (')') != MATCH_YES
)
3855 if ((matched_type
&& strcmp ("real", name
) == 0)
3856 || (!matched_type
&& gfc_match (" real") == MATCH_YES
))
3859 ts
->kind
= gfc_default_real_kind
;
3864 && (strcmp ("doubleprecision", name
) == 0
3865 || (strcmp ("double", name
) == 0
3866 && gfc_match (" precision") == MATCH_YES
)))
3867 || (!matched_type
&& gfc_match (" double precision") == MATCH_YES
))
3870 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
3871 "intrinsic-type-spec at %C"))
3873 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
3877 ts
->kind
= gfc_default_double_kind
;
3881 if ((matched_type
&& strcmp ("complex", name
) == 0)
3882 || (!matched_type
&& gfc_match (" complex") == MATCH_YES
))
3884 ts
->type
= BT_COMPLEX
;
3885 ts
->kind
= gfc_default_complex_kind
;
3890 && (strcmp ("doublecomplex", name
) == 0
3891 || (strcmp ("double", name
) == 0
3892 && gfc_match (" complex") == MATCH_YES
)))
3893 || (!matched_type
&& gfc_match (" double complex") == MATCH_YES
))
3895 if (!gfc_notify_std (GFC_STD_GNU
, "DOUBLE COMPLEX at %C"))
3899 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
3900 "intrinsic-type-spec at %C"))
3903 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
3906 ts
->type
= BT_COMPLEX
;
3907 ts
->kind
= gfc_default_double_kind
;
3911 if ((matched_type
&& strcmp ("logical", name
) == 0)
3912 || (!matched_type
&& gfc_match (" logical") == MATCH_YES
))
3914 ts
->type
= BT_LOGICAL
;
3915 ts
->kind
= gfc_default_logical_kind
;
3921 m
= gfc_match_actual_arglist (1, &decl_type_param_list
, true);
3922 if (m
== MATCH_ERROR
)
3925 m
= gfc_match_char (')');
3929 m
= match_record_decl (name
);
3931 if (matched_type
|| m
== MATCH_YES
)
3933 ts
->type
= BT_DERIVED
;
3934 /* We accept record/s/ or type(s) where s is a structure, but we
3935 * don't need all the extra derived-type stuff for structures. */
3936 if (gfc_find_symbol (gfc_dt_upper_string (name
), NULL
, 1, &sym
))
3938 gfc_error ("Type name %qs at %C is ambiguous", name
);
3942 if (sym
&& sym
->attr
.flavor
== FL_DERIVED
3943 && sym
->attr
.pdt_template
3944 && gfc_current_state () != COMP_DERIVED
)
3946 m
= gfc_get_pdt_instance (decl_type_param_list
, &sym
, NULL
);
3949 gcc_assert (!sym
->attr
.pdt_template
&& sym
->attr
.pdt_type
);
3950 ts
->u
.derived
= sym
;
3951 strcpy (name
, gfc_dt_lower_string (sym
->name
));
3954 if (sym
&& sym
->attr
.flavor
== FL_STRUCT
)
3956 ts
->u
.derived
= sym
;
3959 /* Actually a derived type. */
3964 /* Match nested STRUCTURE declarations; only valid within another
3965 structure declaration. */
3966 if (flag_dec_structure
3967 && (gfc_current_state () == COMP_STRUCTURE
3968 || gfc_current_state () == COMP_MAP
))
3970 m
= gfc_match (" structure");
3973 m
= gfc_match_structure_decl ();
3976 /* gfc_new_block is updated by match_structure_decl. */
3977 ts
->type
= BT_DERIVED
;
3978 ts
->u
.derived
= gfc_new_block
;
3982 if (m
== MATCH_ERROR
)
3986 /* Match CLASS declarations. */
3987 m
= gfc_match (" class ( * )");
3988 if (m
== MATCH_ERROR
)
3990 else if (m
== MATCH_YES
)
3994 ts
->type
= BT_CLASS
;
3995 gfc_find_symbol ("STAR", gfc_current_ns
, 1, &upe
);
3998 upe
= gfc_new_symbol ("STAR", gfc_current_ns
);
3999 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "STAR");
4001 gfc_set_sym_referenced (upe
);
4003 upe
->ts
.type
= BT_VOID
;
4004 upe
->attr
.unlimited_polymorphic
= 1;
4005 /* This is essential to force the construction of
4006 unlimited polymorphic component class containers. */
4007 upe
->attr
.zero_comp
= 1;
4008 if (!gfc_add_flavor (&upe
->attr
, FL_DERIVED
, NULL
,
4009 &gfc_current_locus
))
4014 st
= gfc_get_tbp_symtree (&gfc_current_ns
->sym_root
, "STAR");
4018 ts
->u
.derived
= upe
;
4022 m
= gfc_match (" class (");
4025 m
= gfc_match ("%n", name
);
4031 ts
->type
= BT_CLASS
;
4033 if (!gfc_notify_std (GFC_STD_F2003
, "CLASS statement at %C"))
4036 m
= gfc_match_actual_arglist (1, &decl_type_param_list
, true);
4037 if (m
== MATCH_ERROR
)
4040 m
= gfc_match_char (')');
4045 /* Defer association of the derived type until the end of the
4046 specification block. However, if the derived type can be
4047 found, add it to the typespec. */
4048 if (gfc_matching_function
)
4050 ts
->u
.derived
= NULL
;
4051 if (gfc_current_state () != COMP_INTERFACE
4052 && !gfc_find_symbol (name
, NULL
, 1, &sym
) && sym
)
4054 sym
= gfc_find_dt_in_generic (sym
);
4055 ts
->u
.derived
= sym
;
4060 /* Search for the name but allow the components to be defined later. If
4061 type = -1, this typespec has been seen in a function declaration but
4062 the type could not be accessed at that point. The actual derived type is
4063 stored in a symtree with the first letter of the name capitalized; the
4064 symtree with the all lower-case name contains the associated
4065 generic function. */
4066 dt_name
= gfc_dt_upper_string (name
);
4071 gfc_get_ha_symbol (name
, &sym
);
4072 if (sym
->generic
&& gfc_find_symbol (dt_name
, NULL
, 0, &dt_sym
))
4074 gfc_error ("Type name %qs at %C is ambiguous", name
);
4077 if (sym
->generic
&& !dt_sym
)
4078 dt_sym
= gfc_find_dt_in_generic (sym
);
4080 /* Host associated PDTs can get confused with their constructors
4081 because they ar instantiated in the template's namespace. */
4084 if (gfc_find_symbol (dt_name
, NULL
, 1, &dt_sym
))
4086 gfc_error ("Type name %qs at %C is ambiguous", name
);
4089 if (dt_sym
&& !dt_sym
->attr
.pdt_type
)
4093 else if (ts
->kind
== -1)
4095 int iface
= gfc_state_stack
->previous
->state
!= COMP_INTERFACE
4096 || gfc_current_ns
->has_import_set
;
4097 gfc_find_symbol (name
, NULL
, iface
, &sym
);
4098 if (sym
&& sym
->generic
&& gfc_find_symbol (dt_name
, NULL
, 1, &dt_sym
))
4100 gfc_error ("Type name %qs at %C is ambiguous", name
);
4103 if (sym
&& sym
->generic
&& !dt_sym
)
4104 dt_sym
= gfc_find_dt_in_generic (sym
);
4111 if ((sym
->attr
.flavor
!= FL_UNKNOWN
&& sym
->attr
.flavor
!= FL_STRUCT
4112 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.generic
))
4113 || sym
->attr
.subroutine
)
4115 gfc_error ("Type name %qs at %C conflicts with previously declared "
4116 "entity at %L, which has the same name", name
,
4121 if (sym
&& sym
->attr
.flavor
== FL_DERIVED
4122 && sym
->attr
.pdt_template
4123 && gfc_current_state () != COMP_DERIVED
)
4125 m
= gfc_get_pdt_instance (decl_type_param_list
, &sym
, NULL
);
4128 gcc_assert (!sym
->attr
.pdt_template
&& sym
->attr
.pdt_type
);
4129 ts
->u
.derived
= sym
;
4130 strcpy (name
, gfc_dt_lower_string (sym
->name
));
4133 gfc_save_symbol_data (sym
);
4134 gfc_set_sym_referenced (sym
);
4135 if (!sym
->attr
.generic
4136 && !gfc_add_generic (&sym
->attr
, sym
->name
, NULL
))
4139 if (!sym
->attr
.function
4140 && !gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
4143 if (dt_sym
&& dt_sym
->attr
.flavor
== FL_DERIVED
4144 && dt_sym
->attr
.pdt_template
4145 && gfc_current_state () != COMP_DERIVED
)
4147 m
= gfc_get_pdt_instance (decl_type_param_list
, &dt_sym
, NULL
);
4150 gcc_assert (!dt_sym
->attr
.pdt_template
&& dt_sym
->attr
.pdt_type
);
4155 gfc_interface
*intr
, *head
;
4157 /* Use upper case to save the actual derived-type symbol. */
4158 gfc_get_symbol (dt_name
, NULL
, &dt_sym
);
4159 dt_sym
->name
= gfc_get_string ("%s", sym
->name
);
4160 head
= sym
->generic
;
4161 intr
= gfc_get_interface ();
4163 intr
->where
= gfc_current_locus
;
4165 sym
->generic
= intr
;
4166 sym
->attr
.if_source
= IFSRC_DECL
;
4169 gfc_save_symbol_data (dt_sym
);
4171 gfc_set_sym_referenced (dt_sym
);
4173 if (dt_sym
->attr
.flavor
!= FL_DERIVED
&& dt_sym
->attr
.flavor
!= FL_STRUCT
4174 && !gfc_add_flavor (&dt_sym
->attr
, FL_DERIVED
, sym
->name
, NULL
))
4177 ts
->u
.derived
= dt_sym
;
4183 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
4184 "intrinsic-type-spec at %C"))
4187 /* For all types except double, derived and character, look for an
4188 optional kind specifier. MATCH_NO is actually OK at this point. */
4189 if (implicit_flag
== 1)
4191 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
4197 if (gfc_current_form
== FORM_FREE
)
4199 c
= gfc_peek_ascii_char ();
4200 if (!gfc_is_whitespace (c
) && c
!= '*' && c
!= '('
4201 && c
!= ':' && c
!= ',')
4203 if (matched_type
&& c
== ')')
4205 gfc_next_ascii_char ();
4212 m
= gfc_match_kind_spec (ts
, false);
4213 if (m
== MATCH_NO
&& ts
->type
!= BT_CHARACTER
)
4215 m
= gfc_match_old_kind_spec (ts
);
4216 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) == -1)
4220 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
4223 /* Defer association of the KIND expression of function results
4224 until after USE and IMPORT statements. */
4225 if ((gfc_current_state () == COMP_NONE
&& gfc_error_flag_test ())
4226 || gfc_matching_function
)
4230 m
= MATCH_YES
; /* No kind specifier found. */
4236 /* Match an IMPLICIT NONE statement. Actually, this statement is
4237 already matched in parse.c, or we would not end up here in the
4238 first place. So the only thing we need to check, is if there is
4239 trailing garbage. If not, the match is successful. */
4242 gfc_match_implicit_none (void)
4246 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4248 bool external
= false;
4249 locus cur_loc
= gfc_current_locus
;
4251 if (gfc_current_ns
->seen_implicit_none
4252 || gfc_current_ns
->has_implicit_none_export
)
4254 gfc_error ("Duplicate IMPLICIT NONE statement at %C");
4258 gfc_gobble_whitespace ();
4259 c
= gfc_peek_ascii_char ();
4262 (void) gfc_next_ascii_char ();
4263 if (!gfc_notify_std (GFC_STD_F2018
, "IMPORT NONE with spec list at %C"))
4266 gfc_gobble_whitespace ();
4267 if (gfc_peek_ascii_char () == ')')
4269 (void) gfc_next_ascii_char ();
4275 m
= gfc_match (" %n", name
);
4279 if (strcmp (name
, "type") == 0)
4281 else if (strcmp (name
, "external") == 0)
4286 gfc_gobble_whitespace ();
4287 c
= gfc_next_ascii_char ();
4298 if (gfc_match_eos () != MATCH_YES
)
4301 gfc_set_implicit_none (type
, external
, &cur_loc
);
4307 /* Match the letter range(s) of an IMPLICIT statement. */
4310 match_implicit_range (void)
4316 cur_loc
= gfc_current_locus
;
4318 gfc_gobble_whitespace ();
4319 c
= gfc_next_ascii_char ();
4322 gfc_error ("Missing character range in IMPLICIT at %C");
4329 gfc_gobble_whitespace ();
4330 c1
= gfc_next_ascii_char ();
4334 gfc_gobble_whitespace ();
4335 c
= gfc_next_ascii_char ();
4340 inner
= 0; /* Fall through. */
4347 gfc_gobble_whitespace ();
4348 c2
= gfc_next_ascii_char ();
4352 gfc_gobble_whitespace ();
4353 c
= gfc_next_ascii_char ();
4355 if ((c
!= ',') && (c
!= ')'))
4368 gfc_error ("Letters must be in alphabetic order in "
4369 "IMPLICIT statement at %C");
4373 /* See if we can add the newly matched range to the pending
4374 implicits from this IMPLICIT statement. We do not check for
4375 conflicts with whatever earlier IMPLICIT statements may have
4376 set. This is done when we've successfully finished matching
4378 if (!gfc_add_new_implicit_range (c1
, c2
))
4385 gfc_syntax_error (ST_IMPLICIT
);
4387 gfc_current_locus
= cur_loc
;
4392 /* Match an IMPLICIT statement, storing the types for
4393 gfc_set_implicit() if the statement is accepted by the parser.
4394 There is a strange looking, but legal syntactic construction
4395 possible. It looks like:
4397 IMPLICIT INTEGER (a-b) (c-d)
4399 This is legal if "a-b" is a constant expression that happens to
4400 equal one of the legal kinds for integers. The real problem
4401 happens with an implicit specification that looks like:
4403 IMPLICIT INTEGER (a-b)
4405 In this case, a typespec matcher that is "greedy" (as most of the
4406 matchers are) gobbles the character range as a kindspec, leaving
4407 nothing left. We therefore have to go a bit more slowly in the
4408 matching process by inhibiting the kindspec checking during
4409 typespec matching and checking for a kind later. */
4412 gfc_match_implicit (void)
4419 if (gfc_current_ns
->seen_implicit_none
)
4421 gfc_error ("IMPLICIT statement at %C following an IMPLICIT NONE (type) "
4428 /* We don't allow empty implicit statements. */
4429 if (gfc_match_eos () == MATCH_YES
)
4431 gfc_error ("Empty IMPLICIT statement at %C");
4437 /* First cleanup. */
4438 gfc_clear_new_implicit ();
4440 /* A basic type is mandatory here. */
4441 m
= gfc_match_decl_type_spec (&ts
, 1);
4442 if (m
== MATCH_ERROR
)
4447 cur_loc
= gfc_current_locus
;
4448 m
= match_implicit_range ();
4452 /* We may have <TYPE> (<RANGE>). */
4453 gfc_gobble_whitespace ();
4454 c
= gfc_peek_ascii_char ();
4455 if (c
== ',' || c
== '\n' || c
== ';' || c
== '!')
4457 /* Check for CHARACTER with no length parameter. */
4458 if (ts
.type
== BT_CHARACTER
&& !ts
.u
.cl
)
4460 ts
.kind
= gfc_default_character_kind
;
4461 ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4462 ts
.u
.cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
,
4466 /* Record the Successful match. */
4467 if (!gfc_merge_new_implicit (&ts
))
4470 c
= gfc_next_ascii_char ();
4471 else if (gfc_match_eos () == MATCH_ERROR
)
4476 gfc_current_locus
= cur_loc
;
4479 /* Discard the (incorrectly) matched range. */
4480 gfc_clear_new_implicit ();
4482 /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
4483 if (ts
.type
== BT_CHARACTER
)
4484 m
= gfc_match_char_spec (&ts
);
4487 m
= gfc_match_kind_spec (&ts
, false);
4490 m
= gfc_match_old_kind_spec (&ts
);
4491 if (m
== MATCH_ERROR
)
4497 if (m
== MATCH_ERROR
)
4500 m
= match_implicit_range ();
4501 if (m
== MATCH_ERROR
)
4506 gfc_gobble_whitespace ();
4507 c
= gfc_next_ascii_char ();
4508 if (c
!= ',' && gfc_match_eos () != MATCH_YES
)
4511 if (!gfc_merge_new_implicit (&ts
))
4519 gfc_syntax_error (ST_IMPLICIT
);
4527 gfc_match_import (void)
4529 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4534 if (gfc_current_ns
->proc_name
== NULL
4535 || gfc_current_ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
4537 gfc_error ("IMPORT statement at %C only permitted in "
4538 "an INTERFACE body");
4542 if (gfc_current_ns
->proc_name
->attr
.module_procedure
)
4544 gfc_error ("F2008: C1210 IMPORT statement at %C is not permitted "
4545 "in a module procedure interface body");
4549 if (!gfc_notify_std (GFC_STD_F2003
, "IMPORT statement at %C"))
4552 if (gfc_match_eos () == MATCH_YES
)
4554 /* All host variables should be imported. */
4555 gfc_current_ns
->has_import_set
= 1;
4559 if (gfc_match (" ::") == MATCH_YES
)
4561 if (gfc_match_eos () == MATCH_YES
)
4563 gfc_error ("Expecting list of named entities at %C");
4571 m
= gfc_match (" %n", name
);
4575 if (gfc_current_ns
->parent
!= NULL
4576 && gfc_find_symbol (name
, gfc_current_ns
->parent
, 1, &sym
))
4578 gfc_error ("Type name %qs at %C is ambiguous", name
);
4581 else if (!sym
&& gfc_current_ns
->proc_name
->ns
->parent
!= NULL
4582 && gfc_find_symbol (name
,
4583 gfc_current_ns
->proc_name
->ns
->parent
,
4586 gfc_error ("Type name %qs at %C is ambiguous", name
);
4592 gfc_error ("Cannot IMPORT %qs from host scoping unit "
4593 "at %C - does not exist.", name
);
4597 if (gfc_find_symtree (gfc_current_ns
->sym_root
, name
))
4599 gfc_warning (0, "%qs is already IMPORTed from host scoping unit "
4604 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, name
);
4607 sym
->attr
.imported
= 1;
4609 if (sym
->attr
.generic
&& (sym
= gfc_find_dt_in_generic (sym
)))
4611 /* The actual derived type is stored in a symtree with the first
4612 letter of the name capitalized; the symtree with the all
4613 lower-case name contains the associated generic function. */
4614 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
,
4615 gfc_dt_upper_string (name
));
4618 sym
->attr
.imported
= 1;
4631 if (gfc_match_eos () == MATCH_YES
)
4633 if (gfc_match_char (',') != MATCH_YES
)
4640 gfc_error ("Syntax error in IMPORT statement at %C");
4645 /* A minimal implementation of gfc_match without whitespace, escape
4646 characters or variable arguments. Returns true if the next
4647 characters match the TARGET template exactly. */
4650 match_string_p (const char *target
)
4654 for (p
= target
; *p
; p
++)
4655 if ((char) gfc_next_ascii_char () != *p
)
4660 /* Matches an attribute specification including array specs. If
4661 successful, leaves the variables current_attr and current_as
4662 holding the specification. Also sets the colon_seen variable for
4663 later use by matchers associated with initializations.
4665 This subroutine is a little tricky in the sense that we don't know
4666 if we really have an attr-spec until we hit the double colon.
4667 Until that time, we can only return MATCH_NO. This forces us to
4668 check for duplicate specification at this level. */
4671 match_attr_spec (void)
4673 /* Modifiers that can exist in a type statement. */
4675 { GFC_DECL_BEGIN
= 0,
4676 DECL_ALLOCATABLE
= GFC_DECL_BEGIN
, DECL_DIMENSION
, DECL_EXTERNAL
,
4677 DECL_IN
, DECL_OUT
, DECL_INOUT
, DECL_INTRINSIC
, DECL_OPTIONAL
,
4678 DECL_PARAMETER
, DECL_POINTER
, DECL_PROTECTED
, DECL_PRIVATE
,
4679 DECL_STATIC
, DECL_AUTOMATIC
,
4680 DECL_PUBLIC
, DECL_SAVE
, DECL_TARGET
, DECL_VALUE
, DECL_VOLATILE
,
4681 DECL_IS_BIND_C
, DECL_CODIMENSION
, DECL_ASYNCHRONOUS
, DECL_CONTIGUOUS
,
4682 DECL_LEN
, DECL_KIND
, DECL_NONE
, GFC_DECL_END
/* Sentinel */
4685 /* GFC_DECL_END is the sentinel, index starts at 0. */
4686 #define NUM_DECL GFC_DECL_END
4688 locus start
, seen_at
[NUM_DECL
];
4695 gfc_clear_attr (¤t_attr
);
4696 start
= gfc_current_locus
;
4702 /* See if we get all of the keywords up to the final double colon. */
4703 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
4711 gfc_gobble_whitespace ();
4713 ch
= gfc_next_ascii_char ();
4716 /* This is the successful exit condition for the loop. */
4717 if (gfc_next_ascii_char () == ':')
4722 gfc_gobble_whitespace ();
4723 switch (gfc_peek_ascii_char ())
4726 gfc_next_ascii_char ();
4727 switch (gfc_next_ascii_char ())
4730 if (match_string_p ("locatable"))
4732 /* Matched "allocatable". */
4733 d
= DECL_ALLOCATABLE
;
4738 if (match_string_p ("ynchronous"))
4740 /* Matched "asynchronous". */
4741 d
= DECL_ASYNCHRONOUS
;
4746 if (match_string_p ("tomatic"))
4748 /* Matched "automatic". */
4756 /* Try and match the bind(c). */
4757 m
= gfc_match_bind_c (NULL
, true);
4760 else if (m
== MATCH_ERROR
)
4765 gfc_next_ascii_char ();
4766 if ('o' != gfc_next_ascii_char ())
4768 switch (gfc_next_ascii_char ())
4771 if (match_string_p ("imension"))
4773 d
= DECL_CODIMENSION
;
4778 if (match_string_p ("tiguous"))
4780 d
= DECL_CONTIGUOUS
;
4787 if (match_string_p ("dimension"))
4792 if (match_string_p ("external"))
4797 if (match_string_p ("int"))
4799 ch
= gfc_next_ascii_char ();
4802 if (match_string_p ("nt"))
4804 /* Matched "intent". */
4805 /* TODO: Call match_intent_spec from here. */
4806 if (gfc_match (" ( in out )") == MATCH_YES
)
4808 else if (gfc_match (" ( in )") == MATCH_YES
)
4810 else if (gfc_match (" ( out )") == MATCH_YES
)
4816 if (match_string_p ("insic"))
4818 /* Matched "intrinsic". */
4826 if (match_string_p ("kind"))
4831 if (match_string_p ("len"))
4836 if (match_string_p ("optional"))
4841 gfc_next_ascii_char ();
4842 switch (gfc_next_ascii_char ())
4845 if (match_string_p ("rameter"))
4847 /* Matched "parameter". */
4853 if (match_string_p ("inter"))
4855 /* Matched "pointer". */
4861 ch
= gfc_next_ascii_char ();
4864 if (match_string_p ("vate"))
4866 /* Matched "private". */
4872 if (match_string_p ("tected"))
4874 /* Matched "protected". */
4881 if (match_string_p ("blic"))
4883 /* Matched "public". */
4891 gfc_next_ascii_char ();
4892 switch (gfc_next_ascii_char ())
4895 if (match_string_p ("ve"))
4897 /* Matched "save". */
4903 if (match_string_p ("atic"))
4905 /* Matched "static". */
4913 if (match_string_p ("target"))
4918 gfc_next_ascii_char ();
4919 ch
= gfc_next_ascii_char ();
4922 if (match_string_p ("lue"))
4924 /* Matched "value". */
4930 if (match_string_p ("latile"))
4932 /* Matched "volatile". */
4940 /* No double colon and no recognizable decl_type, so assume that
4941 we've been looking at something else the whole time. */
4948 /* Check to make sure any parens are paired up correctly. */
4949 if (gfc_match_parens () == MATCH_ERROR
)
4956 seen_at
[d
] = gfc_current_locus
;
4958 if (d
== DECL_DIMENSION
|| d
== DECL_CODIMENSION
)
4960 gfc_array_spec
*as
= NULL
;
4962 m
= gfc_match_array_spec (&as
, d
== DECL_DIMENSION
,
4963 d
== DECL_CODIMENSION
);
4965 if (current_as
== NULL
)
4967 else if (m
== MATCH_YES
)
4969 if (!merge_array_spec (as
, current_as
, false))
4976 if (d
== DECL_CODIMENSION
)
4977 gfc_error ("Missing codimension specification at %C");
4979 gfc_error ("Missing dimension specification at %C");
4983 if (m
== MATCH_ERROR
)
4988 /* Since we've seen a double colon, we have to be looking at an
4989 attr-spec. This means that we can now issue errors. */
4990 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
4995 case DECL_ALLOCATABLE
:
4996 attr
= "ALLOCATABLE";
4998 case DECL_ASYNCHRONOUS
:
4999 attr
= "ASYNCHRONOUS";
5001 case DECL_CODIMENSION
:
5002 attr
= "CODIMENSION";
5004 case DECL_CONTIGUOUS
:
5005 attr
= "CONTIGUOUS";
5007 case DECL_DIMENSION
:
5014 attr
= "INTENT (IN)";
5017 attr
= "INTENT (OUT)";
5020 attr
= "INTENT (IN OUT)";
5022 case DECL_INTRINSIC
:
5034 case DECL_PARAMETER
:
5040 case DECL_PROTECTED
:
5055 case DECL_AUTOMATIC
:
5061 case DECL_IS_BIND_C
:
5071 attr
= NULL
; /* This shouldn't happen. */
5074 gfc_error ("Duplicate %s attribute at %L", attr
, &seen_at
[d
]);
5079 /* Now that we've dealt with duplicate attributes, add the attributes
5080 to the current attribute. */
5081 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
5088 if ((d
== DECL_STATIC
|| d
== DECL_AUTOMATIC
)
5089 && !flag_dec_static
)
5091 gfc_error ("%s at %L is a DEC extension, enable with "
5093 d
== DECL_STATIC
? "STATIC" : "AUTOMATIC", &seen_at
[d
]);
5097 /* Allow SAVE with STATIC, but don't complain. */
5098 if (d
== DECL_STATIC
&& seen
[DECL_SAVE
])
5101 if (gfc_current_state () == COMP_DERIVED
5102 && d
!= DECL_DIMENSION
&& d
!= DECL_CODIMENSION
5103 && d
!= DECL_POINTER
&& d
!= DECL_PRIVATE
5104 && d
!= DECL_PUBLIC
&& d
!= DECL_CONTIGUOUS
&& d
!= DECL_NONE
)
5106 if (d
== DECL_ALLOCATABLE
)
5108 if (!gfc_notify_std (GFC_STD_F2003
, "ALLOCATABLE "
5109 "attribute at %C in a TYPE definition"))
5115 else if (d
== DECL_KIND
)
5117 if (!gfc_notify_std (GFC_STD_F2003
, "KIND "
5118 "attribute at %C in a TYPE definition"))
5123 if (current_ts
.type
!= BT_INTEGER
)
5125 gfc_error ("Component with KIND attribute at %C must be "
5130 if (current_ts
.kind
!= gfc_default_integer_kind
)
5132 gfc_error ("Component with KIND attribute at %C must be "
5133 "default integer kind (%d)",
5134 gfc_default_integer_kind
);
5139 else if (d
== DECL_LEN
)
5141 if (!gfc_notify_std (GFC_STD_F2003
, "LEN "
5142 "attribute at %C in a TYPE definition"))
5147 if (current_ts
.type
!= BT_INTEGER
)
5149 gfc_error ("Component with LEN attribute at %C must be "
5154 if (current_ts
.kind
!= gfc_default_integer_kind
)
5156 gfc_error ("Component with LEN attribute at %C must be "
5157 "default integer kind (%d)",
5158 gfc_default_integer_kind
);
5165 gfc_error ("Attribute at %L is not allowed in a TYPE definition",
5172 if ((d
== DECL_PRIVATE
|| d
== DECL_PUBLIC
)
5173 && gfc_current_state () != COMP_MODULE
)
5175 if (d
== DECL_PRIVATE
)
5179 if (gfc_current_state () == COMP_DERIVED
5180 && gfc_state_stack
->previous
5181 && gfc_state_stack
->previous
->state
== COMP_MODULE
)
5183 if (!gfc_notify_std (GFC_STD_F2003
, "Attribute %s "
5184 "at %L in a TYPE definition", attr
,
5193 gfc_error ("%s attribute at %L is not allowed outside of the "
5194 "specification part of a module", attr
, &seen_at
[d
]);
5200 if (gfc_current_state () != COMP_DERIVED
5201 && (d
== DECL_KIND
|| d
== DECL_LEN
))
5203 gfc_error ("Attribute at %L is not allowed outside a TYPE "
5204 "definition", &seen_at
[d
]);
5211 case DECL_ALLOCATABLE
:
5212 t
= gfc_add_allocatable (¤t_attr
, &seen_at
[d
]);
5215 case DECL_ASYNCHRONOUS
:
5216 if (!gfc_notify_std (GFC_STD_F2003
, "ASYNCHRONOUS attribute at %C"))
5219 t
= gfc_add_asynchronous (¤t_attr
, NULL
, &seen_at
[d
]);
5222 case DECL_CODIMENSION
:
5223 t
= gfc_add_codimension (¤t_attr
, NULL
, &seen_at
[d
]);
5226 case DECL_CONTIGUOUS
:
5227 if (!gfc_notify_std (GFC_STD_F2008
, "CONTIGUOUS attribute at %C"))
5230 t
= gfc_add_contiguous (¤t_attr
, NULL
, &seen_at
[d
]);
5233 case DECL_DIMENSION
:
5234 t
= gfc_add_dimension (¤t_attr
, NULL
, &seen_at
[d
]);
5238 t
= gfc_add_external (¤t_attr
, &seen_at
[d
]);
5242 t
= gfc_add_intent (¤t_attr
, INTENT_IN
, &seen_at
[d
]);
5246 t
= gfc_add_intent (¤t_attr
, INTENT_OUT
, &seen_at
[d
]);
5250 t
= gfc_add_intent (¤t_attr
, INTENT_INOUT
, &seen_at
[d
]);
5253 case DECL_INTRINSIC
:
5254 t
= gfc_add_intrinsic (¤t_attr
, &seen_at
[d
]);
5258 t
= gfc_add_optional (¤t_attr
, &seen_at
[d
]);
5262 t
= gfc_add_kind (¤t_attr
, &seen_at
[d
]);
5266 t
= gfc_add_len (¤t_attr
, &seen_at
[d
]);
5269 case DECL_PARAMETER
:
5270 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, &seen_at
[d
]);
5274 t
= gfc_add_pointer (¤t_attr
, &seen_at
[d
]);
5277 case DECL_PROTECTED
:
5278 if (gfc_current_state () != COMP_MODULE
5279 || (gfc_current_ns
->proc_name
5280 && gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
))
5282 gfc_error ("PROTECTED at %C only allowed in specification "
5283 "part of a module");
5288 if (!gfc_notify_std (GFC_STD_F2003
, "PROTECTED attribute at %C"))
5291 t
= gfc_add_protected (¤t_attr
, NULL
, &seen_at
[d
]);
5295 t
= gfc_add_access (¤t_attr
, ACCESS_PRIVATE
, NULL
,
5300 t
= gfc_add_access (¤t_attr
, ACCESS_PUBLIC
, NULL
,
5306 t
= gfc_add_save (¤t_attr
, SAVE_EXPLICIT
, NULL
, &seen_at
[d
]);
5309 case DECL_AUTOMATIC
:
5310 t
= gfc_add_automatic (¤t_attr
, NULL
, &seen_at
[d
]);
5314 t
= gfc_add_target (¤t_attr
, &seen_at
[d
]);
5317 case DECL_IS_BIND_C
:
5318 t
= gfc_add_is_bind_c(¤t_attr
, NULL
, &seen_at
[d
], 0);
5322 if (!gfc_notify_std (GFC_STD_F2003
, "VALUE attribute at %C"))
5325 t
= gfc_add_value (¤t_attr
, NULL
, &seen_at
[d
]);
5329 if (!gfc_notify_std (GFC_STD_F2003
, "VOLATILE attribute at %C"))
5332 t
= gfc_add_volatile (¤t_attr
, NULL
, &seen_at
[d
]);
5336 gfc_internal_error ("match_attr_spec(): Bad attribute");
5346 /* Since Fortran 2008 module variables implicitly have the SAVE attribute. */
5347 if ((gfc_current_state () == COMP_MODULE
5348 || gfc_current_state () == COMP_SUBMODULE
)
5349 && !current_attr
.save
5350 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
5351 current_attr
.save
= SAVE_IMPLICIT
;
5357 gfc_current_locus
= start
;
5358 gfc_free_array_spec (current_as
);
5365 /* Set the binding label, dest_label, either with the binding label
5366 stored in the given gfc_typespec, ts, or if none was provided, it
5367 will be the symbol name in all lower case, as required by the draft
5368 (J3/04-007, section 15.4.1). If a binding label was given and
5369 there is more than one argument (num_idents), it is an error. */
5372 set_binding_label (const char **dest_label
, const char *sym_name
,
5375 if (num_idents
> 1 && has_name_equals
)
5377 gfc_error ("Multiple identifiers provided with "
5378 "single NAME= specifier at %C");
5382 if (curr_binding_label
)
5383 /* Binding label given; store in temp holder till have sym. */
5384 *dest_label
= curr_binding_label
;
5387 /* No binding label given, and the NAME= specifier did not exist,
5388 which means there was no NAME="". */
5389 if (sym_name
!= NULL
&& has_name_equals
== 0)
5390 *dest_label
= IDENTIFIER_POINTER (get_identifier (sym_name
));
5397 /* Set the status of the given common block as being BIND(C) or not,
5398 depending on the given parameter, is_bind_c. */
5401 set_com_block_bind_c (gfc_common_head
*com_block
, int is_bind_c
)
5403 com_block
->is_bind_c
= is_bind_c
;
5408 /* Verify that the given gfc_typespec is for a C interoperable type. */
5411 gfc_verify_c_interop (gfc_typespec
*ts
)
5413 if (ts
->type
== BT_DERIVED
&& ts
->u
.derived
!= NULL
)
5414 return (ts
->u
.derived
->ts
.is_c_interop
|| ts
->u
.derived
->attr
.is_bind_c
)
5416 else if (ts
->type
== BT_CLASS
)
5418 else if (ts
->is_c_interop
!= 1 && ts
->type
!= BT_ASSUMED
)
5425 /* Verify that the variables of a given common block, which has been
5426 defined with the attribute specifier bind(c), to be of a C
5427 interoperable type. Errors will be reported here, if
5431 verify_com_block_vars_c_interop (gfc_common_head
*com_block
)
5433 gfc_symbol
*curr_sym
= NULL
;
5436 curr_sym
= com_block
->head
;
5438 /* Make sure we have at least one symbol. */
5439 if (curr_sym
== NULL
)
5442 /* Here we know we have a symbol, so we'll execute this loop
5446 /* The second to last param, 1, says this is in a common block. */
5447 retval
= verify_bind_c_sym (curr_sym
, &(curr_sym
->ts
), 1, com_block
);
5448 curr_sym
= curr_sym
->common_next
;
5449 } while (curr_sym
!= NULL
);
5455 /* Verify that a given BIND(C) symbol is C interoperable. If it is not,
5456 an appropriate error message is reported. */
5459 verify_bind_c_sym (gfc_symbol
*tmp_sym
, gfc_typespec
*ts
,
5460 int is_in_common
, gfc_common_head
*com_block
)
5462 bool bind_c_function
= false;
5465 if (tmp_sym
->attr
.function
&& tmp_sym
->attr
.is_bind_c
)
5466 bind_c_function
= true;
5468 if (tmp_sym
->attr
.function
&& tmp_sym
->result
!= NULL
)
5470 tmp_sym
= tmp_sym
->result
;
5471 /* Make sure it wasn't an implicitly typed result. */
5472 if (tmp_sym
->attr
.implicit_type
&& warn_c_binding_type
)
5474 gfc_warning (OPT_Wc_binding_type
,
5475 "Implicitly declared BIND(C) function %qs at "
5476 "%L may not be C interoperable", tmp_sym
->name
,
5477 &tmp_sym
->declared_at
);
5478 tmp_sym
->ts
.f90_type
= tmp_sym
->ts
.type
;
5479 /* Mark it as C interoperable to prevent duplicate warnings. */
5480 tmp_sym
->ts
.is_c_interop
= 1;
5481 tmp_sym
->attr
.is_c_interop
= 1;
5485 /* Here, we know we have the bind(c) attribute, so if we have
5486 enough type info, then verify that it's a C interop kind.
5487 The info could be in the symbol already, or possibly still in
5488 the given ts (current_ts), so look in both. */
5489 if (tmp_sym
->ts
.type
!= BT_UNKNOWN
|| ts
->type
!= BT_UNKNOWN
)
5491 if (!gfc_verify_c_interop (&(tmp_sym
->ts
)))
5493 /* See if we're dealing with a sym in a common block or not. */
5494 if (is_in_common
== 1 && warn_c_binding_type
)
5496 gfc_warning (OPT_Wc_binding_type
,
5497 "Variable %qs in common block %qs at %L "
5498 "may not be a C interoperable "
5499 "kind though common block %qs is BIND(C)",
5500 tmp_sym
->name
, com_block
->name
,
5501 &(tmp_sym
->declared_at
), com_block
->name
);
5505 if (tmp_sym
->ts
.type
== BT_DERIVED
|| ts
->type
== BT_DERIVED
)
5506 gfc_error ("Type declaration %qs at %L is not C "
5507 "interoperable but it is BIND(C)",
5508 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5509 else if (warn_c_binding_type
)
5510 gfc_warning (OPT_Wc_binding_type
, "Variable %qs at %L "
5511 "may not be a C interoperable "
5512 "kind but it is BIND(C)",
5513 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5517 /* Variables declared w/in a common block can't be bind(c)
5518 since there's no way for C to see these variables, so there's
5519 semantically no reason for the attribute. */
5520 if (is_in_common
== 1 && tmp_sym
->attr
.is_bind_c
== 1)
5522 gfc_error ("Variable %qs in common block %qs at "
5523 "%L cannot be declared with BIND(C) "
5524 "since it is not a global",
5525 tmp_sym
->name
, com_block
->name
,
5526 &(tmp_sym
->declared_at
));
5530 /* Scalar variables that are bind(c) can not have the pointer
5531 or allocatable attributes. */
5532 if (tmp_sym
->attr
.is_bind_c
== 1)
5534 if (tmp_sym
->attr
.pointer
== 1)
5536 gfc_error ("Variable %qs at %L cannot have both the "
5537 "POINTER and BIND(C) attributes",
5538 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5542 if (tmp_sym
->attr
.allocatable
== 1)
5544 gfc_error ("Variable %qs at %L cannot have both the "
5545 "ALLOCATABLE and BIND(C) attributes",
5546 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5552 /* If it is a BIND(C) function, make sure the return value is a
5553 scalar value. The previous tests in this function made sure
5554 the type is interoperable. */
5555 if (bind_c_function
&& tmp_sym
->as
!= NULL
)
5556 gfc_error ("Return type of BIND(C) function %qs at %L cannot "
5557 "be an array", tmp_sym
->name
, &(tmp_sym
->declared_at
));
5559 /* BIND(C) functions can not return a character string. */
5560 if (bind_c_function
&& tmp_sym
->ts
.type
== BT_CHARACTER
)
5561 if (tmp_sym
->ts
.u
.cl
== NULL
|| tmp_sym
->ts
.u
.cl
->length
== NULL
5562 || tmp_sym
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
5563 || mpz_cmp_si (tmp_sym
->ts
.u
.cl
->length
->value
.integer
, 1) != 0)
5564 gfc_error ("Return type of BIND(C) function %qs at %L cannot "
5565 "be a character string", tmp_sym
->name
,
5566 &(tmp_sym
->declared_at
));
5569 /* See if the symbol has been marked as private. If it has, make sure
5570 there is no binding label and warn the user if there is one. */
5571 if (tmp_sym
->attr
.access
== ACCESS_PRIVATE
5572 && tmp_sym
->binding_label
)
5573 /* Use gfc_warning_now because we won't say that the symbol fails
5574 just because of this. */
5575 gfc_warning_now (0, "Symbol %qs at %L is marked PRIVATE but has been "
5576 "given the binding label %qs", tmp_sym
->name
,
5577 &(tmp_sym
->declared_at
), tmp_sym
->binding_label
);
5583 /* Set the appropriate fields for a symbol that's been declared as
5584 BIND(C) (the is_bind_c flag and the binding label), and verify that
5585 the type is C interoperable. Errors are reported by the functions
5586 used to set/test these fields. */
5589 set_verify_bind_c_sym (gfc_symbol
*tmp_sym
, int num_idents
)
5593 /* TODO: Do we need to make sure the vars aren't marked private? */
5595 /* Set the is_bind_c bit in symbol_attribute. */
5596 gfc_add_is_bind_c (&(tmp_sym
->attr
), tmp_sym
->name
, &gfc_current_locus
, 0);
5598 if (!set_binding_label (&tmp_sym
->binding_label
, tmp_sym
->name
, num_idents
))
5605 /* Set the fields marking the given common block as BIND(C), including
5606 a binding label, and report any errors encountered. */
5609 set_verify_bind_c_com_block (gfc_common_head
*com_block
, int num_idents
)
5613 /* destLabel, common name, typespec (which may have binding label). */
5614 if (!set_binding_label (&com_block
->binding_label
, com_block
->name
,
5618 /* Set the given common block (com_block) to being bind(c) (1). */
5619 set_com_block_bind_c (com_block
, 1);
5625 /* Retrieve the list of one or more identifiers that the given bind(c)
5626 attribute applies to. */
5629 get_bind_c_idents (void)
5631 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5633 gfc_symbol
*tmp_sym
= NULL
;
5635 gfc_common_head
*com_block
= NULL
;
5637 if (gfc_match_name (name
) == MATCH_YES
)
5639 found_id
= MATCH_YES
;
5640 gfc_get_ha_symbol (name
, &tmp_sym
);
5642 else if (match_common_name (name
) == MATCH_YES
)
5644 found_id
= MATCH_YES
;
5645 com_block
= gfc_get_common (name
, 0);
5649 gfc_error ("Need either entity or common block name for "
5650 "attribute specification statement at %C");
5654 /* Save the current identifier and look for more. */
5657 /* Increment the number of identifiers found for this spec stmt. */
5660 /* Make sure we have a sym or com block, and verify that it can
5661 be bind(c). Set the appropriate field(s) and look for more
5663 if (tmp_sym
!= NULL
|| com_block
!= NULL
)
5665 if (tmp_sym
!= NULL
)
5667 if (!set_verify_bind_c_sym (tmp_sym
, num_idents
))
5672 if (!set_verify_bind_c_com_block (com_block
, num_idents
))
5676 /* Look to see if we have another identifier. */
5678 if (gfc_match_eos () == MATCH_YES
)
5679 found_id
= MATCH_NO
;
5680 else if (gfc_match_char (',') != MATCH_YES
)
5681 found_id
= MATCH_NO
;
5682 else if (gfc_match_name (name
) == MATCH_YES
)
5684 found_id
= MATCH_YES
;
5685 gfc_get_ha_symbol (name
, &tmp_sym
);
5687 else if (match_common_name (name
) == MATCH_YES
)
5689 found_id
= MATCH_YES
;
5690 com_block
= gfc_get_common (name
, 0);
5694 gfc_error ("Missing entity or common block name for "
5695 "attribute specification statement at %C");
5701 gfc_internal_error ("Missing symbol");
5703 } while (found_id
== MATCH_YES
);
5705 /* if we get here we were successful */
5710 /* Try and match a BIND(C) attribute specification statement. */
5713 gfc_match_bind_c_stmt (void)
5715 match found_match
= MATCH_NO
;
5720 /* This may not be necessary. */
5722 /* Clear the temporary binding label holder. */
5723 curr_binding_label
= NULL
;
5725 /* Look for the bind(c). */
5726 found_match
= gfc_match_bind_c (NULL
, true);
5728 if (found_match
== MATCH_YES
)
5730 if (!gfc_notify_std (GFC_STD_F2003
, "BIND(C) statement at %C"))
5733 /* Look for the :: now, but it is not required. */
5736 /* Get the identifier(s) that needs to be updated. This may need to
5737 change to hand the flag(s) for the attr specified so all identifiers
5738 found can have all appropriate parts updated (assuming that the same
5739 spec stmt can have multiple attrs, such as both bind(c) and
5741 if (!get_bind_c_idents ())
5742 /* Error message should have printed already. */
5750 /* Match a data declaration statement. */
5753 gfc_match_data_decl (void)
5759 type_param_spec_list
= NULL
;
5760 decl_type_param_list
= NULL
;
5762 num_idents_on_line
= 0;
5764 m
= gfc_match_decl_type_spec (¤t_ts
, 0);
5768 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
5769 && !gfc_comp_struct (gfc_current_state ()))
5771 sym
= gfc_use_derived (current_ts
.u
.derived
);
5779 current_ts
.u
.derived
= sym
;
5782 m
= match_attr_spec ();
5783 if (m
== MATCH_ERROR
)
5789 if (current_ts
.type
== BT_CLASS
5790 && current_ts
.u
.derived
->attr
.unlimited_polymorphic
)
5793 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
5794 && current_ts
.u
.derived
->components
== NULL
5795 && !current_ts
.u
.derived
->attr
.zero_comp
)
5798 if (current_attr
.pointer
&& gfc_comp_struct (gfc_current_state ()))
5801 if (current_attr
.allocatable
&& gfc_current_state () == COMP_DERIVED
5802 && current_ts
.u
.derived
== gfc_current_block ())
5805 gfc_find_symbol (current_ts
.u
.derived
->name
,
5806 current_ts
.u
.derived
->ns
, 1, &sym
);
5808 /* Any symbol that we find had better be a type definition
5809 which has its components defined, or be a structure definition
5810 actively being parsed. */
5811 if (sym
!= NULL
&& gfc_fl_struct (sym
->attr
.flavor
)
5812 && (current_ts
.u
.derived
->components
!= NULL
5813 || current_ts
.u
.derived
->attr
.zero_comp
5814 || current_ts
.u
.derived
== gfc_new_block
))
5817 gfc_error ("Derived type at %C has not been previously defined "
5818 "and so cannot appear in a derived type definition");
5824 /* If we have an old-style character declaration, and no new-style
5825 attribute specifications, then there a comma is optional between
5826 the type specification and the variable list. */
5827 if (m
== MATCH_NO
&& current_ts
.type
== BT_CHARACTER
&& old_char_selector
)
5828 gfc_match_char (',');
5830 /* Give the types/attributes to symbols that follow. Give the element
5831 a number so that repeat character length expressions can be copied. */
5835 num_idents_on_line
++;
5836 m
= variable_decl (elem
++);
5837 if (m
== MATCH_ERROR
)
5842 if (gfc_match_eos () == MATCH_YES
)
5844 if (gfc_match_char (',') != MATCH_YES
)
5848 if (!gfc_error_flag_test ())
5850 /* An anonymous structure declaration is unambiguous; if we matched one
5851 according to gfc_match_structure_decl, we need to return MATCH_YES
5852 here to avoid confusing the remaining matchers, even if there was an
5853 error during variable_decl. We must flush any such errors. Note this
5854 causes the parser to gracefully continue parsing the remaining input
5855 as a structure body, which likely follows. */
5856 if (current_ts
.type
== BT_DERIVED
&& current_ts
.u
.derived
5857 && gfc_fl_struct (current_ts
.u
.derived
->attr
.flavor
))
5859 gfc_error_now ("Syntax error in anonymous structure declaration"
5861 /* Skip the bad variable_decl and line up for the start of the
5863 gfc_error_recovery ();
5868 gfc_error ("Syntax error in data declaration at %C");
5873 gfc_free_data_all (gfc_current_ns
);
5876 if (saved_kind_expr
)
5877 gfc_free_expr (saved_kind_expr
);
5878 if (type_param_spec_list
)
5879 gfc_free_actual_arglist (type_param_spec_list
);
5880 if (decl_type_param_list
)
5881 gfc_free_actual_arglist (decl_type_param_list
);
5882 saved_kind_expr
= NULL
;
5883 gfc_free_array_spec (current_as
);
5889 /* Match a prefix associated with a function or subroutine
5890 declaration. If the typespec pointer is nonnull, then a typespec
5891 can be matched. Note that if nothing matches, MATCH_YES is
5892 returned (the null string was matched). */
5895 gfc_match_prefix (gfc_typespec
*ts
)
5901 gfc_clear_attr (¤t_attr
);
5903 seen_impure
= false;
5905 gcc_assert (!gfc_matching_prefix
);
5906 gfc_matching_prefix
= true;
5910 found_prefix
= false;
5912 /* MODULE is a prefix like PURE, ELEMENTAL, etc., having a
5913 corresponding attribute seems natural and distinguishes these
5914 procedures from procedure types of PROC_MODULE, which these are
5916 if (gfc_match ("module% ") == MATCH_YES
)
5918 if (!gfc_notify_std (GFC_STD_F2008
, "MODULE prefix at %C"))
5921 current_attr
.module_procedure
= 1;
5922 found_prefix
= true;
5925 if (!seen_type
&& ts
!= NULL
5926 && gfc_match_decl_type_spec (ts
, 0) == MATCH_YES
5927 && gfc_match_space () == MATCH_YES
)
5931 found_prefix
= true;
5934 if (gfc_match ("elemental% ") == MATCH_YES
)
5936 if (!gfc_add_elemental (¤t_attr
, NULL
))
5939 found_prefix
= true;
5942 if (gfc_match ("pure% ") == MATCH_YES
)
5944 if (!gfc_add_pure (¤t_attr
, NULL
))
5947 found_prefix
= true;
5950 if (gfc_match ("recursive% ") == MATCH_YES
)
5952 if (!gfc_add_recursive (¤t_attr
, NULL
))
5955 found_prefix
= true;
5958 /* IMPURE is a somewhat special case, as it needs not set an actual
5959 attribute but rather only prevents ELEMENTAL routines from being
5960 automatically PURE. */
5961 if (gfc_match ("impure% ") == MATCH_YES
)
5963 if (!gfc_notify_std (GFC_STD_F2008
, "IMPURE procedure at %C"))
5967 found_prefix
= true;
5970 while (found_prefix
);
5972 /* IMPURE and PURE must not both appear, of course. */
5973 if (seen_impure
&& current_attr
.pure
)
5975 gfc_error ("PURE and IMPURE must not appear both at %C");
5979 /* If IMPURE it not seen but the procedure is ELEMENTAL, mark it as PURE. */
5980 if (!seen_impure
&& current_attr
.elemental
&& !current_attr
.pure
)
5982 if (!gfc_add_pure (¤t_attr
, NULL
))
5986 /* At this point, the next item is not a prefix. */
5987 gcc_assert (gfc_matching_prefix
);
5989 gfc_matching_prefix
= false;
5993 gcc_assert (gfc_matching_prefix
);
5994 gfc_matching_prefix
= false;
5999 /* Copy attributes matched by gfc_match_prefix() to attributes on a symbol. */
6002 copy_prefix (symbol_attribute
*dest
, locus
*where
)
6004 if (dest
->module_procedure
)
6006 if (current_attr
.elemental
)
6007 dest
->elemental
= 1;
6009 if (current_attr
.pure
)
6012 if (current_attr
.recursive
)
6013 dest
->recursive
= 1;
6015 /* Module procedures are unusual in that the 'dest' is copied from
6016 the interface declaration. However, this is an oportunity to
6017 check that the submodule declaration is compliant with the
6019 if (dest
->elemental
&& !current_attr
.elemental
)
6021 gfc_error ("ELEMENTAL prefix in MODULE PROCEDURE interface is "
6022 "missing at %L", where
);
6026 if (dest
->pure
&& !current_attr
.pure
)
6028 gfc_error ("PURE prefix in MODULE PROCEDURE interface is "
6029 "missing at %L", where
);
6033 if (dest
->recursive
&& !current_attr
.recursive
)
6035 gfc_error ("RECURSIVE prefix in MODULE PROCEDURE interface is "
6036 "missing at %L", where
);
6043 if (current_attr
.elemental
&& !gfc_add_elemental (dest
, where
))
6046 if (current_attr
.pure
&& !gfc_add_pure (dest
, where
))
6049 if (current_attr
.recursive
&& !gfc_add_recursive (dest
, where
))
6056 /* Match a formal argument list or, if typeparam is true, a
6057 type_param_name_list. */
6060 gfc_match_formal_arglist (gfc_symbol
*progname
, int st_flag
,
6061 int null_flag
, bool typeparam
)
6063 gfc_formal_arglist
*head
, *tail
, *p
, *q
;
6064 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6067 gfc_formal_arglist
*formal
= NULL
;
6071 /* Keep the interface formal argument list and null it so that the
6072 matching for the new declaration can be done. The numbers and
6073 names of the arguments are checked here. The interface formal
6074 arguments are retained in formal_arglist and the characteristics
6075 are compared in resolve.c(resolve_fl_procedure). See the remark
6076 in get_proc_name about the eventual need to copy the formal_arglist
6077 and populate the formal namespace of the interface symbol. */
6078 if (progname
->attr
.module_procedure
6079 && progname
->attr
.host_assoc
)
6081 formal
= progname
->formal
;
6082 progname
->formal
= NULL
;
6085 if (gfc_match_char ('(') != MATCH_YES
)
6092 if (gfc_match_char (')') == MATCH_YES
)
6097 if (gfc_match_char ('*') == MATCH_YES
)
6100 if (!typeparam
&& !gfc_notify_std (GFC_STD_F95_OBS
,
6101 "Alternate-return argument at %C"))
6107 gfc_error_now ("A parameter name is required at %C");
6111 m
= gfc_match_name (name
);
6115 gfc_error_now ("A parameter name is required at %C");
6119 if (!typeparam
&& gfc_get_symbol (name
, NULL
, &sym
))
6122 && gfc_get_symbol (name
, progname
->f2k_derived
, &sym
))
6126 p
= gfc_get_formal_arglist ();
6138 /* We don't add the VARIABLE flavor because the name could be a
6139 dummy procedure. We don't apply these attributes to formal
6140 arguments of statement functions. */
6141 if (sym
!= NULL
&& !st_flag
6142 && (!gfc_add_dummy(&sym
->attr
, sym
->name
, NULL
)
6143 || !gfc_missing_attr (&sym
->attr
, NULL
)))
6149 /* The name of a program unit can be in a different namespace,
6150 so check for it explicitly. After the statement is accepted,
6151 the name is checked for especially in gfc_get_symbol(). */
6152 if (gfc_new_block
!= NULL
&& sym
!= NULL
&& !typeparam
6153 && strcmp (sym
->name
, gfc_new_block
->name
) == 0)
6155 gfc_error ("Name %qs at %C is the name of the procedure",
6161 if (gfc_match_char (')') == MATCH_YES
)
6164 m
= gfc_match_char (',');
6168 gfc_error_now ("Expected parameter list in type declaration "
6171 gfc_error ("Unexpected junk in formal argument list at %C");
6177 /* Check for duplicate symbols in the formal argument list. */
6180 for (p
= head
; p
->next
; p
= p
->next
)
6185 for (q
= p
->next
; q
; q
= q
->next
)
6186 if (p
->sym
== q
->sym
)
6189 gfc_error_now ("Duplicate name %qs in parameter "
6190 "list at %C", p
->sym
->name
);
6192 gfc_error ("Duplicate symbol %qs in formal argument "
6193 "list at %C", p
->sym
->name
);
6201 if (!gfc_add_explicit_interface (progname
, IFSRC_DECL
, head
, NULL
))
6207 /* gfc_error_now used in following and return with MATCH_YES because
6208 doing otherwise results in a cascade of extraneous errors and in
6209 some cases an ICE in symbol.c(gfc_release_symbol). */
6210 if (progname
->attr
.module_procedure
&& progname
->attr
.host_assoc
)
6212 bool arg_count_mismatch
= false;
6214 if (!formal
&& head
)
6215 arg_count_mismatch
= true;
6217 /* Abbreviated module procedure declaration is not meant to have any
6218 formal arguments! */
6219 if (!progname
->abr_modproc_decl
&& formal
&& !head
)
6220 arg_count_mismatch
= true;
6222 for (p
= formal
, q
= head
; p
&& q
; p
= p
->next
, q
= q
->next
)
6224 if ((p
->next
!= NULL
&& q
->next
== NULL
)
6225 || (p
->next
== NULL
&& q
->next
!= NULL
))
6226 arg_count_mismatch
= true;
6227 else if ((p
->sym
== NULL
&& q
->sym
== NULL
)
6228 || strcmp (p
->sym
->name
, q
->sym
->name
) == 0)
6231 gfc_error_now ("Mismatch in MODULE PROCEDURE formal "
6232 "argument names (%s/%s) at %C",
6233 p
->sym
->name
, q
->sym
->name
);
6236 if (arg_count_mismatch
)
6237 gfc_error_now ("Mismatch in number of MODULE PROCEDURE "
6238 "formal arguments at %C");
6244 gfc_free_formal_arglist (head
);
6249 /* Match a RESULT specification following a function declaration or
6250 ENTRY statement. Also matches the end-of-statement. */
6253 match_result (gfc_symbol
*function
, gfc_symbol
**result
)
6255 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6259 if (gfc_match (" result (") != MATCH_YES
)
6262 m
= gfc_match_name (name
);
6266 /* Get the right paren, and that's it because there could be the
6267 bind(c) attribute after the result clause. */
6268 if (gfc_match_char (')') != MATCH_YES
)
6270 /* TODO: should report the missing right paren here. */
6274 if (strcmp (function
->name
, name
) == 0)
6276 gfc_error ("RESULT variable at %C must be different than function name");
6280 if (gfc_get_symbol (name
, NULL
, &r
))
6283 if (!gfc_add_result (&r
->attr
, r
->name
, NULL
))
6292 /* Match a function suffix, which could be a combination of a result
6293 clause and BIND(C), either one, or neither. The draft does not
6294 require them to come in a specific order. */
6297 gfc_match_suffix (gfc_symbol
*sym
, gfc_symbol
**result
)
6299 match is_bind_c
; /* Found bind(c). */
6300 match is_result
; /* Found result clause. */
6301 match found_match
; /* Status of whether we've found a good match. */
6302 char peek_char
; /* Character we're going to peek at. */
6303 bool allow_binding_name
;
6305 /* Initialize to having found nothing. */
6306 found_match
= MATCH_NO
;
6307 is_bind_c
= MATCH_NO
;
6308 is_result
= MATCH_NO
;
6310 /* Get the next char to narrow between result and bind(c). */
6311 gfc_gobble_whitespace ();
6312 peek_char
= gfc_peek_ascii_char ();
6314 /* C binding names are not allowed for internal procedures. */
6315 if (gfc_current_state () == COMP_CONTAINS
6316 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
6317 allow_binding_name
= false;
6319 allow_binding_name
= true;
6324 /* Look for result clause. */
6325 is_result
= match_result (sym
, result
);
6326 if (is_result
== MATCH_YES
)
6328 /* Now see if there is a bind(c) after it. */
6329 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
6330 /* We've found the result clause and possibly bind(c). */
6331 found_match
= MATCH_YES
;
6334 /* This should only be MATCH_ERROR. */
6335 found_match
= is_result
;
6338 /* Look for bind(c) first. */
6339 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
6340 if (is_bind_c
== MATCH_YES
)
6342 /* Now see if a result clause followed it. */
6343 is_result
= match_result (sym
, result
);
6344 found_match
= MATCH_YES
;
6348 /* Should only be a MATCH_ERROR if we get here after seeing 'b'. */
6349 found_match
= MATCH_ERROR
;
6353 gfc_error ("Unexpected junk after function declaration at %C");
6354 found_match
= MATCH_ERROR
;
6358 if (is_bind_c
== MATCH_YES
)
6360 /* Fortran 2008 draft allows BIND(C) for internal procedures. */
6361 if (gfc_current_state () == COMP_CONTAINS
6362 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
6363 && !gfc_notify_std (GFC_STD_F2008
, "BIND(C) attribute "
6364 "at %L may not be specified for an internal "
6365 "procedure", &gfc_current_locus
))
6368 if (!gfc_add_is_bind_c (&(sym
->attr
), sym
->name
, &gfc_current_locus
, 1))
6376 /* Procedure pointer return value without RESULT statement:
6377 Add "hidden" result variable named "ppr@". */
6380 add_hidden_procptr_result (gfc_symbol
*sym
)
6384 if (gfc_notification_std (GFC_STD_F2003
) == ERROR
)
6387 /* First usage case: PROCEDURE and EXTERNAL statements. */
6388 case1
= gfc_current_state () == COMP_FUNCTION
&& gfc_current_block ()
6389 && strcmp (gfc_current_block ()->name
, sym
->name
) == 0
6390 && sym
->attr
.external
;
6391 /* Second usage case: INTERFACE statements. */
6392 case2
= gfc_current_state () == COMP_INTERFACE
&& gfc_state_stack
->previous
6393 && gfc_state_stack
->previous
->state
== COMP_FUNCTION
6394 && strcmp (gfc_state_stack
->previous
->sym
->name
, sym
->name
) == 0;
6400 gfc_get_sym_tree ("ppr@", gfc_current_ns
, &stree
, false);
6404 gfc_get_sym_tree ("ppr@", gfc_current_ns
->parent
, &stree
, false);
6405 st2
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "ppr@");
6406 st2
->n
.sym
= stree
->n
.sym
;
6407 stree
->n
.sym
->refs
++;
6409 sym
->result
= stree
->n
.sym
;
6411 sym
->result
->attr
.proc_pointer
= sym
->attr
.proc_pointer
;
6412 sym
->result
->attr
.pointer
= sym
->attr
.pointer
;
6413 sym
->result
->attr
.external
= sym
->attr
.external
;
6414 sym
->result
->attr
.referenced
= sym
->attr
.referenced
;
6415 sym
->result
->ts
= sym
->ts
;
6416 sym
->attr
.proc_pointer
= 0;
6417 sym
->attr
.pointer
= 0;
6418 sym
->attr
.external
= 0;
6419 if (sym
->result
->attr
.external
&& sym
->result
->attr
.pointer
)
6421 sym
->result
->attr
.pointer
= 0;
6422 sym
->result
->attr
.proc_pointer
= 1;
6425 return gfc_add_result (&sym
->result
->attr
, sym
->result
->name
, NULL
);
6427 /* POINTER after PROCEDURE/EXTERNAL/INTERFACE statement. */
6428 else if (sym
->attr
.function
&& !sym
->attr
.external
&& sym
->attr
.pointer
6429 && sym
->result
&& sym
->result
!= sym
&& sym
->result
->attr
.external
6430 && sym
== gfc_current_ns
->proc_name
6431 && sym
== sym
->result
->ns
->proc_name
6432 && strcmp ("ppr@", sym
->result
->name
) == 0)
6434 sym
->result
->attr
.proc_pointer
= 1;
6435 sym
->attr
.pointer
= 0;
6443 /* Match the interface for a PROCEDURE declaration,
6444 including brackets (R1212). */
6447 match_procedure_interface (gfc_symbol
**proc_if
)
6451 locus old_loc
, entry_loc
;
6452 gfc_namespace
*old_ns
= gfc_current_ns
;
6453 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6455 old_loc
= entry_loc
= gfc_current_locus
;
6456 gfc_clear_ts (¤t_ts
);
6458 if (gfc_match (" (") != MATCH_YES
)
6460 gfc_current_locus
= entry_loc
;
6464 /* Get the type spec. for the procedure interface. */
6465 old_loc
= gfc_current_locus
;
6466 m
= gfc_match_decl_type_spec (¤t_ts
, 0);
6467 gfc_gobble_whitespace ();
6468 if (m
== MATCH_YES
|| (m
== MATCH_NO
&& gfc_peek_ascii_char () == ')'))
6471 if (m
== MATCH_ERROR
)
6474 /* Procedure interface is itself a procedure. */
6475 gfc_current_locus
= old_loc
;
6476 m
= gfc_match_name (name
);
6478 /* First look to see if it is already accessible in the current
6479 namespace because it is use associated or contained. */
6481 if (gfc_find_sym_tree (name
, NULL
, 0, &st
))
6484 /* If it is still not found, then try the parent namespace, if it
6485 exists and create the symbol there if it is still not found. */
6486 if (gfc_current_ns
->parent
)
6487 gfc_current_ns
= gfc_current_ns
->parent
;
6488 if (st
== NULL
&& gfc_get_ha_sym_tree (name
, &st
))
6491 gfc_current_ns
= old_ns
;
6492 *proc_if
= st
->n
.sym
;
6497 /* Resolve interface if possible. That way, attr.procedure is only set
6498 if it is declared by a later procedure-declaration-stmt, which is
6499 invalid per F08:C1216 (cf. resolve_procedure_interface). */
6500 while ((*proc_if
)->ts
.interface
6501 && *proc_if
!= (*proc_if
)->ts
.interface
)
6502 *proc_if
= (*proc_if
)->ts
.interface
;
6504 if ((*proc_if
)->attr
.flavor
== FL_UNKNOWN
6505 && (*proc_if
)->ts
.type
== BT_UNKNOWN
6506 && !gfc_add_flavor (&(*proc_if
)->attr
, FL_PROCEDURE
,
6507 (*proc_if
)->name
, NULL
))
6512 if (gfc_match (" )") != MATCH_YES
)
6514 gfc_current_locus
= entry_loc
;
6522 /* Match a PROCEDURE declaration (R1211). */
6525 match_procedure_decl (void)
6528 gfc_symbol
*sym
, *proc_if
= NULL
;
6530 gfc_expr
*initializer
= NULL
;
6532 /* Parse interface (with brackets). */
6533 m
= match_procedure_interface (&proc_if
);
6537 /* Parse attributes (with colons). */
6538 m
= match_attr_spec();
6539 if (m
== MATCH_ERROR
)
6542 if (proc_if
&& proc_if
->attr
.is_bind_c
&& !current_attr
.is_bind_c
)
6544 current_attr
.is_bind_c
= 1;
6545 has_name_equals
= 0;
6546 curr_binding_label
= NULL
;
6549 /* Get procedure symbols. */
6552 m
= gfc_match_symbol (&sym
, 0);
6555 else if (m
== MATCH_ERROR
)
6558 /* Add current_attr to the symbol attributes. */
6559 if (!gfc_copy_attr (&sym
->attr
, ¤t_attr
, NULL
))
6562 if (sym
->attr
.is_bind_c
)
6564 /* Check for C1218. */
6565 if (!proc_if
|| !proc_if
->attr
.is_bind_c
)
6567 gfc_error ("BIND(C) attribute at %C requires "
6568 "an interface with BIND(C)");
6571 /* Check for C1217. */
6572 if (has_name_equals
&& sym
->attr
.pointer
)
6574 gfc_error ("BIND(C) procedure with NAME may not have "
6575 "POINTER attribute at %C");
6578 if (has_name_equals
&& sym
->attr
.dummy
)
6580 gfc_error ("Dummy procedure at %C may not have "
6581 "BIND(C) attribute with NAME");
6584 /* Set binding label for BIND(C). */
6585 if (!set_binding_label (&sym
->binding_label
, sym
->name
, num
))
6589 if (!gfc_add_external (&sym
->attr
, NULL
))
6592 if (add_hidden_procptr_result (sym
))
6595 if (!gfc_add_proc (&sym
->attr
, sym
->name
, NULL
))
6598 /* Set interface. */
6599 if (proc_if
!= NULL
)
6601 if (sym
->ts
.type
!= BT_UNKNOWN
)
6603 gfc_error ("Procedure %qs at %L already has basic type of %s",
6604 sym
->name
, &gfc_current_locus
,
6605 gfc_basic_typename (sym
->ts
.type
));
6608 sym
->ts
.interface
= proc_if
;
6609 sym
->attr
.untyped
= 1;
6610 sym
->attr
.if_source
= IFSRC_IFBODY
;
6612 else if (current_ts
.type
!= BT_UNKNOWN
)
6614 if (!gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
6616 sym
->ts
.interface
= gfc_new_symbol ("", gfc_current_ns
);
6617 sym
->ts
.interface
->ts
= current_ts
;
6618 sym
->ts
.interface
->attr
.flavor
= FL_PROCEDURE
;
6619 sym
->ts
.interface
->attr
.function
= 1;
6620 sym
->attr
.function
= 1;
6621 sym
->attr
.if_source
= IFSRC_UNKNOWN
;
6624 if (gfc_match (" =>") == MATCH_YES
)
6626 if (!current_attr
.pointer
)
6628 gfc_error ("Initialization at %C isn't for a pointer variable");
6633 m
= match_pointer_init (&initializer
, 1);
6637 if (!add_init_expr_to_sym (sym
->name
, &initializer
, &gfc_current_locus
))
6642 if (gfc_match_eos () == MATCH_YES
)
6644 if (gfc_match_char (',') != MATCH_YES
)
6649 gfc_error ("Syntax error in PROCEDURE statement at %C");
6653 /* Free stuff up and return. */
6654 gfc_free_expr (initializer
);
6660 match_binding_attributes (gfc_typebound_proc
* ba
, bool generic
, bool ppc
);
6663 /* Match a procedure pointer component declaration (R445). */
6666 match_ppc_decl (void)
6669 gfc_symbol
*proc_if
= NULL
;
6673 gfc_expr
*initializer
= NULL
;
6674 gfc_typebound_proc
* tb
;
6675 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6677 /* Parse interface (with brackets). */
6678 m
= match_procedure_interface (&proc_if
);
6682 /* Parse attributes. */
6683 tb
= XCNEW (gfc_typebound_proc
);
6684 tb
->where
= gfc_current_locus
;
6685 m
= match_binding_attributes (tb
, false, true);
6686 if (m
== MATCH_ERROR
)
6689 gfc_clear_attr (¤t_attr
);
6690 current_attr
.procedure
= 1;
6691 current_attr
.proc_pointer
= 1;
6692 current_attr
.access
= tb
->access
;
6693 current_attr
.flavor
= FL_PROCEDURE
;
6695 /* Match the colons (required). */
6696 if (gfc_match (" ::") != MATCH_YES
)
6698 gfc_error ("Expected %<::%> after binding-attributes at %C");
6702 /* Check for C450. */
6703 if (!tb
->nopass
&& proc_if
== NULL
)
6705 gfc_error("NOPASS or explicit interface required at %C");
6709 if (!gfc_notify_std (GFC_STD_F2003
, "Procedure pointer component at %C"))
6712 /* Match PPC names. */
6716 m
= gfc_match_name (name
);
6719 else if (m
== MATCH_ERROR
)
6722 if (!gfc_add_component (gfc_current_block(), name
, &c
))
6725 /* Add current_attr to the symbol attributes. */
6726 if (!gfc_copy_attr (&c
->attr
, ¤t_attr
, NULL
))
6729 if (!gfc_add_external (&c
->attr
, NULL
))
6732 if (!gfc_add_proc (&c
->attr
, name
, NULL
))
6739 c
->tb
= XCNEW (gfc_typebound_proc
);
6740 c
->tb
->where
= gfc_current_locus
;
6744 /* Set interface. */
6745 if (proc_if
!= NULL
)
6747 c
->ts
.interface
= proc_if
;
6748 c
->attr
.untyped
= 1;
6749 c
->attr
.if_source
= IFSRC_IFBODY
;
6751 else if (ts
.type
!= BT_UNKNOWN
)
6754 c
->ts
.interface
= gfc_new_symbol ("", gfc_current_ns
);
6755 c
->ts
.interface
->result
= c
->ts
.interface
;
6756 c
->ts
.interface
->ts
= ts
;
6757 c
->ts
.interface
->attr
.flavor
= FL_PROCEDURE
;
6758 c
->ts
.interface
->attr
.function
= 1;
6759 c
->attr
.function
= 1;
6760 c
->attr
.if_source
= IFSRC_UNKNOWN
;
6763 if (gfc_match (" =>") == MATCH_YES
)
6765 m
= match_pointer_init (&initializer
, 1);
6768 gfc_free_expr (initializer
);
6771 c
->initializer
= initializer
;
6774 if (gfc_match_eos () == MATCH_YES
)
6776 if (gfc_match_char (',') != MATCH_YES
)
6781 gfc_error ("Syntax error in procedure pointer component at %C");
6786 /* Match a PROCEDURE declaration inside an interface (R1206). */
6789 match_procedure_in_interface (void)
6793 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6796 if (current_interface
.type
== INTERFACE_NAMELESS
6797 || current_interface
.type
== INTERFACE_ABSTRACT
)
6799 gfc_error ("PROCEDURE at %C must be in a generic interface");
6803 /* Check if the F2008 optional double colon appears. */
6804 gfc_gobble_whitespace ();
6805 old_locus
= gfc_current_locus
;
6806 if (gfc_match ("::") == MATCH_YES
)
6808 if (!gfc_notify_std (GFC_STD_F2008
, "double colon in "
6809 "MODULE PROCEDURE statement at %L", &old_locus
))
6813 gfc_current_locus
= old_locus
;
6817 m
= gfc_match_name (name
);
6820 else if (m
== MATCH_ERROR
)
6822 if (gfc_get_symbol (name
, gfc_current_ns
->parent
, &sym
))
6825 if (!gfc_add_interface (sym
))
6828 if (gfc_match_eos () == MATCH_YES
)
6830 if (gfc_match_char (',') != MATCH_YES
)
6837 gfc_error ("Syntax error in PROCEDURE statement at %C");
6842 /* General matcher for PROCEDURE declarations. */
6844 static match
match_procedure_in_type (void);
6847 gfc_match_procedure (void)
6851 switch (gfc_current_state ())
6856 case COMP_SUBMODULE
:
6857 case COMP_SUBROUTINE
:
6860 m
= match_procedure_decl ();
6862 case COMP_INTERFACE
:
6863 m
= match_procedure_in_interface ();
6866 m
= match_ppc_decl ();
6868 case COMP_DERIVED_CONTAINS
:
6869 m
= match_procedure_in_type ();
6878 if (!gfc_notify_std (GFC_STD_F2003
, "PROCEDURE statement at %C"))
6885 /* Warn if a matched procedure has the same name as an intrinsic; this is
6886 simply a wrapper around gfc_warn_intrinsic_shadow that interprets the current
6887 parser-state-stack to find out whether we're in a module. */
6890 do_warn_intrinsic_shadow (const gfc_symbol
* sym
, bool func
)
6894 in_module
= (gfc_state_stack
->previous
6895 && (gfc_state_stack
->previous
->state
== COMP_MODULE
6896 || gfc_state_stack
->previous
->state
== COMP_SUBMODULE
));
6898 gfc_warn_intrinsic_shadow (sym
, in_module
, func
);
6902 /* Match a function declaration. */
6905 gfc_match_function_decl (void)
6907 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6908 gfc_symbol
*sym
, *result
;
6912 match found_match
; /* Status returned by match func. */
6914 if (gfc_current_state () != COMP_NONE
6915 && gfc_current_state () != COMP_INTERFACE
6916 && gfc_current_state () != COMP_CONTAINS
)
6919 gfc_clear_ts (¤t_ts
);
6921 old_loc
= gfc_current_locus
;
6923 m
= gfc_match_prefix (¤t_ts
);
6926 gfc_current_locus
= old_loc
;
6930 if (gfc_match ("function% %n", name
) != MATCH_YES
)
6932 gfc_current_locus
= old_loc
;
6936 if (get_proc_name (name
, &sym
, false))
6939 if (add_hidden_procptr_result (sym
))
6942 if (current_attr
.module_procedure
)
6943 sym
->attr
.module_procedure
= 1;
6945 gfc_new_block
= sym
;
6947 m
= gfc_match_formal_arglist (sym
, 0, 0);
6950 gfc_error ("Expected formal argument list in function "
6951 "definition at %C");
6955 else if (m
== MATCH_ERROR
)
6960 /* According to the draft, the bind(c) and result clause can
6961 come in either order after the formal_arg_list (i.e., either
6962 can be first, both can exist together or by themselves or neither
6963 one). Therefore, the match_result can't match the end of the
6964 string, and check for the bind(c) or result clause in either order. */
6965 found_match
= gfc_match_eos ();
6967 /* Make sure that it isn't already declared as BIND(C). If it is, it
6968 must have been marked BIND(C) with a BIND(C) attribute and that is
6969 not allowed for procedures. */
6970 if (sym
->attr
.is_bind_c
== 1)
6972 sym
->attr
.is_bind_c
= 0;
6973 if (sym
->old_symbol
!= NULL
)
6974 gfc_error_now ("BIND(C) attribute at %L can only be used for "
6975 "variables or common blocks",
6976 &(sym
->old_symbol
->declared_at
));
6978 gfc_error_now ("BIND(C) attribute at %L can only be used for "
6979 "variables or common blocks", &gfc_current_locus
);
6982 if (found_match
!= MATCH_YES
)
6984 /* If we haven't found the end-of-statement, look for a suffix. */
6985 suffix_match
= gfc_match_suffix (sym
, &result
);
6986 if (suffix_match
== MATCH_YES
)
6987 /* Need to get the eos now. */
6988 found_match
= gfc_match_eos ();
6990 found_match
= suffix_match
;
6993 if(found_match
!= MATCH_YES
)
6997 /* Make changes to the symbol. */
7000 if (!gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
7003 if (!gfc_missing_attr (&sym
->attr
, NULL
))
7006 if (!copy_prefix (&sym
->attr
, &sym
->declared_at
))
7008 if(!sym
->attr
.module_procedure
)
7014 /* Delay matching the function characteristics until after the
7015 specification block by signalling kind=-1. */
7016 sym
->declared_at
= old_loc
;
7017 if (current_ts
.type
!= BT_UNKNOWN
)
7018 current_ts
.kind
= -1;
7020 current_ts
.kind
= 0;
7024 if (current_ts
.type
!= BT_UNKNOWN
7025 && !gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
7031 if (current_ts
.type
!= BT_UNKNOWN
7032 && !gfc_add_type (result
, ¤t_ts
, &gfc_current_locus
))
7034 sym
->result
= result
;
7037 /* Warn if this procedure has the same name as an intrinsic. */
7038 do_warn_intrinsic_shadow (sym
, true);
7044 gfc_current_locus
= old_loc
;
7049 /* This is mostly a copy of parse.c(add_global_procedure) but modified to
7050 pass the name of the entry, rather than the gfc_current_block name, and
7051 to return false upon finding an existing global entry. */
7054 add_global_entry (const char *name
, const char *binding_label
, bool sub
,
7058 enum gfc_symbol_type type
;
7060 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
7062 /* Only in Fortran 2003: For procedures with a binding label also the Fortran
7063 name is a global identifier. */
7064 if (!binding_label
|| gfc_notification_std (GFC_STD_F2008
))
7066 s
= gfc_get_gsymbol (name
);
7068 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= type
))
7070 gfc_global_used (s
, where
);
7079 s
->ns
= gfc_current_ns
;
7083 /* Don't add the symbol multiple times. */
7085 && (!gfc_notification_std (GFC_STD_F2008
)
7086 || strcmp (name
, binding_label
) != 0))
7088 s
= gfc_get_gsymbol (binding_label
);
7090 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= type
))
7092 gfc_global_used (s
, where
);
7099 s
->binding_label
= binding_label
;
7102 s
->ns
= gfc_current_ns
;
7110 /* Match an ENTRY statement. */
7113 gfc_match_entry (void)
7118 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7119 gfc_compile_state state
;
7123 bool module_procedure
;
7127 m
= gfc_match_name (name
);
7131 if (!gfc_notify_std (GFC_STD_F2008_OBS
, "ENTRY statement at %C"))
7134 state
= gfc_current_state ();
7135 if (state
!= COMP_SUBROUTINE
&& state
!= COMP_FUNCTION
)
7140 gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
7143 gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
7145 case COMP_SUBMODULE
:
7146 gfc_error ("ENTRY statement at %C cannot appear within a SUBMODULE");
7148 case COMP_BLOCK_DATA
:
7149 gfc_error ("ENTRY statement at %C cannot appear within "
7152 case COMP_INTERFACE
:
7153 gfc_error ("ENTRY statement at %C cannot appear within "
7156 case COMP_STRUCTURE
:
7157 gfc_error ("ENTRY statement at %C cannot appear within "
7158 "a STRUCTURE block");
7161 gfc_error ("ENTRY statement at %C cannot appear within "
7162 "a DERIVED TYPE block");
7165 gfc_error ("ENTRY statement at %C cannot appear within "
7166 "an IF-THEN block");
7169 case COMP_DO_CONCURRENT
:
7170 gfc_error ("ENTRY statement at %C cannot appear within "
7174 gfc_error ("ENTRY statement at %C cannot appear within "
7178 gfc_error ("ENTRY statement at %C cannot appear within "
7182 gfc_error ("ENTRY statement at %C cannot appear within "
7186 gfc_error ("ENTRY statement at %C cannot appear within "
7187 "a contained subprogram");
7190 gfc_error ("Unexpected ENTRY statement at %C");
7195 if ((state
== COMP_SUBROUTINE
|| state
== COMP_FUNCTION
)
7196 && gfc_state_stack
->previous
->state
== COMP_INTERFACE
)
7198 gfc_error ("ENTRY statement at %C cannot appear within an INTERFACE");
7202 module_procedure
= gfc_current_ns
->parent
!= NULL
7203 && gfc_current_ns
->parent
->proc_name
7204 && gfc_current_ns
->parent
->proc_name
->attr
.flavor
7207 if (gfc_current_ns
->parent
!= NULL
7208 && gfc_current_ns
->parent
->proc_name
7209 && !module_procedure
)
7211 gfc_error("ENTRY statement at %C cannot appear in a "
7212 "contained procedure");
7216 /* Module function entries need special care in get_proc_name
7217 because previous references within the function will have
7218 created symbols attached to the current namespace. */
7219 if (get_proc_name (name
, &entry
,
7220 gfc_current_ns
->parent
!= NULL
7221 && module_procedure
))
7224 proc
= gfc_current_block ();
7226 /* Make sure that it isn't already declared as BIND(C). If it is, it
7227 must have been marked BIND(C) with a BIND(C) attribute and that is
7228 not allowed for procedures. */
7229 if (entry
->attr
.is_bind_c
== 1)
7231 entry
->attr
.is_bind_c
= 0;
7232 if (entry
->old_symbol
!= NULL
)
7233 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7234 "variables or common blocks",
7235 &(entry
->old_symbol
->declared_at
));
7237 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7238 "variables or common blocks", &gfc_current_locus
);
7241 /* Check what next non-whitespace character is so we can tell if there
7242 is the required parens if we have a BIND(C). */
7243 old_loc
= gfc_current_locus
;
7244 gfc_gobble_whitespace ();
7245 peek_char
= gfc_peek_ascii_char ();
7247 if (state
== COMP_SUBROUTINE
)
7249 m
= gfc_match_formal_arglist (entry
, 0, 1);
7253 /* Call gfc_match_bind_c with allow_binding_name = true as ENTRY can
7254 never be an internal procedure. */
7255 is_bind_c
= gfc_match_bind_c (entry
, true);
7256 if (is_bind_c
== MATCH_ERROR
)
7258 if (is_bind_c
== MATCH_YES
)
7260 if (peek_char
!= '(')
7262 gfc_error ("Missing required parentheses before BIND(C) at %C");
7265 if (!gfc_add_is_bind_c (&(entry
->attr
), entry
->name
,
7266 &(entry
->declared_at
), 1))
7270 if (!gfc_current_ns
->parent
7271 && !add_global_entry (name
, entry
->binding_label
, true,
7275 /* An entry in a subroutine. */
7276 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
7277 || !gfc_add_subroutine (&entry
->attr
, entry
->name
, NULL
))
7282 /* An entry in a function.
7283 We need to take special care because writing
7288 ENTRY f() RESULT (r)
7290 ENTRY f RESULT (r). */
7291 if (gfc_match_eos () == MATCH_YES
)
7293 gfc_current_locus
= old_loc
;
7294 /* Match the empty argument list, and add the interface to
7296 m
= gfc_match_formal_arglist (entry
, 0, 1);
7299 m
= gfc_match_formal_arglist (entry
, 0, 0);
7306 if (gfc_match_eos () == MATCH_YES
)
7308 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
7309 || !gfc_add_function (&entry
->attr
, entry
->name
, NULL
))
7312 entry
->result
= entry
;
7316 m
= gfc_match_suffix (entry
, &result
);
7318 gfc_syntax_error (ST_ENTRY
);
7324 if (!gfc_add_result (&result
->attr
, result
->name
, NULL
)
7325 || !gfc_add_entry (&entry
->attr
, result
->name
, NULL
)
7326 || !gfc_add_function (&entry
->attr
, result
->name
, NULL
))
7328 entry
->result
= result
;
7332 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
7333 || !gfc_add_function (&entry
->attr
, entry
->name
, NULL
))
7335 entry
->result
= entry
;
7339 if (!gfc_current_ns
->parent
7340 && !add_global_entry (name
, entry
->binding_label
, false,
7345 if (gfc_match_eos () != MATCH_YES
)
7347 gfc_syntax_error (ST_ENTRY
);
7351 entry
->attr
.recursive
= proc
->attr
.recursive
;
7352 entry
->attr
.elemental
= proc
->attr
.elemental
;
7353 entry
->attr
.pure
= proc
->attr
.pure
;
7355 el
= gfc_get_entry_list ();
7357 el
->next
= gfc_current_ns
->entries
;
7358 gfc_current_ns
->entries
= el
;
7360 el
->id
= el
->next
->id
+ 1;
7364 new_st
.op
= EXEC_ENTRY
;
7365 new_st
.ext
.entry
= el
;
7371 /* Match a subroutine statement, including optional prefixes. */
7374 gfc_match_subroutine (void)
7376 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7381 bool allow_binding_name
;
7383 if (gfc_current_state () != COMP_NONE
7384 && gfc_current_state () != COMP_INTERFACE
7385 && gfc_current_state () != COMP_CONTAINS
)
7388 m
= gfc_match_prefix (NULL
);
7392 m
= gfc_match ("subroutine% %n", name
);
7396 if (get_proc_name (name
, &sym
, false))
7399 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
7400 the symbol existed before. */
7401 sym
->declared_at
= gfc_current_locus
;
7403 if (current_attr
.module_procedure
)
7404 sym
->attr
.module_procedure
= 1;
7406 if (add_hidden_procptr_result (sym
))
7409 gfc_new_block
= sym
;
7411 /* Check what next non-whitespace character is so we can tell if there
7412 is the required parens if we have a BIND(C). */
7413 gfc_gobble_whitespace ();
7414 peek_char
= gfc_peek_ascii_char ();
7416 if (!gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
))
7419 if (gfc_match_formal_arglist (sym
, 0, 1) != MATCH_YES
)
7422 /* Make sure that it isn't already declared as BIND(C). If it is, it
7423 must have been marked BIND(C) with a BIND(C) attribute and that is
7424 not allowed for procedures. */
7425 if (sym
->attr
.is_bind_c
== 1)
7427 sym
->attr
.is_bind_c
= 0;
7428 if (sym
->old_symbol
!= NULL
)
7429 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7430 "variables or common blocks",
7431 &(sym
->old_symbol
->declared_at
));
7433 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7434 "variables or common blocks", &gfc_current_locus
);
7437 /* C binding names are not allowed for internal procedures. */
7438 if (gfc_current_state () == COMP_CONTAINS
7439 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
7440 allow_binding_name
= false;
7442 allow_binding_name
= true;
7444 /* Here, we are just checking if it has the bind(c) attribute, and if
7445 so, then we need to make sure it's all correct. If it doesn't,
7446 we still need to continue matching the rest of the subroutine line. */
7447 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
7448 if (is_bind_c
== MATCH_ERROR
)
7450 /* There was an attempt at the bind(c), but it was wrong. An
7451 error message should have been printed w/in the gfc_match_bind_c
7452 so here we'll just return the MATCH_ERROR. */
7456 if (is_bind_c
== MATCH_YES
)
7458 /* The following is allowed in the Fortran 2008 draft. */
7459 if (gfc_current_state () == COMP_CONTAINS
7460 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
7461 && !gfc_notify_std (GFC_STD_F2008
, "BIND(C) attribute "
7462 "at %L may not be specified for an internal "
7463 "procedure", &gfc_current_locus
))
7466 if (peek_char
!= '(')
7468 gfc_error ("Missing required parentheses before BIND(C) at %C");
7471 if (!gfc_add_is_bind_c (&(sym
->attr
), sym
->name
,
7472 &(sym
->declared_at
), 1))
7476 if (gfc_match_eos () != MATCH_YES
)
7478 gfc_syntax_error (ST_SUBROUTINE
);
7482 if (!copy_prefix (&sym
->attr
, &sym
->declared_at
))
7484 if(!sym
->attr
.module_procedure
)
7490 /* Warn if it has the same name as an intrinsic. */
7491 do_warn_intrinsic_shadow (sym
, false);
7497 /* Check that the NAME identifier in a BIND attribute or statement
7498 is conform to C identifier rules. */
7501 check_bind_name_identifier (char **name
)
7503 char *n
= *name
, *p
;
7505 /* Remove leading spaces. */
7509 /* On an empty string, free memory and set name to NULL. */
7517 /* Remove trailing spaces. */
7518 p
= n
+ strlen(n
) - 1;
7522 /* Insert the identifier into the symbol table. */
7527 /* Now check that identifier is valid under C rules. */
7530 gfc_error ("Invalid C identifier in NAME= specifier at %C");
7535 if (!(ISALNUM (*p
) || *p
== '_' || *p
== '$'))
7537 gfc_error ("Invalid C identifier in NAME= specifier at %C");
7545 /* Match a BIND(C) specifier, with the optional 'name=' specifier if
7546 given, and set the binding label in either the given symbol (if not
7547 NULL), or in the current_ts. The symbol may be NULL because we may
7548 encounter the BIND(C) before the declaration itself. Return
7549 MATCH_NO if what we're looking at isn't a BIND(C) specifier,
7550 MATCH_ERROR if it is a BIND(C) clause but an error was encountered,
7551 or MATCH_YES if the specifier was correct and the binding label and
7552 bind(c) fields were set correctly for the given symbol or the
7553 current_ts. If allow_binding_name is false, no binding name may be
7557 gfc_match_bind_c (gfc_symbol
*sym
, bool allow_binding_name
)
7559 char *binding_label
= NULL
;
7562 /* Initialize the flag that specifies whether we encountered a NAME=
7563 specifier or not. */
7564 has_name_equals
= 0;
7566 /* This much we have to be able to match, in this order, if
7567 there is a bind(c) label. */
7568 if (gfc_match (" bind ( c ") != MATCH_YES
)
7571 /* Now see if there is a binding label, or if we've reached the
7572 end of the bind(c) attribute without one. */
7573 if (gfc_match_char (',') == MATCH_YES
)
7575 if (gfc_match (" name = ") != MATCH_YES
)
7577 gfc_error ("Syntax error in NAME= specifier for binding label "
7579 /* should give an error message here */
7583 has_name_equals
= 1;
7585 if (gfc_match_init_expr (&e
) != MATCH_YES
)
7591 if (!gfc_simplify_expr(e
, 0))
7593 gfc_error ("NAME= specifier at %C should be a constant expression");
7598 if (e
->expr_type
!= EXPR_CONSTANT
|| e
->ts
.type
!= BT_CHARACTER
7599 || e
->ts
.kind
!= gfc_default_character_kind
|| e
->rank
!= 0)
7601 gfc_error ("NAME= specifier at %C should be a scalar of "
7602 "default character kind");
7607 // Get a C string from the Fortran string constant
7608 binding_label
= gfc_widechar_to_char (e
->value
.character
.string
,
7609 e
->value
.character
.length
);
7612 // Check that it is valid (old gfc_match_name_C)
7613 if (check_bind_name_identifier (&binding_label
) != MATCH_YES
)
7617 /* Get the required right paren. */
7618 if (gfc_match_char (')') != MATCH_YES
)
7620 gfc_error ("Missing closing paren for binding label at %C");
7624 if (has_name_equals
&& !allow_binding_name
)
7626 gfc_error ("No binding name is allowed in BIND(C) at %C");
7630 if (has_name_equals
&& sym
!= NULL
&& sym
->attr
.dummy
)
7632 gfc_error ("For dummy procedure %s, no binding name is "
7633 "allowed in BIND(C) at %C", sym
->name
);
7638 /* Save the binding label to the symbol. If sym is null, we're
7639 probably matching the typespec attributes of a declaration and
7640 haven't gotten the name yet, and therefore, no symbol yet. */
7644 sym
->binding_label
= binding_label
;
7646 curr_binding_label
= binding_label
;
7648 else if (allow_binding_name
)
7650 /* No binding label, but if symbol isn't null, we
7651 can set the label for it here.
7652 If name="" or allow_binding_name is false, no C binding name is
7654 if (sym
!= NULL
&& sym
->name
!= NULL
&& has_name_equals
== 0)
7655 sym
->binding_label
= IDENTIFIER_POINTER (get_identifier (sym
->name
));
7658 if (has_name_equals
&& gfc_current_state () == COMP_INTERFACE
7659 && current_interface
.type
== INTERFACE_ABSTRACT
)
7661 gfc_error ("NAME not allowed on BIND(C) for ABSTRACT INTERFACE at %C");
7669 /* Return nonzero if we're currently compiling a contained procedure. */
7672 contained_procedure (void)
7674 gfc_state_data
*s
= gfc_state_stack
;
7676 if ((s
->state
== COMP_SUBROUTINE
|| s
->state
== COMP_FUNCTION
)
7677 && s
->previous
!= NULL
&& s
->previous
->state
== COMP_CONTAINS
)
7683 /* Set the kind of each enumerator. The kind is selected such that it is
7684 interoperable with the corresponding C enumeration type, making
7685 sure that -fshort-enums is honored. */
7690 enumerator_history
*current_history
= NULL
;
7694 if (max_enum
== NULL
|| enum_history
== NULL
)
7697 if (!flag_short_enums
)
7703 kind
= gfc_integer_kinds
[i
++].kind
;
7705 while (kind
< gfc_c_int_kind
7706 && gfc_check_integer_range (max_enum
->initializer
->value
.integer
,
7709 current_history
= enum_history
;
7710 while (current_history
!= NULL
)
7712 current_history
->sym
->ts
.kind
= kind
;
7713 current_history
= current_history
->next
;
7718 /* Match any of the various end-block statements. Returns the type of
7719 END to the caller. The END INTERFACE, END IF, END DO, END SELECT
7720 and END BLOCK statements cannot be replaced by a single END statement. */
7723 gfc_match_end (gfc_statement
*st
)
7725 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7726 gfc_compile_state state
;
7728 const char *block_name
;
7732 gfc_namespace
*parent_ns
, *ns
, *prev_ns
;
7733 gfc_namespace
**nsp
;
7734 bool abreviated_modproc_decl
= false;
7735 bool got_matching_end
= false;
7737 old_loc
= gfc_current_locus
;
7738 if (gfc_match ("end") != MATCH_YES
)
7741 state
= gfc_current_state ();
7742 block_name
= gfc_current_block () == NULL
7743 ? NULL
: gfc_current_block ()->name
;
7747 case COMP_ASSOCIATE
:
7749 if (!strncmp (block_name
, "block@", strlen("block@")))
7754 case COMP_DERIVED_CONTAINS
:
7755 state
= gfc_state_stack
->previous
->state
;
7756 block_name
= gfc_state_stack
->previous
->sym
== NULL
7757 ? NULL
: gfc_state_stack
->previous
->sym
->name
;
7758 abreviated_modproc_decl
= gfc_state_stack
->previous
->sym
7759 && gfc_state_stack
->previous
->sym
->abr_modproc_decl
;
7766 if (!abreviated_modproc_decl
)
7767 abreviated_modproc_decl
= gfc_current_block ()
7768 && gfc_current_block ()->abr_modproc_decl
;
7774 *st
= ST_END_PROGRAM
;
7775 target
= " program";
7779 case COMP_SUBROUTINE
:
7780 *st
= ST_END_SUBROUTINE
;
7781 if (!abreviated_modproc_decl
)
7782 target
= " subroutine";
7784 target
= " procedure";
7785 eos_ok
= !contained_procedure ();
7789 *st
= ST_END_FUNCTION
;
7790 if (!abreviated_modproc_decl
)
7791 target
= " function";
7793 target
= " procedure";
7794 eos_ok
= !contained_procedure ();
7797 case COMP_BLOCK_DATA
:
7798 *st
= ST_END_BLOCK_DATA
;
7799 target
= " block data";
7804 *st
= ST_END_MODULE
;
7809 case COMP_SUBMODULE
:
7810 *st
= ST_END_SUBMODULE
;
7811 target
= " submodule";
7815 case COMP_INTERFACE
:
7816 *st
= ST_END_INTERFACE
;
7817 target
= " interface";
7833 case COMP_STRUCTURE
:
7834 *st
= ST_END_STRUCTURE
;
7835 target
= " structure";
7840 case COMP_DERIVED_CONTAINS
:
7846 case COMP_ASSOCIATE
:
7847 *st
= ST_END_ASSOCIATE
;
7848 target
= " associate";
7865 case COMP_DO_CONCURRENT
:
7872 *st
= ST_END_CRITICAL
;
7873 target
= " critical";
7878 case COMP_SELECT_TYPE
:
7879 *st
= ST_END_SELECT
;
7885 *st
= ST_END_FORALL
;
7900 last_initializer
= NULL
;
7902 gfc_free_enum_history ();
7906 gfc_error ("Unexpected END statement at %C");
7910 old_loc
= gfc_current_locus
;
7911 if (gfc_match_eos () == MATCH_YES
)
7913 if (!eos_ok
&& (*st
== ST_END_SUBROUTINE
|| *st
== ST_END_FUNCTION
))
7915 if (!gfc_notify_std (GFC_STD_F2008
, "END statement "
7916 "instead of %s statement at %L",
7917 abreviated_modproc_decl
? "END PROCEDURE"
7918 : gfc_ascii_statement(*st
), &old_loc
))
7923 /* We would have required END [something]. */
7924 gfc_error ("%s statement expected at %L",
7925 gfc_ascii_statement (*st
), &old_loc
);
7932 /* Verify that we've got the sort of end-block that we're expecting. */
7933 if (gfc_match (target
) != MATCH_YES
)
7935 gfc_error ("Expecting %s statement at %L", abreviated_modproc_decl
7936 ? "END PROCEDURE" : gfc_ascii_statement(*st
), &old_loc
);
7940 got_matching_end
= true;
7942 old_loc
= gfc_current_locus
;
7943 /* If we're at the end, make sure a block name wasn't required. */
7944 if (gfc_match_eos () == MATCH_YES
)
7947 if (*st
!= ST_ENDDO
&& *st
!= ST_ENDIF
&& *st
!= ST_END_SELECT
7948 && *st
!= ST_END_FORALL
&& *st
!= ST_END_WHERE
&& *st
!= ST_END_BLOCK
7949 && *st
!= ST_END_ASSOCIATE
&& *st
!= ST_END_CRITICAL
)
7955 gfc_error ("Expected block name of %qs in %s statement at %L",
7956 block_name
, gfc_ascii_statement (*st
), &old_loc
);
7961 /* END INTERFACE has a special handler for its several possible endings. */
7962 if (*st
== ST_END_INTERFACE
)
7963 return gfc_match_end_interface ();
7965 /* We haven't hit the end of statement, so what is left must be an
7967 m
= gfc_match_space ();
7969 m
= gfc_match_name (name
);
7972 gfc_error ("Expected terminating name at %C");
7976 if (block_name
== NULL
)
7979 /* We have to pick out the declared submodule name from the composite
7980 required by F2008:11.2.3 para 2, which ends in the declared name. */
7981 if (state
== COMP_SUBMODULE
)
7982 block_name
= strchr (block_name
, '.') + 1;
7984 if (strcmp (name
, block_name
) != 0 && strcmp (block_name
, "ppr@") != 0)
7986 gfc_error ("Expected label %qs for %s statement at %C", block_name
,
7987 gfc_ascii_statement (*st
));
7990 /* Procedure pointer as function result. */
7991 else if (strcmp (block_name
, "ppr@") == 0
7992 && strcmp (name
, gfc_current_block ()->ns
->proc_name
->name
) != 0)
7994 gfc_error ("Expected label %qs for %s statement at %C",
7995 gfc_current_block ()->ns
->proc_name
->name
,
7996 gfc_ascii_statement (*st
));
8000 if (gfc_match_eos () == MATCH_YES
)
8004 gfc_syntax_error (*st
);
8007 gfc_current_locus
= old_loc
;
8009 /* If we are missing an END BLOCK, we created a half-ready namespace.
8010 Remove it from the parent namespace's sibling list. */
8012 while (state
== COMP_BLOCK
&& !got_matching_end
)
8014 parent_ns
= gfc_current_ns
->parent
;
8016 nsp
= &(gfc_state_stack
->previous
->tail
->ext
.block
.ns
);
8022 if (ns
== gfc_current_ns
)
8024 if (prev_ns
== NULL
)
8027 prev_ns
->sibling
= ns
->sibling
;
8033 gfc_free_namespace (gfc_current_ns
);
8034 gfc_current_ns
= parent_ns
;
8035 gfc_state_stack
= gfc_state_stack
->previous
;
8036 state
= gfc_current_state ();
8044 /***************** Attribute declaration statements ****************/
8046 /* Set the attribute of a single variable. */
8051 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8054 /* Workaround -Wmaybe-uninitialized false positive during
8055 profiledbootstrap by initializing them. */
8056 gfc_symbol
*sym
= NULL
;
8062 m
= gfc_match_name (name
);
8066 if (find_special (name
, &sym
, false))
8069 if (!check_function_name (name
))
8075 var_locus
= gfc_current_locus
;
8077 /* Deal with possible array specification for certain attributes. */
8078 if (current_attr
.dimension
8079 || current_attr
.codimension
8080 || current_attr
.allocatable
8081 || current_attr
.pointer
8082 || current_attr
.target
)
8084 m
= gfc_match_array_spec (&as
, !current_attr
.codimension
,
8085 !current_attr
.dimension
8086 && !current_attr
.pointer
8087 && !current_attr
.target
);
8088 if (m
== MATCH_ERROR
)
8091 if (current_attr
.dimension
&& m
== MATCH_NO
)
8093 gfc_error ("Missing array specification at %L in DIMENSION "
8094 "statement", &var_locus
);
8099 if (current_attr
.dimension
&& sym
->value
)
8101 gfc_error ("Dimensions specified for %s at %L after its "
8102 "initialization", sym
->name
, &var_locus
);
8107 if (current_attr
.codimension
&& m
== MATCH_NO
)
8109 gfc_error ("Missing array specification at %L in CODIMENSION "
8110 "statement", &var_locus
);
8115 if ((current_attr
.allocatable
|| current_attr
.pointer
)
8116 && (m
== MATCH_YES
) && (as
->type
!= AS_DEFERRED
))
8118 gfc_error ("Array specification must be deferred at %L", &var_locus
);
8124 /* Update symbol table. DIMENSION attribute is set in
8125 gfc_set_array_spec(). For CLASS variables, this must be applied
8126 to the first component, or '_data' field. */
8127 if (sym
->ts
.type
== BT_CLASS
&& sym
->ts
.u
.derived
->attr
.is_class
)
8129 if (!gfc_copy_attr (&CLASS_DATA(sym
)->attr
, ¤t_attr
, &var_locus
))
8137 if (current_attr
.dimension
== 0 && current_attr
.codimension
== 0
8138 && !gfc_copy_attr (&sym
->attr
, ¤t_attr
, &var_locus
))
8145 if (sym
->ts
.type
== BT_CLASS
8146 && !gfc_build_class_symbol (&sym
->ts
, &sym
->attr
, &sym
->as
))
8152 if (!gfc_set_array_spec (sym
, as
, &var_locus
))
8158 if (sym
->attr
.cray_pointee
&& sym
->as
!= NULL
)
8160 /* Fix the array spec. */
8161 m
= gfc_mod_pointee_as (sym
->as
);
8162 if (m
== MATCH_ERROR
)
8166 if (!gfc_add_attribute (&sym
->attr
, &var_locus
))
8172 if ((current_attr
.external
|| current_attr
.intrinsic
)
8173 && sym
->attr
.flavor
!= FL_PROCEDURE
8174 && !gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, NULL
))
8180 add_hidden_procptr_result (sym
);
8185 gfc_free_array_spec (as
);
8190 /* Generic attribute declaration subroutine. Used for attributes that
8191 just have a list of names. */
8198 /* Gobble the optional double colon, by simply ignoring the result
8208 if (gfc_match_eos () == MATCH_YES
)
8214 if (gfc_match_char (',') != MATCH_YES
)
8216 gfc_error ("Unexpected character in variable list at %C");
8226 /* This routine matches Cray Pointer declarations of the form:
8227 pointer ( <pointer>, <pointee> )
8229 pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...
8230 The pointer, if already declared, should be an integer. Otherwise, we
8231 set it as BT_INTEGER with kind gfc_index_integer_kind. The pointee may
8232 be either a scalar, or an array declaration. No space is allocated for
8233 the pointee. For the statement
8234 pointer (ipt, ar(10))
8235 any subsequent uses of ar will be translated (in C-notation) as
8236 ar(i) => ((<type> *) ipt)(i)
8237 After gimplification, pointee variable will disappear in the code. */
8240 cray_pointer_decl (void)
8243 gfc_array_spec
*as
= NULL
;
8244 gfc_symbol
*cptr
; /* Pointer symbol. */
8245 gfc_symbol
*cpte
; /* Pointee symbol. */
8251 if (gfc_match_char ('(') != MATCH_YES
)
8253 gfc_error ("Expected %<(%> at %C");
8257 /* Match pointer. */
8258 var_locus
= gfc_current_locus
;
8259 gfc_clear_attr (¤t_attr
);
8260 gfc_add_cray_pointer (¤t_attr
, &var_locus
);
8261 current_ts
.type
= BT_INTEGER
;
8262 current_ts
.kind
= gfc_index_integer_kind
;
8264 m
= gfc_match_symbol (&cptr
, 0);
8267 gfc_error ("Expected variable name at %C");
8271 if (!gfc_add_cray_pointer (&cptr
->attr
, &var_locus
))
8274 gfc_set_sym_referenced (cptr
);
8276 if (cptr
->ts
.type
== BT_UNKNOWN
) /* Override the type, if necessary. */
8278 cptr
->ts
.type
= BT_INTEGER
;
8279 cptr
->ts
.kind
= gfc_index_integer_kind
;
8281 else if (cptr
->ts
.type
!= BT_INTEGER
)
8283 gfc_error ("Cray pointer at %C must be an integer");
8286 else if (cptr
->ts
.kind
< gfc_index_integer_kind
)
8287 gfc_warning (0, "Cray pointer at %C has %d bytes of precision;"
8288 " memory addresses require %d bytes",
8289 cptr
->ts
.kind
, gfc_index_integer_kind
);
8291 if (gfc_match_char (',') != MATCH_YES
)
8293 gfc_error ("Expected \",\" at %C");
8297 /* Match Pointee. */
8298 var_locus
= gfc_current_locus
;
8299 gfc_clear_attr (¤t_attr
);
8300 gfc_add_cray_pointee (¤t_attr
, &var_locus
);
8301 current_ts
.type
= BT_UNKNOWN
;
8302 current_ts
.kind
= 0;
8304 m
= gfc_match_symbol (&cpte
, 0);
8307 gfc_error ("Expected variable name at %C");
8311 /* Check for an optional array spec. */
8312 m
= gfc_match_array_spec (&as
, true, false);
8313 if (m
== MATCH_ERROR
)
8315 gfc_free_array_spec (as
);
8318 else if (m
== MATCH_NO
)
8320 gfc_free_array_spec (as
);
8324 if (!gfc_add_cray_pointee (&cpte
->attr
, &var_locus
))
8327 gfc_set_sym_referenced (cpte
);
8329 if (cpte
->as
== NULL
)
8331 if (!gfc_set_array_spec (cpte
, as
, &var_locus
))
8332 gfc_internal_error ("Couldn't set Cray pointee array spec.");
8334 else if (as
!= NULL
)
8336 gfc_error ("Duplicate array spec for Cray pointee at %C");
8337 gfc_free_array_spec (as
);
8343 if (cpte
->as
!= NULL
)
8345 /* Fix array spec. */
8346 m
= gfc_mod_pointee_as (cpte
->as
);
8347 if (m
== MATCH_ERROR
)
8351 /* Point the Pointee at the Pointer. */
8352 cpte
->cp_pointer
= cptr
;
8354 if (gfc_match_char (')') != MATCH_YES
)
8356 gfc_error ("Expected \")\" at %C");
8359 m
= gfc_match_char (',');
8361 done
= true; /* Stop searching for more declarations. */
8365 if (m
== MATCH_ERROR
/* Failed when trying to find ',' above. */
8366 || gfc_match_eos () != MATCH_YES
)
8368 gfc_error ("Expected %<,%> or end of statement at %C");
8376 gfc_match_external (void)
8379 gfc_clear_attr (¤t_attr
);
8380 current_attr
.external
= 1;
8382 return attr_decl ();
8387 gfc_match_intent (void)
8391 /* This is not allowed within a BLOCK construct! */
8392 if (gfc_current_state () == COMP_BLOCK
)
8394 gfc_error ("INTENT is not allowed inside of BLOCK at %C");
8398 intent
= match_intent_spec ();
8399 if (intent
== INTENT_UNKNOWN
)
8402 gfc_clear_attr (¤t_attr
);
8403 current_attr
.intent
= intent
;
8405 return attr_decl ();
8410 gfc_match_intrinsic (void)
8413 gfc_clear_attr (¤t_attr
);
8414 current_attr
.intrinsic
= 1;
8416 return attr_decl ();
8421 gfc_match_optional (void)
8423 /* This is not allowed within a BLOCK construct! */
8424 if (gfc_current_state () == COMP_BLOCK
)
8426 gfc_error ("OPTIONAL is not allowed inside of BLOCK at %C");
8430 gfc_clear_attr (¤t_attr
);
8431 current_attr
.optional
= 1;
8433 return attr_decl ();
8438 gfc_match_pointer (void)
8440 gfc_gobble_whitespace ();
8441 if (gfc_peek_ascii_char () == '(')
8443 if (!flag_cray_pointer
)
8445 gfc_error ("Cray pointer declaration at %C requires -fcray-pointer "
8449 return cray_pointer_decl ();
8453 gfc_clear_attr (¤t_attr
);
8454 current_attr
.pointer
= 1;
8456 return attr_decl ();
8462 gfc_match_allocatable (void)
8464 gfc_clear_attr (¤t_attr
);
8465 current_attr
.allocatable
= 1;
8467 return attr_decl ();
8472 gfc_match_codimension (void)
8474 gfc_clear_attr (¤t_attr
);
8475 current_attr
.codimension
= 1;
8477 return attr_decl ();
8482 gfc_match_contiguous (void)
8484 if (!gfc_notify_std (GFC_STD_F2008
, "CONTIGUOUS statement at %C"))
8487 gfc_clear_attr (¤t_attr
);
8488 current_attr
.contiguous
= 1;
8490 return attr_decl ();
8495 gfc_match_dimension (void)
8497 gfc_clear_attr (¤t_attr
);
8498 current_attr
.dimension
= 1;
8500 return attr_decl ();
8505 gfc_match_target (void)
8507 gfc_clear_attr (¤t_attr
);
8508 current_attr
.target
= 1;
8510 return attr_decl ();
8514 /* Match the list of entities being specified in a PUBLIC or PRIVATE
8518 access_attr_decl (gfc_statement st
)
8520 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8521 interface_type type
;
8523 gfc_symbol
*sym
, *dt_sym
;
8524 gfc_intrinsic_op op
;
8527 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
8532 m
= gfc_match_generic_spec (&type
, name
, &op
);
8535 if (m
== MATCH_ERROR
)
8540 case INTERFACE_NAMELESS
:
8541 case INTERFACE_ABSTRACT
:
8544 case INTERFACE_GENERIC
:
8545 case INTERFACE_DTIO
:
8547 if (gfc_get_symbol (name
, NULL
, &sym
))
8550 if (type
== INTERFACE_DTIO
8551 && gfc_current_ns
->proc_name
8552 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
8553 && sym
->attr
.flavor
== FL_UNKNOWN
)
8554 sym
->attr
.flavor
= FL_PROCEDURE
;
8556 if (!gfc_add_access (&sym
->attr
,
8558 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
,
8562 if (sym
->attr
.generic
&& (dt_sym
= gfc_find_dt_in_generic (sym
))
8563 && !gfc_add_access (&dt_sym
->attr
,
8565 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
,
8571 case INTERFACE_INTRINSIC_OP
:
8572 if (gfc_current_ns
->operator_access
[op
] == ACCESS_UNKNOWN
)
8574 gfc_intrinsic_op other_op
;
8576 gfc_current_ns
->operator_access
[op
] =
8577 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
8579 /* Handle the case if there is another op with the same
8580 function, for INTRINSIC_EQ vs. INTRINSIC_EQ_OS and so on. */
8581 other_op
= gfc_equivalent_op (op
);
8583 if (other_op
!= INTRINSIC_NONE
)
8584 gfc_current_ns
->operator_access
[other_op
] =
8585 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
8590 gfc_error ("Access specification of the %s operator at %C has "
8591 "already been specified", gfc_op2string (op
));
8597 case INTERFACE_USER_OP
:
8598 uop
= gfc_get_uop (name
);
8600 if (uop
->access
== ACCESS_UNKNOWN
)
8602 uop
->access
= (st
== ST_PUBLIC
)
8603 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
8607 gfc_error ("Access specification of the .%s. operator at %C "
8608 "has already been specified", sym
->name
);
8615 if (gfc_match_char (',') == MATCH_NO
)
8619 if (gfc_match_eos () != MATCH_YES
)
8624 gfc_syntax_error (st
);
8632 gfc_match_protected (void)
8637 if (!gfc_current_ns
->proc_name
8638 || gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
8640 gfc_error ("PROTECTED at %C only allowed in specification "
8641 "part of a module");
8646 if (!gfc_notify_std (GFC_STD_F2003
, "PROTECTED statement at %C"))
8649 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
8654 if (gfc_match_eos () == MATCH_YES
)
8659 m
= gfc_match_symbol (&sym
, 0);
8663 if (!gfc_add_protected (&sym
->attr
, sym
->name
, &gfc_current_locus
))
8675 if (gfc_match_eos () == MATCH_YES
)
8677 if (gfc_match_char (',') != MATCH_YES
)
8684 gfc_error ("Syntax error in PROTECTED statement at %C");
8689 /* The PRIVATE statement is a bit weird in that it can be an attribute
8690 declaration, but also works as a standalone statement inside of a
8691 type declaration or a module. */
8694 gfc_match_private (gfc_statement
*st
)
8697 if (gfc_match ("private") != MATCH_YES
)
8700 if (gfc_current_state () != COMP_MODULE
8701 && !(gfc_current_state () == COMP_DERIVED
8702 && gfc_state_stack
->previous
8703 && gfc_state_stack
->previous
->state
== COMP_MODULE
)
8704 && !(gfc_current_state () == COMP_DERIVED_CONTAINS
8705 && gfc_state_stack
->previous
&& gfc_state_stack
->previous
->previous
8706 && gfc_state_stack
->previous
->previous
->state
== COMP_MODULE
))
8708 gfc_error ("PRIVATE statement at %C is only allowed in the "
8709 "specification part of a module");
8713 if (gfc_current_state () == COMP_DERIVED
)
8715 if (gfc_match_eos () == MATCH_YES
)
8721 gfc_syntax_error (ST_PRIVATE
);
8725 if (gfc_match_eos () == MATCH_YES
)
8732 return access_attr_decl (ST_PRIVATE
);
8737 gfc_match_public (gfc_statement
*st
)
8740 if (gfc_match ("public") != MATCH_YES
)
8743 if (gfc_current_state () != COMP_MODULE
)
8745 gfc_error ("PUBLIC statement at %C is only allowed in the "
8746 "specification part of a module");
8750 if (gfc_match_eos () == MATCH_YES
)
8757 return access_attr_decl (ST_PUBLIC
);
8761 /* Workhorse for gfc_match_parameter. */
8771 m
= gfc_match_symbol (&sym
, 0);
8773 gfc_error ("Expected variable name at %C in PARAMETER statement");
8778 if (gfc_match_char ('=') == MATCH_NO
)
8780 gfc_error ("Expected = sign in PARAMETER statement at %C");
8784 m
= gfc_match_init_expr (&init
);
8786 gfc_error ("Expected expression at %C in PARAMETER statement");
8790 if (sym
->ts
.type
== BT_UNKNOWN
8791 && !gfc_set_default_type (sym
, 1, NULL
))
8797 if (!gfc_check_assign_symbol (sym
, NULL
, init
)
8798 || !gfc_add_flavor (&sym
->attr
, FL_PARAMETER
, sym
->name
, NULL
))
8806 gfc_error ("Initializing already initialized variable at %C");
8811 t
= add_init_expr_to_sym (sym
->name
, &init
, &gfc_current_locus
);
8812 return (t
) ? MATCH_YES
: MATCH_ERROR
;
8815 gfc_free_expr (init
);
8820 /* Match a parameter statement, with the weird syntax that these have. */
8823 gfc_match_parameter (void)
8825 const char *term
= " )%t";
8828 if (gfc_match_char ('(') == MATCH_NO
)
8830 /* With legacy PARAMETER statements, don't expect a terminating ')'. */
8831 if (!gfc_notify_std (GFC_STD_LEGACY
, "PARAMETER without '()' at %C"))
8842 if (gfc_match (term
) == MATCH_YES
)
8845 if (gfc_match_char (',') != MATCH_YES
)
8847 gfc_error ("Unexpected characters in PARAMETER statement at %C");
8858 gfc_match_automatic (void)
8862 bool seen_symbol
= false;
8864 if (!flag_dec_static
)
8866 gfc_error ("%s at %C is a DEC extension, enable with "
8877 m
= gfc_match_symbol (&sym
, 0);
8887 if (!gfc_add_automatic (&sym
->attr
, sym
->name
, &gfc_current_locus
))
8893 if (gfc_match_eos () == MATCH_YES
)
8895 if (gfc_match_char (',') != MATCH_YES
)
8901 gfc_error ("Expected entity-list in AUTOMATIC statement at %C");
8908 gfc_error ("Syntax error in AUTOMATIC statement at %C");
8914 gfc_match_static (void)
8918 bool seen_symbol
= false;
8920 if (!flag_dec_static
)
8922 gfc_error ("%s at %C is a DEC extension, enable with "
8932 m
= gfc_match_symbol (&sym
, 0);
8942 if (!gfc_add_save (&sym
->attr
, SAVE_EXPLICIT
, sym
->name
,
8943 &gfc_current_locus
))
8949 if (gfc_match_eos () == MATCH_YES
)
8951 if (gfc_match_char (',') != MATCH_YES
)
8957 gfc_error ("Expected entity-list in STATIC statement at %C");
8964 gfc_error ("Syntax error in STATIC statement at %C");
8969 /* Save statements have a special syntax. */
8972 gfc_match_save (void)
8974 char n
[GFC_MAX_SYMBOL_LEN
+1];
8979 if (gfc_match_eos () == MATCH_YES
)
8981 if (gfc_current_ns
->seen_save
)
8983 if (!gfc_notify_std (GFC_STD_LEGACY
, "Blanket SAVE statement at %C "
8984 "follows previous SAVE statement"))
8988 gfc_current_ns
->save_all
= gfc_current_ns
->seen_save
= 1;
8992 if (gfc_current_ns
->save_all
)
8994 if (!gfc_notify_std (GFC_STD_LEGACY
, "SAVE statement at %C follows "
8995 "blanket SAVE statement"))
9003 m
= gfc_match_symbol (&sym
, 0);
9007 if (!gfc_add_save (&sym
->attr
, SAVE_EXPLICIT
, sym
->name
,
9008 &gfc_current_locus
))
9019 m
= gfc_match (" / %n /", &n
);
9020 if (m
== MATCH_ERROR
)
9025 c
= gfc_get_common (n
, 0);
9028 gfc_current_ns
->seen_save
= 1;
9031 if (gfc_match_eos () == MATCH_YES
)
9033 if (gfc_match_char (',') != MATCH_YES
)
9040 gfc_error ("Syntax error in SAVE statement at %C");
9046 gfc_match_value (void)
9051 /* This is not allowed within a BLOCK construct! */
9052 if (gfc_current_state () == COMP_BLOCK
)
9054 gfc_error ("VALUE is not allowed inside of BLOCK at %C");
9058 if (!gfc_notify_std (GFC_STD_F2003
, "VALUE statement at %C"))
9061 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
9066 if (gfc_match_eos () == MATCH_YES
)
9071 m
= gfc_match_symbol (&sym
, 0);
9075 if (!gfc_add_value (&sym
->attr
, sym
->name
, &gfc_current_locus
))
9087 if (gfc_match_eos () == MATCH_YES
)
9089 if (gfc_match_char (',') != MATCH_YES
)
9096 gfc_error ("Syntax error in VALUE statement at %C");
9102 gfc_match_volatile (void)
9107 if (!gfc_notify_std (GFC_STD_F2003
, "VOLATILE statement at %C"))
9110 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
9115 if (gfc_match_eos () == MATCH_YES
)
9120 /* VOLATILE is special because it can be added to host-associated
9121 symbols locally. Except for coarrays. */
9122 m
= gfc_match_symbol (&sym
, 1);
9126 /* F2008, C560+C561. VOLATILE for host-/use-associated variable or
9127 for variable in a BLOCK which is defined outside of the BLOCK. */
9128 if (sym
->ns
!= gfc_current_ns
&& sym
->attr
.codimension
)
9130 gfc_error ("Specifying VOLATILE for coarray variable %qs at "
9131 "%C, which is use-/host-associated", sym
->name
);
9134 if (!gfc_add_volatile (&sym
->attr
, sym
->name
, &gfc_current_locus
))
9146 if (gfc_match_eos () == MATCH_YES
)
9148 if (gfc_match_char (',') != MATCH_YES
)
9155 gfc_error ("Syntax error in VOLATILE statement at %C");
9161 gfc_match_asynchronous (void)
9166 if (!gfc_notify_std (GFC_STD_F2003
, "ASYNCHRONOUS statement at %C"))
9169 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
9174 if (gfc_match_eos () == MATCH_YES
)
9179 /* ASYNCHRONOUS is special because it can be added to host-associated
9181 m
= gfc_match_symbol (&sym
, 1);
9185 if (!gfc_add_asynchronous (&sym
->attr
, sym
->name
, &gfc_current_locus
))
9197 if (gfc_match_eos () == MATCH_YES
)
9199 if (gfc_match_char (',') != MATCH_YES
)
9206 gfc_error ("Syntax error in ASYNCHRONOUS statement at %C");
9211 /* Match a module procedure statement in a submodule. */
9214 gfc_match_submod_proc (void)
9216 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9217 gfc_symbol
*sym
, *fsym
;
9219 gfc_formal_arglist
*formal
, *head
, *tail
;
9221 if (gfc_current_state () != COMP_CONTAINS
9222 || !(gfc_state_stack
->previous
9223 && (gfc_state_stack
->previous
->state
== COMP_SUBMODULE
9224 || gfc_state_stack
->previous
->state
== COMP_MODULE
)))
9227 m
= gfc_match (" module% procedure% %n", name
);
9231 if (!gfc_notify_std (GFC_STD_F2008
, "MODULE PROCEDURE declaration "
9235 if (get_proc_name (name
, &sym
, false))
9238 /* Make sure that the result field is appropriately filled, even though
9239 the result symbol will be replaced later on. */
9240 if (sym
->tlink
&& sym
->tlink
->attr
.function
)
9242 if (sym
->tlink
->result
9243 && sym
->tlink
->result
!= sym
->tlink
)
9244 sym
->result
= sym
->tlink
->result
;
9249 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
9250 the symbol existed before. */
9251 sym
->declared_at
= gfc_current_locus
;
9253 if (!sym
->attr
.module_procedure
)
9256 /* Signal match_end to expect "end procedure". */
9257 sym
->abr_modproc_decl
= 1;
9259 /* Change from IFSRC_IFBODY coming from the interface declaration. */
9260 sym
->attr
.if_source
= IFSRC_DECL
;
9262 gfc_new_block
= sym
;
9264 /* Make a new formal arglist with the symbols in the procedure
9267 for (formal
= sym
->formal
; formal
&& formal
->sym
; formal
= formal
->next
)
9269 if (formal
== sym
->formal
)
9270 head
= tail
= gfc_get_formal_arglist ();
9273 tail
->next
= gfc_get_formal_arglist ();
9277 if (gfc_copy_dummy_sym (&fsym
, formal
->sym
, 0))
9281 gfc_set_sym_referenced (fsym
);
9284 /* The dummy symbols get cleaned up, when the formal_namespace of the
9285 interface declaration is cleared. This allows us to add the
9286 explicit interface as is done for other type of procedure. */
9287 if (!gfc_add_explicit_interface (sym
, IFSRC_DECL
, head
,
9288 &gfc_current_locus
))
9291 if (gfc_match_eos () != MATCH_YES
)
9293 gfc_syntax_error (ST_MODULE_PROC
);
9300 gfc_free_formal_arglist (head
);
9305 /* Match a module procedure statement. Note that we have to modify
9306 symbols in the parent's namespace because the current one was there
9307 to receive symbols that are in an interface's formal argument list. */
9310 gfc_match_modproc (void)
9312 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9316 gfc_namespace
*module_ns
;
9317 gfc_interface
*old_interface_head
, *interface
;
9319 if (gfc_state_stack
->state
!= COMP_INTERFACE
9320 || gfc_state_stack
->previous
== NULL
9321 || current_interface
.type
== INTERFACE_NAMELESS
9322 || current_interface
.type
== INTERFACE_ABSTRACT
)
9324 gfc_error ("MODULE PROCEDURE at %C must be in a generic module "
9329 module_ns
= gfc_current_ns
->parent
;
9330 for (; module_ns
; module_ns
= module_ns
->parent
)
9331 if (module_ns
->proc_name
->attr
.flavor
== FL_MODULE
9332 || module_ns
->proc_name
->attr
.flavor
== FL_PROGRAM
9333 || (module_ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
9334 && !module_ns
->proc_name
->attr
.contained
))
9337 if (module_ns
== NULL
)
9340 /* Store the current state of the interface. We will need it if we
9341 end up with a syntax error and need to recover. */
9342 old_interface_head
= gfc_current_interface_head ();
9344 /* Check if the F2008 optional double colon appears. */
9345 gfc_gobble_whitespace ();
9346 old_locus
= gfc_current_locus
;
9347 if (gfc_match ("::") == MATCH_YES
)
9349 if (!gfc_notify_std (GFC_STD_F2008
, "double colon in "
9350 "MODULE PROCEDURE statement at %L", &old_locus
))
9354 gfc_current_locus
= old_locus
;
9359 old_locus
= gfc_current_locus
;
9361 m
= gfc_match_name (name
);
9367 /* Check for syntax error before starting to add symbols to the
9368 current namespace. */
9369 if (gfc_match_eos () == MATCH_YES
)
9372 if (!last
&& gfc_match_char (',') != MATCH_YES
)
9375 /* Now we're sure the syntax is valid, we process this item
9377 if (gfc_get_symbol (name
, module_ns
, &sym
))
9380 if (sym
->attr
.intrinsic
)
9382 gfc_error ("Intrinsic procedure at %L cannot be a MODULE "
9383 "PROCEDURE", &old_locus
);
9387 if (sym
->attr
.proc
!= PROC_MODULE
9388 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
9391 if (!gfc_add_interface (sym
))
9394 sym
->attr
.mod_proc
= 1;
9395 sym
->declared_at
= old_locus
;
9404 /* Restore the previous state of the interface. */
9405 interface
= gfc_current_interface_head ();
9406 gfc_set_current_interface_head (old_interface_head
);
9408 /* Free the new interfaces. */
9409 while (interface
!= old_interface_head
)
9411 gfc_interface
*i
= interface
->next
;
9416 /* And issue a syntax error. */
9417 gfc_syntax_error (ST_MODULE_PROC
);
9422 /* Check a derived type that is being extended. */
9425 check_extended_derived_type (char *name
)
9427 gfc_symbol
*extended
;
9429 if (gfc_find_symbol (name
, gfc_current_ns
, 1, &extended
))
9431 gfc_error ("Ambiguous symbol in TYPE definition at %C");
9435 extended
= gfc_find_dt_in_generic (extended
);
9440 gfc_error ("Symbol %qs at %C has not been previously defined", name
);
9444 if (extended
->attr
.flavor
!= FL_DERIVED
)
9446 gfc_error ("%qs in EXTENDS expression at %C is not a "
9447 "derived type", name
);
9451 if (extended
->attr
.is_bind_c
)
9453 gfc_error ("%qs cannot be extended at %C because it "
9454 "is BIND(C)", extended
->name
);
9458 if (extended
->attr
.sequence
)
9460 gfc_error ("%qs cannot be extended at %C because it "
9461 "is a SEQUENCE type", extended
->name
);
9469 /* Match the optional attribute specifiers for a type declaration.
9470 Return MATCH_ERROR if an error is encountered in one of the handled
9471 attributes (public, private, bind(c)), MATCH_NO if what's found is
9472 not a handled attribute, and MATCH_YES otherwise. TODO: More error
9473 checking on attribute conflicts needs to be done. */
9476 gfc_get_type_attr_spec (symbol_attribute
*attr
, char *name
)
9478 /* See if the derived type is marked as private. */
9479 if (gfc_match (" , private") == MATCH_YES
)
9481 if (gfc_current_state () != COMP_MODULE
)
9483 gfc_error ("Derived type at %C can only be PRIVATE in the "
9484 "specification part of a module");
9488 if (!gfc_add_access (attr
, ACCESS_PRIVATE
, NULL
, NULL
))
9491 else if (gfc_match (" , public") == MATCH_YES
)
9493 if (gfc_current_state () != COMP_MODULE
)
9495 gfc_error ("Derived type at %C can only be PUBLIC in the "
9496 "specification part of a module");
9500 if (!gfc_add_access (attr
, ACCESS_PUBLIC
, NULL
, NULL
))
9503 else if (gfc_match (" , bind ( c )") == MATCH_YES
)
9505 /* If the type is defined to be bind(c) it then needs to make
9506 sure that all fields are interoperable. This will
9507 need to be a semantic check on the finished derived type.
9508 See 15.2.3 (lines 9-12) of F2003 draft. */
9509 if (!gfc_add_is_bind_c (attr
, NULL
, &gfc_current_locus
, 0))
9512 /* TODO: attr conflicts need to be checked, probably in symbol.c. */
9514 else if (gfc_match (" , abstract") == MATCH_YES
)
9516 if (!gfc_notify_std (GFC_STD_F2003
, "ABSTRACT type at %C"))
9519 if (!gfc_add_abstract (attr
, &gfc_current_locus
))
9522 else if (name
&& gfc_match (" , extends ( %n )", name
) == MATCH_YES
)
9524 if (!gfc_add_extension (attr
, &gfc_current_locus
))
9530 /* If we get here, something matched. */
9535 /* Common function for type declaration blocks similar to derived types, such
9536 as STRUCTURES and MAPs. Unlike derived types, a structure type
9537 does NOT have a generic symbol matching the name given by the user.
9538 STRUCTUREs can share names with variables and PARAMETERs so we must allow
9539 for the creation of an independent symbol.
9540 Other parameters are a message to prefix errors with, the name of the new
9541 type to be created, and the flavor to add to the resulting symbol. */
9544 get_struct_decl (const char *name
, sym_flavor fl
, locus
*decl
,
9545 gfc_symbol
**result
)
9550 gcc_assert (name
[0] == (char) TOUPPER (name
[0]));
9555 where
= gfc_current_locus
;
9557 if (gfc_get_symbol (name
, NULL
, &sym
))
9562 gfc_internal_error ("Failed to create structure type '%s' at %C", name
);
9566 if (sym
->components
!= NULL
|| sym
->attr
.zero_comp
)
9568 gfc_error ("Type definition of %qs at %C was already defined at %L",
9569 sym
->name
, &sym
->declared_at
);
9573 sym
->declared_at
= where
;
9575 if (sym
->attr
.flavor
!= fl
9576 && !gfc_add_flavor (&sym
->attr
, fl
, sym
->name
, NULL
))
9579 if (!sym
->hash_value
)
9580 /* Set the hash for the compound name for this type. */
9581 sym
->hash_value
= gfc_hash_value (sym
);
9583 /* Normally the type is expected to have been completely parsed by the time
9584 a field declaration with this type is seen. For unions, maps, and nested
9585 structure declarations, we need to indicate that it is okay that we
9586 haven't seen any components yet. This will be updated after the structure
9588 sym
->attr
.zero_comp
= 0;
9590 /* Structures always act like derived-types with the SEQUENCE attribute */
9591 gfc_add_sequence (&sym
->attr
, sym
->name
, NULL
);
9593 if (result
) *result
= sym
;
9599 /* Match the opening of a MAP block. Like a struct within a union in C;
9600 behaves identical to STRUCTURE blocks. */
9603 gfc_match_map (void)
9605 /* Counter used to give unique internal names to map structures. */
9606 static unsigned int gfc_map_id
= 0;
9607 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9611 old_loc
= gfc_current_locus
;
9613 if (gfc_match_eos () != MATCH_YES
)
9615 gfc_error ("Junk after MAP statement at %C");
9616 gfc_current_locus
= old_loc
;
9620 /* Map blocks are anonymous so we make up unique names for the symbol table
9621 which are invalid Fortran identifiers. */
9622 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "MM$%u", gfc_map_id
++);
9624 if (!get_struct_decl (name
, FL_STRUCT
, &old_loc
, &sym
))
9627 gfc_new_block
= sym
;
9633 /* Match the opening of a UNION block. */
9636 gfc_match_union (void)
9638 /* Counter used to give unique internal names to union types. */
9639 static unsigned int gfc_union_id
= 0;
9640 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9644 old_loc
= gfc_current_locus
;
9646 if (gfc_match_eos () != MATCH_YES
)
9648 gfc_error ("Junk after UNION statement at %C");
9649 gfc_current_locus
= old_loc
;
9653 /* Unions are anonymous so we make up unique names for the symbol table
9654 which are invalid Fortran identifiers. */
9655 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "UU$%u", gfc_union_id
++);
9657 if (!get_struct_decl (name
, FL_UNION
, &old_loc
, &sym
))
9660 gfc_new_block
= sym
;
9666 /* Match the beginning of a STRUCTURE declaration. This is similar to
9667 matching the beginning of a derived type declaration with a few
9668 twists. The resulting type symbol has no access control or other
9669 interesting attributes. */
9672 gfc_match_structure_decl (void)
9674 /* Counter used to give unique internal names to anonymous structures. */
9675 static unsigned int gfc_structure_id
= 0;
9676 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9681 if (!flag_dec_structure
)
9683 gfc_error ("%s at %C is a DEC extension, enable with "
9684 "%<-fdec-structure%>",
9691 m
= gfc_match (" /%n/", name
);
9694 /* Non-nested structure declarations require a structure name. */
9695 if (!gfc_comp_struct (gfc_current_state ()))
9697 gfc_error ("Structure name expected in non-nested structure "
9698 "declaration at %C");
9701 /* This is an anonymous structure; make up a unique name for it
9702 (upper-case letters never make it to symbol names from the source).
9703 The important thing is initializing the type variable
9704 and setting gfc_new_symbol, which is immediately used by
9705 parse_structure () and variable_decl () to add components of
9707 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "SS$%u", gfc_structure_id
++);
9710 where
= gfc_current_locus
;
9711 /* No field list allowed after non-nested structure declaration. */
9712 if (!gfc_comp_struct (gfc_current_state ())
9713 && gfc_match_eos () != MATCH_YES
)
9715 gfc_error ("Junk after non-nested STRUCTURE statement at %C");
9719 /* Make sure the name is not the name of an intrinsic type. */
9720 if (gfc_is_intrinsic_typename (name
))
9722 gfc_error ("Structure name %qs at %C cannot be the same as an"
9723 " intrinsic type", name
);
9727 /* Store the actual type symbol for the structure with an upper-case first
9728 letter (an invalid Fortran identifier). */
9730 if (!get_struct_decl (gfc_dt_upper_string (name
), FL_STRUCT
, &where
, &sym
))
9733 gfc_new_block
= sym
;
9738 /* This function does some work to determine which matcher should be used to
9739 * match a statement beginning with "TYPE". This is used to disambiguate TYPE
9740 * as an alias for PRINT from derived type declarations, TYPE IS statements,
9741 * and derived type data declarations. */
9744 gfc_match_type (gfc_statement
*st
)
9746 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9750 /* Requires -fdec. */
9754 m
= gfc_match ("type");
9757 /* If we already have an error in the buffer, it is probably from failing to
9758 * match a derived type data declaration. Let it happen. */
9759 else if (gfc_error_flag_test ())
9762 old_loc
= gfc_current_locus
;
9765 /* If we see an attribute list before anything else it's definitely a derived
9766 * type declaration. */
9767 if (gfc_match (" ,") == MATCH_YES
|| gfc_match (" ::") == MATCH_YES
)
9769 gfc_current_locus
= old_loc
;
9770 *st
= ST_DERIVED_DECL
;
9771 return gfc_match_derived_decl ();
9774 /* By now "TYPE" has already been matched. If we do not see a name, this may
9775 * be something like "TYPE *" or "TYPE <fmt>". */
9776 m
= gfc_match_name (name
);
9779 /* Let print match if it can, otherwise throw an error from
9780 * gfc_match_derived_decl. */
9781 gfc_current_locus
= old_loc
;
9782 if (gfc_match_print () == MATCH_YES
)
9787 gfc_current_locus
= old_loc
;
9788 *st
= ST_DERIVED_DECL
;
9789 return gfc_match_derived_decl ();
9792 /* A derived type declaration requires an EOS. Without it, assume print. */
9793 m
= gfc_match_eos ();
9796 /* Check manually for TYPE IS (... - this is invalid print syntax. */
9797 if (strncmp ("is", name
, 3) == 0
9798 && gfc_match (" (", name
) == MATCH_YES
)
9800 gfc_current_locus
= old_loc
;
9801 gcc_assert (gfc_match (" is") == MATCH_YES
);
9803 return gfc_match_type_is ();
9805 gfc_current_locus
= old_loc
;
9807 return gfc_match_print ();
9811 /* By now we have "TYPE <name> <EOS>". Check first if the name is an
9812 * intrinsic typename - if so let gfc_match_derived_decl dump an error.
9813 * Otherwise if gfc_match_derived_decl fails it's probably an existing
9814 * symbol which can be printed. */
9815 gfc_current_locus
= old_loc
;
9816 m
= gfc_match_derived_decl ();
9817 if (gfc_is_intrinsic_typename (name
) || m
== MATCH_YES
)
9819 *st
= ST_DERIVED_DECL
;
9822 gfc_current_locus
= old_loc
;
9824 return gfc_match_print ();
9831 /* Match the beginning of a derived type declaration. If a type name
9832 was the result of a function, then it is possible to have a symbol
9833 already to be known as a derived type yet have no components. */
9836 gfc_match_derived_decl (void)
9838 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9839 char parent
[GFC_MAX_SYMBOL_LEN
+ 1];
9840 symbol_attribute attr
;
9841 gfc_symbol
*sym
, *gensym
;
9842 gfc_symbol
*extended
;
9844 match is_type_attr_spec
= MATCH_NO
;
9845 bool seen_attr
= false;
9846 gfc_interface
*intr
= NULL
, *head
;
9847 bool parameterized_type
= false;
9848 bool seen_colons
= false;
9850 if (gfc_comp_struct (gfc_current_state ()))
9855 gfc_clear_attr (&attr
);
9860 is_type_attr_spec
= gfc_get_type_attr_spec (&attr
, parent
);
9861 if (is_type_attr_spec
== MATCH_ERROR
)
9863 if (is_type_attr_spec
== MATCH_YES
)
9865 } while (is_type_attr_spec
== MATCH_YES
);
9867 /* Deal with derived type extensions. The extension attribute has
9868 been added to 'attr' but now the parent type must be found and
9871 extended
= check_extended_derived_type (parent
);
9873 if (parent
[0] && !extended
)
9876 m
= gfc_match (" ::");
9883 gfc_error ("Expected :: in TYPE definition at %C");
9887 m
= gfc_match (" %n ", name
);
9891 /* Make sure that we don't identify TYPE IS (...) as a parameterized
9892 derived type named 'is'.
9893 TODO Expand the check, when 'name' = "is" by matching " (tname) "
9894 and checking if this is a(n intrinsic) typename. his picks up
9895 misplaced TYPE IS statements such as in select_type_1.f03. */
9896 if (gfc_peek_ascii_char () == '(')
9898 if (gfc_current_state () == COMP_SELECT_TYPE
9899 || (!seen_colons
&& !strcmp (name
, "is")))
9901 parameterized_type
= true;
9904 m
= gfc_match_eos ();
9905 if (m
!= MATCH_YES
&& !parameterized_type
)
9908 /* Make sure the name is not the name of an intrinsic type. */
9909 if (gfc_is_intrinsic_typename (name
))
9911 gfc_error ("Type name %qs at %C cannot be the same as an intrinsic "
9916 if (gfc_get_symbol (name
, NULL
, &gensym
))
9919 if (!gensym
->attr
.generic
&& gensym
->ts
.type
!= BT_UNKNOWN
)
9921 gfc_error ("Derived type name %qs at %C already has a basic type "
9922 "of %s", gensym
->name
, gfc_typename (&gensym
->ts
));
9926 if (!gensym
->attr
.generic
9927 && !gfc_add_generic (&gensym
->attr
, gensym
->name
, NULL
))
9930 if (!gensym
->attr
.function
9931 && !gfc_add_function (&gensym
->attr
, gensym
->name
, NULL
))
9934 sym
= gfc_find_dt_in_generic (gensym
);
9936 if (sym
&& (sym
->components
!= NULL
|| sym
->attr
.zero_comp
))
9938 gfc_error ("Derived type definition of %qs at %C has already been "
9939 "defined", sym
->name
);
9945 /* Use upper case to save the actual derived-type symbol. */
9946 gfc_get_symbol (gfc_dt_upper_string (gensym
->name
), NULL
, &sym
);
9947 sym
->name
= gfc_get_string ("%s", gensym
->name
);
9948 head
= gensym
->generic
;
9949 intr
= gfc_get_interface ();
9951 intr
->where
= gfc_current_locus
;
9952 intr
->sym
->declared_at
= gfc_current_locus
;
9954 gensym
->generic
= intr
;
9955 gensym
->attr
.if_source
= IFSRC_DECL
;
9958 /* The symbol may already have the derived attribute without the
9959 components. The ways this can happen is via a function
9960 definition, an INTRINSIC statement or a subtype in another
9961 derived type that is a pointer. The first part of the AND clause
9962 is true if the symbol is not the return value of a function. */
9963 if (sym
->attr
.flavor
!= FL_DERIVED
9964 && !gfc_add_flavor (&sym
->attr
, FL_DERIVED
, sym
->name
, NULL
))
9967 if (attr
.access
!= ACCESS_UNKNOWN
9968 && !gfc_add_access (&sym
->attr
, attr
.access
, sym
->name
, NULL
))
9970 else if (sym
->attr
.access
== ACCESS_UNKNOWN
9971 && gensym
->attr
.access
!= ACCESS_UNKNOWN
9972 && !gfc_add_access (&sym
->attr
, gensym
->attr
.access
,
9976 if (sym
->attr
.access
!= ACCESS_UNKNOWN
9977 && gensym
->attr
.access
== ACCESS_UNKNOWN
)
9978 gensym
->attr
.access
= sym
->attr
.access
;
9980 /* See if the derived type was labeled as bind(c). */
9981 if (attr
.is_bind_c
!= 0)
9982 sym
->attr
.is_bind_c
= attr
.is_bind_c
;
9984 /* Construct the f2k_derived namespace if it is not yet there. */
9985 if (!sym
->f2k_derived
)
9986 sym
->f2k_derived
= gfc_get_namespace (NULL
, 0);
9988 if (parameterized_type
)
9990 /* Ignore error or mismatches by going to the end of the statement
9991 in order to avoid the component declarations causing problems. */
9992 m
= gfc_match_formal_arglist (sym
, 0, 0, true);
9994 gfc_error_recovery ();
9995 m
= gfc_match_eos ();
9998 gfc_error_recovery ();
9999 gfc_error_now ("Garbage after PARAMETERIZED TYPE declaration at %C");
10001 sym
->attr
.pdt_template
= 1;
10004 if (extended
&& !sym
->components
)
10007 gfc_formal_arglist
*f
, *g
, *h
;
10009 /* Add the extended derived type as the first component. */
10010 gfc_add_component (sym
, parent
, &p
);
10012 gfc_set_sym_referenced (extended
);
10014 p
->ts
.type
= BT_DERIVED
;
10015 p
->ts
.u
.derived
= extended
;
10016 p
->initializer
= gfc_default_initializer (&p
->ts
);
10018 /* Set extension level. */
10019 if (extended
->attr
.extension
== 255)
10021 /* Since the extension field is 8 bit wide, we can only have
10022 up to 255 extension levels. */
10023 gfc_error ("Maximum extension level reached with type %qs at %L",
10024 extended
->name
, &extended
->declared_at
);
10025 return MATCH_ERROR
;
10027 sym
->attr
.extension
= extended
->attr
.extension
+ 1;
10029 /* Provide the links between the extended type and its extension. */
10030 if (!extended
->f2k_derived
)
10031 extended
->f2k_derived
= gfc_get_namespace (NULL
, 0);
10033 /* Copy the extended type-param-name-list from the extended type,
10034 append those of the extension and add the whole lot to the
10036 if (extended
->attr
.pdt_template
)
10039 sym
->attr
.pdt_template
= 1;
10040 for (f
= extended
->formal
; f
; f
= f
->next
)
10042 if (f
== extended
->formal
)
10044 g
= gfc_get_formal_arglist ();
10049 g
->next
= gfc_get_formal_arglist ();
10054 g
->next
= sym
->formal
;
10059 if (!sym
->hash_value
)
10060 /* Set the hash for the compound name for this type. */
10061 sym
->hash_value
= gfc_hash_value (sym
);
10063 /* Take over the ABSTRACT attribute. */
10064 sym
->attr
.abstract
= attr
.abstract
;
10066 gfc_new_block
= sym
;
10072 /* Cray Pointees can be declared as:
10073 pointer (ipt, a (n,m,...,*)) */
10076 gfc_mod_pointee_as (gfc_array_spec
*as
)
10078 as
->cray_pointee
= true; /* This will be useful to know later. */
10079 if (as
->type
== AS_ASSUMED_SIZE
)
10080 as
->cp_was_assumed
= true;
10081 else if (as
->type
== AS_ASSUMED_SHAPE
)
10083 gfc_error ("Cray Pointee at %C cannot be assumed shape array");
10084 return MATCH_ERROR
;
10090 /* Match the enum definition statement, here we are trying to match
10091 the first line of enum definition statement.
10092 Returns MATCH_YES if match is found. */
10095 gfc_match_enum (void)
10099 m
= gfc_match_eos ();
10100 if (m
!= MATCH_YES
)
10103 if (!gfc_notify_std (GFC_STD_F2003
, "ENUM and ENUMERATOR at %C"))
10104 return MATCH_ERROR
;
10110 /* Returns an initializer whose value is one higher than the value of the
10111 LAST_INITIALIZER argument. If the argument is NULL, the
10112 initializers value will be set to zero. The initializer's kind
10113 will be set to gfc_c_int_kind.
10115 If -fshort-enums is given, the appropriate kind will be selected
10116 later after all enumerators have been parsed. A warning is issued
10117 here if an initializer exceeds gfc_c_int_kind. */
10120 enum_initializer (gfc_expr
*last_initializer
, locus where
)
10123 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_c_int_kind
, &where
);
10125 mpz_init (result
->value
.integer
);
10127 if (last_initializer
!= NULL
)
10129 mpz_add_ui (result
->value
.integer
, last_initializer
->value
.integer
, 1);
10130 result
->where
= last_initializer
->where
;
10132 if (gfc_check_integer_range (result
->value
.integer
,
10133 gfc_c_int_kind
) != ARITH_OK
)
10135 gfc_error ("Enumerator exceeds the C integer type at %C");
10141 /* Control comes here, if it's the very first enumerator and no
10142 initializer has been given. It will be initialized to zero. */
10143 mpz_set_si (result
->value
.integer
, 0);
10150 /* Match a variable name with an optional initializer. When this
10151 subroutine is called, a variable is expected to be parsed next.
10152 Depending on what is happening at the moment, updates either the
10153 symbol table or the current interface. */
10156 enumerator_decl (void)
10158 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10159 gfc_expr
*initializer
;
10160 gfc_array_spec
*as
= NULL
;
10167 initializer
= NULL
;
10168 old_locus
= gfc_current_locus
;
10170 /* When we get here, we've just matched a list of attributes and
10171 maybe a type and a double colon. The next thing we expect to see
10172 is the name of the symbol. */
10173 m
= gfc_match_name (name
);
10174 if (m
!= MATCH_YES
)
10177 var_locus
= gfc_current_locus
;
10179 /* OK, we've successfully matched the declaration. Now put the
10180 symbol in the current namespace. If we fail to create the symbol,
10182 if (!build_sym (name
, NULL
, false, &as
, &var_locus
))
10188 /* The double colon must be present in order to have initializers.
10189 Otherwise the statement is ambiguous with an assignment statement. */
10192 if (gfc_match_char ('=') == MATCH_YES
)
10194 m
= gfc_match_init_expr (&initializer
);
10197 gfc_error ("Expected an initialization expression at %C");
10201 if (m
!= MATCH_YES
)
10206 /* If we do not have an initializer, the initialization value of the
10207 previous enumerator (stored in last_initializer) is incremented
10208 by 1 and is used to initialize the current enumerator. */
10209 if (initializer
== NULL
)
10210 initializer
= enum_initializer (last_initializer
, old_locus
);
10212 if (initializer
== NULL
|| initializer
->ts
.type
!= BT_INTEGER
)
10214 gfc_error ("ENUMERATOR %L not initialized with integer expression",
10220 /* Store this current initializer, for the next enumerator variable
10221 to be parsed. add_init_expr_to_sym() zeros initializer, so we
10222 use last_initializer below. */
10223 last_initializer
= initializer
;
10224 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
10226 /* Maintain enumerator history. */
10227 gfc_find_symbol (name
, NULL
, 0, &sym
);
10228 create_enum_history (sym
, last_initializer
);
10230 return (t
) ? MATCH_YES
: MATCH_ERROR
;
10233 /* Free stuff up and return. */
10234 gfc_free_expr (initializer
);
10240 /* Match the enumerator definition statement. */
10243 gfc_match_enumerator_def (void)
10248 gfc_clear_ts (¤t_ts
);
10250 m
= gfc_match (" enumerator");
10251 if (m
!= MATCH_YES
)
10254 m
= gfc_match (" :: ");
10255 if (m
== MATCH_ERROR
)
10258 colon_seen
= (m
== MATCH_YES
);
10260 if (gfc_current_state () != COMP_ENUM
)
10262 gfc_error ("ENUM definition statement expected before %C");
10263 gfc_free_enum_history ();
10264 return MATCH_ERROR
;
10267 (¤t_ts
)->type
= BT_INTEGER
;
10268 (¤t_ts
)->kind
= gfc_c_int_kind
;
10270 gfc_clear_attr (¤t_attr
);
10271 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, NULL
);
10280 m
= enumerator_decl ();
10281 if (m
== MATCH_ERROR
)
10283 gfc_free_enum_history ();
10289 if (gfc_match_eos () == MATCH_YES
)
10291 if (gfc_match_char (',') != MATCH_YES
)
10295 if (gfc_current_state () == COMP_ENUM
)
10297 gfc_free_enum_history ();
10298 gfc_error ("Syntax error in ENUMERATOR definition at %C");
10303 gfc_free_array_spec (current_as
);
10310 /* Match binding attributes. */
10313 match_binding_attributes (gfc_typebound_proc
* ba
, bool generic
, bool ppc
)
10315 bool found_passing
= false;
10316 bool seen_ptr
= false;
10317 match m
= MATCH_YES
;
10319 /* Initialize to defaults. Do so even before the MATCH_NO check so that in
10320 this case the defaults are in there. */
10321 ba
->access
= ACCESS_UNKNOWN
;
10322 ba
->pass_arg
= NULL
;
10323 ba
->pass_arg_num
= 0;
10325 ba
->non_overridable
= 0;
10329 /* If we find a comma, we believe there are binding attributes. */
10330 m
= gfc_match_char (',');
10336 /* Access specifier. */
10338 m
= gfc_match (" public");
10339 if (m
== MATCH_ERROR
)
10341 if (m
== MATCH_YES
)
10343 if (ba
->access
!= ACCESS_UNKNOWN
)
10345 gfc_error ("Duplicate access-specifier at %C");
10349 ba
->access
= ACCESS_PUBLIC
;
10353 m
= gfc_match (" private");
10354 if (m
== MATCH_ERROR
)
10356 if (m
== MATCH_YES
)
10358 if (ba
->access
!= ACCESS_UNKNOWN
)
10360 gfc_error ("Duplicate access-specifier at %C");
10364 ba
->access
= ACCESS_PRIVATE
;
10368 /* If inside GENERIC, the following is not allowed. */
10373 m
= gfc_match (" nopass");
10374 if (m
== MATCH_ERROR
)
10376 if (m
== MATCH_YES
)
10380 gfc_error ("Binding attributes already specify passing,"
10381 " illegal NOPASS at %C");
10385 found_passing
= true;
10390 /* PASS possibly including argument. */
10391 m
= gfc_match (" pass");
10392 if (m
== MATCH_ERROR
)
10394 if (m
== MATCH_YES
)
10396 char arg
[GFC_MAX_SYMBOL_LEN
+ 1];
10400 gfc_error ("Binding attributes already specify passing,"
10401 " illegal PASS at %C");
10405 m
= gfc_match (" ( %n )", arg
);
10406 if (m
== MATCH_ERROR
)
10408 if (m
== MATCH_YES
)
10409 ba
->pass_arg
= gfc_get_string ("%s", arg
);
10410 gcc_assert ((m
== MATCH_YES
) == (ba
->pass_arg
!= NULL
));
10412 found_passing
= true;
10419 /* POINTER flag. */
10420 m
= gfc_match (" pointer");
10421 if (m
== MATCH_ERROR
)
10423 if (m
== MATCH_YES
)
10427 gfc_error ("Duplicate POINTER attribute at %C");
10437 /* NON_OVERRIDABLE flag. */
10438 m
= gfc_match (" non_overridable");
10439 if (m
== MATCH_ERROR
)
10441 if (m
== MATCH_YES
)
10443 if (ba
->non_overridable
)
10445 gfc_error ("Duplicate NON_OVERRIDABLE at %C");
10449 ba
->non_overridable
= 1;
10453 /* DEFERRED flag. */
10454 m
= gfc_match (" deferred");
10455 if (m
== MATCH_ERROR
)
10457 if (m
== MATCH_YES
)
10461 gfc_error ("Duplicate DEFERRED at %C");
10472 /* Nothing matching found. */
10474 gfc_error ("Expected access-specifier at %C");
10476 gfc_error ("Expected binding attribute at %C");
10479 while (gfc_match_char (',') == MATCH_YES
);
10481 /* NON_OVERRIDABLE and DEFERRED exclude themselves. */
10482 if (ba
->non_overridable
&& ba
->deferred
)
10484 gfc_error ("NON_OVERRIDABLE and DEFERRED can't both appear at %C");
10491 if (ba
->access
== ACCESS_UNKNOWN
)
10492 ba
->access
= gfc_typebound_default_access
;
10494 if (ppc
&& !seen_ptr
)
10496 gfc_error ("POINTER attribute is required for procedure pointer component"
10504 return MATCH_ERROR
;
10508 /* Match a PROCEDURE specific binding inside a derived type. */
10511 match_procedure_in_type (void)
10513 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10514 char target_buf
[GFC_MAX_SYMBOL_LEN
+ 1];
10515 char* target
= NULL
, *ifc
= NULL
;
10516 gfc_typebound_proc tb
;
10520 gfc_symtree
* stree
;
10525 /* Check current state. */
10526 gcc_assert (gfc_state_stack
->state
== COMP_DERIVED_CONTAINS
);
10527 block
= gfc_state_stack
->previous
->sym
;
10528 gcc_assert (block
);
10530 /* Try to match PROCEDURE(interface). */
10531 if (gfc_match (" (") == MATCH_YES
)
10533 m
= gfc_match_name (target_buf
);
10534 if (m
== MATCH_ERROR
)
10536 if (m
!= MATCH_YES
)
10538 gfc_error ("Interface-name expected after %<(%> at %C");
10539 return MATCH_ERROR
;
10542 if (gfc_match (" )") != MATCH_YES
)
10544 gfc_error ("%<)%> expected at %C");
10545 return MATCH_ERROR
;
10551 /* Construct the data structure. */
10552 memset (&tb
, 0, sizeof (tb
));
10553 tb
.where
= gfc_current_locus
;
10555 /* Match binding attributes. */
10556 m
= match_binding_attributes (&tb
, false, false);
10557 if (m
== MATCH_ERROR
)
10559 seen_attrs
= (m
== MATCH_YES
);
10561 /* Check that attribute DEFERRED is given if an interface is specified. */
10562 if (tb
.deferred
&& !ifc
)
10564 gfc_error ("Interface must be specified for DEFERRED binding at %C");
10565 return MATCH_ERROR
;
10567 if (ifc
&& !tb
.deferred
)
10569 gfc_error ("PROCEDURE(interface) at %C should be declared DEFERRED");
10570 return MATCH_ERROR
;
10573 /* Match the colons. */
10574 m
= gfc_match (" ::");
10575 if (m
== MATCH_ERROR
)
10577 seen_colons
= (m
== MATCH_YES
);
10578 if (seen_attrs
&& !seen_colons
)
10580 gfc_error ("Expected %<::%> after binding-attributes at %C");
10581 return MATCH_ERROR
;
10584 /* Match the binding names. */
10587 m
= gfc_match_name (name
);
10588 if (m
== MATCH_ERROR
)
10592 gfc_error ("Expected binding name at %C");
10593 return MATCH_ERROR
;
10596 if (num
>1 && !gfc_notify_std (GFC_STD_F2008
, "PROCEDURE list at %C"))
10597 return MATCH_ERROR
;
10599 /* Try to match the '=> target', if it's there. */
10601 m
= gfc_match (" =>");
10602 if (m
== MATCH_ERROR
)
10604 if (m
== MATCH_YES
)
10608 gfc_error ("%<=> target%> is invalid for DEFERRED binding at %C");
10609 return MATCH_ERROR
;
10614 gfc_error ("%<::%> needed in PROCEDURE binding with explicit target"
10616 return MATCH_ERROR
;
10619 m
= gfc_match_name (target_buf
);
10620 if (m
== MATCH_ERROR
)
10624 gfc_error ("Expected binding target after %<=>%> at %C");
10625 return MATCH_ERROR
;
10627 target
= target_buf
;
10630 /* If no target was found, it has the same name as the binding. */
10634 /* Get the namespace to insert the symbols into. */
10635 ns
= block
->f2k_derived
;
10638 /* If the binding is DEFERRED, check that the containing type is ABSTRACT. */
10639 if (tb
.deferred
&& !block
->attr
.abstract
)
10641 gfc_error ("Type %qs containing DEFERRED binding at %C "
10642 "is not ABSTRACT", block
->name
);
10643 return MATCH_ERROR
;
10646 /* See if we already have a binding with this name in the symtree which
10647 would be an error. If a GENERIC already targeted this binding, it may
10648 be already there but then typebound is still NULL. */
10649 stree
= gfc_find_symtree (ns
->tb_sym_root
, name
);
10650 if (stree
&& stree
->n
.tb
)
10652 gfc_error ("There is already a procedure with binding name %qs for "
10653 "the derived type %qs at %C", name
, block
->name
);
10654 return MATCH_ERROR
;
10657 /* Insert it and set attributes. */
10661 stree
= gfc_new_symtree (&ns
->tb_sym_root
, name
);
10662 gcc_assert (stree
);
10664 stree
->n
.tb
= gfc_get_typebound_proc (&tb
);
10666 if (gfc_get_sym_tree (target
, gfc_current_ns
, &stree
->n
.tb
->u
.specific
,
10668 return MATCH_ERROR
;
10669 gfc_set_sym_referenced (stree
->n
.tb
->u
.specific
->n
.sym
);
10670 gfc_add_flavor(&stree
->n
.tb
->u
.specific
->n
.sym
->attr
, FL_PROCEDURE
,
10671 target
, &stree
->n
.tb
->u
.specific
->n
.sym
->declared_at
);
10673 if (gfc_match_eos () == MATCH_YES
)
10675 if (gfc_match_char (',') != MATCH_YES
)
10680 gfc_error ("Syntax error in PROCEDURE statement at %C");
10681 return MATCH_ERROR
;
10685 /* Match a GENERIC procedure binding inside a derived type. */
10688 gfc_match_generic (void)
10690 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10691 char bind_name
[GFC_MAX_SYMBOL_LEN
+ 16]; /* Allow space for OPERATOR(...). */
10693 gfc_typebound_proc tbattr
; /* Used for match_binding_attributes. */
10694 gfc_typebound_proc
* tb
;
10696 interface_type op_type
;
10697 gfc_intrinsic_op op
;
10700 /* Check current state. */
10701 if (gfc_current_state () == COMP_DERIVED
)
10703 gfc_error ("GENERIC at %C must be inside a derived-type CONTAINS");
10704 return MATCH_ERROR
;
10706 if (gfc_current_state () != COMP_DERIVED_CONTAINS
)
10708 block
= gfc_state_stack
->previous
->sym
;
10709 ns
= block
->f2k_derived
;
10710 gcc_assert (block
&& ns
);
10712 memset (&tbattr
, 0, sizeof (tbattr
));
10713 tbattr
.where
= gfc_current_locus
;
10715 /* See if we get an access-specifier. */
10716 m
= match_binding_attributes (&tbattr
, true, false);
10717 if (m
== MATCH_ERROR
)
10720 /* Now the colons, those are required. */
10721 if (gfc_match (" ::") != MATCH_YES
)
10723 gfc_error ("Expected %<::%> at %C");
10727 /* Match the binding name; depending on type (operator / generic) format
10728 it for future error messages into bind_name. */
10730 m
= gfc_match_generic_spec (&op_type
, name
, &op
);
10731 if (m
== MATCH_ERROR
)
10732 return MATCH_ERROR
;
10735 gfc_error ("Expected generic name or operator descriptor at %C");
10741 case INTERFACE_GENERIC
:
10742 case INTERFACE_DTIO
:
10743 snprintf (bind_name
, sizeof (bind_name
), "%s", name
);
10746 case INTERFACE_USER_OP
:
10747 snprintf (bind_name
, sizeof (bind_name
), "OPERATOR(.%s.)", name
);
10750 case INTERFACE_INTRINSIC_OP
:
10751 snprintf (bind_name
, sizeof (bind_name
), "OPERATOR(%s)",
10752 gfc_op2string (op
));
10755 case INTERFACE_NAMELESS
:
10756 gfc_error ("Malformed GENERIC statement at %C");
10761 gcc_unreachable ();
10764 /* Match the required =>. */
10765 if (gfc_match (" =>") != MATCH_YES
)
10767 gfc_error ("Expected %<=>%> at %C");
10771 /* Try to find existing GENERIC binding with this name / for this operator;
10772 if there is something, check that it is another GENERIC and then extend
10773 it rather than building a new node. Otherwise, create it and put it
10774 at the right position. */
10778 case INTERFACE_DTIO
:
10779 case INTERFACE_USER_OP
:
10780 case INTERFACE_GENERIC
:
10782 const bool is_op
= (op_type
== INTERFACE_USER_OP
);
10785 st
= gfc_find_symtree (is_op
? ns
->tb_uop_root
: ns
->tb_sym_root
, name
);
10786 tb
= st
? st
->n
.tb
: NULL
;
10790 case INTERFACE_INTRINSIC_OP
:
10791 tb
= ns
->tb_op
[op
];
10795 gcc_unreachable ();
10800 if (!tb
->is_generic
)
10802 gcc_assert (op_type
== INTERFACE_GENERIC
);
10803 gfc_error ("There's already a non-generic procedure with binding name"
10804 " %qs for the derived type %qs at %C",
10805 bind_name
, block
->name
);
10809 if (tb
->access
!= tbattr
.access
)
10811 gfc_error ("Binding at %C must have the same access as already"
10812 " defined binding %qs", bind_name
);
10818 tb
= gfc_get_typebound_proc (NULL
);
10819 tb
->where
= gfc_current_locus
;
10820 tb
->access
= tbattr
.access
;
10821 tb
->is_generic
= 1;
10822 tb
->u
.generic
= NULL
;
10826 case INTERFACE_DTIO
:
10827 case INTERFACE_GENERIC
:
10828 case INTERFACE_USER_OP
:
10830 const bool is_op
= (op_type
== INTERFACE_USER_OP
);
10831 gfc_symtree
* st
= gfc_get_tbp_symtree (is_op
? &ns
->tb_uop_root
:
10832 &ns
->tb_sym_root
, name
);
10839 case INTERFACE_INTRINSIC_OP
:
10840 ns
->tb_op
[op
] = tb
;
10844 gcc_unreachable ();
10848 /* Now, match all following names as specific targets. */
10851 gfc_symtree
* target_st
;
10852 gfc_tbp_generic
* target
;
10854 m
= gfc_match_name (name
);
10855 if (m
== MATCH_ERROR
)
10859 gfc_error ("Expected specific binding name at %C");
10863 target_st
= gfc_get_tbp_symtree (&ns
->tb_sym_root
, name
);
10865 /* See if this is a duplicate specification. */
10866 for (target
= tb
->u
.generic
; target
; target
= target
->next
)
10867 if (target_st
== target
->specific_st
)
10869 gfc_error ("%qs already defined as specific binding for the"
10870 " generic %qs at %C", name
, bind_name
);
10874 target
= gfc_get_tbp_generic ();
10875 target
->specific_st
= target_st
;
10876 target
->specific
= NULL
;
10877 target
->next
= tb
->u
.generic
;
10878 target
->is_operator
= ((op_type
== INTERFACE_USER_OP
)
10879 || (op_type
== INTERFACE_INTRINSIC_OP
));
10880 tb
->u
.generic
= target
;
10882 while (gfc_match (" ,") == MATCH_YES
);
10884 /* Here should be the end. */
10885 if (gfc_match_eos () != MATCH_YES
)
10887 gfc_error ("Junk after GENERIC binding at %C");
10894 return MATCH_ERROR
;
10898 /* Match a FINAL declaration inside a derived type. */
10901 gfc_match_final_decl (void)
10903 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10906 gfc_namespace
* module_ns
;
10910 if (gfc_current_form
== FORM_FREE
)
10912 char c
= gfc_peek_ascii_char ();
10913 if (!gfc_is_whitespace (c
) && c
!= ':')
10917 if (gfc_state_stack
->state
!= COMP_DERIVED_CONTAINS
)
10919 if (gfc_current_form
== FORM_FIXED
)
10922 gfc_error ("FINAL declaration at %C must be inside a derived type "
10923 "CONTAINS section");
10924 return MATCH_ERROR
;
10927 block
= gfc_state_stack
->previous
->sym
;
10928 gcc_assert (block
);
10930 if (!gfc_state_stack
->previous
|| !gfc_state_stack
->previous
->previous
10931 || gfc_state_stack
->previous
->previous
->state
!= COMP_MODULE
)
10933 gfc_error ("Derived type declaration with FINAL at %C must be in the"
10934 " specification part of a MODULE");
10935 return MATCH_ERROR
;
10938 module_ns
= gfc_current_ns
;
10939 gcc_assert (module_ns
);
10940 gcc_assert (module_ns
->proc_name
->attr
.flavor
== FL_MODULE
);
10942 /* Match optional ::, don't care about MATCH_YES or MATCH_NO. */
10943 if (gfc_match (" ::") == MATCH_ERROR
)
10944 return MATCH_ERROR
;
10946 /* Match the sequence of procedure names. */
10953 if (first
&& gfc_match_eos () == MATCH_YES
)
10955 gfc_error ("Empty FINAL at %C");
10956 return MATCH_ERROR
;
10959 m
= gfc_match_name (name
);
10962 gfc_error ("Expected module procedure name at %C");
10963 return MATCH_ERROR
;
10965 else if (m
!= MATCH_YES
)
10966 return MATCH_ERROR
;
10968 if (gfc_match_eos () == MATCH_YES
)
10970 if (!last
&& gfc_match_char (',') != MATCH_YES
)
10972 gfc_error ("Expected %<,%> at %C");
10973 return MATCH_ERROR
;
10976 if (gfc_get_symbol (name
, module_ns
, &sym
))
10978 gfc_error ("Unknown procedure name %qs at %C", name
);
10979 return MATCH_ERROR
;
10982 /* Mark the symbol as module procedure. */
10983 if (sym
->attr
.proc
!= PROC_MODULE
10984 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
10985 return MATCH_ERROR
;
10987 /* Check if we already have this symbol in the list, this is an error. */
10988 for (f
= block
->f2k_derived
->finalizers
; f
; f
= f
->next
)
10989 if (f
->proc_sym
== sym
)
10991 gfc_error ("%qs at %C is already defined as FINAL procedure",
10993 return MATCH_ERROR
;
10996 /* Add this symbol to the list of finalizers. */
10997 gcc_assert (block
->f2k_derived
);
10999 f
= XCNEW (gfc_finalizer
);
11001 f
->proc_tree
= NULL
;
11002 f
->where
= gfc_current_locus
;
11003 f
->next
= block
->f2k_derived
->finalizers
;
11004 block
->f2k_derived
->finalizers
= f
;
11014 const ext_attr_t ext_attr_list
[] = {
11015 { "dllimport", EXT_ATTR_DLLIMPORT
, "dllimport" },
11016 { "dllexport", EXT_ATTR_DLLEXPORT
, "dllexport" },
11017 { "cdecl", EXT_ATTR_CDECL
, "cdecl" },
11018 { "stdcall", EXT_ATTR_STDCALL
, "stdcall" },
11019 { "fastcall", EXT_ATTR_FASTCALL
, "fastcall" },
11020 { "no_arg_check", EXT_ATTR_NO_ARG_CHECK
, NULL
},
11021 { NULL
, EXT_ATTR_LAST
, NULL
}
11024 /* Match a !GCC$ ATTRIBUTES statement of the form:
11025 !GCC$ ATTRIBUTES attribute-list :: var-name [, var-name] ...
11026 When we come here, we have already matched the !GCC$ ATTRIBUTES string.
11028 TODO: We should support all GCC attributes using the same syntax for
11029 the attribute list, i.e. the list in C
11030 __attributes(( attribute-list ))
11032 !GCC$ ATTRIBUTES attribute-list ::
11033 Cf. c-parser.c's c_parser_attributes; the data can then directly be
11036 As there is absolutely no risk of confusion, we should never return
11039 gfc_match_gcc_attributes (void)
11041 symbol_attribute attr
;
11042 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
11047 gfc_clear_attr (&attr
);
11052 if (gfc_match_name (name
) != MATCH_YES
)
11053 return MATCH_ERROR
;
11055 for (id
= 0; id
< EXT_ATTR_LAST
; id
++)
11056 if (strcmp (name
, ext_attr_list
[id
].name
) == 0)
11059 if (id
== EXT_ATTR_LAST
)
11061 gfc_error ("Unknown attribute in !GCC$ ATTRIBUTES statement at %C");
11062 return MATCH_ERROR
;
11065 if (!gfc_add_ext_attribute (&attr
, (ext_attr_id_t
)id
, &gfc_current_locus
))
11066 return MATCH_ERROR
;
11068 gfc_gobble_whitespace ();
11069 ch
= gfc_next_ascii_char ();
11072 /* This is the successful exit condition for the loop. */
11073 if (gfc_next_ascii_char () == ':')
11083 if (gfc_match_eos () == MATCH_YES
)
11088 m
= gfc_match_name (name
);
11089 if (m
!= MATCH_YES
)
11092 if (find_special (name
, &sym
, true))
11093 return MATCH_ERROR
;
11095 sym
->attr
.ext_attr
|= attr
.ext_attr
;
11097 if (gfc_match_eos () == MATCH_YES
)
11100 if (gfc_match_char (',') != MATCH_YES
)
11107 gfc_error ("Syntax error in !GCC$ ATTRIBUTES statement at %C");
11108 return MATCH_ERROR
;
11112 /* Match a !GCC$ UNROLL statement of the form:
11115 The parameter n is the number of times we are supposed to unroll.
11117 When we come here, we have already matched the !GCC$ UNROLL string. */
11119 gfc_match_gcc_unroll (void)
11123 if (gfc_match_small_int (&value
) == MATCH_YES
)
11125 if (value
< 0 || value
> USHRT_MAX
)
11127 gfc_error ("%<GCC unroll%> directive requires a"
11128 " non-negative integral constant"
11129 " less than or equal to %u at %C",
11132 return MATCH_ERROR
;
11134 if (gfc_match_eos () == MATCH_YES
)
11136 directive_unroll
= value
== 0 ? 1 : value
;
11141 gfc_error ("Syntax error in !GCC$ UNROLL directive at %C");
11142 return MATCH_ERROR
;