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 ("RESULT variable %qs at %L prohibits FUNCTION name %qs at %C "
2257 "from appearing in a specification statement",
2258 block
->result
->name
, &block
->result
->declared_at
, name
);
2267 /* Match a variable name with an optional initializer. When this
2268 subroutine is called, a variable is expected to be parsed next.
2269 Depending on what is happening at the moment, updates either the
2270 symbol table or the current interface. */
2273 variable_decl (int elem
)
2275 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2276 static unsigned int fill_id
= 0;
2277 gfc_expr
*initializer
, *char_len
;
2279 gfc_array_spec
*cp_as
; /* Extra copy for Cray Pointees. */
2291 /* When we get here, we've just matched a list of attributes and
2292 maybe a type and a double colon. The next thing we expect to see
2293 is the name of the symbol. */
2295 /* If we are parsing a structure with legacy support, we allow the symbol
2296 name to be '%FILL' which gives it an anonymous (inaccessible) name. */
2298 gfc_gobble_whitespace ();
2299 if (gfc_peek_ascii_char () == '%')
2301 gfc_next_ascii_char ();
2302 m
= gfc_match ("fill");
2307 m
= gfc_match_name (name
);
2315 if (gfc_current_state () != COMP_STRUCTURE
)
2317 if (flag_dec_structure
)
2318 gfc_error ("%qs not allowed outside STRUCTURE at %C", "%FILL");
2320 gfc_error ("%qs at %C is a DEC extension, enable with "
2321 "%<-fdec-structure%>", "%FILL");
2327 gfc_error ("%qs entity cannot have attributes at %C", "%FILL");
2331 /* %FILL components are given invalid fortran names. */
2332 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "%%FILL%u", fill_id
++);
2336 var_locus
= gfc_current_locus
;
2338 /* Now we could see the optional array spec. or character length. */
2339 m
= gfc_match_array_spec (&as
, true, true);
2340 if (m
== MATCH_ERROR
)
2344 as
= gfc_copy_array_spec (current_as
);
2346 && !merge_array_spec (current_as
, as
, true))
2352 if (flag_cray_pointer
)
2353 cp_as
= gfc_copy_array_spec (as
);
2355 /* At this point, we know for sure if the symbol is PARAMETER and can thus
2356 determine (and check) whether it can be implied-shape. If it
2357 was parsed as assumed-size, change it because PARAMETERs can not
2360 An explicit-shape-array cannot appear under several conditions.
2361 That check is done here as well. */
2364 if (as
->type
== AS_IMPLIED_SHAPE
&& current_attr
.flavor
!= FL_PARAMETER
)
2367 gfc_error ("Non-PARAMETER symbol %qs at %L can't be implied-shape",
2372 if (as
->type
== AS_ASSUMED_SIZE
&& as
->rank
== 1
2373 && current_attr
.flavor
== FL_PARAMETER
)
2374 as
->type
= AS_IMPLIED_SHAPE
;
2376 if (as
->type
== AS_IMPLIED_SHAPE
2377 && !gfc_notify_std (GFC_STD_F2008
, "Implied-shape array at %L",
2384 /* F2018:C830 (R816) An explicit-shape-spec whose bounds are not
2385 constant expressions shall appear only in a subprogram, derived
2386 type definition, BLOCK construct, or interface body. */
2387 if (as
->type
== AS_EXPLICIT
2388 && gfc_current_state () != COMP_BLOCK
2389 && gfc_current_state () != COMP_DERIVED
2390 && gfc_current_state () != COMP_FUNCTION
2391 && gfc_current_state () != COMP_INTERFACE
2392 && gfc_current_state () != COMP_SUBROUTINE
)
2395 bool not_constant
= false;
2397 for (int i
= 0; i
< as
->rank
; i
++)
2399 e
= gfc_copy_expr (as
->lower
[i
]);
2400 gfc_resolve_expr (e
);
2401 gfc_simplify_expr (e
, 0);
2402 if (e
&& (e
->expr_type
!= EXPR_CONSTANT
))
2404 not_constant
= true;
2409 e
= gfc_copy_expr (as
->upper
[i
]);
2410 gfc_resolve_expr (e
);
2411 gfc_simplify_expr (e
, 0);
2412 if (e
&& (e
->expr_type
!= EXPR_CONSTANT
))
2414 not_constant
= true;
2422 gfc_error ("Explicit shaped array with nonconstant bounds at %C");
2427 if (as
->type
== AS_EXPLICIT
)
2429 for (int i
= 0; i
< as
->rank
; i
++)
2433 if (e
->expr_type
!= EXPR_CONSTANT
)
2435 n
= gfc_copy_expr (e
);
2436 gfc_simplify_expr (n
, 1);
2437 if (n
->expr_type
== EXPR_CONSTANT
)
2438 gfc_replace_expr (e
, n
);
2443 if (e
->expr_type
!= EXPR_CONSTANT
)
2445 n
= gfc_copy_expr (e
);
2446 gfc_simplify_expr (n
, 1);
2447 if (n
->expr_type
== EXPR_CONSTANT
)
2448 gfc_replace_expr (e
, n
);
2458 cl_deferred
= false;
2460 if (current_ts
.type
== BT_CHARACTER
)
2462 switch (match_char_length (&char_len
, &cl_deferred
, false))
2465 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2467 cl
->length
= char_len
;
2470 /* Non-constant lengths need to be copied after the first
2471 element. Also copy assumed lengths. */
2474 && (current_ts
.u
.cl
->length
== NULL
2475 || current_ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
2477 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2478 cl
->length
= gfc_copy_expr (current_ts
.u
.cl
->length
);
2481 cl
= current_ts
.u
.cl
;
2483 cl_deferred
= current_ts
.deferred
;
2492 /* The dummy arguments and result of the abreviated form of MODULE
2493 PROCEDUREs, used in SUBMODULES should not be redefined. */
2494 if (gfc_current_ns
->proc_name
2495 && gfc_current_ns
->proc_name
->abr_modproc_decl
)
2497 gfc_find_symbol (name
, gfc_current_ns
, 1, &sym
);
2498 if (sym
!= NULL
&& (sym
->attr
.dummy
|| sym
->attr
.result
))
2501 gfc_error ("%qs at %C is a redefinition of the declaration "
2502 "in the corresponding interface for MODULE "
2503 "PROCEDURE %qs", sym
->name
,
2504 gfc_current_ns
->proc_name
->name
);
2509 /* %FILL components may not have initializers. */
2510 if (strncmp (name
, "%FILL", 5) == 0 && gfc_match_eos () != MATCH_YES
)
2512 gfc_error ("%qs entity cannot have an initializer at %C", "%FILL");
2517 /* If this symbol has already shown up in a Cray Pointer declaration,
2518 and this is not a component declaration,
2519 then we want to set the type & bail out. */
2520 if (flag_cray_pointer
&& !gfc_comp_struct (gfc_current_state ()))
2522 gfc_find_symbol (name
, gfc_current_ns
, 1, &sym
);
2523 if (sym
!= NULL
&& sym
->attr
.cray_pointee
)
2525 sym
->ts
.type
= current_ts
.type
;
2526 sym
->ts
.kind
= current_ts
.kind
;
2528 sym
->ts
.u
.derived
= current_ts
.u
.derived
;
2529 sym
->ts
.is_c_interop
= current_ts
.is_c_interop
;
2530 sym
->ts
.is_iso_c
= current_ts
.is_iso_c
;
2533 /* Check to see if we have an array specification. */
2536 if (sym
->as
!= NULL
)
2538 gfc_error ("Duplicate array spec for Cray pointee at %C");
2539 gfc_free_array_spec (cp_as
);
2545 if (!gfc_set_array_spec (sym
, cp_as
, &var_locus
))
2546 gfc_internal_error ("Couldn't set pointee array spec.");
2548 /* Fix the array spec. */
2549 m
= gfc_mod_pointee_as (sym
->as
);
2550 if (m
== MATCH_ERROR
)
2558 gfc_free_array_spec (cp_as
);
2562 /* Procedure pointer as function result. */
2563 if (gfc_current_state () == COMP_FUNCTION
2564 && strcmp ("ppr@", gfc_current_block ()->name
) == 0
2565 && strcmp (name
, gfc_current_block ()->ns
->proc_name
->name
) == 0)
2566 strcpy (name
, "ppr@");
2568 if (gfc_current_state () == COMP_FUNCTION
2569 && strcmp (name
, gfc_current_block ()->name
) == 0
2570 && gfc_current_block ()->result
2571 && strcmp ("ppr@", gfc_current_block ()->result
->name
) == 0)
2572 strcpy (name
, "ppr@");
2574 /* OK, we've successfully matched the declaration. Now put the
2575 symbol in the current namespace, because it might be used in the
2576 optional initialization expression for this symbol, e.g. this is
2579 integer, parameter :: i = huge(i)
2581 This is only true for parameters or variables of a basic type.
2582 For components of derived types, it is not true, so we don't
2583 create a symbol for those yet. If we fail to create the symbol,
2585 if (!gfc_comp_struct (gfc_current_state ())
2586 && !build_sym (name
, cl
, cl_deferred
, &as
, &var_locus
))
2592 if (!check_function_name (name
))
2598 /* We allow old-style initializations of the form
2599 integer i /2/, j(4) /3*3, 1/
2600 (if no colon has been seen). These are different from data
2601 statements in that initializers are only allowed to apply to the
2602 variable immediately preceding, i.e.
2604 is not allowed. Therefore we have to do some work manually, that
2605 could otherwise be left to the matchers for DATA statements. */
2607 if (!colon_seen
&& gfc_match (" /") == MATCH_YES
)
2609 if (!gfc_notify_std (GFC_STD_GNU
, "Old-style "
2610 "initialization at %C"))
2613 /* Allow old style initializations for components of STRUCTUREs and MAPs
2614 but not components of derived types. */
2615 else if (gfc_current_state () == COMP_DERIVED
)
2617 gfc_error ("Invalid old style initialization for derived type "
2623 /* For structure components, read the initializer as a special
2624 expression and let the rest of this function apply the initializer
2626 else if (gfc_comp_struct (gfc_current_state ()))
2628 m
= match_clist_expr (&initializer
, ¤t_ts
, as
);
2630 gfc_error ("Syntax error in old style initialization of %s at %C",
2636 /* Otherwise we treat the old style initialization just like a
2637 DATA declaration for the current variable. */
2639 return match_old_style_init (name
);
2642 /* The double colon must be present in order to have initializers.
2643 Otherwise the statement is ambiguous with an assignment statement. */
2646 if (gfc_match (" =>") == MATCH_YES
)
2648 if (!current_attr
.pointer
)
2650 gfc_error ("Initialization at %C isn't for a pointer variable");
2655 m
= match_pointer_init (&initializer
, 0);
2659 else if (gfc_match_char ('=') == MATCH_YES
)
2661 if (current_attr
.pointer
)
2663 gfc_error ("Pointer initialization at %C requires %<=>%>, "
2669 m
= gfc_match_init_expr (&initializer
);
2672 gfc_error ("Expected an initialization expression at %C");
2676 if (current_attr
.flavor
!= FL_PARAMETER
&& gfc_pure (NULL
)
2677 && !gfc_comp_struct (gfc_state_stack
->state
))
2679 gfc_error ("Initialization of variable at %C is not allowed in "
2680 "a PURE procedure");
2684 if (current_attr
.flavor
!= FL_PARAMETER
2685 && !gfc_comp_struct (gfc_state_stack
->state
))
2686 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
2693 if (initializer
!= NULL
&& current_attr
.allocatable
2694 && gfc_comp_struct (gfc_current_state ()))
2696 gfc_error ("Initialization of allocatable component at %C is not "
2702 if (gfc_current_state () == COMP_DERIVED
2703 && gfc_current_block ()->attr
.pdt_template
)
2706 gfc_find_symbol (name
, gfc_current_block ()->f2k_derived
,
2708 if (!param
&& (current_attr
.pdt_kind
|| current_attr
.pdt_len
))
2710 gfc_error ("The component with KIND or LEN attribute at %C does not "
2711 "not appear in the type parameter list at %L",
2712 &gfc_current_block ()->declared_at
);
2716 else if (param
&& !(current_attr
.pdt_kind
|| current_attr
.pdt_len
))
2718 gfc_error ("The component at %C that appears in the type parameter "
2719 "list at %L has neither the KIND nor LEN attribute",
2720 &gfc_current_block ()->declared_at
);
2724 else if (as
&& (current_attr
.pdt_kind
|| current_attr
.pdt_len
))
2726 gfc_error ("The component at %C which is a type parameter must be "
2731 else if (param
&& initializer
)
2732 param
->value
= gfc_copy_expr (initializer
);
2735 /* Add the initializer. Note that it is fine if initializer is
2736 NULL here, because we sometimes also need to check if a
2737 declaration *must* have an initialization expression. */
2738 if (!gfc_comp_struct (gfc_current_state ()))
2739 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
2742 if (current_ts
.type
== BT_DERIVED
2743 && !current_attr
.pointer
&& !initializer
)
2744 initializer
= gfc_default_initializer (¤t_ts
);
2745 t
= build_struct (name
, cl
, &initializer
, &as
);
2747 /* If we match a nested structure definition we expect to see the
2748 * body even if the variable declarations blow up, so we need to keep
2749 * the structure declaration around. */
2750 if (gfc_new_block
&& gfc_new_block
->attr
.flavor
== FL_STRUCT
)
2751 gfc_commit_symbol (gfc_new_block
);
2754 m
= (t
) ? MATCH_YES
: MATCH_ERROR
;
2757 /* Free stuff up and return. */
2758 gfc_free_expr (initializer
);
2759 gfc_free_array_spec (as
);
2765 /* Match an extended-f77 "TYPESPEC*bytesize"-style kind specification.
2766 This assumes that the byte size is equal to the kind number for
2767 non-COMPLEX types, and equal to twice the kind number for COMPLEX. */
2770 gfc_match_old_kind_spec (gfc_typespec
*ts
)
2775 if (gfc_match_char ('*') != MATCH_YES
)
2778 m
= gfc_match_small_literal_int (&ts
->kind
, NULL
);
2782 original_kind
= ts
->kind
;
2784 /* Massage the kind numbers for complex types. */
2785 if (ts
->type
== BT_COMPLEX
)
2789 gfc_error ("Old-style type declaration %s*%d not supported at %C",
2790 gfc_basic_typename (ts
->type
), original_kind
);
2797 if (ts
->type
== BT_INTEGER
&& ts
->kind
== 4 && flag_integer4_kind
== 8)
2800 if (ts
->type
== BT_REAL
|| ts
->type
== BT_COMPLEX
)
2804 if (flag_real4_kind
== 8)
2806 if (flag_real4_kind
== 10)
2808 if (flag_real4_kind
== 16)
2814 if (flag_real8_kind
== 4)
2816 if (flag_real8_kind
== 10)
2818 if (flag_real8_kind
== 16)
2823 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
2825 gfc_error ("Old-style type declaration %s*%d not supported at %C",
2826 gfc_basic_typename (ts
->type
), original_kind
);
2830 if (!gfc_notify_std (GFC_STD_GNU
,
2831 "Nonstandard type declaration %s*%d at %C",
2832 gfc_basic_typename(ts
->type
), original_kind
))
2839 /* Match a kind specification. Since kinds are generally optional, we
2840 usually return MATCH_NO if something goes wrong. If a "kind="
2841 string is found, then we know we have an error. */
2844 gfc_match_kind_spec (gfc_typespec
*ts
, bool kind_expr_only
)
2854 saved_kind_expr
= NULL
;
2856 where
= loc
= gfc_current_locus
;
2861 if (gfc_match_char ('(') == MATCH_NO
)
2864 /* Also gobbles optional text. */
2865 if (gfc_match (" kind = ") == MATCH_YES
)
2868 loc
= gfc_current_locus
;
2872 n
= gfc_match_init_expr (&e
);
2874 if (gfc_derived_parameter_expr (e
))
2877 saved_kind_expr
= gfc_copy_expr (e
);
2878 goto close_brackets
;
2883 if (gfc_matching_function
)
2885 /* The function kind expression might include use associated or
2886 imported parameters and try again after the specification
2888 if (gfc_match_char (')') != MATCH_YES
)
2890 gfc_error ("Missing right parenthesis at %C");
2896 gfc_undo_symbols ();
2901 /* ....or else, the match is real. */
2903 gfc_error ("Expected initialization expression at %C");
2911 gfc_error ("Expected scalar initialization expression at %C");
2916 if (gfc_extract_int (e
, &ts
->kind
, 1))
2922 /* Before throwing away the expression, let's see if we had a
2923 C interoperable kind (and store the fact). */
2924 if (e
->ts
.is_c_interop
== 1)
2926 /* Mark this as C interoperable if being declared with one
2927 of the named constants from iso_c_binding. */
2928 ts
->is_c_interop
= e
->ts
.is_iso_c
;
2929 ts
->f90_type
= e
->ts
.f90_type
;
2931 ts
->interop_kind
= e
->symtree
->n
.sym
;
2937 /* Ignore errors to this point, if we've gotten here. This means
2938 we ignore the m=MATCH_ERROR from above. */
2939 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
2941 gfc_error ("Kind %d not supported for type %s at %C", ts
->kind
,
2942 gfc_basic_typename (ts
->type
));
2943 gfc_current_locus
= where
;
2947 /* Warn if, e.g., c_int is used for a REAL variable, but not
2948 if, e.g., c_double is used for COMPLEX as the standard
2949 explicitly says that the kind type parameter for complex and real
2950 variable is the same, i.e. c_float == c_float_complex. */
2951 if (ts
->f90_type
!= BT_UNKNOWN
&& ts
->f90_type
!= ts
->type
2952 && !((ts
->f90_type
== BT_REAL
&& ts
->type
== BT_COMPLEX
)
2953 || (ts
->f90_type
== BT_COMPLEX
&& ts
->type
== BT_REAL
)))
2954 gfc_warning_now (0, "C kind type parameter is for type %s but type at %L "
2955 "is %s", gfc_basic_typename (ts
->f90_type
), &where
,
2956 gfc_basic_typename (ts
->type
));
2960 gfc_gobble_whitespace ();
2961 if ((c
= gfc_next_ascii_char ()) != ')'
2962 && (ts
->type
!= BT_CHARACTER
|| c
!= ','))
2964 if (ts
->type
== BT_CHARACTER
)
2965 gfc_error ("Missing right parenthesis or comma at %C");
2967 gfc_error ("Missing right parenthesis at %C");
2971 /* All tests passed. */
2974 if(m
== MATCH_ERROR
)
2975 gfc_current_locus
= where
;
2977 if (ts
->type
== BT_INTEGER
&& ts
->kind
== 4 && flag_integer4_kind
== 8)
2980 if (ts
->type
== BT_REAL
|| ts
->type
== BT_COMPLEX
)
2984 if (flag_real4_kind
== 8)
2986 if (flag_real4_kind
== 10)
2988 if (flag_real4_kind
== 16)
2994 if (flag_real8_kind
== 4)
2996 if (flag_real8_kind
== 10)
2998 if (flag_real8_kind
== 16)
3003 /* Return what we know from the test(s). */
3008 gfc_current_locus
= where
;
3014 match_char_kind (int * kind
, int * is_iso_c
)
3023 where
= gfc_current_locus
;
3025 n
= gfc_match_init_expr (&e
);
3027 if (n
!= MATCH_YES
&& gfc_matching_function
)
3029 /* The expression might include use-associated or imported
3030 parameters and try again after the specification
3033 gfc_undo_symbols ();
3038 gfc_error ("Expected initialization expression at %C");
3044 gfc_error ("Expected scalar initialization expression at %C");
3049 if (gfc_derived_parameter_expr (e
))
3051 saved_kind_expr
= e
;
3056 fail
= gfc_extract_int (e
, kind
, 1);
3057 *is_iso_c
= e
->ts
.is_iso_c
;
3066 /* Ignore errors to this point, if we've gotten here. This means
3067 we ignore the m=MATCH_ERROR from above. */
3068 if (gfc_validate_kind (BT_CHARACTER
, *kind
, true) < 0)
3070 gfc_error ("Kind %d is not supported for CHARACTER at %C", *kind
);
3074 /* All tests passed. */
3077 if (m
== MATCH_ERROR
)
3078 gfc_current_locus
= where
;
3080 /* Return what we know from the test(s). */
3085 gfc_current_locus
= where
;
3090 /* Match the various kind/length specifications in a CHARACTER
3091 declaration. We don't return MATCH_NO. */
3094 gfc_match_char_spec (gfc_typespec
*ts
)
3096 int kind
, seen_length
, is_iso_c
;
3108 /* Try the old-style specification first. */
3109 old_char_selector
= 0;
3111 m
= match_char_length (&len
, &deferred
, true);
3115 old_char_selector
= 1;
3120 m
= gfc_match_char ('(');
3123 m
= MATCH_YES
; /* Character without length is a single char. */
3127 /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ). */
3128 if (gfc_match (" kind =") == MATCH_YES
)
3130 m
= match_char_kind (&kind
, &is_iso_c
);
3132 if (m
== MATCH_ERROR
)
3137 if (gfc_match (" , len =") == MATCH_NO
)
3140 m
= char_len_param_value (&len
, &deferred
);
3143 if (m
== MATCH_ERROR
)
3150 /* Try to match "LEN = <len-param>" or "LEN = <len-param>, KIND = <int>". */
3151 if (gfc_match (" len =") == MATCH_YES
)
3153 m
= char_len_param_value (&len
, &deferred
);
3156 if (m
== MATCH_ERROR
)
3160 if (gfc_match_char (')') == MATCH_YES
)
3163 if (gfc_match (" , kind =") != MATCH_YES
)
3166 if (match_char_kind (&kind
, &is_iso_c
) == MATCH_ERROR
)
3172 /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ). */
3173 m
= char_len_param_value (&len
, &deferred
);
3176 if (m
== MATCH_ERROR
)
3180 m
= gfc_match_char (')');
3184 if (gfc_match_char (',') != MATCH_YES
)
3187 gfc_match (" kind ="); /* Gobble optional text. */
3189 m
= match_char_kind (&kind
, &is_iso_c
);
3190 if (m
== MATCH_ERROR
)
3196 /* Require a right-paren at this point. */
3197 m
= gfc_match_char (')');
3202 gfc_error ("Syntax error in CHARACTER declaration at %C");
3204 gfc_free_expr (len
);
3208 /* Deal with character functions after USE and IMPORT statements. */
3209 if (gfc_matching_function
)
3211 gfc_free_expr (len
);
3212 gfc_undo_symbols ();
3218 gfc_free_expr (len
);
3222 /* Do some final massaging of the length values. */
3223 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
3225 if (seen_length
== 0)
3226 cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
, 1);
3229 /* If gfortran ends up here, then the len may be reducible to a
3230 constant. Try to do that here. If it does not reduce, simply
3231 assign len to the charlen. */
3232 if (len
&& len
->expr_type
!= EXPR_CONSTANT
)
3235 e
= gfc_copy_expr (len
);
3236 gfc_reduce_init_expr (e
);
3237 if (e
->expr_type
== EXPR_CONSTANT
)
3238 gfc_replace_expr (len
, e
);
3248 ts
->kind
= kind
== 0 ? gfc_default_character_kind
: kind
;
3249 ts
->deferred
= deferred
;
3251 /* We have to know if it was a C interoperable kind so we can
3252 do accurate type checking of bind(c) procs, etc. */
3254 /* Mark this as C interoperable if being declared with one
3255 of the named constants from iso_c_binding. */
3256 ts
->is_c_interop
= is_iso_c
;
3257 else if (len
!= NULL
)
3258 /* Here, we might have parsed something such as: character(c_char)
3259 In this case, the parsing code above grabs the c_char when
3260 looking for the length (line 1690, roughly). it's the last
3261 testcase for parsing the kind params of a character variable.
3262 However, it's not actually the length. this seems like it
3264 To see if the user used a C interop kind, test the expr
3265 of the so called length, and see if it's C interoperable. */
3266 ts
->is_c_interop
= len
->ts
.is_iso_c
;
3272 /* Matches a RECORD declaration. */
3275 match_record_decl (char *name
)
3278 old_loc
= gfc_current_locus
;
3281 m
= gfc_match (" record /");
3284 if (!flag_dec_structure
)
3286 gfc_current_locus
= old_loc
;
3287 gfc_error ("RECORD at %C is an extension, enable it with "
3291 m
= gfc_match (" %n/", name
);
3296 gfc_current_locus
= old_loc
;
3297 if (flag_dec_structure
3298 && (gfc_match (" record% ") == MATCH_YES
3299 || gfc_match (" record%t") == MATCH_YES
))
3300 gfc_error ("Structure name expected after RECORD at %C");
3308 /* This function uses the gfc_actual_arglist 'type_param_spec_list' as a source
3309 of expressions to substitute into the possibly parameterized expression
3310 'e'. Using a list is inefficient but should not be too bad since the
3311 number of type parameters is not likely to be large. */
3313 insert_parameter_exprs (gfc_expr
* e
, gfc_symbol
* sym ATTRIBUTE_UNUSED
,
3316 gfc_actual_arglist
*param
;
3319 if (e
->expr_type
!= EXPR_VARIABLE
)
3322 gcc_assert (e
->symtree
);
3323 if (e
->symtree
->n
.sym
->attr
.pdt_kind
3324 || (*f
!= 0 && e
->symtree
->n
.sym
->attr
.pdt_len
))
3326 for (param
= type_param_spec_list
; param
; param
= param
->next
)
3327 if (strcmp (e
->symtree
->n
.sym
->name
, param
->name
) == 0)
3332 copy
= gfc_copy_expr (param
->expr
);
3343 gfc_insert_kind_parameter_exprs (gfc_expr
*e
)
3345 return gfc_traverse_expr (e
, NULL
, &insert_parameter_exprs
, 0);
3350 gfc_insert_parameter_exprs (gfc_expr
*e
, gfc_actual_arglist
*param_list
)
3352 gfc_actual_arglist
*old_param_spec_list
= type_param_spec_list
;
3353 type_param_spec_list
= param_list
;
3354 return gfc_traverse_expr (e
, NULL
, &insert_parameter_exprs
, 1);
3355 type_param_spec_list
= NULL
;
3356 type_param_spec_list
= old_param_spec_list
;
3359 /* Determines the instance of a parameterized derived type to be used by
3360 matching determining the values of the kind parameters and using them
3361 in the name of the instance. If the instance exists, it is used, otherwise
3362 a new derived type is created. */
3364 gfc_get_pdt_instance (gfc_actual_arglist
*param_list
, gfc_symbol
**sym
,
3365 gfc_actual_arglist
**ext_param_list
)
3367 /* The PDT template symbol. */
3368 gfc_symbol
*pdt
= *sym
;
3369 /* The symbol for the parameter in the template f2k_namespace. */
3371 /* The hoped for instance of the PDT. */
3372 gfc_symbol
*instance
;
3373 /* The list of parameters appearing in the PDT declaration. */
3374 gfc_formal_arglist
*type_param_name_list
;
3375 /* Used to store the parameter specification list during recursive calls. */
3376 gfc_actual_arglist
*old_param_spec_list
;
3377 /* Pointers to the parameter specification being used. */
3378 gfc_actual_arglist
*actual_param
;
3379 gfc_actual_arglist
*tail
= NULL
;
3380 /* Used to build up the name of the PDT instance. The prefix uses 4
3381 characters and each KIND parameter 2 more. Allow 8 of the latter. */
3382 char name
[GFC_MAX_SYMBOL_LEN
+ 21];
3384 bool name_seen
= (param_list
== NULL
);
3385 bool assumed_seen
= false;
3386 bool deferred_seen
= false;
3387 bool spec_error
= false;
3389 gfc_expr
*kind_expr
;
3390 gfc_component
*c1
, *c2
;
3393 type_param_spec_list
= NULL
;
3395 type_param_name_list
= pdt
->formal
;
3396 actual_param
= param_list
;
3397 sprintf (name
, "Pdt%s", pdt
->name
);
3399 /* Run through the parameter name list and pick up the actual
3400 parameter values or use the default values in the PDT declaration. */
3401 for (; type_param_name_list
;
3402 type_param_name_list
= type_param_name_list
->next
)
3404 if (actual_param
&& actual_param
->spec_type
!= SPEC_EXPLICIT
)
3406 if (actual_param
->spec_type
== SPEC_ASSUMED
)
3407 spec_error
= deferred_seen
;
3409 spec_error
= assumed_seen
;
3413 gfc_error ("The type parameter spec list at %C cannot contain "
3414 "both ASSUMED and DEFERRED parameters");
3419 if (actual_param
&& actual_param
->name
)
3421 param
= type_param_name_list
->sym
;
3423 if (!param
|| !param
->name
)
3426 c1
= gfc_find_component (pdt
, param
->name
, false, true, NULL
);
3427 /* An error should already have been thrown in resolve.c
3428 (resolve_fl_derived0). */
3429 if (!pdt
->attr
.use_assoc
&& !c1
)
3435 if (!actual_param
&& !(c1
&& c1
->initializer
))
3437 gfc_error ("The type parameter spec list at %C does not contain "
3438 "enough parameter expressions");
3441 else if (!actual_param
&& c1
&& c1
->initializer
)
3442 kind_expr
= gfc_copy_expr (c1
->initializer
);
3443 else if (actual_param
&& actual_param
->spec_type
== SPEC_EXPLICIT
)
3444 kind_expr
= gfc_copy_expr (actual_param
->expr
);
3448 actual_param
= param_list
;
3449 for (;actual_param
; actual_param
= actual_param
->next
)
3450 if (actual_param
->name
3451 && strcmp (actual_param
->name
, param
->name
) == 0)
3453 if (actual_param
&& actual_param
->spec_type
== SPEC_EXPLICIT
)
3454 kind_expr
= gfc_copy_expr (actual_param
->expr
);
3457 if (c1
->initializer
)
3458 kind_expr
= gfc_copy_expr (c1
->initializer
);
3459 else if (!(actual_param
&& param
->attr
.pdt_len
))
3461 gfc_error ("The derived parameter %qs at %C does not "
3462 "have a default value", param
->name
);
3468 /* Store the current parameter expressions in a temporary actual
3469 arglist 'list' so that they can be substituted in the corresponding
3470 expressions in the PDT instance. */
3471 if (type_param_spec_list
== NULL
)
3473 type_param_spec_list
= gfc_get_actual_arglist ();
3474 tail
= type_param_spec_list
;
3478 tail
->next
= gfc_get_actual_arglist ();
3481 tail
->name
= param
->name
;
3485 /* Try simplification even for LEN expressions. */
3486 gfc_resolve_expr (kind_expr
);
3487 gfc_simplify_expr (kind_expr
, 1);
3488 /* Variable expressions seem to default to BT_PROCEDURE.
3489 TODO find out why this is and fix it. */
3490 if (kind_expr
->ts
.type
!= BT_INTEGER
3491 && kind_expr
->ts
.type
!= BT_PROCEDURE
)
3493 gfc_error ("The parameter expression at %C must be of "
3494 "INTEGER type and not %s type",
3495 gfc_basic_typename (kind_expr
->ts
.type
));
3499 tail
->expr
= gfc_copy_expr (kind_expr
);
3503 tail
->spec_type
= actual_param
->spec_type
;
3505 if (!param
->attr
.pdt_kind
)
3507 if (!name_seen
&& actual_param
)
3508 actual_param
= actual_param
->next
;
3511 gfc_free_expr (kind_expr
);
3518 && (actual_param
->spec_type
== SPEC_ASSUMED
3519 || actual_param
->spec_type
== SPEC_DEFERRED
))
3521 gfc_error ("The KIND parameter %qs at %C cannot either be "
3522 "ASSUMED or DEFERRED", param
->name
);
3526 if (!kind_expr
|| !gfc_is_constant_expr (kind_expr
))
3528 gfc_error ("The value for the KIND parameter %qs at %C does not "
3529 "reduce to a constant expression", param
->name
);
3533 gfc_extract_int (kind_expr
, &kind_value
);
3534 sprintf (name
+ strlen (name
), "_%d", kind_value
);
3536 if (!name_seen
&& actual_param
)
3537 actual_param
= actual_param
->next
;
3538 gfc_free_expr (kind_expr
);
3541 if (!name_seen
&& actual_param
)
3543 gfc_error ("The type parameter spec list at %C contains too many "
3544 "parameter expressions");
3548 /* Now we search for the PDT instance 'name'. If it doesn't exist, we
3549 build it, using 'pdt' as a template. */
3550 if (gfc_get_symbol (name
, pdt
->ns
, &instance
))
3552 gfc_error ("Parameterized derived type at %C is ambiguous");
3558 if (instance
->attr
.flavor
== FL_DERIVED
3559 && instance
->attr
.pdt_type
)
3563 *ext_param_list
= type_param_spec_list
;
3565 gfc_commit_symbols ();
3569 /* Start building the new instance of the parameterized type. */
3570 gfc_copy_attr (&instance
->attr
, &pdt
->attr
, &pdt
->declared_at
);
3571 instance
->attr
.pdt_template
= 0;
3572 instance
->attr
.pdt_type
= 1;
3573 instance
->declared_at
= gfc_current_locus
;
3575 /* Add the components, replacing the parameters in all expressions
3576 with the expressions for their values in 'type_param_spec_list'. */
3577 c1
= pdt
->components
;
3578 tail
= type_param_spec_list
;
3579 for (; c1
; c1
= c1
->next
)
3581 gfc_add_component (instance
, c1
->name
, &c2
);
3584 c2
->attr
= c1
->attr
;
3586 /* The order of declaration of the type_specs might not be the
3587 same as that of the components. */
3588 if (c1
->attr
.pdt_kind
|| c1
->attr
.pdt_len
)
3590 for (tail
= type_param_spec_list
; tail
; tail
= tail
->next
)
3591 if (strcmp (c1
->name
, tail
->name
) == 0)
3595 /* Deal with type extension by recursively calling this function
3596 to obtain the instance of the extended type. */
3597 if (gfc_current_state () != COMP_DERIVED
3598 && c1
== pdt
->components
3599 && (c1
->ts
.type
== BT_DERIVED
|| c1
->ts
.type
== BT_CLASS
)
3600 && c1
->ts
.u
.derived
&& c1
->ts
.u
.derived
->attr
.pdt_template
3601 && gfc_get_derived_super_type (*sym
) == c2
->ts
.u
.derived
)
3603 gfc_formal_arglist
*f
;
3605 old_param_spec_list
= type_param_spec_list
;
3607 /* Obtain a spec list appropriate to the extended type..*/
3608 actual_param
= gfc_copy_actual_arglist (type_param_spec_list
);
3609 type_param_spec_list
= actual_param
;
3610 for (f
= c1
->ts
.u
.derived
->formal
; f
&& f
->next
; f
= f
->next
)
3611 actual_param
= actual_param
->next
;
3614 gfc_free_actual_arglist (actual_param
->next
);
3615 actual_param
->next
= NULL
;
3618 /* Now obtain the PDT instance for the extended type. */
3619 c2
->param_list
= type_param_spec_list
;
3620 m
= gfc_get_pdt_instance (type_param_spec_list
, &c2
->ts
.u
.derived
,
3622 type_param_spec_list
= old_param_spec_list
;
3624 c2
->ts
.u
.derived
->refs
++;
3625 gfc_set_sym_referenced (c2
->ts
.u
.derived
);
3627 /* Set extension level. */
3628 if (c2
->ts
.u
.derived
->attr
.extension
== 255)
3630 /* Since the extension field is 8 bit wide, we can only have
3631 up to 255 extension levels. */
3632 gfc_error ("Maximum extension level reached with type %qs at %L",
3633 c2
->ts
.u
.derived
->name
,
3634 &c2
->ts
.u
.derived
->declared_at
);
3637 instance
->attr
.extension
= c2
->ts
.u
.derived
->attr
.extension
+ 1;
3642 /* Set the component kind using the parameterized expression. */
3643 if ((c1
->ts
.kind
== 0 || c1
->ts
.type
== BT_CHARACTER
)
3644 && c1
->kind_expr
!= NULL
)
3646 gfc_expr
*e
= gfc_copy_expr (c1
->kind_expr
);
3647 gfc_insert_kind_parameter_exprs (e
);
3648 gfc_simplify_expr (e
, 1);
3649 gfc_extract_int (e
, &c2
->ts
.kind
);
3651 if (gfc_validate_kind (c2
->ts
.type
, c2
->ts
.kind
, true) < 0)
3653 gfc_error ("Kind %d not supported for type %s at %C",
3654 c2
->ts
.kind
, gfc_basic_typename (c2
->ts
.type
));
3659 /* Similarly, set the string length if parameterized. */
3660 if (c1
->ts
.type
== BT_CHARACTER
3661 && c1
->ts
.u
.cl
->length
3662 && gfc_derived_parameter_expr (c1
->ts
.u
.cl
->length
))
3665 e
= gfc_copy_expr (c1
->ts
.u
.cl
->length
);
3666 gfc_insert_kind_parameter_exprs (e
);
3667 gfc_simplify_expr (e
, 1);
3668 c2
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
3669 c2
->ts
.u
.cl
->length
= e
;
3670 c2
->attr
.pdt_string
= 1;
3673 /* Set up either the KIND/LEN initializer, if constant,
3674 or the parameterized expression. Use the template
3675 initializer if one is not already set in this instance. */
3676 if (c2
->attr
.pdt_kind
|| c2
->attr
.pdt_len
)
3678 if (tail
&& tail
->expr
&& gfc_is_constant_expr (tail
->expr
))
3679 c2
->initializer
= gfc_copy_expr (tail
->expr
);
3680 else if (tail
&& tail
->expr
)
3682 c2
->param_list
= gfc_get_actual_arglist ();
3683 c2
->param_list
->name
= tail
->name
;
3684 c2
->param_list
->expr
= gfc_copy_expr (tail
->expr
);
3685 c2
->param_list
->next
= NULL
;
3688 if (!c2
->initializer
&& c1
->initializer
)
3689 c2
->initializer
= gfc_copy_expr (c1
->initializer
);
3692 /* Copy the array spec. */
3693 c2
->as
= gfc_copy_array_spec (c1
->as
);
3694 if (c1
->ts
.type
== BT_CLASS
)
3695 CLASS_DATA (c2
)->as
= gfc_copy_array_spec (CLASS_DATA (c1
)->as
);
3697 /* Determine if an array spec is parameterized. If so, substitute
3698 in the parameter expressions for the bounds and set the pdt_array
3699 attribute. Notice that this attribute must be unconditionally set
3700 if this is an array of parameterized character length. */
3701 if (c1
->as
&& c1
->as
->type
== AS_EXPLICIT
)
3703 bool pdt_array
= false;
3705 /* Are the bounds of the array parameterized? */
3706 for (i
= 0; i
< c1
->as
->rank
; i
++)
3708 if (gfc_derived_parameter_expr (c1
->as
->lower
[i
]))
3710 if (gfc_derived_parameter_expr (c1
->as
->upper
[i
]))
3714 /* If they are, free the expressions for the bounds and
3715 replace them with the template expressions with substitute
3717 for (i
= 0; pdt_array
&& i
< c1
->as
->rank
; i
++)
3720 e
= gfc_copy_expr (c1
->as
->lower
[i
]);
3721 gfc_insert_kind_parameter_exprs (e
);
3722 gfc_simplify_expr (e
, 1);
3723 gfc_free_expr (c2
->as
->lower
[i
]);
3724 c2
->as
->lower
[i
] = e
;
3725 e
= gfc_copy_expr (c1
->as
->upper
[i
]);
3726 gfc_insert_kind_parameter_exprs (e
);
3727 gfc_simplify_expr (e
, 1);
3728 gfc_free_expr (c2
->as
->upper
[i
]);
3729 c2
->as
->upper
[i
] = e
;
3731 c2
->attr
.pdt_array
= pdt_array
? 1 : c2
->attr
.pdt_string
;
3732 if (c1
->initializer
)
3734 c2
->initializer
= gfc_copy_expr (c1
->initializer
);
3735 gfc_insert_kind_parameter_exprs (c2
->initializer
);
3736 gfc_simplify_expr (c2
->initializer
, 1);
3740 /* Recurse into this function for PDT components. */
3741 if ((c1
->ts
.type
== BT_DERIVED
|| c1
->ts
.type
== BT_CLASS
)
3742 && c1
->ts
.u
.derived
&& c1
->ts
.u
.derived
->attr
.pdt_template
)
3744 gfc_actual_arglist
*params
;
3745 /* The component in the template has a list of specification
3746 expressions derived from its declaration. */
3747 params
= gfc_copy_actual_arglist (c1
->param_list
);
3748 actual_param
= params
;
3749 /* Substitute the template parameters with the expressions
3750 from the specification list. */
3751 for (;actual_param
; actual_param
= actual_param
->next
)
3752 gfc_insert_parameter_exprs (actual_param
->expr
,
3753 type_param_spec_list
);
3755 /* Now obtain the PDT instance for the component. */
3756 old_param_spec_list
= type_param_spec_list
;
3757 m
= gfc_get_pdt_instance (params
, &c2
->ts
.u
.derived
, NULL
);
3758 type_param_spec_list
= old_param_spec_list
;
3760 c2
->param_list
= params
;
3761 if (!(c2
->attr
.pointer
|| c2
->attr
.allocatable
))
3762 c2
->initializer
= gfc_default_initializer (&c2
->ts
);
3764 if (c2
->attr
.allocatable
)
3765 instance
->attr
.alloc_comp
= 1;
3769 gfc_commit_symbol (instance
);
3771 *ext_param_list
= type_param_spec_list
;
3776 gfc_free_actual_arglist (type_param_spec_list
);
3781 /* Matches a declaration-type-spec (F03:R502). If successful, sets the ts
3782 structure to the matched specification. This is necessary for FUNCTION and
3783 IMPLICIT statements.
3785 If implicit_flag is nonzero, then we don't check for the optional
3786 kind specification. Not doing so is needed for matching an IMPLICIT
3787 statement correctly. */
3790 gfc_match_decl_type_spec (gfc_typespec
*ts
, int implicit_flag
)
3792 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3793 gfc_symbol
*sym
, *dt_sym
;
3796 bool seen_deferred_kind
, matched_type
;
3797 const char *dt_name
;
3799 decl_type_param_list
= NULL
;
3801 /* A belt and braces check that the typespec is correctly being treated
3802 as a deferred characteristic association. */
3803 seen_deferred_kind
= (gfc_current_state () == COMP_FUNCTION
)
3804 && (gfc_current_block ()->result
->ts
.kind
== -1)
3805 && (ts
->kind
== -1);
3807 if (seen_deferred_kind
)
3810 /* Clear the current binding label, in case one is given. */
3811 curr_binding_label
= NULL
;
3813 if (gfc_match (" byte") == MATCH_YES
)
3815 if (!gfc_notify_std (GFC_STD_GNU
, "BYTE type at %C"))
3818 if (gfc_validate_kind (BT_INTEGER
, 1, true) < 0)
3820 gfc_error ("BYTE type used at %C "
3821 "is not available on the target machine");
3825 ts
->type
= BT_INTEGER
;
3831 m
= gfc_match (" type (");
3832 matched_type
= (m
== MATCH_YES
);
3835 gfc_gobble_whitespace ();
3836 if (gfc_peek_ascii_char () == '*')
3838 if ((m
= gfc_match ("*)")) != MATCH_YES
)
3840 if (gfc_comp_struct (gfc_current_state ()))
3842 gfc_error ("Assumed type at %C is not allowed for components");
3845 if (!gfc_notify_std (GFC_STD_F2008_TS
, "Assumed type "
3848 ts
->type
= BT_ASSUMED
;
3852 m
= gfc_match ("%n", name
);
3853 matched_type
= (m
== MATCH_YES
);
3856 if ((matched_type
&& strcmp ("integer", name
) == 0)
3857 || (!matched_type
&& gfc_match (" integer") == MATCH_YES
))
3859 ts
->type
= BT_INTEGER
;
3860 ts
->kind
= gfc_default_integer_kind
;
3864 if ((matched_type
&& strcmp ("character", name
) == 0)
3865 || (!matched_type
&& gfc_match (" character") == MATCH_YES
))
3868 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
3869 "intrinsic-type-spec at %C"))
3872 ts
->type
= BT_CHARACTER
;
3873 if (implicit_flag
== 0)
3874 m
= gfc_match_char_spec (ts
);
3878 if (matched_type
&& m
== MATCH_YES
&& gfc_match_char (')') != MATCH_YES
)
3884 if ((matched_type
&& strcmp ("real", name
) == 0)
3885 || (!matched_type
&& gfc_match (" real") == MATCH_YES
))
3888 ts
->kind
= gfc_default_real_kind
;
3893 && (strcmp ("doubleprecision", name
) == 0
3894 || (strcmp ("double", name
) == 0
3895 && gfc_match (" precision") == MATCH_YES
)))
3896 || (!matched_type
&& gfc_match (" double precision") == MATCH_YES
))
3899 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
3900 "intrinsic-type-spec at %C"))
3902 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
3906 ts
->kind
= gfc_default_double_kind
;
3910 if ((matched_type
&& strcmp ("complex", name
) == 0)
3911 || (!matched_type
&& gfc_match (" complex") == MATCH_YES
))
3913 ts
->type
= BT_COMPLEX
;
3914 ts
->kind
= gfc_default_complex_kind
;
3919 && (strcmp ("doublecomplex", name
) == 0
3920 || (strcmp ("double", name
) == 0
3921 && gfc_match (" complex") == MATCH_YES
)))
3922 || (!matched_type
&& gfc_match (" double complex") == MATCH_YES
))
3924 if (!gfc_notify_std (GFC_STD_GNU
, "DOUBLE COMPLEX at %C"))
3928 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
3929 "intrinsic-type-spec at %C"))
3932 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
3935 ts
->type
= BT_COMPLEX
;
3936 ts
->kind
= gfc_default_double_kind
;
3940 if ((matched_type
&& strcmp ("logical", name
) == 0)
3941 || (!matched_type
&& gfc_match (" logical") == MATCH_YES
))
3943 ts
->type
= BT_LOGICAL
;
3944 ts
->kind
= gfc_default_logical_kind
;
3950 m
= gfc_match_actual_arglist (1, &decl_type_param_list
, true);
3951 if (m
== MATCH_ERROR
)
3954 m
= gfc_match_char (')');
3958 m
= match_record_decl (name
);
3960 if (matched_type
|| m
== MATCH_YES
)
3962 ts
->type
= BT_DERIVED
;
3963 /* We accept record/s/ or type(s) where s is a structure, but we
3964 * don't need all the extra derived-type stuff for structures. */
3965 if (gfc_find_symbol (gfc_dt_upper_string (name
), NULL
, 1, &sym
))
3967 gfc_error ("Type name %qs at %C is ambiguous", name
);
3971 if (sym
&& sym
->attr
.flavor
== FL_DERIVED
3972 && sym
->attr
.pdt_template
3973 && gfc_current_state () != COMP_DERIVED
)
3975 m
= gfc_get_pdt_instance (decl_type_param_list
, &sym
, NULL
);
3978 gcc_assert (!sym
->attr
.pdt_template
&& sym
->attr
.pdt_type
);
3979 ts
->u
.derived
= sym
;
3980 strcpy (name
, gfc_dt_lower_string (sym
->name
));
3983 if (sym
&& sym
->attr
.flavor
== FL_STRUCT
)
3985 ts
->u
.derived
= sym
;
3988 /* Actually a derived type. */
3993 /* Match nested STRUCTURE declarations; only valid within another
3994 structure declaration. */
3995 if (flag_dec_structure
3996 && (gfc_current_state () == COMP_STRUCTURE
3997 || gfc_current_state () == COMP_MAP
))
3999 m
= gfc_match (" structure");
4002 m
= gfc_match_structure_decl ();
4005 /* gfc_new_block is updated by match_structure_decl. */
4006 ts
->type
= BT_DERIVED
;
4007 ts
->u
.derived
= gfc_new_block
;
4011 if (m
== MATCH_ERROR
)
4015 /* Match CLASS declarations. */
4016 m
= gfc_match (" class ( * )");
4017 if (m
== MATCH_ERROR
)
4019 else if (m
== MATCH_YES
)
4023 ts
->type
= BT_CLASS
;
4024 gfc_find_symbol ("STAR", gfc_current_ns
, 1, &upe
);
4027 upe
= gfc_new_symbol ("STAR", gfc_current_ns
);
4028 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "STAR");
4030 gfc_set_sym_referenced (upe
);
4032 upe
->ts
.type
= BT_VOID
;
4033 upe
->attr
.unlimited_polymorphic
= 1;
4034 /* This is essential to force the construction of
4035 unlimited polymorphic component class containers. */
4036 upe
->attr
.zero_comp
= 1;
4037 if (!gfc_add_flavor (&upe
->attr
, FL_DERIVED
, NULL
,
4038 &gfc_current_locus
))
4043 st
= gfc_get_tbp_symtree (&gfc_current_ns
->sym_root
, "STAR");
4047 ts
->u
.derived
= upe
;
4051 m
= gfc_match (" class (");
4054 m
= gfc_match ("%n", name
);
4060 ts
->type
= BT_CLASS
;
4062 if (!gfc_notify_std (GFC_STD_F2003
, "CLASS statement at %C"))
4065 m
= gfc_match_actual_arglist (1, &decl_type_param_list
, true);
4066 if (m
== MATCH_ERROR
)
4069 m
= gfc_match_char (')');
4074 /* Defer association of the derived type until the end of the
4075 specification block. However, if the derived type can be
4076 found, add it to the typespec. */
4077 if (gfc_matching_function
)
4079 ts
->u
.derived
= NULL
;
4080 if (gfc_current_state () != COMP_INTERFACE
4081 && !gfc_find_symbol (name
, NULL
, 1, &sym
) && sym
)
4083 sym
= gfc_find_dt_in_generic (sym
);
4084 ts
->u
.derived
= sym
;
4089 /* Search for the name but allow the components to be defined later. If
4090 type = -1, this typespec has been seen in a function declaration but
4091 the type could not be accessed at that point. The actual derived type is
4092 stored in a symtree with the first letter of the name capitalized; the
4093 symtree with the all lower-case name contains the associated
4094 generic function. */
4095 dt_name
= gfc_dt_upper_string (name
);
4100 gfc_get_ha_symbol (name
, &sym
);
4101 if (sym
->generic
&& gfc_find_symbol (dt_name
, NULL
, 0, &dt_sym
))
4103 gfc_error ("Type name %qs at %C is ambiguous", name
);
4106 if (sym
->generic
&& !dt_sym
)
4107 dt_sym
= gfc_find_dt_in_generic (sym
);
4109 /* Host associated PDTs can get confused with their constructors
4110 because they ar instantiated in the template's namespace. */
4113 if (gfc_find_symbol (dt_name
, NULL
, 1, &dt_sym
))
4115 gfc_error ("Type name %qs at %C is ambiguous", name
);
4118 if (dt_sym
&& !dt_sym
->attr
.pdt_type
)
4122 else if (ts
->kind
== -1)
4124 int iface
= gfc_state_stack
->previous
->state
!= COMP_INTERFACE
4125 || gfc_current_ns
->has_import_set
;
4126 gfc_find_symbol (name
, NULL
, iface
, &sym
);
4127 if (sym
&& sym
->generic
&& gfc_find_symbol (dt_name
, NULL
, 1, &dt_sym
))
4129 gfc_error ("Type name %qs at %C is ambiguous", name
);
4132 if (sym
&& sym
->generic
&& !dt_sym
)
4133 dt_sym
= gfc_find_dt_in_generic (sym
);
4140 if ((sym
->attr
.flavor
!= FL_UNKNOWN
&& sym
->attr
.flavor
!= FL_STRUCT
4141 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.generic
))
4142 || sym
->attr
.subroutine
)
4144 gfc_error ("Type name %qs at %C conflicts with previously declared "
4145 "entity at %L, which has the same name", name
,
4150 if (sym
&& sym
->attr
.flavor
== FL_DERIVED
4151 && sym
->attr
.pdt_template
4152 && gfc_current_state () != COMP_DERIVED
)
4154 m
= gfc_get_pdt_instance (decl_type_param_list
, &sym
, NULL
);
4157 gcc_assert (!sym
->attr
.pdt_template
&& sym
->attr
.pdt_type
);
4158 ts
->u
.derived
= sym
;
4159 strcpy (name
, gfc_dt_lower_string (sym
->name
));
4162 gfc_save_symbol_data (sym
);
4163 gfc_set_sym_referenced (sym
);
4164 if (!sym
->attr
.generic
4165 && !gfc_add_generic (&sym
->attr
, sym
->name
, NULL
))
4168 if (!sym
->attr
.function
4169 && !gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
4172 if (dt_sym
&& dt_sym
->attr
.flavor
== FL_DERIVED
4173 && dt_sym
->attr
.pdt_template
4174 && gfc_current_state () != COMP_DERIVED
)
4176 m
= gfc_get_pdt_instance (decl_type_param_list
, &dt_sym
, NULL
);
4179 gcc_assert (!dt_sym
->attr
.pdt_template
&& dt_sym
->attr
.pdt_type
);
4184 gfc_interface
*intr
, *head
;
4186 /* Use upper case to save the actual derived-type symbol. */
4187 gfc_get_symbol (dt_name
, NULL
, &dt_sym
);
4188 dt_sym
->name
= gfc_get_string ("%s", sym
->name
);
4189 head
= sym
->generic
;
4190 intr
= gfc_get_interface ();
4192 intr
->where
= gfc_current_locus
;
4194 sym
->generic
= intr
;
4195 sym
->attr
.if_source
= IFSRC_DECL
;
4198 gfc_save_symbol_data (dt_sym
);
4200 gfc_set_sym_referenced (dt_sym
);
4202 if (dt_sym
->attr
.flavor
!= FL_DERIVED
&& dt_sym
->attr
.flavor
!= FL_STRUCT
4203 && !gfc_add_flavor (&dt_sym
->attr
, FL_DERIVED
, sym
->name
, NULL
))
4206 ts
->u
.derived
= dt_sym
;
4212 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
4213 "intrinsic-type-spec at %C"))
4216 /* For all types except double, derived and character, look for an
4217 optional kind specifier. MATCH_NO is actually OK at this point. */
4218 if (implicit_flag
== 1)
4220 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
4226 if (gfc_current_form
== FORM_FREE
)
4228 c
= gfc_peek_ascii_char ();
4229 if (!gfc_is_whitespace (c
) && c
!= '*' && c
!= '('
4230 && c
!= ':' && c
!= ',')
4232 if (matched_type
&& c
== ')')
4234 gfc_next_ascii_char ();
4241 m
= gfc_match_kind_spec (ts
, false);
4242 if (m
== MATCH_NO
&& ts
->type
!= BT_CHARACTER
)
4244 m
= gfc_match_old_kind_spec (ts
);
4245 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) == -1)
4249 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
4252 /* Defer association of the KIND expression of function results
4253 until after USE and IMPORT statements. */
4254 if ((gfc_current_state () == COMP_NONE
&& gfc_error_flag_test ())
4255 || gfc_matching_function
)
4259 m
= MATCH_YES
; /* No kind specifier found. */
4265 /* Match an IMPLICIT NONE statement. Actually, this statement is
4266 already matched in parse.c, or we would not end up here in the
4267 first place. So the only thing we need to check, is if there is
4268 trailing garbage. If not, the match is successful. */
4271 gfc_match_implicit_none (void)
4275 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4277 bool external
= false;
4278 locus cur_loc
= gfc_current_locus
;
4280 if (gfc_current_ns
->seen_implicit_none
4281 || gfc_current_ns
->has_implicit_none_export
)
4283 gfc_error ("Duplicate IMPLICIT NONE statement at %C");
4287 gfc_gobble_whitespace ();
4288 c
= gfc_peek_ascii_char ();
4291 (void) gfc_next_ascii_char ();
4292 if (!gfc_notify_std (GFC_STD_F2018
, "IMPORT NONE with spec list at %C"))
4295 gfc_gobble_whitespace ();
4296 if (gfc_peek_ascii_char () == ')')
4298 (void) gfc_next_ascii_char ();
4304 m
= gfc_match (" %n", name
);
4308 if (strcmp (name
, "type") == 0)
4310 else if (strcmp (name
, "external") == 0)
4315 gfc_gobble_whitespace ();
4316 c
= gfc_next_ascii_char ();
4327 if (gfc_match_eos () != MATCH_YES
)
4330 gfc_set_implicit_none (type
, external
, &cur_loc
);
4336 /* Match the letter range(s) of an IMPLICIT statement. */
4339 match_implicit_range (void)
4345 cur_loc
= gfc_current_locus
;
4347 gfc_gobble_whitespace ();
4348 c
= gfc_next_ascii_char ();
4351 gfc_error ("Missing character range in IMPLICIT at %C");
4358 gfc_gobble_whitespace ();
4359 c1
= gfc_next_ascii_char ();
4363 gfc_gobble_whitespace ();
4364 c
= gfc_next_ascii_char ();
4369 inner
= 0; /* Fall through. */
4376 gfc_gobble_whitespace ();
4377 c2
= gfc_next_ascii_char ();
4381 gfc_gobble_whitespace ();
4382 c
= gfc_next_ascii_char ();
4384 if ((c
!= ',') && (c
!= ')'))
4397 gfc_error ("Letters must be in alphabetic order in "
4398 "IMPLICIT statement at %C");
4402 /* See if we can add the newly matched range to the pending
4403 implicits from this IMPLICIT statement. We do not check for
4404 conflicts with whatever earlier IMPLICIT statements may have
4405 set. This is done when we've successfully finished matching
4407 if (!gfc_add_new_implicit_range (c1
, c2
))
4414 gfc_syntax_error (ST_IMPLICIT
);
4416 gfc_current_locus
= cur_loc
;
4421 /* Match an IMPLICIT statement, storing the types for
4422 gfc_set_implicit() if the statement is accepted by the parser.
4423 There is a strange looking, but legal syntactic construction
4424 possible. It looks like:
4426 IMPLICIT INTEGER (a-b) (c-d)
4428 This is legal if "a-b" is a constant expression that happens to
4429 equal one of the legal kinds for integers. The real problem
4430 happens with an implicit specification that looks like:
4432 IMPLICIT INTEGER (a-b)
4434 In this case, a typespec matcher that is "greedy" (as most of the
4435 matchers are) gobbles the character range as a kindspec, leaving
4436 nothing left. We therefore have to go a bit more slowly in the
4437 matching process by inhibiting the kindspec checking during
4438 typespec matching and checking for a kind later. */
4441 gfc_match_implicit (void)
4448 if (gfc_current_ns
->seen_implicit_none
)
4450 gfc_error ("IMPLICIT statement at %C following an IMPLICIT NONE (type) "
4457 /* We don't allow empty implicit statements. */
4458 if (gfc_match_eos () == MATCH_YES
)
4460 gfc_error ("Empty IMPLICIT statement at %C");
4466 /* First cleanup. */
4467 gfc_clear_new_implicit ();
4469 /* A basic type is mandatory here. */
4470 m
= gfc_match_decl_type_spec (&ts
, 1);
4471 if (m
== MATCH_ERROR
)
4476 cur_loc
= gfc_current_locus
;
4477 m
= match_implicit_range ();
4481 /* We may have <TYPE> (<RANGE>). */
4482 gfc_gobble_whitespace ();
4483 c
= gfc_peek_ascii_char ();
4484 if (c
== ',' || c
== '\n' || c
== ';' || c
== '!')
4486 /* Check for CHARACTER with no length parameter. */
4487 if (ts
.type
== BT_CHARACTER
&& !ts
.u
.cl
)
4489 ts
.kind
= gfc_default_character_kind
;
4490 ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4491 ts
.u
.cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
,
4495 /* Record the Successful match. */
4496 if (!gfc_merge_new_implicit (&ts
))
4499 c
= gfc_next_ascii_char ();
4500 else if (gfc_match_eos () == MATCH_ERROR
)
4505 gfc_current_locus
= cur_loc
;
4508 /* Discard the (incorrectly) matched range. */
4509 gfc_clear_new_implicit ();
4511 /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
4512 if (ts
.type
== BT_CHARACTER
)
4513 m
= gfc_match_char_spec (&ts
);
4516 m
= gfc_match_kind_spec (&ts
, false);
4519 m
= gfc_match_old_kind_spec (&ts
);
4520 if (m
== MATCH_ERROR
)
4526 if (m
== MATCH_ERROR
)
4529 m
= match_implicit_range ();
4530 if (m
== MATCH_ERROR
)
4535 gfc_gobble_whitespace ();
4536 c
= gfc_next_ascii_char ();
4537 if (c
!= ',' && gfc_match_eos () != MATCH_YES
)
4540 if (!gfc_merge_new_implicit (&ts
))
4548 gfc_syntax_error (ST_IMPLICIT
);
4556 gfc_match_import (void)
4558 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4563 if (gfc_current_ns
->proc_name
== NULL
4564 || gfc_current_ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
4566 gfc_error ("IMPORT statement at %C only permitted in "
4567 "an INTERFACE body");
4571 if (gfc_current_ns
->proc_name
->attr
.module_procedure
)
4573 gfc_error ("F2008: C1210 IMPORT statement at %C is not permitted "
4574 "in a module procedure interface body");
4578 if (!gfc_notify_std (GFC_STD_F2003
, "IMPORT statement at %C"))
4581 if (gfc_match_eos () == MATCH_YES
)
4583 /* All host variables should be imported. */
4584 gfc_current_ns
->has_import_set
= 1;
4588 if (gfc_match (" ::") == MATCH_YES
)
4590 if (gfc_match_eos () == MATCH_YES
)
4592 gfc_error ("Expecting list of named entities at %C");
4600 m
= gfc_match (" %n", name
);
4604 if (gfc_current_ns
->parent
!= NULL
4605 && gfc_find_symbol (name
, gfc_current_ns
->parent
, 1, &sym
))
4607 gfc_error ("Type name %qs at %C is ambiguous", name
);
4610 else if (!sym
&& gfc_current_ns
->proc_name
->ns
->parent
!= NULL
4611 && gfc_find_symbol (name
,
4612 gfc_current_ns
->proc_name
->ns
->parent
,
4615 gfc_error ("Type name %qs at %C is ambiguous", name
);
4621 gfc_error ("Cannot IMPORT %qs from host scoping unit "
4622 "at %C - does not exist.", name
);
4626 if (gfc_find_symtree (gfc_current_ns
->sym_root
, name
))
4628 gfc_warning (0, "%qs is already IMPORTed from host scoping unit "
4633 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, name
);
4636 sym
->attr
.imported
= 1;
4638 if (sym
->attr
.generic
&& (sym
= gfc_find_dt_in_generic (sym
)))
4640 /* The actual derived type is stored in a symtree with the first
4641 letter of the name capitalized; the symtree with the all
4642 lower-case name contains the associated generic function. */
4643 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
,
4644 gfc_dt_upper_string (name
));
4647 sym
->attr
.imported
= 1;
4660 if (gfc_match_eos () == MATCH_YES
)
4662 if (gfc_match_char (',') != MATCH_YES
)
4669 gfc_error ("Syntax error in IMPORT statement at %C");
4674 /* A minimal implementation of gfc_match without whitespace, escape
4675 characters or variable arguments. Returns true if the next
4676 characters match the TARGET template exactly. */
4679 match_string_p (const char *target
)
4683 for (p
= target
; *p
; p
++)
4684 if ((char) gfc_next_ascii_char () != *p
)
4689 /* Matches an attribute specification including array specs. If
4690 successful, leaves the variables current_attr and current_as
4691 holding the specification. Also sets the colon_seen variable for
4692 later use by matchers associated with initializations.
4694 This subroutine is a little tricky in the sense that we don't know
4695 if we really have an attr-spec until we hit the double colon.
4696 Until that time, we can only return MATCH_NO. This forces us to
4697 check for duplicate specification at this level. */
4700 match_attr_spec (void)
4702 /* Modifiers that can exist in a type statement. */
4704 { GFC_DECL_BEGIN
= 0,
4705 DECL_ALLOCATABLE
= GFC_DECL_BEGIN
, DECL_DIMENSION
, DECL_EXTERNAL
,
4706 DECL_IN
, DECL_OUT
, DECL_INOUT
, DECL_INTRINSIC
, DECL_OPTIONAL
,
4707 DECL_PARAMETER
, DECL_POINTER
, DECL_PROTECTED
, DECL_PRIVATE
,
4708 DECL_STATIC
, DECL_AUTOMATIC
,
4709 DECL_PUBLIC
, DECL_SAVE
, DECL_TARGET
, DECL_VALUE
, DECL_VOLATILE
,
4710 DECL_IS_BIND_C
, DECL_CODIMENSION
, DECL_ASYNCHRONOUS
, DECL_CONTIGUOUS
,
4711 DECL_LEN
, DECL_KIND
, DECL_NONE
, GFC_DECL_END
/* Sentinel */
4714 /* GFC_DECL_END is the sentinel, index starts at 0. */
4715 #define NUM_DECL GFC_DECL_END
4717 locus start
, seen_at
[NUM_DECL
];
4724 gfc_clear_attr (¤t_attr
);
4725 start
= gfc_current_locus
;
4731 /* See if we get all of the keywords up to the final double colon. */
4732 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
4740 gfc_gobble_whitespace ();
4742 ch
= gfc_next_ascii_char ();
4745 /* This is the successful exit condition for the loop. */
4746 if (gfc_next_ascii_char () == ':')
4751 gfc_gobble_whitespace ();
4752 switch (gfc_peek_ascii_char ())
4755 gfc_next_ascii_char ();
4756 switch (gfc_next_ascii_char ())
4759 if (match_string_p ("locatable"))
4761 /* Matched "allocatable". */
4762 d
= DECL_ALLOCATABLE
;
4767 if (match_string_p ("ynchronous"))
4769 /* Matched "asynchronous". */
4770 d
= DECL_ASYNCHRONOUS
;
4775 if (match_string_p ("tomatic"))
4777 /* Matched "automatic". */
4785 /* Try and match the bind(c). */
4786 m
= gfc_match_bind_c (NULL
, true);
4789 else if (m
== MATCH_ERROR
)
4794 gfc_next_ascii_char ();
4795 if ('o' != gfc_next_ascii_char ())
4797 switch (gfc_next_ascii_char ())
4800 if (match_string_p ("imension"))
4802 d
= DECL_CODIMENSION
;
4807 if (match_string_p ("tiguous"))
4809 d
= DECL_CONTIGUOUS
;
4816 if (match_string_p ("dimension"))
4821 if (match_string_p ("external"))
4826 if (match_string_p ("int"))
4828 ch
= gfc_next_ascii_char ();
4831 if (match_string_p ("nt"))
4833 /* Matched "intent". */
4834 /* TODO: Call match_intent_spec from here. */
4835 if (gfc_match (" ( in out )") == MATCH_YES
)
4837 else if (gfc_match (" ( in )") == MATCH_YES
)
4839 else if (gfc_match (" ( out )") == MATCH_YES
)
4845 if (match_string_p ("insic"))
4847 /* Matched "intrinsic". */
4855 if (match_string_p ("kind"))
4860 if (match_string_p ("len"))
4865 if (match_string_p ("optional"))
4870 gfc_next_ascii_char ();
4871 switch (gfc_next_ascii_char ())
4874 if (match_string_p ("rameter"))
4876 /* Matched "parameter". */
4882 if (match_string_p ("inter"))
4884 /* Matched "pointer". */
4890 ch
= gfc_next_ascii_char ();
4893 if (match_string_p ("vate"))
4895 /* Matched "private". */
4901 if (match_string_p ("tected"))
4903 /* Matched "protected". */
4910 if (match_string_p ("blic"))
4912 /* Matched "public". */
4920 gfc_next_ascii_char ();
4921 switch (gfc_next_ascii_char ())
4924 if (match_string_p ("ve"))
4926 /* Matched "save". */
4932 if (match_string_p ("atic"))
4934 /* Matched "static". */
4942 if (match_string_p ("target"))
4947 gfc_next_ascii_char ();
4948 ch
= gfc_next_ascii_char ();
4951 if (match_string_p ("lue"))
4953 /* Matched "value". */
4959 if (match_string_p ("latile"))
4961 /* Matched "volatile". */
4969 /* No double colon and no recognizable decl_type, so assume that
4970 we've been looking at something else the whole time. */
4977 /* Check to make sure any parens are paired up correctly. */
4978 if (gfc_match_parens () == MATCH_ERROR
)
4985 seen_at
[d
] = gfc_current_locus
;
4987 if (d
== DECL_DIMENSION
|| d
== DECL_CODIMENSION
)
4989 gfc_array_spec
*as
= NULL
;
4991 m
= gfc_match_array_spec (&as
, d
== DECL_DIMENSION
,
4992 d
== DECL_CODIMENSION
);
4994 if (current_as
== NULL
)
4996 else if (m
== MATCH_YES
)
4998 if (!merge_array_spec (as
, current_as
, false))
5005 if (d
== DECL_CODIMENSION
)
5006 gfc_error ("Missing codimension specification at %C");
5008 gfc_error ("Missing dimension specification at %C");
5012 if (m
== MATCH_ERROR
)
5017 /* Since we've seen a double colon, we have to be looking at an
5018 attr-spec. This means that we can now issue errors. */
5019 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
5024 case DECL_ALLOCATABLE
:
5025 attr
= "ALLOCATABLE";
5027 case DECL_ASYNCHRONOUS
:
5028 attr
= "ASYNCHRONOUS";
5030 case DECL_CODIMENSION
:
5031 attr
= "CODIMENSION";
5033 case DECL_CONTIGUOUS
:
5034 attr
= "CONTIGUOUS";
5036 case DECL_DIMENSION
:
5043 attr
= "INTENT (IN)";
5046 attr
= "INTENT (OUT)";
5049 attr
= "INTENT (IN OUT)";
5051 case DECL_INTRINSIC
:
5063 case DECL_PARAMETER
:
5069 case DECL_PROTECTED
:
5084 case DECL_AUTOMATIC
:
5090 case DECL_IS_BIND_C
:
5100 attr
= NULL
; /* This shouldn't happen. */
5103 gfc_error ("Duplicate %s attribute at %L", attr
, &seen_at
[d
]);
5108 /* Now that we've dealt with duplicate attributes, add the attributes
5109 to the current attribute. */
5110 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
5117 if ((d
== DECL_STATIC
|| d
== DECL_AUTOMATIC
)
5118 && !flag_dec_static
)
5120 gfc_error ("%s at %L is a DEC extension, enable with "
5122 d
== DECL_STATIC
? "STATIC" : "AUTOMATIC", &seen_at
[d
]);
5126 /* Allow SAVE with STATIC, but don't complain. */
5127 if (d
== DECL_STATIC
&& seen
[DECL_SAVE
])
5130 if (gfc_current_state () == COMP_DERIVED
5131 && d
!= DECL_DIMENSION
&& d
!= DECL_CODIMENSION
5132 && d
!= DECL_POINTER
&& d
!= DECL_PRIVATE
5133 && d
!= DECL_PUBLIC
&& d
!= DECL_CONTIGUOUS
&& d
!= DECL_NONE
)
5135 if (d
== DECL_ALLOCATABLE
)
5137 if (!gfc_notify_std (GFC_STD_F2003
, "ALLOCATABLE "
5138 "attribute at %C in a TYPE definition"))
5144 else if (d
== DECL_KIND
)
5146 if (!gfc_notify_std (GFC_STD_F2003
, "KIND "
5147 "attribute at %C in a TYPE definition"))
5152 if (current_ts
.type
!= BT_INTEGER
)
5154 gfc_error ("Component with KIND attribute at %C must be "
5159 if (current_ts
.kind
!= gfc_default_integer_kind
)
5161 gfc_error ("Component with KIND attribute at %C must be "
5162 "default integer kind (%d)",
5163 gfc_default_integer_kind
);
5168 else if (d
== DECL_LEN
)
5170 if (!gfc_notify_std (GFC_STD_F2003
, "LEN "
5171 "attribute at %C in a TYPE definition"))
5176 if (current_ts
.type
!= BT_INTEGER
)
5178 gfc_error ("Component with LEN attribute at %C must be "
5183 if (current_ts
.kind
!= gfc_default_integer_kind
)
5185 gfc_error ("Component with LEN attribute at %C must be "
5186 "default integer kind (%d)",
5187 gfc_default_integer_kind
);
5194 gfc_error ("Attribute at %L is not allowed in a TYPE definition",
5201 if ((d
== DECL_PRIVATE
|| d
== DECL_PUBLIC
)
5202 && gfc_current_state () != COMP_MODULE
)
5204 if (d
== DECL_PRIVATE
)
5208 if (gfc_current_state () == COMP_DERIVED
5209 && gfc_state_stack
->previous
5210 && gfc_state_stack
->previous
->state
== COMP_MODULE
)
5212 if (!gfc_notify_std (GFC_STD_F2003
, "Attribute %s "
5213 "at %L in a TYPE definition", attr
,
5222 gfc_error ("%s attribute at %L is not allowed outside of the "
5223 "specification part of a module", attr
, &seen_at
[d
]);
5229 if (gfc_current_state () != COMP_DERIVED
5230 && (d
== DECL_KIND
|| d
== DECL_LEN
))
5232 gfc_error ("Attribute at %L is not allowed outside a TYPE "
5233 "definition", &seen_at
[d
]);
5240 case DECL_ALLOCATABLE
:
5241 t
= gfc_add_allocatable (¤t_attr
, &seen_at
[d
]);
5244 case DECL_ASYNCHRONOUS
:
5245 if (!gfc_notify_std (GFC_STD_F2003
, "ASYNCHRONOUS attribute at %C"))
5248 t
= gfc_add_asynchronous (¤t_attr
, NULL
, &seen_at
[d
]);
5251 case DECL_CODIMENSION
:
5252 t
= gfc_add_codimension (¤t_attr
, NULL
, &seen_at
[d
]);
5255 case DECL_CONTIGUOUS
:
5256 if (!gfc_notify_std (GFC_STD_F2008
, "CONTIGUOUS attribute at %C"))
5259 t
= gfc_add_contiguous (¤t_attr
, NULL
, &seen_at
[d
]);
5262 case DECL_DIMENSION
:
5263 t
= gfc_add_dimension (¤t_attr
, NULL
, &seen_at
[d
]);
5267 t
= gfc_add_external (¤t_attr
, &seen_at
[d
]);
5271 t
= gfc_add_intent (¤t_attr
, INTENT_IN
, &seen_at
[d
]);
5275 t
= gfc_add_intent (¤t_attr
, INTENT_OUT
, &seen_at
[d
]);
5279 t
= gfc_add_intent (¤t_attr
, INTENT_INOUT
, &seen_at
[d
]);
5282 case DECL_INTRINSIC
:
5283 t
= gfc_add_intrinsic (¤t_attr
, &seen_at
[d
]);
5287 t
= gfc_add_optional (¤t_attr
, &seen_at
[d
]);
5291 t
= gfc_add_kind (¤t_attr
, &seen_at
[d
]);
5295 t
= gfc_add_len (¤t_attr
, &seen_at
[d
]);
5298 case DECL_PARAMETER
:
5299 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, &seen_at
[d
]);
5303 t
= gfc_add_pointer (¤t_attr
, &seen_at
[d
]);
5306 case DECL_PROTECTED
:
5307 if (gfc_current_state () != COMP_MODULE
5308 || (gfc_current_ns
->proc_name
5309 && gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
))
5311 gfc_error ("PROTECTED at %C only allowed in specification "
5312 "part of a module");
5317 if (!gfc_notify_std (GFC_STD_F2003
, "PROTECTED attribute at %C"))
5320 t
= gfc_add_protected (¤t_attr
, NULL
, &seen_at
[d
]);
5324 t
= gfc_add_access (¤t_attr
, ACCESS_PRIVATE
, NULL
,
5329 t
= gfc_add_access (¤t_attr
, ACCESS_PUBLIC
, NULL
,
5335 t
= gfc_add_save (¤t_attr
, SAVE_EXPLICIT
, NULL
, &seen_at
[d
]);
5338 case DECL_AUTOMATIC
:
5339 t
= gfc_add_automatic (¤t_attr
, NULL
, &seen_at
[d
]);
5343 t
= gfc_add_target (¤t_attr
, &seen_at
[d
]);
5346 case DECL_IS_BIND_C
:
5347 t
= gfc_add_is_bind_c(¤t_attr
, NULL
, &seen_at
[d
], 0);
5351 if (!gfc_notify_std (GFC_STD_F2003
, "VALUE attribute at %C"))
5354 t
= gfc_add_value (¤t_attr
, NULL
, &seen_at
[d
]);
5358 if (!gfc_notify_std (GFC_STD_F2003
, "VOLATILE attribute at %C"))
5361 t
= gfc_add_volatile (¤t_attr
, NULL
, &seen_at
[d
]);
5365 gfc_internal_error ("match_attr_spec(): Bad attribute");
5375 /* Since Fortran 2008 module variables implicitly have the SAVE attribute. */
5376 if ((gfc_current_state () == COMP_MODULE
5377 || gfc_current_state () == COMP_SUBMODULE
)
5378 && !current_attr
.save
5379 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
5380 current_attr
.save
= SAVE_IMPLICIT
;
5386 gfc_current_locus
= start
;
5387 gfc_free_array_spec (current_as
);
5394 /* Set the binding label, dest_label, either with the binding label
5395 stored in the given gfc_typespec, ts, or if none was provided, it
5396 will be the symbol name in all lower case, as required by the draft
5397 (J3/04-007, section 15.4.1). If a binding label was given and
5398 there is more than one argument (num_idents), it is an error. */
5401 set_binding_label (const char **dest_label
, const char *sym_name
,
5404 if (num_idents
> 1 && has_name_equals
)
5406 gfc_error ("Multiple identifiers provided with "
5407 "single NAME= specifier at %C");
5411 if (curr_binding_label
)
5412 /* Binding label given; store in temp holder till have sym. */
5413 *dest_label
= curr_binding_label
;
5416 /* No binding label given, and the NAME= specifier did not exist,
5417 which means there was no NAME="". */
5418 if (sym_name
!= NULL
&& has_name_equals
== 0)
5419 *dest_label
= IDENTIFIER_POINTER (get_identifier (sym_name
));
5426 /* Set the status of the given common block as being BIND(C) or not,
5427 depending on the given parameter, is_bind_c. */
5430 set_com_block_bind_c (gfc_common_head
*com_block
, int is_bind_c
)
5432 com_block
->is_bind_c
= is_bind_c
;
5437 /* Verify that the given gfc_typespec is for a C interoperable type. */
5440 gfc_verify_c_interop (gfc_typespec
*ts
)
5442 if (ts
->type
== BT_DERIVED
&& ts
->u
.derived
!= NULL
)
5443 return (ts
->u
.derived
->ts
.is_c_interop
|| ts
->u
.derived
->attr
.is_bind_c
)
5445 else if (ts
->type
== BT_CLASS
)
5447 else if (ts
->is_c_interop
!= 1 && ts
->type
!= BT_ASSUMED
)
5454 /* Verify that the variables of a given common block, which has been
5455 defined with the attribute specifier bind(c), to be of a C
5456 interoperable type. Errors will be reported here, if
5460 verify_com_block_vars_c_interop (gfc_common_head
*com_block
)
5462 gfc_symbol
*curr_sym
= NULL
;
5465 curr_sym
= com_block
->head
;
5467 /* Make sure we have at least one symbol. */
5468 if (curr_sym
== NULL
)
5471 /* Here we know we have a symbol, so we'll execute this loop
5475 /* The second to last param, 1, says this is in a common block. */
5476 retval
= verify_bind_c_sym (curr_sym
, &(curr_sym
->ts
), 1, com_block
);
5477 curr_sym
= curr_sym
->common_next
;
5478 } while (curr_sym
!= NULL
);
5484 /* Verify that a given BIND(C) symbol is C interoperable. If it is not,
5485 an appropriate error message is reported. */
5488 verify_bind_c_sym (gfc_symbol
*tmp_sym
, gfc_typespec
*ts
,
5489 int is_in_common
, gfc_common_head
*com_block
)
5491 bool bind_c_function
= false;
5494 if (tmp_sym
->attr
.function
&& tmp_sym
->attr
.is_bind_c
)
5495 bind_c_function
= true;
5497 if (tmp_sym
->attr
.function
&& tmp_sym
->result
!= NULL
)
5499 tmp_sym
= tmp_sym
->result
;
5500 /* Make sure it wasn't an implicitly typed result. */
5501 if (tmp_sym
->attr
.implicit_type
&& warn_c_binding_type
)
5503 gfc_warning (OPT_Wc_binding_type
,
5504 "Implicitly declared BIND(C) function %qs at "
5505 "%L may not be C interoperable", tmp_sym
->name
,
5506 &tmp_sym
->declared_at
);
5507 tmp_sym
->ts
.f90_type
= tmp_sym
->ts
.type
;
5508 /* Mark it as C interoperable to prevent duplicate warnings. */
5509 tmp_sym
->ts
.is_c_interop
= 1;
5510 tmp_sym
->attr
.is_c_interop
= 1;
5514 /* Here, we know we have the bind(c) attribute, so if we have
5515 enough type info, then verify that it's a C interop kind.
5516 The info could be in the symbol already, or possibly still in
5517 the given ts (current_ts), so look in both. */
5518 if (tmp_sym
->ts
.type
!= BT_UNKNOWN
|| ts
->type
!= BT_UNKNOWN
)
5520 if (!gfc_verify_c_interop (&(tmp_sym
->ts
)))
5522 /* See if we're dealing with a sym in a common block or not. */
5523 if (is_in_common
== 1 && warn_c_binding_type
)
5525 gfc_warning (OPT_Wc_binding_type
,
5526 "Variable %qs in common block %qs at %L "
5527 "may not be a C interoperable "
5528 "kind though common block %qs is BIND(C)",
5529 tmp_sym
->name
, com_block
->name
,
5530 &(tmp_sym
->declared_at
), com_block
->name
);
5534 if (tmp_sym
->ts
.type
== BT_DERIVED
|| ts
->type
== BT_DERIVED
)
5535 gfc_error ("Type declaration %qs at %L is not C "
5536 "interoperable but it is BIND(C)",
5537 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5538 else if (warn_c_binding_type
)
5539 gfc_warning (OPT_Wc_binding_type
, "Variable %qs at %L "
5540 "may not be a C interoperable "
5541 "kind but it is BIND(C)",
5542 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5546 /* Variables declared w/in a common block can't be bind(c)
5547 since there's no way for C to see these variables, so there's
5548 semantically no reason for the attribute. */
5549 if (is_in_common
== 1 && tmp_sym
->attr
.is_bind_c
== 1)
5551 gfc_error ("Variable %qs in common block %qs at "
5552 "%L cannot be declared with BIND(C) "
5553 "since it is not a global",
5554 tmp_sym
->name
, com_block
->name
,
5555 &(tmp_sym
->declared_at
));
5559 /* Scalar variables that are bind(c) can not have the pointer
5560 or allocatable attributes. */
5561 if (tmp_sym
->attr
.is_bind_c
== 1)
5563 if (tmp_sym
->attr
.pointer
== 1)
5565 gfc_error ("Variable %qs at %L cannot have both the "
5566 "POINTER and BIND(C) attributes",
5567 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5571 if (tmp_sym
->attr
.allocatable
== 1)
5573 gfc_error ("Variable %qs at %L cannot have both the "
5574 "ALLOCATABLE and BIND(C) attributes",
5575 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5581 /* If it is a BIND(C) function, make sure the return value is a
5582 scalar value. The previous tests in this function made sure
5583 the type is interoperable. */
5584 if (bind_c_function
&& tmp_sym
->as
!= NULL
)
5585 gfc_error ("Return type of BIND(C) function %qs at %L cannot "
5586 "be an array", tmp_sym
->name
, &(tmp_sym
->declared_at
));
5588 /* BIND(C) functions can not return a character string. */
5589 if (bind_c_function
&& tmp_sym
->ts
.type
== BT_CHARACTER
)
5590 if (tmp_sym
->ts
.u
.cl
== NULL
|| tmp_sym
->ts
.u
.cl
->length
== NULL
5591 || tmp_sym
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
5592 || mpz_cmp_si (tmp_sym
->ts
.u
.cl
->length
->value
.integer
, 1) != 0)
5593 gfc_error ("Return type of BIND(C) function %qs at %L cannot "
5594 "be a character string", tmp_sym
->name
,
5595 &(tmp_sym
->declared_at
));
5598 /* See if the symbol has been marked as private. If it has, make sure
5599 there is no binding label and warn the user if there is one. */
5600 if (tmp_sym
->attr
.access
== ACCESS_PRIVATE
5601 && tmp_sym
->binding_label
)
5602 /* Use gfc_warning_now because we won't say that the symbol fails
5603 just because of this. */
5604 gfc_warning_now (0, "Symbol %qs at %L is marked PRIVATE but has been "
5605 "given the binding label %qs", tmp_sym
->name
,
5606 &(tmp_sym
->declared_at
), tmp_sym
->binding_label
);
5612 /* Set the appropriate fields for a symbol that's been declared as
5613 BIND(C) (the is_bind_c flag and the binding label), and verify that
5614 the type is C interoperable. Errors are reported by the functions
5615 used to set/test these fields. */
5618 set_verify_bind_c_sym (gfc_symbol
*tmp_sym
, int num_idents
)
5622 /* TODO: Do we need to make sure the vars aren't marked private? */
5624 /* Set the is_bind_c bit in symbol_attribute. */
5625 gfc_add_is_bind_c (&(tmp_sym
->attr
), tmp_sym
->name
, &gfc_current_locus
, 0);
5627 if (!set_binding_label (&tmp_sym
->binding_label
, tmp_sym
->name
, num_idents
))
5634 /* Set the fields marking the given common block as BIND(C), including
5635 a binding label, and report any errors encountered. */
5638 set_verify_bind_c_com_block (gfc_common_head
*com_block
, int num_idents
)
5642 /* destLabel, common name, typespec (which may have binding label). */
5643 if (!set_binding_label (&com_block
->binding_label
, com_block
->name
,
5647 /* Set the given common block (com_block) to being bind(c) (1). */
5648 set_com_block_bind_c (com_block
, 1);
5654 /* Retrieve the list of one or more identifiers that the given bind(c)
5655 attribute applies to. */
5658 get_bind_c_idents (void)
5660 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5662 gfc_symbol
*tmp_sym
= NULL
;
5664 gfc_common_head
*com_block
= NULL
;
5666 if (gfc_match_name (name
) == MATCH_YES
)
5668 found_id
= MATCH_YES
;
5669 gfc_get_ha_symbol (name
, &tmp_sym
);
5671 else if (match_common_name (name
) == MATCH_YES
)
5673 found_id
= MATCH_YES
;
5674 com_block
= gfc_get_common (name
, 0);
5678 gfc_error ("Need either entity or common block name for "
5679 "attribute specification statement at %C");
5683 /* Save the current identifier and look for more. */
5686 /* Increment the number of identifiers found for this spec stmt. */
5689 /* Make sure we have a sym or com block, and verify that it can
5690 be bind(c). Set the appropriate field(s) and look for more
5692 if (tmp_sym
!= NULL
|| com_block
!= NULL
)
5694 if (tmp_sym
!= NULL
)
5696 if (!set_verify_bind_c_sym (tmp_sym
, num_idents
))
5701 if (!set_verify_bind_c_com_block (com_block
, num_idents
))
5705 /* Look to see if we have another identifier. */
5707 if (gfc_match_eos () == MATCH_YES
)
5708 found_id
= MATCH_NO
;
5709 else if (gfc_match_char (',') != MATCH_YES
)
5710 found_id
= MATCH_NO
;
5711 else if (gfc_match_name (name
) == MATCH_YES
)
5713 found_id
= MATCH_YES
;
5714 gfc_get_ha_symbol (name
, &tmp_sym
);
5716 else if (match_common_name (name
) == MATCH_YES
)
5718 found_id
= MATCH_YES
;
5719 com_block
= gfc_get_common (name
, 0);
5723 gfc_error ("Missing entity or common block name for "
5724 "attribute specification statement at %C");
5730 gfc_internal_error ("Missing symbol");
5732 } while (found_id
== MATCH_YES
);
5734 /* if we get here we were successful */
5739 /* Try and match a BIND(C) attribute specification statement. */
5742 gfc_match_bind_c_stmt (void)
5744 match found_match
= MATCH_NO
;
5749 /* This may not be necessary. */
5751 /* Clear the temporary binding label holder. */
5752 curr_binding_label
= NULL
;
5754 /* Look for the bind(c). */
5755 found_match
= gfc_match_bind_c (NULL
, true);
5757 if (found_match
== MATCH_YES
)
5759 if (!gfc_notify_std (GFC_STD_F2003
, "BIND(C) statement at %C"))
5762 /* Look for the :: now, but it is not required. */
5765 /* Get the identifier(s) that needs to be updated. This may need to
5766 change to hand the flag(s) for the attr specified so all identifiers
5767 found can have all appropriate parts updated (assuming that the same
5768 spec stmt can have multiple attrs, such as both bind(c) and
5770 if (!get_bind_c_idents ())
5771 /* Error message should have printed already. */
5779 /* Match a data declaration statement. */
5782 gfc_match_data_decl (void)
5788 type_param_spec_list
= NULL
;
5789 decl_type_param_list
= NULL
;
5791 num_idents_on_line
= 0;
5793 m
= gfc_match_decl_type_spec (¤t_ts
, 0);
5797 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
5798 && !gfc_comp_struct (gfc_current_state ()))
5800 sym
= gfc_use_derived (current_ts
.u
.derived
);
5808 current_ts
.u
.derived
= sym
;
5811 m
= match_attr_spec ();
5812 if (m
== MATCH_ERROR
)
5818 if (current_ts
.type
== BT_CLASS
5819 && current_ts
.u
.derived
->attr
.unlimited_polymorphic
)
5822 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
5823 && current_ts
.u
.derived
->components
== NULL
5824 && !current_ts
.u
.derived
->attr
.zero_comp
)
5827 if (current_attr
.pointer
&& gfc_comp_struct (gfc_current_state ()))
5830 if (current_attr
.allocatable
&& gfc_current_state () == COMP_DERIVED
5831 && current_ts
.u
.derived
== gfc_current_block ())
5834 gfc_find_symbol (current_ts
.u
.derived
->name
,
5835 current_ts
.u
.derived
->ns
, 1, &sym
);
5837 /* Any symbol that we find had better be a type definition
5838 which has its components defined, or be a structure definition
5839 actively being parsed. */
5840 if (sym
!= NULL
&& gfc_fl_struct (sym
->attr
.flavor
)
5841 && (current_ts
.u
.derived
->components
!= NULL
5842 || current_ts
.u
.derived
->attr
.zero_comp
5843 || current_ts
.u
.derived
== gfc_new_block
))
5846 gfc_error ("Derived type at %C has not been previously defined "
5847 "and so cannot appear in a derived type definition");
5853 /* If we have an old-style character declaration, and no new-style
5854 attribute specifications, then there a comma is optional between
5855 the type specification and the variable list. */
5856 if (m
== MATCH_NO
&& current_ts
.type
== BT_CHARACTER
&& old_char_selector
)
5857 gfc_match_char (',');
5859 /* Give the types/attributes to symbols that follow. Give the element
5860 a number so that repeat character length expressions can be copied. */
5864 num_idents_on_line
++;
5865 m
= variable_decl (elem
++);
5866 if (m
== MATCH_ERROR
)
5871 if (gfc_match_eos () == MATCH_YES
)
5873 if (gfc_match_char (',') != MATCH_YES
)
5877 if (!gfc_error_flag_test ())
5879 /* An anonymous structure declaration is unambiguous; if we matched one
5880 according to gfc_match_structure_decl, we need to return MATCH_YES
5881 here to avoid confusing the remaining matchers, even if there was an
5882 error during variable_decl. We must flush any such errors. Note this
5883 causes the parser to gracefully continue parsing the remaining input
5884 as a structure body, which likely follows. */
5885 if (current_ts
.type
== BT_DERIVED
&& current_ts
.u
.derived
5886 && gfc_fl_struct (current_ts
.u
.derived
->attr
.flavor
))
5888 gfc_error_now ("Syntax error in anonymous structure declaration"
5890 /* Skip the bad variable_decl and line up for the start of the
5892 gfc_error_recovery ();
5897 gfc_error ("Syntax error in data declaration at %C");
5902 gfc_free_data_all (gfc_current_ns
);
5905 if (saved_kind_expr
)
5906 gfc_free_expr (saved_kind_expr
);
5907 if (type_param_spec_list
)
5908 gfc_free_actual_arglist (type_param_spec_list
);
5909 if (decl_type_param_list
)
5910 gfc_free_actual_arglist (decl_type_param_list
);
5911 saved_kind_expr
= NULL
;
5912 gfc_free_array_spec (current_as
);
5918 /* Match a prefix associated with a function or subroutine
5919 declaration. If the typespec pointer is nonnull, then a typespec
5920 can be matched. Note that if nothing matches, MATCH_YES is
5921 returned (the null string was matched). */
5924 gfc_match_prefix (gfc_typespec
*ts
)
5930 gfc_clear_attr (¤t_attr
);
5932 seen_impure
= false;
5934 gcc_assert (!gfc_matching_prefix
);
5935 gfc_matching_prefix
= true;
5939 found_prefix
= false;
5941 /* MODULE is a prefix like PURE, ELEMENTAL, etc., having a
5942 corresponding attribute seems natural and distinguishes these
5943 procedures from procedure types of PROC_MODULE, which these are
5945 if (gfc_match ("module% ") == MATCH_YES
)
5947 if (!gfc_notify_std (GFC_STD_F2008
, "MODULE prefix at %C"))
5950 current_attr
.module_procedure
= 1;
5951 found_prefix
= true;
5954 if (!seen_type
&& ts
!= NULL
5955 && gfc_match_decl_type_spec (ts
, 0) == MATCH_YES
5956 && gfc_match_space () == MATCH_YES
)
5960 found_prefix
= true;
5963 if (gfc_match ("elemental% ") == MATCH_YES
)
5965 if (!gfc_add_elemental (¤t_attr
, NULL
))
5968 found_prefix
= true;
5971 if (gfc_match ("pure% ") == MATCH_YES
)
5973 if (!gfc_add_pure (¤t_attr
, NULL
))
5976 found_prefix
= true;
5979 if (gfc_match ("recursive% ") == MATCH_YES
)
5981 if (!gfc_add_recursive (¤t_attr
, NULL
))
5984 found_prefix
= true;
5987 /* IMPURE is a somewhat special case, as it needs not set an actual
5988 attribute but rather only prevents ELEMENTAL routines from being
5989 automatically PURE. */
5990 if (gfc_match ("impure% ") == MATCH_YES
)
5992 if (!gfc_notify_std (GFC_STD_F2008
, "IMPURE procedure at %C"))
5996 found_prefix
= true;
5999 while (found_prefix
);
6001 /* IMPURE and PURE must not both appear, of course. */
6002 if (seen_impure
&& current_attr
.pure
)
6004 gfc_error ("PURE and IMPURE must not appear both at %C");
6008 /* If IMPURE it not seen but the procedure is ELEMENTAL, mark it as PURE. */
6009 if (!seen_impure
&& current_attr
.elemental
&& !current_attr
.pure
)
6011 if (!gfc_add_pure (¤t_attr
, NULL
))
6015 /* At this point, the next item is not a prefix. */
6016 gcc_assert (gfc_matching_prefix
);
6018 gfc_matching_prefix
= false;
6022 gcc_assert (gfc_matching_prefix
);
6023 gfc_matching_prefix
= false;
6028 /* Copy attributes matched by gfc_match_prefix() to attributes on a symbol. */
6031 copy_prefix (symbol_attribute
*dest
, locus
*where
)
6033 if (dest
->module_procedure
)
6035 if (current_attr
.elemental
)
6036 dest
->elemental
= 1;
6038 if (current_attr
.pure
)
6041 if (current_attr
.recursive
)
6042 dest
->recursive
= 1;
6044 /* Module procedures are unusual in that the 'dest' is copied from
6045 the interface declaration. However, this is an oportunity to
6046 check that the submodule declaration is compliant with the
6048 if (dest
->elemental
&& !current_attr
.elemental
)
6050 gfc_error ("ELEMENTAL prefix in MODULE PROCEDURE interface is "
6051 "missing at %L", where
);
6055 if (dest
->pure
&& !current_attr
.pure
)
6057 gfc_error ("PURE prefix in MODULE PROCEDURE interface is "
6058 "missing at %L", where
);
6062 if (dest
->recursive
&& !current_attr
.recursive
)
6064 gfc_error ("RECURSIVE prefix in MODULE PROCEDURE interface is "
6065 "missing at %L", where
);
6072 if (current_attr
.elemental
&& !gfc_add_elemental (dest
, where
))
6075 if (current_attr
.pure
&& !gfc_add_pure (dest
, where
))
6078 if (current_attr
.recursive
&& !gfc_add_recursive (dest
, where
))
6085 /* Match a formal argument list or, if typeparam is true, a
6086 type_param_name_list. */
6089 gfc_match_formal_arglist (gfc_symbol
*progname
, int st_flag
,
6090 int null_flag
, bool typeparam
)
6092 gfc_formal_arglist
*head
, *tail
, *p
, *q
;
6093 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6096 gfc_formal_arglist
*formal
= NULL
;
6100 /* Keep the interface formal argument list and null it so that the
6101 matching for the new declaration can be done. The numbers and
6102 names of the arguments are checked here. The interface formal
6103 arguments are retained in formal_arglist and the characteristics
6104 are compared in resolve.c(resolve_fl_procedure). See the remark
6105 in get_proc_name about the eventual need to copy the formal_arglist
6106 and populate the formal namespace of the interface symbol. */
6107 if (progname
->attr
.module_procedure
6108 && progname
->attr
.host_assoc
)
6110 formal
= progname
->formal
;
6111 progname
->formal
= NULL
;
6114 if (gfc_match_char ('(') != MATCH_YES
)
6121 if (gfc_match_char (')') == MATCH_YES
)
6126 if (gfc_match_char ('*') == MATCH_YES
)
6129 if (!typeparam
&& !gfc_notify_std (GFC_STD_F95_OBS
,
6130 "Alternate-return argument at %C"))
6136 gfc_error_now ("A parameter name is required at %C");
6140 m
= gfc_match_name (name
);
6144 gfc_error_now ("A parameter name is required at %C");
6148 if (!typeparam
&& gfc_get_symbol (name
, NULL
, &sym
))
6151 && gfc_get_symbol (name
, progname
->f2k_derived
, &sym
))
6155 p
= gfc_get_formal_arglist ();
6167 /* We don't add the VARIABLE flavor because the name could be a
6168 dummy procedure. We don't apply these attributes to formal
6169 arguments of statement functions. */
6170 if (sym
!= NULL
&& !st_flag
6171 && (!gfc_add_dummy(&sym
->attr
, sym
->name
, NULL
)
6172 || !gfc_missing_attr (&sym
->attr
, NULL
)))
6178 /* The name of a program unit can be in a different namespace,
6179 so check for it explicitly. After the statement is accepted,
6180 the name is checked for especially in gfc_get_symbol(). */
6181 if (gfc_new_block
!= NULL
&& sym
!= NULL
&& !typeparam
6182 && strcmp (sym
->name
, gfc_new_block
->name
) == 0)
6184 gfc_error ("Name %qs at %C is the name of the procedure",
6190 if (gfc_match_char (')') == MATCH_YES
)
6193 m
= gfc_match_char (',');
6197 gfc_error_now ("Expected parameter list in type declaration "
6200 gfc_error ("Unexpected junk in formal argument list at %C");
6206 /* Check for duplicate symbols in the formal argument list. */
6209 for (p
= head
; p
->next
; p
= p
->next
)
6214 for (q
= p
->next
; q
; q
= q
->next
)
6215 if (p
->sym
== q
->sym
)
6218 gfc_error_now ("Duplicate name %qs in parameter "
6219 "list at %C", p
->sym
->name
);
6221 gfc_error ("Duplicate symbol %qs in formal argument "
6222 "list at %C", p
->sym
->name
);
6230 if (!gfc_add_explicit_interface (progname
, IFSRC_DECL
, head
, NULL
))
6236 /* gfc_error_now used in following and return with MATCH_YES because
6237 doing otherwise results in a cascade of extraneous errors and in
6238 some cases an ICE in symbol.c(gfc_release_symbol). */
6239 if (progname
->attr
.module_procedure
&& progname
->attr
.host_assoc
)
6241 bool arg_count_mismatch
= false;
6243 if (!formal
&& head
)
6244 arg_count_mismatch
= true;
6246 /* Abbreviated module procedure declaration is not meant to have any
6247 formal arguments! */
6248 if (!progname
->abr_modproc_decl
&& formal
&& !head
)
6249 arg_count_mismatch
= true;
6251 for (p
= formal
, q
= head
; p
&& q
; p
= p
->next
, q
= q
->next
)
6253 if ((p
->next
!= NULL
&& q
->next
== NULL
)
6254 || (p
->next
== NULL
&& q
->next
!= NULL
))
6255 arg_count_mismatch
= true;
6256 else if ((p
->sym
== NULL
&& q
->sym
== NULL
)
6257 || strcmp (p
->sym
->name
, q
->sym
->name
) == 0)
6260 gfc_error_now ("Mismatch in MODULE PROCEDURE formal "
6261 "argument names (%s/%s) at %C",
6262 p
->sym
->name
, q
->sym
->name
);
6265 if (arg_count_mismatch
)
6266 gfc_error_now ("Mismatch in number of MODULE PROCEDURE "
6267 "formal arguments at %C");
6273 gfc_free_formal_arglist (head
);
6278 /* Match a RESULT specification following a function declaration or
6279 ENTRY statement. Also matches the end-of-statement. */
6282 match_result (gfc_symbol
*function
, gfc_symbol
**result
)
6284 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6288 if (gfc_match (" result (") != MATCH_YES
)
6291 m
= gfc_match_name (name
);
6295 /* Get the right paren, and that's it because there could be the
6296 bind(c) attribute after the result clause. */
6297 if (gfc_match_char (')') != MATCH_YES
)
6299 /* TODO: should report the missing right paren here. */
6303 if (strcmp (function
->name
, name
) == 0)
6305 gfc_error ("RESULT variable at %C must be different than function name");
6309 if (gfc_get_symbol (name
, NULL
, &r
))
6312 if (!gfc_add_result (&r
->attr
, r
->name
, NULL
))
6321 /* Match a function suffix, which could be a combination of a result
6322 clause and BIND(C), either one, or neither. The draft does not
6323 require them to come in a specific order. */
6326 gfc_match_suffix (gfc_symbol
*sym
, gfc_symbol
**result
)
6328 match is_bind_c
; /* Found bind(c). */
6329 match is_result
; /* Found result clause. */
6330 match found_match
; /* Status of whether we've found a good match. */
6331 char peek_char
; /* Character we're going to peek at. */
6332 bool allow_binding_name
;
6334 /* Initialize to having found nothing. */
6335 found_match
= MATCH_NO
;
6336 is_bind_c
= MATCH_NO
;
6337 is_result
= MATCH_NO
;
6339 /* Get the next char to narrow between result and bind(c). */
6340 gfc_gobble_whitespace ();
6341 peek_char
= gfc_peek_ascii_char ();
6343 /* C binding names are not allowed for internal procedures. */
6344 if (gfc_current_state () == COMP_CONTAINS
6345 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
6346 allow_binding_name
= false;
6348 allow_binding_name
= true;
6353 /* Look for result clause. */
6354 is_result
= match_result (sym
, result
);
6355 if (is_result
== MATCH_YES
)
6357 /* Now see if there is a bind(c) after it. */
6358 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
6359 /* We've found the result clause and possibly bind(c). */
6360 found_match
= MATCH_YES
;
6363 /* This should only be MATCH_ERROR. */
6364 found_match
= is_result
;
6367 /* Look for bind(c) first. */
6368 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
6369 if (is_bind_c
== MATCH_YES
)
6371 /* Now see if a result clause followed it. */
6372 is_result
= match_result (sym
, result
);
6373 found_match
= MATCH_YES
;
6377 /* Should only be a MATCH_ERROR if we get here after seeing 'b'. */
6378 found_match
= MATCH_ERROR
;
6382 gfc_error ("Unexpected junk after function declaration at %C");
6383 found_match
= MATCH_ERROR
;
6387 if (is_bind_c
== MATCH_YES
)
6389 /* Fortran 2008 draft allows BIND(C) for internal procedures. */
6390 if (gfc_current_state () == COMP_CONTAINS
6391 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
6392 && !gfc_notify_std (GFC_STD_F2008
, "BIND(C) attribute "
6393 "at %L may not be specified for an internal "
6394 "procedure", &gfc_current_locus
))
6397 if (!gfc_add_is_bind_c (&(sym
->attr
), sym
->name
, &gfc_current_locus
, 1))
6405 /* Procedure pointer return value without RESULT statement:
6406 Add "hidden" result variable named "ppr@". */
6409 add_hidden_procptr_result (gfc_symbol
*sym
)
6413 if (gfc_notification_std (GFC_STD_F2003
) == ERROR
)
6416 /* First usage case: PROCEDURE and EXTERNAL statements. */
6417 case1
= gfc_current_state () == COMP_FUNCTION
&& gfc_current_block ()
6418 && strcmp (gfc_current_block ()->name
, sym
->name
) == 0
6419 && sym
->attr
.external
;
6420 /* Second usage case: INTERFACE statements. */
6421 case2
= gfc_current_state () == COMP_INTERFACE
&& gfc_state_stack
->previous
6422 && gfc_state_stack
->previous
->state
== COMP_FUNCTION
6423 && strcmp (gfc_state_stack
->previous
->sym
->name
, sym
->name
) == 0;
6429 gfc_get_sym_tree ("ppr@", gfc_current_ns
, &stree
, false);
6433 gfc_get_sym_tree ("ppr@", gfc_current_ns
->parent
, &stree
, false);
6434 st2
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "ppr@");
6435 st2
->n
.sym
= stree
->n
.sym
;
6436 stree
->n
.sym
->refs
++;
6438 sym
->result
= stree
->n
.sym
;
6440 sym
->result
->attr
.proc_pointer
= sym
->attr
.proc_pointer
;
6441 sym
->result
->attr
.pointer
= sym
->attr
.pointer
;
6442 sym
->result
->attr
.external
= sym
->attr
.external
;
6443 sym
->result
->attr
.referenced
= sym
->attr
.referenced
;
6444 sym
->result
->ts
= sym
->ts
;
6445 sym
->attr
.proc_pointer
= 0;
6446 sym
->attr
.pointer
= 0;
6447 sym
->attr
.external
= 0;
6448 if (sym
->result
->attr
.external
&& sym
->result
->attr
.pointer
)
6450 sym
->result
->attr
.pointer
= 0;
6451 sym
->result
->attr
.proc_pointer
= 1;
6454 return gfc_add_result (&sym
->result
->attr
, sym
->result
->name
, NULL
);
6456 /* POINTER after PROCEDURE/EXTERNAL/INTERFACE statement. */
6457 else if (sym
->attr
.function
&& !sym
->attr
.external
&& sym
->attr
.pointer
6458 && sym
->result
&& sym
->result
!= sym
&& sym
->result
->attr
.external
6459 && sym
== gfc_current_ns
->proc_name
6460 && sym
== sym
->result
->ns
->proc_name
6461 && strcmp ("ppr@", sym
->result
->name
) == 0)
6463 sym
->result
->attr
.proc_pointer
= 1;
6464 sym
->attr
.pointer
= 0;
6472 /* Match the interface for a PROCEDURE declaration,
6473 including brackets (R1212). */
6476 match_procedure_interface (gfc_symbol
**proc_if
)
6480 locus old_loc
, entry_loc
;
6481 gfc_namespace
*old_ns
= gfc_current_ns
;
6482 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6484 old_loc
= entry_loc
= gfc_current_locus
;
6485 gfc_clear_ts (¤t_ts
);
6487 if (gfc_match (" (") != MATCH_YES
)
6489 gfc_current_locus
= entry_loc
;
6493 /* Get the type spec. for the procedure interface. */
6494 old_loc
= gfc_current_locus
;
6495 m
= gfc_match_decl_type_spec (¤t_ts
, 0);
6496 gfc_gobble_whitespace ();
6497 if (m
== MATCH_YES
|| (m
== MATCH_NO
&& gfc_peek_ascii_char () == ')'))
6500 if (m
== MATCH_ERROR
)
6503 /* Procedure interface is itself a procedure. */
6504 gfc_current_locus
= old_loc
;
6505 m
= gfc_match_name (name
);
6507 /* First look to see if it is already accessible in the current
6508 namespace because it is use associated or contained. */
6510 if (gfc_find_sym_tree (name
, NULL
, 0, &st
))
6513 /* If it is still not found, then try the parent namespace, if it
6514 exists and create the symbol there if it is still not found. */
6515 if (gfc_current_ns
->parent
)
6516 gfc_current_ns
= gfc_current_ns
->parent
;
6517 if (st
== NULL
&& gfc_get_ha_sym_tree (name
, &st
))
6520 gfc_current_ns
= old_ns
;
6521 *proc_if
= st
->n
.sym
;
6526 /* Resolve interface if possible. That way, attr.procedure is only set
6527 if it is declared by a later procedure-declaration-stmt, which is
6528 invalid per F08:C1216 (cf. resolve_procedure_interface). */
6529 while ((*proc_if
)->ts
.interface
6530 && *proc_if
!= (*proc_if
)->ts
.interface
)
6531 *proc_if
= (*proc_if
)->ts
.interface
;
6533 if ((*proc_if
)->attr
.flavor
== FL_UNKNOWN
6534 && (*proc_if
)->ts
.type
== BT_UNKNOWN
6535 && !gfc_add_flavor (&(*proc_if
)->attr
, FL_PROCEDURE
,
6536 (*proc_if
)->name
, NULL
))
6541 if (gfc_match (" )") != MATCH_YES
)
6543 gfc_current_locus
= entry_loc
;
6551 /* Match a PROCEDURE declaration (R1211). */
6554 match_procedure_decl (void)
6557 gfc_symbol
*sym
, *proc_if
= NULL
;
6559 gfc_expr
*initializer
= NULL
;
6561 /* Parse interface (with brackets). */
6562 m
= match_procedure_interface (&proc_if
);
6566 /* Parse attributes (with colons). */
6567 m
= match_attr_spec();
6568 if (m
== MATCH_ERROR
)
6571 if (proc_if
&& proc_if
->attr
.is_bind_c
&& !current_attr
.is_bind_c
)
6573 current_attr
.is_bind_c
= 1;
6574 has_name_equals
= 0;
6575 curr_binding_label
= NULL
;
6578 /* Get procedure symbols. */
6581 m
= gfc_match_symbol (&sym
, 0);
6584 else if (m
== MATCH_ERROR
)
6587 /* Add current_attr to the symbol attributes. */
6588 if (!gfc_copy_attr (&sym
->attr
, ¤t_attr
, NULL
))
6591 if (sym
->attr
.is_bind_c
)
6593 /* Check for C1218. */
6594 if (!proc_if
|| !proc_if
->attr
.is_bind_c
)
6596 gfc_error ("BIND(C) attribute at %C requires "
6597 "an interface with BIND(C)");
6600 /* Check for C1217. */
6601 if (has_name_equals
&& sym
->attr
.pointer
)
6603 gfc_error ("BIND(C) procedure with NAME may not have "
6604 "POINTER attribute at %C");
6607 if (has_name_equals
&& sym
->attr
.dummy
)
6609 gfc_error ("Dummy procedure at %C may not have "
6610 "BIND(C) attribute with NAME");
6613 /* Set binding label for BIND(C). */
6614 if (!set_binding_label (&sym
->binding_label
, sym
->name
, num
))
6618 if (!gfc_add_external (&sym
->attr
, NULL
))
6621 if (add_hidden_procptr_result (sym
))
6624 if (!gfc_add_proc (&sym
->attr
, sym
->name
, NULL
))
6627 /* Set interface. */
6628 if (proc_if
!= NULL
)
6630 if (sym
->ts
.type
!= BT_UNKNOWN
)
6632 gfc_error ("Procedure %qs at %L already has basic type of %s",
6633 sym
->name
, &gfc_current_locus
,
6634 gfc_basic_typename (sym
->ts
.type
));
6637 sym
->ts
.interface
= proc_if
;
6638 sym
->attr
.untyped
= 1;
6639 sym
->attr
.if_source
= IFSRC_IFBODY
;
6641 else if (current_ts
.type
!= BT_UNKNOWN
)
6643 if (!gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
6645 sym
->ts
.interface
= gfc_new_symbol ("", gfc_current_ns
);
6646 sym
->ts
.interface
->ts
= current_ts
;
6647 sym
->ts
.interface
->attr
.flavor
= FL_PROCEDURE
;
6648 sym
->ts
.interface
->attr
.function
= 1;
6649 sym
->attr
.function
= 1;
6650 sym
->attr
.if_source
= IFSRC_UNKNOWN
;
6653 if (gfc_match (" =>") == MATCH_YES
)
6655 if (!current_attr
.pointer
)
6657 gfc_error ("Initialization at %C isn't for a pointer variable");
6662 m
= match_pointer_init (&initializer
, 1);
6666 if (!add_init_expr_to_sym (sym
->name
, &initializer
, &gfc_current_locus
))
6671 if (gfc_match_eos () == MATCH_YES
)
6673 if (gfc_match_char (',') != MATCH_YES
)
6678 gfc_error ("Syntax error in PROCEDURE statement at %C");
6682 /* Free stuff up and return. */
6683 gfc_free_expr (initializer
);
6689 match_binding_attributes (gfc_typebound_proc
* ba
, bool generic
, bool ppc
);
6692 /* Match a procedure pointer component declaration (R445). */
6695 match_ppc_decl (void)
6698 gfc_symbol
*proc_if
= NULL
;
6702 gfc_expr
*initializer
= NULL
;
6703 gfc_typebound_proc
* tb
;
6704 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6706 /* Parse interface (with brackets). */
6707 m
= match_procedure_interface (&proc_if
);
6711 /* Parse attributes. */
6712 tb
= XCNEW (gfc_typebound_proc
);
6713 tb
->where
= gfc_current_locus
;
6714 m
= match_binding_attributes (tb
, false, true);
6715 if (m
== MATCH_ERROR
)
6718 gfc_clear_attr (¤t_attr
);
6719 current_attr
.procedure
= 1;
6720 current_attr
.proc_pointer
= 1;
6721 current_attr
.access
= tb
->access
;
6722 current_attr
.flavor
= FL_PROCEDURE
;
6724 /* Match the colons (required). */
6725 if (gfc_match (" ::") != MATCH_YES
)
6727 gfc_error ("Expected %<::%> after binding-attributes at %C");
6731 /* Check for C450. */
6732 if (!tb
->nopass
&& proc_if
== NULL
)
6734 gfc_error("NOPASS or explicit interface required at %C");
6738 if (!gfc_notify_std (GFC_STD_F2003
, "Procedure pointer component at %C"))
6741 /* Match PPC names. */
6745 m
= gfc_match_name (name
);
6748 else if (m
== MATCH_ERROR
)
6751 if (!gfc_add_component (gfc_current_block(), name
, &c
))
6754 /* Add current_attr to the symbol attributes. */
6755 if (!gfc_copy_attr (&c
->attr
, ¤t_attr
, NULL
))
6758 if (!gfc_add_external (&c
->attr
, NULL
))
6761 if (!gfc_add_proc (&c
->attr
, name
, NULL
))
6768 c
->tb
= XCNEW (gfc_typebound_proc
);
6769 c
->tb
->where
= gfc_current_locus
;
6773 /* Set interface. */
6774 if (proc_if
!= NULL
)
6776 c
->ts
.interface
= proc_if
;
6777 c
->attr
.untyped
= 1;
6778 c
->attr
.if_source
= IFSRC_IFBODY
;
6780 else if (ts
.type
!= BT_UNKNOWN
)
6783 c
->ts
.interface
= gfc_new_symbol ("", gfc_current_ns
);
6784 c
->ts
.interface
->result
= c
->ts
.interface
;
6785 c
->ts
.interface
->ts
= ts
;
6786 c
->ts
.interface
->attr
.flavor
= FL_PROCEDURE
;
6787 c
->ts
.interface
->attr
.function
= 1;
6788 c
->attr
.function
= 1;
6789 c
->attr
.if_source
= IFSRC_UNKNOWN
;
6792 if (gfc_match (" =>") == MATCH_YES
)
6794 m
= match_pointer_init (&initializer
, 1);
6797 gfc_free_expr (initializer
);
6800 c
->initializer
= initializer
;
6803 if (gfc_match_eos () == MATCH_YES
)
6805 if (gfc_match_char (',') != MATCH_YES
)
6810 gfc_error ("Syntax error in procedure pointer component at %C");
6815 /* Match a PROCEDURE declaration inside an interface (R1206). */
6818 match_procedure_in_interface (void)
6822 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6825 if (current_interface
.type
== INTERFACE_NAMELESS
6826 || current_interface
.type
== INTERFACE_ABSTRACT
)
6828 gfc_error ("PROCEDURE at %C must be in a generic interface");
6832 /* Check if the F2008 optional double colon appears. */
6833 gfc_gobble_whitespace ();
6834 old_locus
= gfc_current_locus
;
6835 if (gfc_match ("::") == MATCH_YES
)
6837 if (!gfc_notify_std (GFC_STD_F2008
, "double colon in "
6838 "MODULE PROCEDURE statement at %L", &old_locus
))
6842 gfc_current_locus
= old_locus
;
6846 m
= gfc_match_name (name
);
6849 else if (m
== MATCH_ERROR
)
6851 if (gfc_get_symbol (name
, gfc_current_ns
->parent
, &sym
))
6854 if (!gfc_add_interface (sym
))
6857 if (gfc_match_eos () == MATCH_YES
)
6859 if (gfc_match_char (',') != MATCH_YES
)
6866 gfc_error ("Syntax error in PROCEDURE statement at %C");
6871 /* General matcher for PROCEDURE declarations. */
6873 static match
match_procedure_in_type (void);
6876 gfc_match_procedure (void)
6880 switch (gfc_current_state ())
6885 case COMP_SUBMODULE
:
6886 case COMP_SUBROUTINE
:
6889 m
= match_procedure_decl ();
6891 case COMP_INTERFACE
:
6892 m
= match_procedure_in_interface ();
6895 m
= match_ppc_decl ();
6897 case COMP_DERIVED_CONTAINS
:
6898 m
= match_procedure_in_type ();
6907 if (!gfc_notify_std (GFC_STD_F2003
, "PROCEDURE statement at %C"))
6914 /* Warn if a matched procedure has the same name as an intrinsic; this is
6915 simply a wrapper around gfc_warn_intrinsic_shadow that interprets the current
6916 parser-state-stack to find out whether we're in a module. */
6919 do_warn_intrinsic_shadow (const gfc_symbol
* sym
, bool func
)
6923 in_module
= (gfc_state_stack
->previous
6924 && (gfc_state_stack
->previous
->state
== COMP_MODULE
6925 || gfc_state_stack
->previous
->state
== COMP_SUBMODULE
));
6927 gfc_warn_intrinsic_shadow (sym
, in_module
, func
);
6931 /* Match a function declaration. */
6934 gfc_match_function_decl (void)
6936 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6937 gfc_symbol
*sym
, *result
;
6941 match found_match
; /* Status returned by match func. */
6943 if (gfc_current_state () != COMP_NONE
6944 && gfc_current_state () != COMP_INTERFACE
6945 && gfc_current_state () != COMP_CONTAINS
)
6948 gfc_clear_ts (¤t_ts
);
6950 old_loc
= gfc_current_locus
;
6952 m
= gfc_match_prefix (¤t_ts
);
6955 gfc_current_locus
= old_loc
;
6959 if (gfc_match ("function% %n", name
) != MATCH_YES
)
6961 gfc_current_locus
= old_loc
;
6965 if (get_proc_name (name
, &sym
, false))
6968 if (add_hidden_procptr_result (sym
))
6971 if (current_attr
.module_procedure
)
6972 sym
->attr
.module_procedure
= 1;
6974 gfc_new_block
= sym
;
6976 m
= gfc_match_formal_arglist (sym
, 0, 0);
6979 gfc_error ("Expected formal argument list in function "
6980 "definition at %C");
6984 else if (m
== MATCH_ERROR
)
6989 /* According to the draft, the bind(c) and result clause can
6990 come in either order after the formal_arg_list (i.e., either
6991 can be first, both can exist together or by themselves or neither
6992 one). Therefore, the match_result can't match the end of the
6993 string, and check for the bind(c) or result clause in either order. */
6994 found_match
= gfc_match_eos ();
6996 /* Make sure that it isn't already declared as BIND(C). If it is, it
6997 must have been marked BIND(C) with a BIND(C) attribute and that is
6998 not allowed for procedures. */
6999 if (sym
->attr
.is_bind_c
== 1)
7001 sym
->attr
.is_bind_c
= 0;
7002 if (sym
->old_symbol
!= NULL
)
7003 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7004 "variables or common blocks",
7005 &(sym
->old_symbol
->declared_at
));
7007 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7008 "variables or common blocks", &gfc_current_locus
);
7011 if (found_match
!= MATCH_YES
)
7013 /* If we haven't found the end-of-statement, look for a suffix. */
7014 suffix_match
= gfc_match_suffix (sym
, &result
);
7015 if (suffix_match
== MATCH_YES
)
7016 /* Need to get the eos now. */
7017 found_match
= gfc_match_eos ();
7019 found_match
= suffix_match
;
7022 if(found_match
!= MATCH_YES
)
7026 /* Make changes to the symbol. */
7029 if (!gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
7032 if (!gfc_missing_attr (&sym
->attr
, NULL
))
7035 if (!copy_prefix (&sym
->attr
, &sym
->declared_at
))
7037 if(!sym
->attr
.module_procedure
)
7043 /* Delay matching the function characteristics until after the
7044 specification block by signalling kind=-1. */
7045 sym
->declared_at
= old_loc
;
7046 if (current_ts
.type
!= BT_UNKNOWN
)
7047 current_ts
.kind
= -1;
7049 current_ts
.kind
= 0;
7053 if (current_ts
.type
!= BT_UNKNOWN
7054 && !gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
7060 if (current_ts
.type
!= BT_UNKNOWN
7061 && !gfc_add_type (result
, ¤t_ts
, &gfc_current_locus
))
7063 sym
->result
= result
;
7066 /* Warn if this procedure has the same name as an intrinsic. */
7067 do_warn_intrinsic_shadow (sym
, true);
7073 gfc_current_locus
= old_loc
;
7078 /* This is mostly a copy of parse.c(add_global_procedure) but modified to
7079 pass the name of the entry, rather than the gfc_current_block name, and
7080 to return false upon finding an existing global entry. */
7083 add_global_entry (const char *name
, const char *binding_label
, bool sub
,
7087 enum gfc_symbol_type type
;
7089 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
7091 /* Only in Fortran 2003: For procedures with a binding label also the Fortran
7092 name is a global identifier. */
7093 if (!binding_label
|| gfc_notification_std (GFC_STD_F2008
))
7095 s
= gfc_get_gsymbol (name
);
7097 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= type
))
7099 gfc_global_used (s
, where
);
7108 s
->ns
= gfc_current_ns
;
7112 /* Don't add the symbol multiple times. */
7114 && (!gfc_notification_std (GFC_STD_F2008
)
7115 || strcmp (name
, binding_label
) != 0))
7117 s
= gfc_get_gsymbol (binding_label
);
7119 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= type
))
7121 gfc_global_used (s
, where
);
7128 s
->binding_label
= binding_label
;
7131 s
->ns
= gfc_current_ns
;
7139 /* Match an ENTRY statement. */
7142 gfc_match_entry (void)
7147 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7148 gfc_compile_state state
;
7152 bool module_procedure
;
7156 m
= gfc_match_name (name
);
7160 if (!gfc_notify_std (GFC_STD_F2008_OBS
, "ENTRY statement at %C"))
7163 state
= gfc_current_state ();
7164 if (state
!= COMP_SUBROUTINE
&& state
!= COMP_FUNCTION
)
7169 gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
7172 gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
7174 case COMP_SUBMODULE
:
7175 gfc_error ("ENTRY statement at %C cannot appear within a SUBMODULE");
7177 case COMP_BLOCK_DATA
:
7178 gfc_error ("ENTRY statement at %C cannot appear within "
7181 case COMP_INTERFACE
:
7182 gfc_error ("ENTRY statement at %C cannot appear within "
7185 case COMP_STRUCTURE
:
7186 gfc_error ("ENTRY statement at %C cannot appear within "
7187 "a STRUCTURE block");
7190 gfc_error ("ENTRY statement at %C cannot appear within "
7191 "a DERIVED TYPE block");
7194 gfc_error ("ENTRY statement at %C cannot appear within "
7195 "an IF-THEN block");
7198 case COMP_DO_CONCURRENT
:
7199 gfc_error ("ENTRY statement at %C cannot appear within "
7203 gfc_error ("ENTRY statement at %C cannot appear within "
7207 gfc_error ("ENTRY statement at %C cannot appear within "
7211 gfc_error ("ENTRY statement at %C cannot appear within "
7215 gfc_error ("ENTRY statement at %C cannot appear within "
7216 "a contained subprogram");
7219 gfc_error ("Unexpected ENTRY statement at %C");
7224 if ((state
== COMP_SUBROUTINE
|| state
== COMP_FUNCTION
)
7225 && gfc_state_stack
->previous
->state
== COMP_INTERFACE
)
7227 gfc_error ("ENTRY statement at %C cannot appear within an INTERFACE");
7231 module_procedure
= gfc_current_ns
->parent
!= NULL
7232 && gfc_current_ns
->parent
->proc_name
7233 && gfc_current_ns
->parent
->proc_name
->attr
.flavor
7236 if (gfc_current_ns
->parent
!= NULL
7237 && gfc_current_ns
->parent
->proc_name
7238 && !module_procedure
)
7240 gfc_error("ENTRY statement at %C cannot appear in a "
7241 "contained procedure");
7245 /* Module function entries need special care in get_proc_name
7246 because previous references within the function will have
7247 created symbols attached to the current namespace. */
7248 if (get_proc_name (name
, &entry
,
7249 gfc_current_ns
->parent
!= NULL
7250 && module_procedure
))
7253 proc
= gfc_current_block ();
7255 /* Make sure that it isn't already declared as BIND(C). If it is, it
7256 must have been marked BIND(C) with a BIND(C) attribute and that is
7257 not allowed for procedures. */
7258 if (entry
->attr
.is_bind_c
== 1)
7260 entry
->attr
.is_bind_c
= 0;
7261 if (entry
->old_symbol
!= NULL
)
7262 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7263 "variables or common blocks",
7264 &(entry
->old_symbol
->declared_at
));
7266 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7267 "variables or common blocks", &gfc_current_locus
);
7270 /* Check what next non-whitespace character is so we can tell if there
7271 is the required parens if we have a BIND(C). */
7272 old_loc
= gfc_current_locus
;
7273 gfc_gobble_whitespace ();
7274 peek_char
= gfc_peek_ascii_char ();
7276 if (state
== COMP_SUBROUTINE
)
7278 m
= gfc_match_formal_arglist (entry
, 0, 1);
7282 /* Call gfc_match_bind_c with allow_binding_name = true as ENTRY can
7283 never be an internal procedure. */
7284 is_bind_c
= gfc_match_bind_c (entry
, true);
7285 if (is_bind_c
== MATCH_ERROR
)
7287 if (is_bind_c
== MATCH_YES
)
7289 if (peek_char
!= '(')
7291 gfc_error ("Missing required parentheses before BIND(C) at %C");
7294 if (!gfc_add_is_bind_c (&(entry
->attr
), entry
->name
,
7295 &(entry
->declared_at
), 1))
7299 if (!gfc_current_ns
->parent
7300 && !add_global_entry (name
, entry
->binding_label
, true,
7304 /* An entry in a subroutine. */
7305 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
7306 || !gfc_add_subroutine (&entry
->attr
, entry
->name
, NULL
))
7311 /* An entry in a function.
7312 We need to take special care because writing
7317 ENTRY f() RESULT (r)
7319 ENTRY f RESULT (r). */
7320 if (gfc_match_eos () == MATCH_YES
)
7322 gfc_current_locus
= old_loc
;
7323 /* Match the empty argument list, and add the interface to
7325 m
= gfc_match_formal_arglist (entry
, 0, 1);
7328 m
= gfc_match_formal_arglist (entry
, 0, 0);
7335 if (gfc_match_eos () == MATCH_YES
)
7337 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
7338 || !gfc_add_function (&entry
->attr
, entry
->name
, NULL
))
7341 entry
->result
= entry
;
7345 m
= gfc_match_suffix (entry
, &result
);
7347 gfc_syntax_error (ST_ENTRY
);
7353 if (!gfc_add_result (&result
->attr
, result
->name
, NULL
)
7354 || !gfc_add_entry (&entry
->attr
, result
->name
, NULL
)
7355 || !gfc_add_function (&entry
->attr
, result
->name
, NULL
))
7357 entry
->result
= result
;
7361 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
7362 || !gfc_add_function (&entry
->attr
, entry
->name
, NULL
))
7364 entry
->result
= entry
;
7368 if (!gfc_current_ns
->parent
7369 && !add_global_entry (name
, entry
->binding_label
, false,
7374 if (gfc_match_eos () != MATCH_YES
)
7376 gfc_syntax_error (ST_ENTRY
);
7380 entry
->attr
.recursive
= proc
->attr
.recursive
;
7381 entry
->attr
.elemental
= proc
->attr
.elemental
;
7382 entry
->attr
.pure
= proc
->attr
.pure
;
7384 el
= gfc_get_entry_list ();
7386 el
->next
= gfc_current_ns
->entries
;
7387 gfc_current_ns
->entries
= el
;
7389 el
->id
= el
->next
->id
+ 1;
7393 new_st
.op
= EXEC_ENTRY
;
7394 new_st
.ext
.entry
= el
;
7400 /* Match a subroutine statement, including optional prefixes. */
7403 gfc_match_subroutine (void)
7405 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7410 bool allow_binding_name
;
7412 if (gfc_current_state () != COMP_NONE
7413 && gfc_current_state () != COMP_INTERFACE
7414 && gfc_current_state () != COMP_CONTAINS
)
7417 m
= gfc_match_prefix (NULL
);
7421 m
= gfc_match ("subroutine% %n", name
);
7425 if (get_proc_name (name
, &sym
, false))
7428 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
7429 the symbol existed before. */
7430 sym
->declared_at
= gfc_current_locus
;
7432 if (current_attr
.module_procedure
)
7433 sym
->attr
.module_procedure
= 1;
7435 if (add_hidden_procptr_result (sym
))
7438 gfc_new_block
= sym
;
7440 /* Check what next non-whitespace character is so we can tell if there
7441 is the required parens if we have a BIND(C). */
7442 gfc_gobble_whitespace ();
7443 peek_char
= gfc_peek_ascii_char ();
7445 if (!gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
))
7448 if (gfc_match_formal_arglist (sym
, 0, 1) != MATCH_YES
)
7451 /* Make sure that it isn't already declared as BIND(C). If it is, it
7452 must have been marked BIND(C) with a BIND(C) attribute and that is
7453 not allowed for procedures. */
7454 if (sym
->attr
.is_bind_c
== 1)
7456 sym
->attr
.is_bind_c
= 0;
7457 if (sym
->old_symbol
!= NULL
)
7458 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7459 "variables or common blocks",
7460 &(sym
->old_symbol
->declared_at
));
7462 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7463 "variables or common blocks", &gfc_current_locus
);
7466 /* C binding names are not allowed for internal procedures. */
7467 if (gfc_current_state () == COMP_CONTAINS
7468 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
7469 allow_binding_name
= false;
7471 allow_binding_name
= true;
7473 /* Here, we are just checking if it has the bind(c) attribute, and if
7474 so, then we need to make sure it's all correct. If it doesn't,
7475 we still need to continue matching the rest of the subroutine line. */
7476 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
7477 if (is_bind_c
== MATCH_ERROR
)
7479 /* There was an attempt at the bind(c), but it was wrong. An
7480 error message should have been printed w/in the gfc_match_bind_c
7481 so here we'll just return the MATCH_ERROR. */
7485 if (is_bind_c
== MATCH_YES
)
7487 /* The following is allowed in the Fortran 2008 draft. */
7488 if (gfc_current_state () == COMP_CONTAINS
7489 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
7490 && !gfc_notify_std (GFC_STD_F2008
, "BIND(C) attribute "
7491 "at %L may not be specified for an internal "
7492 "procedure", &gfc_current_locus
))
7495 if (peek_char
!= '(')
7497 gfc_error ("Missing required parentheses before BIND(C) at %C");
7500 if (!gfc_add_is_bind_c (&(sym
->attr
), sym
->name
,
7501 &(sym
->declared_at
), 1))
7505 if (gfc_match_eos () != MATCH_YES
)
7507 gfc_syntax_error (ST_SUBROUTINE
);
7511 if (!copy_prefix (&sym
->attr
, &sym
->declared_at
))
7513 if(!sym
->attr
.module_procedure
)
7519 /* Warn if it has the same name as an intrinsic. */
7520 do_warn_intrinsic_shadow (sym
, false);
7526 /* Check that the NAME identifier in a BIND attribute or statement
7527 is conform to C identifier rules. */
7530 check_bind_name_identifier (char **name
)
7532 char *n
= *name
, *p
;
7534 /* Remove leading spaces. */
7538 /* On an empty string, free memory and set name to NULL. */
7546 /* Remove trailing spaces. */
7547 p
= n
+ strlen(n
) - 1;
7551 /* Insert the identifier into the symbol table. */
7556 /* Now check that identifier is valid under C rules. */
7559 gfc_error ("Invalid C identifier in NAME= specifier at %C");
7564 if (!(ISALNUM (*p
) || *p
== '_' || *p
== '$'))
7566 gfc_error ("Invalid C identifier in NAME= specifier at %C");
7574 /* Match a BIND(C) specifier, with the optional 'name=' specifier if
7575 given, and set the binding label in either the given symbol (if not
7576 NULL), or in the current_ts. The symbol may be NULL because we may
7577 encounter the BIND(C) before the declaration itself. Return
7578 MATCH_NO if what we're looking at isn't a BIND(C) specifier,
7579 MATCH_ERROR if it is a BIND(C) clause but an error was encountered,
7580 or MATCH_YES if the specifier was correct and the binding label and
7581 bind(c) fields were set correctly for the given symbol or the
7582 current_ts. If allow_binding_name is false, no binding name may be
7586 gfc_match_bind_c (gfc_symbol
*sym
, bool allow_binding_name
)
7588 char *binding_label
= NULL
;
7591 /* Initialize the flag that specifies whether we encountered a NAME=
7592 specifier or not. */
7593 has_name_equals
= 0;
7595 /* This much we have to be able to match, in this order, if
7596 there is a bind(c) label. */
7597 if (gfc_match (" bind ( c ") != MATCH_YES
)
7600 /* Now see if there is a binding label, or if we've reached the
7601 end of the bind(c) attribute without one. */
7602 if (gfc_match_char (',') == MATCH_YES
)
7604 if (gfc_match (" name = ") != MATCH_YES
)
7606 gfc_error ("Syntax error in NAME= specifier for binding label "
7608 /* should give an error message here */
7612 has_name_equals
= 1;
7614 if (gfc_match_init_expr (&e
) != MATCH_YES
)
7620 if (!gfc_simplify_expr(e
, 0))
7622 gfc_error ("NAME= specifier at %C should be a constant expression");
7627 if (e
->expr_type
!= EXPR_CONSTANT
|| e
->ts
.type
!= BT_CHARACTER
7628 || e
->ts
.kind
!= gfc_default_character_kind
|| e
->rank
!= 0)
7630 gfc_error ("NAME= specifier at %C should be a scalar of "
7631 "default character kind");
7636 // Get a C string from the Fortran string constant
7637 binding_label
= gfc_widechar_to_char (e
->value
.character
.string
,
7638 e
->value
.character
.length
);
7641 // Check that it is valid (old gfc_match_name_C)
7642 if (check_bind_name_identifier (&binding_label
) != MATCH_YES
)
7646 /* Get the required right paren. */
7647 if (gfc_match_char (')') != MATCH_YES
)
7649 gfc_error ("Missing closing paren for binding label at %C");
7653 if (has_name_equals
&& !allow_binding_name
)
7655 gfc_error ("No binding name is allowed in BIND(C) at %C");
7659 if (has_name_equals
&& sym
!= NULL
&& sym
->attr
.dummy
)
7661 gfc_error ("For dummy procedure %s, no binding name is "
7662 "allowed in BIND(C) at %C", sym
->name
);
7667 /* Save the binding label to the symbol. If sym is null, we're
7668 probably matching the typespec attributes of a declaration and
7669 haven't gotten the name yet, and therefore, no symbol yet. */
7673 sym
->binding_label
= binding_label
;
7675 curr_binding_label
= binding_label
;
7677 else if (allow_binding_name
)
7679 /* No binding label, but if symbol isn't null, we
7680 can set the label for it here.
7681 If name="" or allow_binding_name is false, no C binding name is
7683 if (sym
!= NULL
&& sym
->name
!= NULL
&& has_name_equals
== 0)
7684 sym
->binding_label
= IDENTIFIER_POINTER (get_identifier (sym
->name
));
7687 if (has_name_equals
&& gfc_current_state () == COMP_INTERFACE
7688 && current_interface
.type
== INTERFACE_ABSTRACT
)
7690 gfc_error ("NAME not allowed on BIND(C) for ABSTRACT INTERFACE at %C");
7698 /* Return nonzero if we're currently compiling a contained procedure. */
7701 contained_procedure (void)
7703 gfc_state_data
*s
= gfc_state_stack
;
7705 if ((s
->state
== COMP_SUBROUTINE
|| s
->state
== COMP_FUNCTION
)
7706 && s
->previous
!= NULL
&& s
->previous
->state
== COMP_CONTAINS
)
7712 /* Set the kind of each enumerator. The kind is selected such that it is
7713 interoperable with the corresponding C enumeration type, making
7714 sure that -fshort-enums is honored. */
7719 enumerator_history
*current_history
= NULL
;
7723 if (max_enum
== NULL
|| enum_history
== NULL
)
7726 if (!flag_short_enums
)
7732 kind
= gfc_integer_kinds
[i
++].kind
;
7734 while (kind
< gfc_c_int_kind
7735 && gfc_check_integer_range (max_enum
->initializer
->value
.integer
,
7738 current_history
= enum_history
;
7739 while (current_history
!= NULL
)
7741 current_history
->sym
->ts
.kind
= kind
;
7742 current_history
= current_history
->next
;
7747 /* Match any of the various end-block statements. Returns the type of
7748 END to the caller. The END INTERFACE, END IF, END DO, END SELECT
7749 and END BLOCK statements cannot be replaced by a single END statement. */
7752 gfc_match_end (gfc_statement
*st
)
7754 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7755 gfc_compile_state state
;
7757 const char *block_name
;
7761 gfc_namespace
*parent_ns
, *ns
, *prev_ns
;
7762 gfc_namespace
**nsp
;
7763 bool abreviated_modproc_decl
= false;
7764 bool got_matching_end
= false;
7766 old_loc
= gfc_current_locus
;
7767 if (gfc_match ("end") != MATCH_YES
)
7770 state
= gfc_current_state ();
7771 block_name
= gfc_current_block () == NULL
7772 ? NULL
: gfc_current_block ()->name
;
7776 case COMP_ASSOCIATE
:
7778 if (!strncmp (block_name
, "block@", strlen("block@")))
7783 case COMP_DERIVED_CONTAINS
:
7784 state
= gfc_state_stack
->previous
->state
;
7785 block_name
= gfc_state_stack
->previous
->sym
== NULL
7786 ? NULL
: gfc_state_stack
->previous
->sym
->name
;
7787 abreviated_modproc_decl
= gfc_state_stack
->previous
->sym
7788 && gfc_state_stack
->previous
->sym
->abr_modproc_decl
;
7795 if (!abreviated_modproc_decl
)
7796 abreviated_modproc_decl
= gfc_current_block ()
7797 && gfc_current_block ()->abr_modproc_decl
;
7803 *st
= ST_END_PROGRAM
;
7804 target
= " program";
7808 case COMP_SUBROUTINE
:
7809 *st
= ST_END_SUBROUTINE
;
7810 if (!abreviated_modproc_decl
)
7811 target
= " subroutine";
7813 target
= " procedure";
7814 eos_ok
= !contained_procedure ();
7818 *st
= ST_END_FUNCTION
;
7819 if (!abreviated_modproc_decl
)
7820 target
= " function";
7822 target
= " procedure";
7823 eos_ok
= !contained_procedure ();
7826 case COMP_BLOCK_DATA
:
7827 *st
= ST_END_BLOCK_DATA
;
7828 target
= " block data";
7833 *st
= ST_END_MODULE
;
7838 case COMP_SUBMODULE
:
7839 *st
= ST_END_SUBMODULE
;
7840 target
= " submodule";
7844 case COMP_INTERFACE
:
7845 *st
= ST_END_INTERFACE
;
7846 target
= " interface";
7862 case COMP_STRUCTURE
:
7863 *st
= ST_END_STRUCTURE
;
7864 target
= " structure";
7869 case COMP_DERIVED_CONTAINS
:
7875 case COMP_ASSOCIATE
:
7876 *st
= ST_END_ASSOCIATE
;
7877 target
= " associate";
7894 case COMP_DO_CONCURRENT
:
7901 *st
= ST_END_CRITICAL
;
7902 target
= " critical";
7907 case COMP_SELECT_TYPE
:
7908 *st
= ST_END_SELECT
;
7914 *st
= ST_END_FORALL
;
7929 last_initializer
= NULL
;
7931 gfc_free_enum_history ();
7935 gfc_error ("Unexpected END statement at %C");
7939 old_loc
= gfc_current_locus
;
7940 if (gfc_match_eos () == MATCH_YES
)
7942 if (!eos_ok
&& (*st
== ST_END_SUBROUTINE
|| *st
== ST_END_FUNCTION
))
7944 if (!gfc_notify_std (GFC_STD_F2008
, "END statement "
7945 "instead of %s statement at %L",
7946 abreviated_modproc_decl
? "END PROCEDURE"
7947 : gfc_ascii_statement(*st
), &old_loc
))
7952 /* We would have required END [something]. */
7953 gfc_error ("%s statement expected at %L",
7954 gfc_ascii_statement (*st
), &old_loc
);
7961 /* Verify that we've got the sort of end-block that we're expecting. */
7962 if (gfc_match (target
) != MATCH_YES
)
7964 gfc_error ("Expecting %s statement at %L", abreviated_modproc_decl
7965 ? "END PROCEDURE" : gfc_ascii_statement(*st
), &old_loc
);
7969 got_matching_end
= true;
7971 old_loc
= gfc_current_locus
;
7972 /* If we're at the end, make sure a block name wasn't required. */
7973 if (gfc_match_eos () == MATCH_YES
)
7976 if (*st
!= ST_ENDDO
&& *st
!= ST_ENDIF
&& *st
!= ST_END_SELECT
7977 && *st
!= ST_END_FORALL
&& *st
!= ST_END_WHERE
&& *st
!= ST_END_BLOCK
7978 && *st
!= ST_END_ASSOCIATE
&& *st
!= ST_END_CRITICAL
)
7984 gfc_error ("Expected block name of %qs in %s statement at %L",
7985 block_name
, gfc_ascii_statement (*st
), &old_loc
);
7990 /* END INTERFACE has a special handler for its several possible endings. */
7991 if (*st
== ST_END_INTERFACE
)
7992 return gfc_match_end_interface ();
7994 /* We haven't hit the end of statement, so what is left must be an
7996 m
= gfc_match_space ();
7998 m
= gfc_match_name (name
);
8001 gfc_error ("Expected terminating name at %C");
8005 if (block_name
== NULL
)
8008 /* We have to pick out the declared submodule name from the composite
8009 required by F2008:11.2.3 para 2, which ends in the declared name. */
8010 if (state
== COMP_SUBMODULE
)
8011 block_name
= strchr (block_name
, '.') + 1;
8013 if (strcmp (name
, block_name
) != 0 && strcmp (block_name
, "ppr@") != 0)
8015 gfc_error ("Expected label %qs for %s statement at %C", block_name
,
8016 gfc_ascii_statement (*st
));
8019 /* Procedure pointer as function result. */
8020 else if (strcmp (block_name
, "ppr@") == 0
8021 && strcmp (name
, gfc_current_block ()->ns
->proc_name
->name
) != 0)
8023 gfc_error ("Expected label %qs for %s statement at %C",
8024 gfc_current_block ()->ns
->proc_name
->name
,
8025 gfc_ascii_statement (*st
));
8029 if (gfc_match_eos () == MATCH_YES
)
8033 gfc_syntax_error (*st
);
8036 gfc_current_locus
= old_loc
;
8038 /* If we are missing an END BLOCK, we created a half-ready namespace.
8039 Remove it from the parent namespace's sibling list. */
8041 while (state
== COMP_BLOCK
&& !got_matching_end
)
8043 parent_ns
= gfc_current_ns
->parent
;
8045 nsp
= &(gfc_state_stack
->previous
->tail
->ext
.block
.ns
);
8051 if (ns
== gfc_current_ns
)
8053 if (prev_ns
== NULL
)
8056 prev_ns
->sibling
= ns
->sibling
;
8062 gfc_free_namespace (gfc_current_ns
);
8063 gfc_current_ns
= parent_ns
;
8064 gfc_state_stack
= gfc_state_stack
->previous
;
8065 state
= gfc_current_state ();
8073 /***************** Attribute declaration statements ****************/
8075 /* Set the attribute of a single variable. */
8080 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8083 /* Workaround -Wmaybe-uninitialized false positive during
8084 profiledbootstrap by initializing them. */
8085 gfc_symbol
*sym
= NULL
;
8091 m
= gfc_match_name (name
);
8095 if (find_special (name
, &sym
, false))
8098 if (!check_function_name (name
))
8104 var_locus
= gfc_current_locus
;
8106 /* Deal with possible array specification for certain attributes. */
8107 if (current_attr
.dimension
8108 || current_attr
.codimension
8109 || current_attr
.allocatable
8110 || current_attr
.pointer
8111 || current_attr
.target
)
8113 m
= gfc_match_array_spec (&as
, !current_attr
.codimension
,
8114 !current_attr
.dimension
8115 && !current_attr
.pointer
8116 && !current_attr
.target
);
8117 if (m
== MATCH_ERROR
)
8120 if (current_attr
.dimension
&& m
== MATCH_NO
)
8122 gfc_error ("Missing array specification at %L in DIMENSION "
8123 "statement", &var_locus
);
8128 if (current_attr
.dimension
&& sym
->value
)
8130 gfc_error ("Dimensions specified for %s at %L after its "
8131 "initialization", sym
->name
, &var_locus
);
8136 if (current_attr
.codimension
&& m
== MATCH_NO
)
8138 gfc_error ("Missing array specification at %L in CODIMENSION "
8139 "statement", &var_locus
);
8144 if ((current_attr
.allocatable
|| current_attr
.pointer
)
8145 && (m
== MATCH_YES
) && (as
->type
!= AS_DEFERRED
))
8147 gfc_error ("Array specification must be deferred at %L", &var_locus
);
8153 /* Update symbol table. DIMENSION attribute is set in
8154 gfc_set_array_spec(). For CLASS variables, this must be applied
8155 to the first component, or '_data' field. */
8156 if (sym
->ts
.type
== BT_CLASS
&& sym
->ts
.u
.derived
->attr
.is_class
)
8158 if (!gfc_copy_attr (&CLASS_DATA(sym
)->attr
, ¤t_attr
, &var_locus
))
8166 if (current_attr
.dimension
== 0 && current_attr
.codimension
== 0
8167 && !gfc_copy_attr (&sym
->attr
, ¤t_attr
, &var_locus
))
8174 if (sym
->ts
.type
== BT_CLASS
8175 && !gfc_build_class_symbol (&sym
->ts
, &sym
->attr
, &sym
->as
))
8181 if (!gfc_set_array_spec (sym
, as
, &var_locus
))
8187 if (sym
->attr
.cray_pointee
&& sym
->as
!= NULL
)
8189 /* Fix the array spec. */
8190 m
= gfc_mod_pointee_as (sym
->as
);
8191 if (m
== MATCH_ERROR
)
8195 if (!gfc_add_attribute (&sym
->attr
, &var_locus
))
8201 if ((current_attr
.external
|| current_attr
.intrinsic
)
8202 && sym
->attr
.flavor
!= FL_PROCEDURE
8203 && !gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, NULL
))
8209 add_hidden_procptr_result (sym
);
8214 gfc_free_array_spec (as
);
8219 /* Generic attribute declaration subroutine. Used for attributes that
8220 just have a list of names. */
8227 /* Gobble the optional double colon, by simply ignoring the result
8237 if (gfc_match_eos () == MATCH_YES
)
8243 if (gfc_match_char (',') != MATCH_YES
)
8245 gfc_error ("Unexpected character in variable list at %C");
8255 /* This routine matches Cray Pointer declarations of the form:
8256 pointer ( <pointer>, <pointee> )
8258 pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...
8259 The pointer, if already declared, should be an integer. Otherwise, we
8260 set it as BT_INTEGER with kind gfc_index_integer_kind. The pointee may
8261 be either a scalar, or an array declaration. No space is allocated for
8262 the pointee. For the statement
8263 pointer (ipt, ar(10))
8264 any subsequent uses of ar will be translated (in C-notation) as
8265 ar(i) => ((<type> *) ipt)(i)
8266 After gimplification, pointee variable will disappear in the code. */
8269 cray_pointer_decl (void)
8272 gfc_array_spec
*as
= NULL
;
8273 gfc_symbol
*cptr
; /* Pointer symbol. */
8274 gfc_symbol
*cpte
; /* Pointee symbol. */
8280 if (gfc_match_char ('(') != MATCH_YES
)
8282 gfc_error ("Expected %<(%> at %C");
8286 /* Match pointer. */
8287 var_locus
= gfc_current_locus
;
8288 gfc_clear_attr (¤t_attr
);
8289 gfc_add_cray_pointer (¤t_attr
, &var_locus
);
8290 current_ts
.type
= BT_INTEGER
;
8291 current_ts
.kind
= gfc_index_integer_kind
;
8293 m
= gfc_match_symbol (&cptr
, 0);
8296 gfc_error ("Expected variable name at %C");
8300 if (!gfc_add_cray_pointer (&cptr
->attr
, &var_locus
))
8303 gfc_set_sym_referenced (cptr
);
8305 if (cptr
->ts
.type
== BT_UNKNOWN
) /* Override the type, if necessary. */
8307 cptr
->ts
.type
= BT_INTEGER
;
8308 cptr
->ts
.kind
= gfc_index_integer_kind
;
8310 else if (cptr
->ts
.type
!= BT_INTEGER
)
8312 gfc_error ("Cray pointer at %C must be an integer");
8315 else if (cptr
->ts
.kind
< gfc_index_integer_kind
)
8316 gfc_warning (0, "Cray pointer at %C has %d bytes of precision;"
8317 " memory addresses require %d bytes",
8318 cptr
->ts
.kind
, gfc_index_integer_kind
);
8320 if (gfc_match_char (',') != MATCH_YES
)
8322 gfc_error ("Expected \",\" at %C");
8326 /* Match Pointee. */
8327 var_locus
= gfc_current_locus
;
8328 gfc_clear_attr (¤t_attr
);
8329 gfc_add_cray_pointee (¤t_attr
, &var_locus
);
8330 current_ts
.type
= BT_UNKNOWN
;
8331 current_ts
.kind
= 0;
8333 m
= gfc_match_symbol (&cpte
, 0);
8336 gfc_error ("Expected variable name at %C");
8340 /* Check for an optional array spec. */
8341 m
= gfc_match_array_spec (&as
, true, false);
8342 if (m
== MATCH_ERROR
)
8344 gfc_free_array_spec (as
);
8347 else if (m
== MATCH_NO
)
8349 gfc_free_array_spec (as
);
8353 if (!gfc_add_cray_pointee (&cpte
->attr
, &var_locus
))
8356 gfc_set_sym_referenced (cpte
);
8358 if (cpte
->as
== NULL
)
8360 if (!gfc_set_array_spec (cpte
, as
, &var_locus
))
8361 gfc_internal_error ("Couldn't set Cray pointee array spec.");
8363 else if (as
!= NULL
)
8365 gfc_error ("Duplicate array spec for Cray pointee at %C");
8366 gfc_free_array_spec (as
);
8372 if (cpte
->as
!= NULL
)
8374 /* Fix array spec. */
8375 m
= gfc_mod_pointee_as (cpte
->as
);
8376 if (m
== MATCH_ERROR
)
8380 /* Point the Pointee at the Pointer. */
8381 cpte
->cp_pointer
= cptr
;
8383 if (gfc_match_char (')') != MATCH_YES
)
8385 gfc_error ("Expected \")\" at %C");
8388 m
= gfc_match_char (',');
8390 done
= true; /* Stop searching for more declarations. */
8394 if (m
== MATCH_ERROR
/* Failed when trying to find ',' above. */
8395 || gfc_match_eos () != MATCH_YES
)
8397 gfc_error ("Expected %<,%> or end of statement at %C");
8405 gfc_match_external (void)
8408 gfc_clear_attr (¤t_attr
);
8409 current_attr
.external
= 1;
8411 return attr_decl ();
8416 gfc_match_intent (void)
8420 /* This is not allowed within a BLOCK construct! */
8421 if (gfc_current_state () == COMP_BLOCK
)
8423 gfc_error ("INTENT is not allowed inside of BLOCK at %C");
8427 intent
= match_intent_spec ();
8428 if (intent
== INTENT_UNKNOWN
)
8431 gfc_clear_attr (¤t_attr
);
8432 current_attr
.intent
= intent
;
8434 return attr_decl ();
8439 gfc_match_intrinsic (void)
8442 gfc_clear_attr (¤t_attr
);
8443 current_attr
.intrinsic
= 1;
8445 return attr_decl ();
8450 gfc_match_optional (void)
8452 /* This is not allowed within a BLOCK construct! */
8453 if (gfc_current_state () == COMP_BLOCK
)
8455 gfc_error ("OPTIONAL is not allowed inside of BLOCK at %C");
8459 gfc_clear_attr (¤t_attr
);
8460 current_attr
.optional
= 1;
8462 return attr_decl ();
8467 gfc_match_pointer (void)
8469 gfc_gobble_whitespace ();
8470 if (gfc_peek_ascii_char () == '(')
8472 if (!flag_cray_pointer
)
8474 gfc_error ("Cray pointer declaration at %C requires -fcray-pointer "
8478 return cray_pointer_decl ();
8482 gfc_clear_attr (¤t_attr
);
8483 current_attr
.pointer
= 1;
8485 return attr_decl ();
8491 gfc_match_allocatable (void)
8493 gfc_clear_attr (¤t_attr
);
8494 current_attr
.allocatable
= 1;
8496 return attr_decl ();
8501 gfc_match_codimension (void)
8503 gfc_clear_attr (¤t_attr
);
8504 current_attr
.codimension
= 1;
8506 return attr_decl ();
8511 gfc_match_contiguous (void)
8513 if (!gfc_notify_std (GFC_STD_F2008
, "CONTIGUOUS statement at %C"))
8516 gfc_clear_attr (¤t_attr
);
8517 current_attr
.contiguous
= 1;
8519 return attr_decl ();
8524 gfc_match_dimension (void)
8526 gfc_clear_attr (¤t_attr
);
8527 current_attr
.dimension
= 1;
8529 return attr_decl ();
8534 gfc_match_target (void)
8536 gfc_clear_attr (¤t_attr
);
8537 current_attr
.target
= 1;
8539 return attr_decl ();
8543 /* Match the list of entities being specified in a PUBLIC or PRIVATE
8547 access_attr_decl (gfc_statement st
)
8549 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8550 interface_type type
;
8552 gfc_symbol
*sym
, *dt_sym
;
8553 gfc_intrinsic_op op
;
8556 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
8561 m
= gfc_match_generic_spec (&type
, name
, &op
);
8564 if (m
== MATCH_ERROR
)
8569 case INTERFACE_NAMELESS
:
8570 case INTERFACE_ABSTRACT
:
8573 case INTERFACE_GENERIC
:
8574 case INTERFACE_DTIO
:
8576 if (gfc_get_symbol (name
, NULL
, &sym
))
8579 if (type
== INTERFACE_DTIO
8580 && gfc_current_ns
->proc_name
8581 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
8582 && sym
->attr
.flavor
== FL_UNKNOWN
)
8583 sym
->attr
.flavor
= FL_PROCEDURE
;
8585 if (!gfc_add_access (&sym
->attr
,
8587 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
,
8591 if (sym
->attr
.generic
&& (dt_sym
= gfc_find_dt_in_generic (sym
))
8592 && !gfc_add_access (&dt_sym
->attr
,
8594 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
,
8600 case INTERFACE_INTRINSIC_OP
:
8601 if (gfc_current_ns
->operator_access
[op
] == ACCESS_UNKNOWN
)
8603 gfc_intrinsic_op other_op
;
8605 gfc_current_ns
->operator_access
[op
] =
8606 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
8608 /* Handle the case if there is another op with the same
8609 function, for INTRINSIC_EQ vs. INTRINSIC_EQ_OS and so on. */
8610 other_op
= gfc_equivalent_op (op
);
8612 if (other_op
!= INTRINSIC_NONE
)
8613 gfc_current_ns
->operator_access
[other_op
] =
8614 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
8619 gfc_error ("Access specification of the %s operator at %C has "
8620 "already been specified", gfc_op2string (op
));
8626 case INTERFACE_USER_OP
:
8627 uop
= gfc_get_uop (name
);
8629 if (uop
->access
== ACCESS_UNKNOWN
)
8631 uop
->access
= (st
== ST_PUBLIC
)
8632 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
8636 gfc_error ("Access specification of the .%s. operator at %C "
8637 "has already been specified", sym
->name
);
8644 if (gfc_match_char (',') == MATCH_NO
)
8648 if (gfc_match_eos () != MATCH_YES
)
8653 gfc_syntax_error (st
);
8661 gfc_match_protected (void)
8666 if (!gfc_current_ns
->proc_name
8667 || gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
8669 gfc_error ("PROTECTED at %C only allowed in specification "
8670 "part of a module");
8675 if (!gfc_notify_std (GFC_STD_F2003
, "PROTECTED statement at %C"))
8678 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
8683 if (gfc_match_eos () == MATCH_YES
)
8688 m
= gfc_match_symbol (&sym
, 0);
8692 if (!gfc_add_protected (&sym
->attr
, sym
->name
, &gfc_current_locus
))
8704 if (gfc_match_eos () == MATCH_YES
)
8706 if (gfc_match_char (',') != MATCH_YES
)
8713 gfc_error ("Syntax error in PROTECTED statement at %C");
8718 /* The PRIVATE statement is a bit weird in that it can be an attribute
8719 declaration, but also works as a standalone statement inside of a
8720 type declaration or a module. */
8723 gfc_match_private (gfc_statement
*st
)
8726 if (gfc_match ("private") != MATCH_YES
)
8729 if (gfc_current_state () != COMP_MODULE
8730 && !(gfc_current_state () == COMP_DERIVED
8731 && gfc_state_stack
->previous
8732 && gfc_state_stack
->previous
->state
== COMP_MODULE
)
8733 && !(gfc_current_state () == COMP_DERIVED_CONTAINS
8734 && gfc_state_stack
->previous
&& gfc_state_stack
->previous
->previous
8735 && gfc_state_stack
->previous
->previous
->state
== COMP_MODULE
))
8737 gfc_error ("PRIVATE statement at %C is only allowed in the "
8738 "specification part of a module");
8742 if (gfc_current_state () == COMP_DERIVED
)
8744 if (gfc_match_eos () == MATCH_YES
)
8750 gfc_syntax_error (ST_PRIVATE
);
8754 if (gfc_match_eos () == MATCH_YES
)
8761 return access_attr_decl (ST_PRIVATE
);
8766 gfc_match_public (gfc_statement
*st
)
8769 if (gfc_match ("public") != MATCH_YES
)
8772 if (gfc_current_state () != COMP_MODULE
)
8774 gfc_error ("PUBLIC statement at %C is only allowed in the "
8775 "specification part of a module");
8779 if (gfc_match_eos () == MATCH_YES
)
8786 return access_attr_decl (ST_PUBLIC
);
8790 /* Workhorse for gfc_match_parameter. */
8800 m
= gfc_match_symbol (&sym
, 0);
8802 gfc_error ("Expected variable name at %C in PARAMETER statement");
8807 if (gfc_match_char ('=') == MATCH_NO
)
8809 gfc_error ("Expected = sign in PARAMETER statement at %C");
8813 m
= gfc_match_init_expr (&init
);
8815 gfc_error ("Expected expression at %C in PARAMETER statement");
8819 if (sym
->ts
.type
== BT_UNKNOWN
8820 && !gfc_set_default_type (sym
, 1, NULL
))
8826 if (!gfc_check_assign_symbol (sym
, NULL
, init
)
8827 || !gfc_add_flavor (&sym
->attr
, FL_PARAMETER
, sym
->name
, NULL
))
8835 gfc_error ("Initializing already initialized variable at %C");
8840 t
= add_init_expr_to_sym (sym
->name
, &init
, &gfc_current_locus
);
8841 return (t
) ? MATCH_YES
: MATCH_ERROR
;
8844 gfc_free_expr (init
);
8849 /* Match a parameter statement, with the weird syntax that these have. */
8852 gfc_match_parameter (void)
8854 const char *term
= " )%t";
8857 if (gfc_match_char ('(') == MATCH_NO
)
8859 /* With legacy PARAMETER statements, don't expect a terminating ')'. */
8860 if (!gfc_notify_std (GFC_STD_LEGACY
, "PARAMETER without '()' at %C"))
8871 if (gfc_match (term
) == MATCH_YES
)
8874 if (gfc_match_char (',') != MATCH_YES
)
8876 gfc_error ("Unexpected characters in PARAMETER statement at %C");
8887 gfc_match_automatic (void)
8891 bool seen_symbol
= false;
8893 if (!flag_dec_static
)
8895 gfc_error ("%s at %C is a DEC extension, enable with "
8906 m
= gfc_match_symbol (&sym
, 0);
8916 if (!gfc_add_automatic (&sym
->attr
, sym
->name
, &gfc_current_locus
))
8922 if (gfc_match_eos () == MATCH_YES
)
8924 if (gfc_match_char (',') != MATCH_YES
)
8930 gfc_error ("Expected entity-list in AUTOMATIC statement at %C");
8937 gfc_error ("Syntax error in AUTOMATIC statement at %C");
8943 gfc_match_static (void)
8947 bool seen_symbol
= false;
8949 if (!flag_dec_static
)
8951 gfc_error ("%s at %C is a DEC extension, enable with "
8961 m
= gfc_match_symbol (&sym
, 0);
8971 if (!gfc_add_save (&sym
->attr
, SAVE_EXPLICIT
, sym
->name
,
8972 &gfc_current_locus
))
8978 if (gfc_match_eos () == MATCH_YES
)
8980 if (gfc_match_char (',') != MATCH_YES
)
8986 gfc_error ("Expected entity-list in STATIC statement at %C");
8993 gfc_error ("Syntax error in STATIC statement at %C");
8998 /* Save statements have a special syntax. */
9001 gfc_match_save (void)
9003 char n
[GFC_MAX_SYMBOL_LEN
+1];
9008 if (gfc_match_eos () == MATCH_YES
)
9010 if (gfc_current_ns
->seen_save
)
9012 if (!gfc_notify_std (GFC_STD_LEGACY
, "Blanket SAVE statement at %C "
9013 "follows previous SAVE statement"))
9017 gfc_current_ns
->save_all
= gfc_current_ns
->seen_save
= 1;
9021 if (gfc_current_ns
->save_all
)
9023 if (!gfc_notify_std (GFC_STD_LEGACY
, "SAVE statement at %C follows "
9024 "blanket SAVE statement"))
9032 m
= gfc_match_symbol (&sym
, 0);
9036 if (!gfc_add_save (&sym
->attr
, SAVE_EXPLICIT
, sym
->name
,
9037 &gfc_current_locus
))
9048 m
= gfc_match (" / %n /", &n
);
9049 if (m
== MATCH_ERROR
)
9054 c
= gfc_get_common (n
, 0);
9057 gfc_current_ns
->seen_save
= 1;
9060 if (gfc_match_eos () == MATCH_YES
)
9062 if (gfc_match_char (',') != MATCH_YES
)
9069 gfc_error ("Syntax error in SAVE statement at %C");
9075 gfc_match_value (void)
9080 /* This is not allowed within a BLOCK construct! */
9081 if (gfc_current_state () == COMP_BLOCK
)
9083 gfc_error ("VALUE is not allowed inside of BLOCK at %C");
9087 if (!gfc_notify_std (GFC_STD_F2003
, "VALUE statement at %C"))
9090 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
9095 if (gfc_match_eos () == MATCH_YES
)
9100 m
= gfc_match_symbol (&sym
, 0);
9104 if (!gfc_add_value (&sym
->attr
, sym
->name
, &gfc_current_locus
))
9116 if (gfc_match_eos () == MATCH_YES
)
9118 if (gfc_match_char (',') != MATCH_YES
)
9125 gfc_error ("Syntax error in VALUE statement at %C");
9131 gfc_match_volatile (void)
9137 if (!gfc_notify_std (GFC_STD_F2003
, "VOLATILE statement at %C"))
9140 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
9145 if (gfc_match_eos () == MATCH_YES
)
9150 /* VOLATILE is special because it can be added to host-associated
9151 symbols locally. Except for coarrays. */
9152 m
= gfc_match_symbol (&sym
, 1);
9156 name
= XCNEWVAR (char, strlen (sym
->name
) + 1);
9157 strcpy (name
, sym
->name
);
9158 if (!check_function_name (name
))
9160 /* F2008, C560+C561. VOLATILE for host-/use-associated variable or
9161 for variable in a BLOCK which is defined outside of the BLOCK. */
9162 if (sym
->ns
!= gfc_current_ns
&& sym
->attr
.codimension
)
9164 gfc_error ("Specifying VOLATILE for coarray variable %qs at "
9165 "%C, which is use-/host-associated", sym
->name
);
9168 if (!gfc_add_volatile (&sym
->attr
, sym
->name
, &gfc_current_locus
))
9180 if (gfc_match_eos () == MATCH_YES
)
9182 if (gfc_match_char (',') != MATCH_YES
)
9189 gfc_error ("Syntax error in VOLATILE statement at %C");
9195 gfc_match_asynchronous (void)
9201 if (!gfc_notify_std (GFC_STD_F2003
, "ASYNCHRONOUS statement at %C"))
9204 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
9209 if (gfc_match_eos () == MATCH_YES
)
9214 /* ASYNCHRONOUS is special because it can be added to host-associated
9216 m
= gfc_match_symbol (&sym
, 1);
9220 name
= XCNEWVAR (char, strlen (sym
->name
) + 1);
9221 strcpy (name
, sym
->name
);
9222 if (!check_function_name (name
))
9224 if (!gfc_add_asynchronous (&sym
->attr
, sym
->name
, &gfc_current_locus
))
9236 if (gfc_match_eos () == MATCH_YES
)
9238 if (gfc_match_char (',') != MATCH_YES
)
9245 gfc_error ("Syntax error in ASYNCHRONOUS statement at %C");
9250 /* Match a module procedure statement in a submodule. */
9253 gfc_match_submod_proc (void)
9255 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9256 gfc_symbol
*sym
, *fsym
;
9258 gfc_formal_arglist
*formal
, *head
, *tail
;
9260 if (gfc_current_state () != COMP_CONTAINS
9261 || !(gfc_state_stack
->previous
9262 && (gfc_state_stack
->previous
->state
== COMP_SUBMODULE
9263 || gfc_state_stack
->previous
->state
== COMP_MODULE
)))
9266 m
= gfc_match (" module% procedure% %n", name
);
9270 if (!gfc_notify_std (GFC_STD_F2008
, "MODULE PROCEDURE declaration "
9274 if (get_proc_name (name
, &sym
, false))
9277 /* Make sure that the result field is appropriately filled, even though
9278 the result symbol will be replaced later on. */
9279 if (sym
->tlink
&& sym
->tlink
->attr
.function
)
9281 if (sym
->tlink
->result
9282 && sym
->tlink
->result
!= sym
->tlink
)
9283 sym
->result
= sym
->tlink
->result
;
9288 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
9289 the symbol existed before. */
9290 sym
->declared_at
= gfc_current_locus
;
9292 if (!sym
->attr
.module_procedure
)
9295 /* Signal match_end to expect "end procedure". */
9296 sym
->abr_modproc_decl
= 1;
9298 /* Change from IFSRC_IFBODY coming from the interface declaration. */
9299 sym
->attr
.if_source
= IFSRC_DECL
;
9301 gfc_new_block
= sym
;
9303 /* Make a new formal arglist with the symbols in the procedure
9306 for (formal
= sym
->formal
; formal
&& formal
->sym
; formal
= formal
->next
)
9308 if (formal
== sym
->formal
)
9309 head
= tail
= gfc_get_formal_arglist ();
9312 tail
->next
= gfc_get_formal_arglist ();
9316 if (gfc_copy_dummy_sym (&fsym
, formal
->sym
, 0))
9320 gfc_set_sym_referenced (fsym
);
9323 /* The dummy symbols get cleaned up, when the formal_namespace of the
9324 interface declaration is cleared. This allows us to add the
9325 explicit interface as is done for other type of procedure. */
9326 if (!gfc_add_explicit_interface (sym
, IFSRC_DECL
, head
,
9327 &gfc_current_locus
))
9330 if (gfc_match_eos () != MATCH_YES
)
9332 gfc_syntax_error (ST_MODULE_PROC
);
9339 gfc_free_formal_arglist (head
);
9344 /* Match a module procedure statement. Note that we have to modify
9345 symbols in the parent's namespace because the current one was there
9346 to receive symbols that are in an interface's formal argument list. */
9349 gfc_match_modproc (void)
9351 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9355 gfc_namespace
*module_ns
;
9356 gfc_interface
*old_interface_head
, *interface
;
9358 if (gfc_state_stack
->state
!= COMP_INTERFACE
9359 || gfc_state_stack
->previous
== NULL
9360 || current_interface
.type
== INTERFACE_NAMELESS
9361 || current_interface
.type
== INTERFACE_ABSTRACT
)
9363 gfc_error ("MODULE PROCEDURE at %C must be in a generic module "
9368 module_ns
= gfc_current_ns
->parent
;
9369 for (; module_ns
; module_ns
= module_ns
->parent
)
9370 if (module_ns
->proc_name
->attr
.flavor
== FL_MODULE
9371 || module_ns
->proc_name
->attr
.flavor
== FL_PROGRAM
9372 || (module_ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
9373 && !module_ns
->proc_name
->attr
.contained
))
9376 if (module_ns
== NULL
)
9379 /* Store the current state of the interface. We will need it if we
9380 end up with a syntax error and need to recover. */
9381 old_interface_head
= gfc_current_interface_head ();
9383 /* Check if the F2008 optional double colon appears. */
9384 gfc_gobble_whitespace ();
9385 old_locus
= gfc_current_locus
;
9386 if (gfc_match ("::") == MATCH_YES
)
9388 if (!gfc_notify_std (GFC_STD_F2008
, "double colon in "
9389 "MODULE PROCEDURE statement at %L", &old_locus
))
9393 gfc_current_locus
= old_locus
;
9398 old_locus
= gfc_current_locus
;
9400 m
= gfc_match_name (name
);
9406 /* Check for syntax error before starting to add symbols to the
9407 current namespace. */
9408 if (gfc_match_eos () == MATCH_YES
)
9411 if (!last
&& gfc_match_char (',') != MATCH_YES
)
9414 /* Now we're sure the syntax is valid, we process this item
9416 if (gfc_get_symbol (name
, module_ns
, &sym
))
9419 if (sym
->attr
.intrinsic
)
9421 gfc_error ("Intrinsic procedure at %L cannot be a MODULE "
9422 "PROCEDURE", &old_locus
);
9426 if (sym
->attr
.proc
!= PROC_MODULE
9427 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
9430 if (!gfc_add_interface (sym
))
9433 sym
->attr
.mod_proc
= 1;
9434 sym
->declared_at
= old_locus
;
9443 /* Restore the previous state of the interface. */
9444 interface
= gfc_current_interface_head ();
9445 gfc_set_current_interface_head (old_interface_head
);
9447 /* Free the new interfaces. */
9448 while (interface
!= old_interface_head
)
9450 gfc_interface
*i
= interface
->next
;
9455 /* And issue a syntax error. */
9456 gfc_syntax_error (ST_MODULE_PROC
);
9461 /* Check a derived type that is being extended. */
9464 check_extended_derived_type (char *name
)
9466 gfc_symbol
*extended
;
9468 if (gfc_find_symbol (name
, gfc_current_ns
, 1, &extended
))
9470 gfc_error ("Ambiguous symbol in TYPE definition at %C");
9474 extended
= gfc_find_dt_in_generic (extended
);
9479 gfc_error ("Symbol %qs at %C has not been previously defined", name
);
9483 if (extended
->attr
.flavor
!= FL_DERIVED
)
9485 gfc_error ("%qs in EXTENDS expression at %C is not a "
9486 "derived type", name
);
9490 if (extended
->attr
.is_bind_c
)
9492 gfc_error ("%qs cannot be extended at %C because it "
9493 "is BIND(C)", extended
->name
);
9497 if (extended
->attr
.sequence
)
9499 gfc_error ("%qs cannot be extended at %C because it "
9500 "is a SEQUENCE type", extended
->name
);
9508 /* Match the optional attribute specifiers for a type declaration.
9509 Return MATCH_ERROR if an error is encountered in one of the handled
9510 attributes (public, private, bind(c)), MATCH_NO if what's found is
9511 not a handled attribute, and MATCH_YES otherwise. TODO: More error
9512 checking on attribute conflicts needs to be done. */
9515 gfc_get_type_attr_spec (symbol_attribute
*attr
, char *name
)
9517 /* See if the derived type is marked as private. */
9518 if (gfc_match (" , private") == MATCH_YES
)
9520 if (gfc_current_state () != COMP_MODULE
)
9522 gfc_error ("Derived type at %C can only be PRIVATE in the "
9523 "specification part of a module");
9527 if (!gfc_add_access (attr
, ACCESS_PRIVATE
, NULL
, NULL
))
9530 else if (gfc_match (" , public") == MATCH_YES
)
9532 if (gfc_current_state () != COMP_MODULE
)
9534 gfc_error ("Derived type at %C can only be PUBLIC in the "
9535 "specification part of a module");
9539 if (!gfc_add_access (attr
, ACCESS_PUBLIC
, NULL
, NULL
))
9542 else if (gfc_match (" , bind ( c )") == MATCH_YES
)
9544 /* If the type is defined to be bind(c) it then needs to make
9545 sure that all fields are interoperable. This will
9546 need to be a semantic check on the finished derived type.
9547 See 15.2.3 (lines 9-12) of F2003 draft. */
9548 if (!gfc_add_is_bind_c (attr
, NULL
, &gfc_current_locus
, 0))
9551 /* TODO: attr conflicts need to be checked, probably in symbol.c. */
9553 else if (gfc_match (" , abstract") == MATCH_YES
)
9555 if (!gfc_notify_std (GFC_STD_F2003
, "ABSTRACT type at %C"))
9558 if (!gfc_add_abstract (attr
, &gfc_current_locus
))
9561 else if (name
&& gfc_match (" , extends ( %n )", name
) == MATCH_YES
)
9563 if (!gfc_add_extension (attr
, &gfc_current_locus
))
9569 /* If we get here, something matched. */
9574 /* Common function for type declaration blocks similar to derived types, such
9575 as STRUCTURES and MAPs. Unlike derived types, a structure type
9576 does NOT have a generic symbol matching the name given by the user.
9577 STRUCTUREs can share names with variables and PARAMETERs so we must allow
9578 for the creation of an independent symbol.
9579 Other parameters are a message to prefix errors with, the name of the new
9580 type to be created, and the flavor to add to the resulting symbol. */
9583 get_struct_decl (const char *name
, sym_flavor fl
, locus
*decl
,
9584 gfc_symbol
**result
)
9589 gcc_assert (name
[0] == (char) TOUPPER (name
[0]));
9594 where
= gfc_current_locus
;
9596 if (gfc_get_symbol (name
, NULL
, &sym
))
9601 gfc_internal_error ("Failed to create structure type '%s' at %C", name
);
9605 if (sym
->components
!= NULL
|| sym
->attr
.zero_comp
)
9607 gfc_error ("Type definition of %qs at %C was already defined at %L",
9608 sym
->name
, &sym
->declared_at
);
9612 sym
->declared_at
= where
;
9614 if (sym
->attr
.flavor
!= fl
9615 && !gfc_add_flavor (&sym
->attr
, fl
, sym
->name
, NULL
))
9618 if (!sym
->hash_value
)
9619 /* Set the hash for the compound name for this type. */
9620 sym
->hash_value
= gfc_hash_value (sym
);
9622 /* Normally the type is expected to have been completely parsed by the time
9623 a field declaration with this type is seen. For unions, maps, and nested
9624 structure declarations, we need to indicate that it is okay that we
9625 haven't seen any components yet. This will be updated after the structure
9627 sym
->attr
.zero_comp
= 0;
9629 /* Structures always act like derived-types with the SEQUENCE attribute */
9630 gfc_add_sequence (&sym
->attr
, sym
->name
, NULL
);
9632 if (result
) *result
= sym
;
9638 /* Match the opening of a MAP block. Like a struct within a union in C;
9639 behaves identical to STRUCTURE blocks. */
9642 gfc_match_map (void)
9644 /* Counter used to give unique internal names to map structures. */
9645 static unsigned int gfc_map_id
= 0;
9646 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9650 old_loc
= gfc_current_locus
;
9652 if (gfc_match_eos () != MATCH_YES
)
9654 gfc_error ("Junk after MAP statement at %C");
9655 gfc_current_locus
= old_loc
;
9659 /* Map blocks are anonymous so we make up unique names for the symbol table
9660 which are invalid Fortran identifiers. */
9661 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "MM$%u", gfc_map_id
++);
9663 if (!get_struct_decl (name
, FL_STRUCT
, &old_loc
, &sym
))
9666 gfc_new_block
= sym
;
9672 /* Match the opening of a UNION block. */
9675 gfc_match_union (void)
9677 /* Counter used to give unique internal names to union types. */
9678 static unsigned int gfc_union_id
= 0;
9679 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9683 old_loc
= gfc_current_locus
;
9685 if (gfc_match_eos () != MATCH_YES
)
9687 gfc_error ("Junk after UNION statement at %C");
9688 gfc_current_locus
= old_loc
;
9692 /* Unions are anonymous so we make up unique names for the symbol table
9693 which are invalid Fortran identifiers. */
9694 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "UU$%u", gfc_union_id
++);
9696 if (!get_struct_decl (name
, FL_UNION
, &old_loc
, &sym
))
9699 gfc_new_block
= sym
;
9705 /* Match the beginning of a STRUCTURE declaration. This is similar to
9706 matching the beginning of a derived type declaration with a few
9707 twists. The resulting type symbol has no access control or other
9708 interesting attributes. */
9711 gfc_match_structure_decl (void)
9713 /* Counter used to give unique internal names to anonymous structures. */
9714 static unsigned int gfc_structure_id
= 0;
9715 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9720 if (!flag_dec_structure
)
9722 gfc_error ("%s at %C is a DEC extension, enable with "
9723 "%<-fdec-structure%>",
9730 m
= gfc_match (" /%n/", name
);
9733 /* Non-nested structure declarations require a structure name. */
9734 if (!gfc_comp_struct (gfc_current_state ()))
9736 gfc_error ("Structure name expected in non-nested structure "
9737 "declaration at %C");
9740 /* This is an anonymous structure; make up a unique name for it
9741 (upper-case letters never make it to symbol names from the source).
9742 The important thing is initializing the type variable
9743 and setting gfc_new_symbol, which is immediately used by
9744 parse_structure () and variable_decl () to add components of
9746 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "SS$%u", gfc_structure_id
++);
9749 where
= gfc_current_locus
;
9750 /* No field list allowed after non-nested structure declaration. */
9751 if (!gfc_comp_struct (gfc_current_state ())
9752 && gfc_match_eos () != MATCH_YES
)
9754 gfc_error ("Junk after non-nested STRUCTURE statement at %C");
9758 /* Make sure the name is not the name of an intrinsic type. */
9759 if (gfc_is_intrinsic_typename (name
))
9761 gfc_error ("Structure name %qs at %C cannot be the same as an"
9762 " intrinsic type", name
);
9766 /* Store the actual type symbol for the structure with an upper-case first
9767 letter (an invalid Fortran identifier). */
9769 if (!get_struct_decl (gfc_dt_upper_string (name
), FL_STRUCT
, &where
, &sym
))
9772 gfc_new_block
= sym
;
9777 /* This function does some work to determine which matcher should be used to
9778 * match a statement beginning with "TYPE". This is used to disambiguate TYPE
9779 * as an alias for PRINT from derived type declarations, TYPE IS statements,
9780 * and derived type data declarations. */
9783 gfc_match_type (gfc_statement
*st
)
9785 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9789 /* Requires -fdec. */
9793 m
= gfc_match ("type");
9796 /* If we already have an error in the buffer, it is probably from failing to
9797 * match a derived type data declaration. Let it happen. */
9798 else if (gfc_error_flag_test ())
9801 old_loc
= gfc_current_locus
;
9804 /* If we see an attribute list before anything else it's definitely a derived
9805 * type declaration. */
9806 if (gfc_match (" ,") == MATCH_YES
|| gfc_match (" ::") == MATCH_YES
)
9808 gfc_current_locus
= old_loc
;
9809 *st
= ST_DERIVED_DECL
;
9810 return gfc_match_derived_decl ();
9813 /* By now "TYPE" has already been matched. If we do not see a name, this may
9814 * be something like "TYPE *" or "TYPE <fmt>". */
9815 m
= gfc_match_name (name
);
9818 /* Let print match if it can, otherwise throw an error from
9819 * gfc_match_derived_decl. */
9820 gfc_current_locus
= old_loc
;
9821 if (gfc_match_print () == MATCH_YES
)
9826 gfc_current_locus
= old_loc
;
9827 *st
= ST_DERIVED_DECL
;
9828 return gfc_match_derived_decl ();
9831 /* A derived type declaration requires an EOS. Without it, assume print. */
9832 m
= gfc_match_eos ();
9835 /* Check manually for TYPE IS (... - this is invalid print syntax. */
9836 if (strncmp ("is", name
, 3) == 0
9837 && gfc_match (" (", name
) == MATCH_YES
)
9839 gfc_current_locus
= old_loc
;
9840 gcc_assert (gfc_match (" is") == MATCH_YES
);
9842 return gfc_match_type_is ();
9844 gfc_current_locus
= old_loc
;
9846 return gfc_match_print ();
9850 /* By now we have "TYPE <name> <EOS>". Check first if the name is an
9851 * intrinsic typename - if so let gfc_match_derived_decl dump an error.
9852 * Otherwise if gfc_match_derived_decl fails it's probably an existing
9853 * symbol which can be printed. */
9854 gfc_current_locus
= old_loc
;
9855 m
= gfc_match_derived_decl ();
9856 if (gfc_is_intrinsic_typename (name
) || m
== MATCH_YES
)
9858 *st
= ST_DERIVED_DECL
;
9861 gfc_current_locus
= old_loc
;
9863 return gfc_match_print ();
9870 /* Match the beginning of a derived type declaration. If a type name
9871 was the result of a function, then it is possible to have a symbol
9872 already to be known as a derived type yet have no components. */
9875 gfc_match_derived_decl (void)
9877 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9878 char parent
[GFC_MAX_SYMBOL_LEN
+ 1];
9879 symbol_attribute attr
;
9880 gfc_symbol
*sym
, *gensym
;
9881 gfc_symbol
*extended
;
9883 match is_type_attr_spec
= MATCH_NO
;
9884 bool seen_attr
= false;
9885 gfc_interface
*intr
= NULL
, *head
;
9886 bool parameterized_type
= false;
9887 bool seen_colons
= false;
9889 if (gfc_comp_struct (gfc_current_state ()))
9894 gfc_clear_attr (&attr
);
9899 is_type_attr_spec
= gfc_get_type_attr_spec (&attr
, parent
);
9900 if (is_type_attr_spec
== MATCH_ERROR
)
9902 if (is_type_attr_spec
== MATCH_YES
)
9904 } while (is_type_attr_spec
== MATCH_YES
);
9906 /* Deal with derived type extensions. The extension attribute has
9907 been added to 'attr' but now the parent type must be found and
9910 extended
= check_extended_derived_type (parent
);
9912 if (parent
[0] && !extended
)
9915 m
= gfc_match (" ::");
9922 gfc_error ("Expected :: in TYPE definition at %C");
9926 m
= gfc_match (" %n ", name
);
9930 /* Make sure that we don't identify TYPE IS (...) as a parameterized
9931 derived type named 'is'.
9932 TODO Expand the check, when 'name' = "is" by matching " (tname) "
9933 and checking if this is a(n intrinsic) typename. his picks up
9934 misplaced TYPE IS statements such as in select_type_1.f03. */
9935 if (gfc_peek_ascii_char () == '(')
9937 if (gfc_current_state () == COMP_SELECT_TYPE
9938 || (!seen_colons
&& !strcmp (name
, "is")))
9940 parameterized_type
= true;
9943 m
= gfc_match_eos ();
9944 if (m
!= MATCH_YES
&& !parameterized_type
)
9947 /* Make sure the name is not the name of an intrinsic type. */
9948 if (gfc_is_intrinsic_typename (name
))
9950 gfc_error ("Type name %qs at %C cannot be the same as an intrinsic "
9955 if (gfc_get_symbol (name
, NULL
, &gensym
))
9958 if (!gensym
->attr
.generic
&& gensym
->ts
.type
!= BT_UNKNOWN
)
9960 gfc_error ("Derived type name %qs at %C already has a basic type "
9961 "of %s", gensym
->name
, gfc_typename (&gensym
->ts
));
9965 if (!gensym
->attr
.generic
9966 && !gfc_add_generic (&gensym
->attr
, gensym
->name
, NULL
))
9969 if (!gensym
->attr
.function
9970 && !gfc_add_function (&gensym
->attr
, gensym
->name
, NULL
))
9973 sym
= gfc_find_dt_in_generic (gensym
);
9975 if (sym
&& (sym
->components
!= NULL
|| sym
->attr
.zero_comp
))
9977 gfc_error ("Derived type definition of %qs at %C has already been "
9978 "defined", sym
->name
);
9984 /* Use upper case to save the actual derived-type symbol. */
9985 gfc_get_symbol (gfc_dt_upper_string (gensym
->name
), NULL
, &sym
);
9986 sym
->name
= gfc_get_string ("%s", gensym
->name
);
9987 head
= gensym
->generic
;
9988 intr
= gfc_get_interface ();
9990 intr
->where
= gfc_current_locus
;
9991 intr
->sym
->declared_at
= gfc_current_locus
;
9993 gensym
->generic
= intr
;
9994 gensym
->attr
.if_source
= IFSRC_DECL
;
9997 /* The symbol may already have the derived attribute without the
9998 components. The ways this can happen is via a function
9999 definition, an INTRINSIC statement or a subtype in another
10000 derived type that is a pointer. The first part of the AND clause
10001 is true if the symbol is not the return value of a function. */
10002 if (sym
->attr
.flavor
!= FL_DERIVED
10003 && !gfc_add_flavor (&sym
->attr
, FL_DERIVED
, sym
->name
, NULL
))
10004 return MATCH_ERROR
;
10006 if (attr
.access
!= ACCESS_UNKNOWN
10007 && !gfc_add_access (&sym
->attr
, attr
.access
, sym
->name
, NULL
))
10008 return MATCH_ERROR
;
10009 else if (sym
->attr
.access
== ACCESS_UNKNOWN
10010 && gensym
->attr
.access
!= ACCESS_UNKNOWN
10011 && !gfc_add_access (&sym
->attr
, gensym
->attr
.access
,
10013 return MATCH_ERROR
;
10015 if (sym
->attr
.access
!= ACCESS_UNKNOWN
10016 && gensym
->attr
.access
== ACCESS_UNKNOWN
)
10017 gensym
->attr
.access
= sym
->attr
.access
;
10019 /* See if the derived type was labeled as bind(c). */
10020 if (attr
.is_bind_c
!= 0)
10021 sym
->attr
.is_bind_c
= attr
.is_bind_c
;
10023 /* Construct the f2k_derived namespace if it is not yet there. */
10024 if (!sym
->f2k_derived
)
10025 sym
->f2k_derived
= gfc_get_namespace (NULL
, 0);
10027 if (parameterized_type
)
10029 /* Ignore error or mismatches by going to the end of the statement
10030 in order to avoid the component declarations causing problems. */
10031 m
= gfc_match_formal_arglist (sym
, 0, 0, true);
10032 if (m
!= MATCH_YES
)
10033 gfc_error_recovery ();
10034 m
= gfc_match_eos ();
10035 if (m
!= MATCH_YES
)
10037 gfc_error_recovery ();
10038 gfc_error_now ("Garbage after PARAMETERIZED TYPE declaration at %C");
10040 sym
->attr
.pdt_template
= 1;
10043 if (extended
&& !sym
->components
)
10046 gfc_formal_arglist
*f
, *g
, *h
;
10048 /* Add the extended derived type as the first component. */
10049 gfc_add_component (sym
, parent
, &p
);
10051 gfc_set_sym_referenced (extended
);
10053 p
->ts
.type
= BT_DERIVED
;
10054 p
->ts
.u
.derived
= extended
;
10055 p
->initializer
= gfc_default_initializer (&p
->ts
);
10057 /* Set extension level. */
10058 if (extended
->attr
.extension
== 255)
10060 /* Since the extension field is 8 bit wide, we can only have
10061 up to 255 extension levels. */
10062 gfc_error ("Maximum extension level reached with type %qs at %L",
10063 extended
->name
, &extended
->declared_at
);
10064 return MATCH_ERROR
;
10066 sym
->attr
.extension
= extended
->attr
.extension
+ 1;
10068 /* Provide the links between the extended type and its extension. */
10069 if (!extended
->f2k_derived
)
10070 extended
->f2k_derived
= gfc_get_namespace (NULL
, 0);
10072 /* Copy the extended type-param-name-list from the extended type,
10073 append those of the extension and add the whole lot to the
10075 if (extended
->attr
.pdt_template
)
10078 sym
->attr
.pdt_template
= 1;
10079 for (f
= extended
->formal
; f
; f
= f
->next
)
10081 if (f
== extended
->formal
)
10083 g
= gfc_get_formal_arglist ();
10088 g
->next
= gfc_get_formal_arglist ();
10093 g
->next
= sym
->formal
;
10098 if (!sym
->hash_value
)
10099 /* Set the hash for the compound name for this type. */
10100 sym
->hash_value
= gfc_hash_value (sym
);
10102 /* Take over the ABSTRACT attribute. */
10103 sym
->attr
.abstract
= attr
.abstract
;
10105 gfc_new_block
= sym
;
10111 /* Cray Pointees can be declared as:
10112 pointer (ipt, a (n,m,...,*)) */
10115 gfc_mod_pointee_as (gfc_array_spec
*as
)
10117 as
->cray_pointee
= true; /* This will be useful to know later. */
10118 if (as
->type
== AS_ASSUMED_SIZE
)
10119 as
->cp_was_assumed
= true;
10120 else if (as
->type
== AS_ASSUMED_SHAPE
)
10122 gfc_error ("Cray Pointee at %C cannot be assumed shape array");
10123 return MATCH_ERROR
;
10129 /* Match the enum definition statement, here we are trying to match
10130 the first line of enum definition statement.
10131 Returns MATCH_YES if match is found. */
10134 gfc_match_enum (void)
10138 m
= gfc_match_eos ();
10139 if (m
!= MATCH_YES
)
10142 if (!gfc_notify_std (GFC_STD_F2003
, "ENUM and ENUMERATOR at %C"))
10143 return MATCH_ERROR
;
10149 /* Returns an initializer whose value is one higher than the value of the
10150 LAST_INITIALIZER argument. If the argument is NULL, the
10151 initializers value will be set to zero. The initializer's kind
10152 will be set to gfc_c_int_kind.
10154 If -fshort-enums is given, the appropriate kind will be selected
10155 later after all enumerators have been parsed. A warning is issued
10156 here if an initializer exceeds gfc_c_int_kind. */
10159 enum_initializer (gfc_expr
*last_initializer
, locus where
)
10162 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_c_int_kind
, &where
);
10164 mpz_init (result
->value
.integer
);
10166 if (last_initializer
!= NULL
)
10168 mpz_add_ui (result
->value
.integer
, last_initializer
->value
.integer
, 1);
10169 result
->where
= last_initializer
->where
;
10171 if (gfc_check_integer_range (result
->value
.integer
,
10172 gfc_c_int_kind
) != ARITH_OK
)
10174 gfc_error ("Enumerator exceeds the C integer type at %C");
10180 /* Control comes here, if it's the very first enumerator and no
10181 initializer has been given. It will be initialized to zero. */
10182 mpz_set_si (result
->value
.integer
, 0);
10189 /* Match a variable name with an optional initializer. When this
10190 subroutine is called, a variable is expected to be parsed next.
10191 Depending on what is happening at the moment, updates either the
10192 symbol table or the current interface. */
10195 enumerator_decl (void)
10197 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10198 gfc_expr
*initializer
;
10199 gfc_array_spec
*as
= NULL
;
10206 initializer
= NULL
;
10207 old_locus
= gfc_current_locus
;
10209 /* When we get here, we've just matched a list of attributes and
10210 maybe a type and a double colon. The next thing we expect to see
10211 is the name of the symbol. */
10212 m
= gfc_match_name (name
);
10213 if (m
!= MATCH_YES
)
10216 var_locus
= gfc_current_locus
;
10218 /* OK, we've successfully matched the declaration. Now put the
10219 symbol in the current namespace. If we fail to create the symbol,
10221 if (!build_sym (name
, NULL
, false, &as
, &var_locus
))
10227 /* The double colon must be present in order to have initializers.
10228 Otherwise the statement is ambiguous with an assignment statement. */
10231 if (gfc_match_char ('=') == MATCH_YES
)
10233 m
= gfc_match_init_expr (&initializer
);
10236 gfc_error ("Expected an initialization expression at %C");
10240 if (m
!= MATCH_YES
)
10245 /* If we do not have an initializer, the initialization value of the
10246 previous enumerator (stored in last_initializer) is incremented
10247 by 1 and is used to initialize the current enumerator. */
10248 if (initializer
== NULL
)
10249 initializer
= enum_initializer (last_initializer
, old_locus
);
10251 if (initializer
== NULL
|| initializer
->ts
.type
!= BT_INTEGER
)
10253 gfc_error ("ENUMERATOR %L not initialized with integer expression",
10259 /* Store this current initializer, for the next enumerator variable
10260 to be parsed. add_init_expr_to_sym() zeros initializer, so we
10261 use last_initializer below. */
10262 last_initializer
= initializer
;
10263 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
10265 /* Maintain enumerator history. */
10266 gfc_find_symbol (name
, NULL
, 0, &sym
);
10267 create_enum_history (sym
, last_initializer
);
10269 return (t
) ? MATCH_YES
: MATCH_ERROR
;
10272 /* Free stuff up and return. */
10273 gfc_free_expr (initializer
);
10279 /* Match the enumerator definition statement. */
10282 gfc_match_enumerator_def (void)
10287 gfc_clear_ts (¤t_ts
);
10289 m
= gfc_match (" enumerator");
10290 if (m
!= MATCH_YES
)
10293 m
= gfc_match (" :: ");
10294 if (m
== MATCH_ERROR
)
10297 colon_seen
= (m
== MATCH_YES
);
10299 if (gfc_current_state () != COMP_ENUM
)
10301 gfc_error ("ENUM definition statement expected before %C");
10302 gfc_free_enum_history ();
10303 return MATCH_ERROR
;
10306 (¤t_ts
)->type
= BT_INTEGER
;
10307 (¤t_ts
)->kind
= gfc_c_int_kind
;
10309 gfc_clear_attr (¤t_attr
);
10310 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, NULL
);
10319 m
= enumerator_decl ();
10320 if (m
== MATCH_ERROR
)
10322 gfc_free_enum_history ();
10328 if (gfc_match_eos () == MATCH_YES
)
10330 if (gfc_match_char (',') != MATCH_YES
)
10334 if (gfc_current_state () == COMP_ENUM
)
10336 gfc_free_enum_history ();
10337 gfc_error ("Syntax error in ENUMERATOR definition at %C");
10342 gfc_free_array_spec (current_as
);
10349 /* Match binding attributes. */
10352 match_binding_attributes (gfc_typebound_proc
* ba
, bool generic
, bool ppc
)
10354 bool found_passing
= false;
10355 bool seen_ptr
= false;
10356 match m
= MATCH_YES
;
10358 /* Initialize to defaults. Do so even before the MATCH_NO check so that in
10359 this case the defaults are in there. */
10360 ba
->access
= ACCESS_UNKNOWN
;
10361 ba
->pass_arg
= NULL
;
10362 ba
->pass_arg_num
= 0;
10364 ba
->non_overridable
= 0;
10368 /* If we find a comma, we believe there are binding attributes. */
10369 m
= gfc_match_char (',');
10375 /* Access specifier. */
10377 m
= gfc_match (" public");
10378 if (m
== MATCH_ERROR
)
10380 if (m
== MATCH_YES
)
10382 if (ba
->access
!= ACCESS_UNKNOWN
)
10384 gfc_error ("Duplicate access-specifier at %C");
10388 ba
->access
= ACCESS_PUBLIC
;
10392 m
= gfc_match (" private");
10393 if (m
== MATCH_ERROR
)
10395 if (m
== MATCH_YES
)
10397 if (ba
->access
!= ACCESS_UNKNOWN
)
10399 gfc_error ("Duplicate access-specifier at %C");
10403 ba
->access
= ACCESS_PRIVATE
;
10407 /* If inside GENERIC, the following is not allowed. */
10412 m
= gfc_match (" nopass");
10413 if (m
== MATCH_ERROR
)
10415 if (m
== MATCH_YES
)
10419 gfc_error ("Binding attributes already specify passing,"
10420 " illegal NOPASS at %C");
10424 found_passing
= true;
10429 /* PASS possibly including argument. */
10430 m
= gfc_match (" pass");
10431 if (m
== MATCH_ERROR
)
10433 if (m
== MATCH_YES
)
10435 char arg
[GFC_MAX_SYMBOL_LEN
+ 1];
10439 gfc_error ("Binding attributes already specify passing,"
10440 " illegal PASS at %C");
10444 m
= gfc_match (" ( %n )", arg
);
10445 if (m
== MATCH_ERROR
)
10447 if (m
== MATCH_YES
)
10448 ba
->pass_arg
= gfc_get_string ("%s", arg
);
10449 gcc_assert ((m
== MATCH_YES
) == (ba
->pass_arg
!= NULL
));
10451 found_passing
= true;
10458 /* POINTER flag. */
10459 m
= gfc_match (" pointer");
10460 if (m
== MATCH_ERROR
)
10462 if (m
== MATCH_YES
)
10466 gfc_error ("Duplicate POINTER attribute at %C");
10476 /* NON_OVERRIDABLE flag. */
10477 m
= gfc_match (" non_overridable");
10478 if (m
== MATCH_ERROR
)
10480 if (m
== MATCH_YES
)
10482 if (ba
->non_overridable
)
10484 gfc_error ("Duplicate NON_OVERRIDABLE at %C");
10488 ba
->non_overridable
= 1;
10492 /* DEFERRED flag. */
10493 m
= gfc_match (" deferred");
10494 if (m
== MATCH_ERROR
)
10496 if (m
== MATCH_YES
)
10500 gfc_error ("Duplicate DEFERRED at %C");
10511 /* Nothing matching found. */
10513 gfc_error ("Expected access-specifier at %C");
10515 gfc_error ("Expected binding attribute at %C");
10518 while (gfc_match_char (',') == MATCH_YES
);
10520 /* NON_OVERRIDABLE and DEFERRED exclude themselves. */
10521 if (ba
->non_overridable
&& ba
->deferred
)
10523 gfc_error ("NON_OVERRIDABLE and DEFERRED can't both appear at %C");
10530 if (ba
->access
== ACCESS_UNKNOWN
)
10531 ba
->access
= gfc_typebound_default_access
;
10533 if (ppc
&& !seen_ptr
)
10535 gfc_error ("POINTER attribute is required for procedure pointer component"
10543 return MATCH_ERROR
;
10547 /* Match a PROCEDURE specific binding inside a derived type. */
10550 match_procedure_in_type (void)
10552 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10553 char target_buf
[GFC_MAX_SYMBOL_LEN
+ 1];
10554 char* target
= NULL
, *ifc
= NULL
;
10555 gfc_typebound_proc tb
;
10559 gfc_symtree
* stree
;
10564 /* Check current state. */
10565 gcc_assert (gfc_state_stack
->state
== COMP_DERIVED_CONTAINS
);
10566 block
= gfc_state_stack
->previous
->sym
;
10567 gcc_assert (block
);
10569 /* Try to match PROCEDURE(interface). */
10570 if (gfc_match (" (") == MATCH_YES
)
10572 m
= gfc_match_name (target_buf
);
10573 if (m
== MATCH_ERROR
)
10575 if (m
!= MATCH_YES
)
10577 gfc_error ("Interface-name expected after %<(%> at %C");
10578 return MATCH_ERROR
;
10581 if (gfc_match (" )") != MATCH_YES
)
10583 gfc_error ("%<)%> expected at %C");
10584 return MATCH_ERROR
;
10590 /* Construct the data structure. */
10591 memset (&tb
, 0, sizeof (tb
));
10592 tb
.where
= gfc_current_locus
;
10594 /* Match binding attributes. */
10595 m
= match_binding_attributes (&tb
, false, false);
10596 if (m
== MATCH_ERROR
)
10598 seen_attrs
= (m
== MATCH_YES
);
10600 /* Check that attribute DEFERRED is given if an interface is specified. */
10601 if (tb
.deferred
&& !ifc
)
10603 gfc_error ("Interface must be specified for DEFERRED binding at %C");
10604 return MATCH_ERROR
;
10606 if (ifc
&& !tb
.deferred
)
10608 gfc_error ("PROCEDURE(interface) at %C should be declared DEFERRED");
10609 return MATCH_ERROR
;
10612 /* Match the colons. */
10613 m
= gfc_match (" ::");
10614 if (m
== MATCH_ERROR
)
10616 seen_colons
= (m
== MATCH_YES
);
10617 if (seen_attrs
&& !seen_colons
)
10619 gfc_error ("Expected %<::%> after binding-attributes at %C");
10620 return MATCH_ERROR
;
10623 /* Match the binding names. */
10626 m
= gfc_match_name (name
);
10627 if (m
== MATCH_ERROR
)
10631 gfc_error ("Expected binding name at %C");
10632 return MATCH_ERROR
;
10635 if (num
>1 && !gfc_notify_std (GFC_STD_F2008
, "PROCEDURE list at %C"))
10636 return MATCH_ERROR
;
10638 /* Try to match the '=> target', if it's there. */
10640 m
= gfc_match (" =>");
10641 if (m
== MATCH_ERROR
)
10643 if (m
== MATCH_YES
)
10647 gfc_error ("%<=> target%> is invalid for DEFERRED binding at %C");
10648 return MATCH_ERROR
;
10653 gfc_error ("%<::%> needed in PROCEDURE binding with explicit target"
10655 return MATCH_ERROR
;
10658 m
= gfc_match_name (target_buf
);
10659 if (m
== MATCH_ERROR
)
10663 gfc_error ("Expected binding target after %<=>%> at %C");
10664 return MATCH_ERROR
;
10666 target
= target_buf
;
10669 /* If no target was found, it has the same name as the binding. */
10673 /* Get the namespace to insert the symbols into. */
10674 ns
= block
->f2k_derived
;
10677 /* If the binding is DEFERRED, check that the containing type is ABSTRACT. */
10678 if (tb
.deferred
&& !block
->attr
.abstract
)
10680 gfc_error ("Type %qs containing DEFERRED binding at %C "
10681 "is not ABSTRACT", block
->name
);
10682 return MATCH_ERROR
;
10685 /* See if we already have a binding with this name in the symtree which
10686 would be an error. If a GENERIC already targeted this binding, it may
10687 be already there but then typebound is still NULL. */
10688 stree
= gfc_find_symtree (ns
->tb_sym_root
, name
);
10689 if (stree
&& stree
->n
.tb
)
10691 gfc_error ("There is already a procedure with binding name %qs for "
10692 "the derived type %qs at %C", name
, block
->name
);
10693 return MATCH_ERROR
;
10696 /* Insert it and set attributes. */
10700 stree
= gfc_new_symtree (&ns
->tb_sym_root
, name
);
10701 gcc_assert (stree
);
10703 stree
->n
.tb
= gfc_get_typebound_proc (&tb
);
10705 if (gfc_get_sym_tree (target
, gfc_current_ns
, &stree
->n
.tb
->u
.specific
,
10707 return MATCH_ERROR
;
10708 gfc_set_sym_referenced (stree
->n
.tb
->u
.specific
->n
.sym
);
10709 gfc_add_flavor(&stree
->n
.tb
->u
.specific
->n
.sym
->attr
, FL_PROCEDURE
,
10710 target
, &stree
->n
.tb
->u
.specific
->n
.sym
->declared_at
);
10712 if (gfc_match_eos () == MATCH_YES
)
10714 if (gfc_match_char (',') != MATCH_YES
)
10719 gfc_error ("Syntax error in PROCEDURE statement at %C");
10720 return MATCH_ERROR
;
10724 /* Match a GENERIC procedure binding inside a derived type. */
10727 gfc_match_generic (void)
10729 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10730 char bind_name
[GFC_MAX_SYMBOL_LEN
+ 16]; /* Allow space for OPERATOR(...). */
10732 gfc_typebound_proc tbattr
; /* Used for match_binding_attributes. */
10733 gfc_typebound_proc
* tb
;
10735 interface_type op_type
;
10736 gfc_intrinsic_op op
;
10739 /* Check current state. */
10740 if (gfc_current_state () == COMP_DERIVED
)
10742 gfc_error ("GENERIC at %C must be inside a derived-type CONTAINS");
10743 return MATCH_ERROR
;
10745 if (gfc_current_state () != COMP_DERIVED_CONTAINS
)
10747 block
= gfc_state_stack
->previous
->sym
;
10748 ns
= block
->f2k_derived
;
10749 gcc_assert (block
&& ns
);
10751 memset (&tbattr
, 0, sizeof (tbattr
));
10752 tbattr
.where
= gfc_current_locus
;
10754 /* See if we get an access-specifier. */
10755 m
= match_binding_attributes (&tbattr
, true, false);
10756 if (m
== MATCH_ERROR
)
10759 /* Now the colons, those are required. */
10760 if (gfc_match (" ::") != MATCH_YES
)
10762 gfc_error ("Expected %<::%> at %C");
10766 /* Match the binding name; depending on type (operator / generic) format
10767 it for future error messages into bind_name. */
10769 m
= gfc_match_generic_spec (&op_type
, name
, &op
);
10770 if (m
== MATCH_ERROR
)
10771 return MATCH_ERROR
;
10774 gfc_error ("Expected generic name or operator descriptor at %C");
10780 case INTERFACE_GENERIC
:
10781 case INTERFACE_DTIO
:
10782 snprintf (bind_name
, sizeof (bind_name
), "%s", name
);
10785 case INTERFACE_USER_OP
:
10786 snprintf (bind_name
, sizeof (bind_name
), "OPERATOR(.%s.)", name
);
10789 case INTERFACE_INTRINSIC_OP
:
10790 snprintf (bind_name
, sizeof (bind_name
), "OPERATOR(%s)",
10791 gfc_op2string (op
));
10794 case INTERFACE_NAMELESS
:
10795 gfc_error ("Malformed GENERIC statement at %C");
10800 gcc_unreachable ();
10803 /* Match the required =>. */
10804 if (gfc_match (" =>") != MATCH_YES
)
10806 gfc_error ("Expected %<=>%> at %C");
10810 /* Try to find existing GENERIC binding with this name / for this operator;
10811 if there is something, check that it is another GENERIC and then extend
10812 it rather than building a new node. Otherwise, create it and put it
10813 at the right position. */
10817 case INTERFACE_DTIO
:
10818 case INTERFACE_USER_OP
:
10819 case INTERFACE_GENERIC
:
10821 const bool is_op
= (op_type
== INTERFACE_USER_OP
);
10824 st
= gfc_find_symtree (is_op
? ns
->tb_uop_root
: ns
->tb_sym_root
, name
);
10825 tb
= st
? st
->n
.tb
: NULL
;
10829 case INTERFACE_INTRINSIC_OP
:
10830 tb
= ns
->tb_op
[op
];
10834 gcc_unreachable ();
10839 if (!tb
->is_generic
)
10841 gcc_assert (op_type
== INTERFACE_GENERIC
);
10842 gfc_error ("There's already a non-generic procedure with binding name"
10843 " %qs for the derived type %qs at %C",
10844 bind_name
, block
->name
);
10848 if (tb
->access
!= tbattr
.access
)
10850 gfc_error ("Binding at %C must have the same access as already"
10851 " defined binding %qs", bind_name
);
10857 tb
= gfc_get_typebound_proc (NULL
);
10858 tb
->where
= gfc_current_locus
;
10859 tb
->access
= tbattr
.access
;
10860 tb
->is_generic
= 1;
10861 tb
->u
.generic
= NULL
;
10865 case INTERFACE_DTIO
:
10866 case INTERFACE_GENERIC
:
10867 case INTERFACE_USER_OP
:
10869 const bool is_op
= (op_type
== INTERFACE_USER_OP
);
10870 gfc_symtree
* st
= gfc_get_tbp_symtree (is_op
? &ns
->tb_uop_root
:
10871 &ns
->tb_sym_root
, name
);
10878 case INTERFACE_INTRINSIC_OP
:
10879 ns
->tb_op
[op
] = tb
;
10883 gcc_unreachable ();
10887 /* Now, match all following names as specific targets. */
10890 gfc_symtree
* target_st
;
10891 gfc_tbp_generic
* target
;
10893 m
= gfc_match_name (name
);
10894 if (m
== MATCH_ERROR
)
10898 gfc_error ("Expected specific binding name at %C");
10902 target_st
= gfc_get_tbp_symtree (&ns
->tb_sym_root
, name
);
10904 /* See if this is a duplicate specification. */
10905 for (target
= tb
->u
.generic
; target
; target
= target
->next
)
10906 if (target_st
== target
->specific_st
)
10908 gfc_error ("%qs already defined as specific binding for the"
10909 " generic %qs at %C", name
, bind_name
);
10913 target
= gfc_get_tbp_generic ();
10914 target
->specific_st
= target_st
;
10915 target
->specific
= NULL
;
10916 target
->next
= tb
->u
.generic
;
10917 target
->is_operator
= ((op_type
== INTERFACE_USER_OP
)
10918 || (op_type
== INTERFACE_INTRINSIC_OP
));
10919 tb
->u
.generic
= target
;
10921 while (gfc_match (" ,") == MATCH_YES
);
10923 /* Here should be the end. */
10924 if (gfc_match_eos () != MATCH_YES
)
10926 gfc_error ("Junk after GENERIC binding at %C");
10933 return MATCH_ERROR
;
10937 /* Match a FINAL declaration inside a derived type. */
10940 gfc_match_final_decl (void)
10942 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10945 gfc_namespace
* module_ns
;
10949 if (gfc_current_form
== FORM_FREE
)
10951 char c
= gfc_peek_ascii_char ();
10952 if (!gfc_is_whitespace (c
) && c
!= ':')
10956 if (gfc_state_stack
->state
!= COMP_DERIVED_CONTAINS
)
10958 if (gfc_current_form
== FORM_FIXED
)
10961 gfc_error ("FINAL declaration at %C must be inside a derived type "
10962 "CONTAINS section");
10963 return MATCH_ERROR
;
10966 block
= gfc_state_stack
->previous
->sym
;
10967 gcc_assert (block
);
10969 if (!gfc_state_stack
->previous
|| !gfc_state_stack
->previous
->previous
10970 || gfc_state_stack
->previous
->previous
->state
!= COMP_MODULE
)
10972 gfc_error ("Derived type declaration with FINAL at %C must be in the"
10973 " specification part of a MODULE");
10974 return MATCH_ERROR
;
10977 module_ns
= gfc_current_ns
;
10978 gcc_assert (module_ns
);
10979 gcc_assert (module_ns
->proc_name
->attr
.flavor
== FL_MODULE
);
10981 /* Match optional ::, don't care about MATCH_YES or MATCH_NO. */
10982 if (gfc_match (" ::") == MATCH_ERROR
)
10983 return MATCH_ERROR
;
10985 /* Match the sequence of procedure names. */
10992 if (first
&& gfc_match_eos () == MATCH_YES
)
10994 gfc_error ("Empty FINAL at %C");
10995 return MATCH_ERROR
;
10998 m
= gfc_match_name (name
);
11001 gfc_error ("Expected module procedure name at %C");
11002 return MATCH_ERROR
;
11004 else if (m
!= MATCH_YES
)
11005 return MATCH_ERROR
;
11007 if (gfc_match_eos () == MATCH_YES
)
11009 if (!last
&& gfc_match_char (',') != MATCH_YES
)
11011 gfc_error ("Expected %<,%> at %C");
11012 return MATCH_ERROR
;
11015 if (gfc_get_symbol (name
, module_ns
, &sym
))
11017 gfc_error ("Unknown procedure name %qs at %C", name
);
11018 return MATCH_ERROR
;
11021 /* Mark the symbol as module procedure. */
11022 if (sym
->attr
.proc
!= PROC_MODULE
11023 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
11024 return MATCH_ERROR
;
11026 /* Check if we already have this symbol in the list, this is an error. */
11027 for (f
= block
->f2k_derived
->finalizers
; f
; f
= f
->next
)
11028 if (f
->proc_sym
== sym
)
11030 gfc_error ("%qs at %C is already defined as FINAL procedure",
11032 return MATCH_ERROR
;
11035 /* Add this symbol to the list of finalizers. */
11036 gcc_assert (block
->f2k_derived
);
11038 f
= XCNEW (gfc_finalizer
);
11040 f
->proc_tree
= NULL
;
11041 f
->where
= gfc_current_locus
;
11042 f
->next
= block
->f2k_derived
->finalizers
;
11043 block
->f2k_derived
->finalizers
= f
;
11053 const ext_attr_t ext_attr_list
[] = {
11054 { "dllimport", EXT_ATTR_DLLIMPORT
, "dllimport" },
11055 { "dllexport", EXT_ATTR_DLLEXPORT
, "dllexport" },
11056 { "cdecl", EXT_ATTR_CDECL
, "cdecl" },
11057 { "stdcall", EXT_ATTR_STDCALL
, "stdcall" },
11058 { "fastcall", EXT_ATTR_FASTCALL
, "fastcall" },
11059 { "no_arg_check", EXT_ATTR_NO_ARG_CHECK
, NULL
},
11060 { NULL
, EXT_ATTR_LAST
, NULL
}
11063 /* Match a !GCC$ ATTRIBUTES statement of the form:
11064 !GCC$ ATTRIBUTES attribute-list :: var-name [, var-name] ...
11065 When we come here, we have already matched the !GCC$ ATTRIBUTES string.
11067 TODO: We should support all GCC attributes using the same syntax for
11068 the attribute list, i.e. the list in C
11069 __attributes(( attribute-list ))
11071 !GCC$ ATTRIBUTES attribute-list ::
11072 Cf. c-parser.c's c_parser_attributes; the data can then directly be
11075 As there is absolutely no risk of confusion, we should never return
11078 gfc_match_gcc_attributes (void)
11080 symbol_attribute attr
;
11081 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
11086 gfc_clear_attr (&attr
);
11091 if (gfc_match_name (name
) != MATCH_YES
)
11092 return MATCH_ERROR
;
11094 for (id
= 0; id
< EXT_ATTR_LAST
; id
++)
11095 if (strcmp (name
, ext_attr_list
[id
].name
) == 0)
11098 if (id
== EXT_ATTR_LAST
)
11100 gfc_error ("Unknown attribute in !GCC$ ATTRIBUTES statement at %C");
11101 return MATCH_ERROR
;
11104 if (!gfc_add_ext_attribute (&attr
, (ext_attr_id_t
)id
, &gfc_current_locus
))
11105 return MATCH_ERROR
;
11107 gfc_gobble_whitespace ();
11108 ch
= gfc_next_ascii_char ();
11111 /* This is the successful exit condition for the loop. */
11112 if (gfc_next_ascii_char () == ':')
11122 if (gfc_match_eos () == MATCH_YES
)
11127 m
= gfc_match_name (name
);
11128 if (m
!= MATCH_YES
)
11131 if (find_special (name
, &sym
, true))
11132 return MATCH_ERROR
;
11134 sym
->attr
.ext_attr
|= attr
.ext_attr
;
11136 if (gfc_match_eos () == MATCH_YES
)
11139 if (gfc_match_char (',') != MATCH_YES
)
11146 gfc_error ("Syntax error in !GCC$ ATTRIBUTES statement at %C");
11147 return MATCH_ERROR
;
11151 /* Match a !GCC$ UNROLL statement of the form:
11154 The parameter n is the number of times we are supposed to unroll.
11156 When we come here, we have already matched the !GCC$ UNROLL string. */
11158 gfc_match_gcc_unroll (void)
11162 if (gfc_match_small_int (&value
) == MATCH_YES
)
11164 if (value
< 0 || value
> USHRT_MAX
)
11166 gfc_error ("%<GCC unroll%> directive requires a"
11167 " non-negative integral constant"
11168 " less than or equal to %u at %C",
11171 return MATCH_ERROR
;
11173 if (gfc_match_eos () == MATCH_YES
)
11175 directive_unroll
= value
== 0 ? 1 : value
;
11180 gfc_error ("Syntax error in !GCC$ UNROLL directive at %C");
11181 return MATCH_ERROR
;