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
1176 && sym
->attr
.if_source
== IFSRC_IFBODY
)
1178 /* Create a partially populated interface symbol to carry the
1179 characteristics of the procedure and the result. */
1180 sym
->tlink
= gfc_new_symbol (name
, sym
->ns
);
1181 gfc_add_type (sym
->tlink
, &(sym
->ts
),
1182 &gfc_current_locus
);
1183 gfc_copy_attr (&sym
->tlink
->attr
, &sym
->attr
, NULL
);
1184 if (sym
->attr
.dimension
)
1185 sym
->tlink
->as
= gfc_copy_array_spec (sym
->as
);
1187 /* Ideally, at this point, a copy would be made of the formal
1188 arguments and their namespace. However, this does not appear
1189 to be necessary, albeit at the expense of not being able to
1190 use gfc_compare_interfaces directly. */
1192 if (sym
->result
&& sym
->result
!= sym
)
1194 sym
->tlink
->result
= sym
->result
;
1197 else if (sym
->result
)
1199 sym
->tlink
->result
= sym
->tlink
;
1202 else if (sym
&& !sym
->gfc_new
1203 && gfc_current_state () != COMP_INTERFACE
)
1205 /* Trap another encompassed procedure with the same name. All
1206 these conditions are necessary to avoid picking up an entry
1207 whose name clashes with that of the encompassing procedure;
1208 this is handled using gsymbols to register unique, globally
1209 accessible names. */
1210 if (sym
->attr
.flavor
!= 0
1211 && sym
->attr
.proc
!= 0
1212 && (sym
->attr
.subroutine
|| sym
->attr
.function
|| sym
->attr
.entry
)
1213 && sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
1214 gfc_error_now ("Procedure %qs at %C is already defined at %L",
1215 name
, &sym
->declared_at
);
1217 if (sym
->attr
.flavor
!= 0
1218 && sym
->attr
.entry
&& sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
1219 gfc_error_now ("Procedure %qs at %C is already defined at %L",
1220 name
, &sym
->declared_at
);
1222 /* Trap a procedure with a name the same as interface in the
1223 encompassing scope. */
1224 if (sym
->attr
.generic
!= 0
1225 && (sym
->attr
.subroutine
|| sym
->attr
.function
)
1226 && !sym
->attr
.mod_proc
)
1227 gfc_error_now ("Name %qs at %C is already defined"
1228 " as a generic interface at %L",
1229 name
, &sym
->declared_at
);
1231 /* Trap declarations of attributes in encompassing scope. The
1232 signature for this is that ts.kind is set. Legitimate
1233 references only set ts.type. */
1234 if (sym
->ts
.kind
!= 0
1235 && !sym
->attr
.implicit_type
1236 && sym
->attr
.proc
== 0
1237 && gfc_current_ns
->parent
!= NULL
1238 && sym
->attr
.access
== 0
1239 && !module_fcn_entry
)
1240 gfc_error_now ("Procedure %qs at %C has an explicit interface "
1241 "and must not have attributes declared at %L",
1242 name
, &sym
->declared_at
);
1245 if (gfc_current_ns
->parent
== NULL
|| *result
== NULL
)
1248 /* Module function entries will already have a symtree in
1249 the current namespace but will need one at module level. */
1250 if (module_fcn_entry
)
1252 /* Present if entry is declared to be a module procedure. */
1253 rc
= gfc_find_sym_tree (name
, gfc_current_ns
->parent
, 0, &st
);
1255 st
= gfc_new_symtree (&gfc_current_ns
->parent
->sym_root
, name
);
1258 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, name
);
1263 /* See if the procedure should be a module procedure. */
1265 if (((sym
->ns
->proc_name
!= NULL
1266 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
1267 && sym
->attr
.proc
!= PROC_MODULE
)
1268 || (module_fcn_entry
&& sym
->attr
.proc
!= PROC_MODULE
))
1269 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
1276 /* Verify that the given symbol representing a parameter is C
1277 interoperable, by checking to see if it was marked as such after
1278 its declaration. If the given symbol is not interoperable, a
1279 warning is reported, thus removing the need to return the status to
1280 the calling function. The standard does not require the user use
1281 one of the iso_c_binding named constants to declare an
1282 interoperable parameter, but we can't be sure if the param is C
1283 interop or not if the user doesn't. For example, integer(4) may be
1284 legal Fortran, but doesn't have meaning in C. It may interop with
1285 a number of the C types, which causes a problem because the
1286 compiler can't know which one. This code is almost certainly not
1287 portable, and the user will get what they deserve if the C type
1288 across platforms isn't always interoperable with integer(4). If
1289 the user had used something like integer(c_int) or integer(c_long),
1290 the compiler could have automatically handled the varying sizes
1291 across platforms. */
1294 gfc_verify_c_interop_param (gfc_symbol
*sym
)
1296 int is_c_interop
= 0;
1299 /* We check implicitly typed variables in symbol.c:gfc_set_default_type().
1300 Don't repeat the checks here. */
1301 if (sym
->attr
.implicit_type
)
1304 /* For subroutines or functions that are passed to a BIND(C) procedure,
1305 they're interoperable if they're BIND(C) and their params are all
1307 if (sym
->attr
.flavor
== FL_PROCEDURE
)
1309 if (sym
->attr
.is_bind_c
== 0)
1311 gfc_error_now ("Procedure %qs at %L must have the BIND(C) "
1312 "attribute to be C interoperable", sym
->name
,
1313 &(sym
->declared_at
));
1318 if (sym
->attr
.is_c_interop
== 1)
1319 /* We've already checked this procedure; don't check it again. */
1322 return verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
1327 /* See if we've stored a reference to a procedure that owns sym. */
1328 if (sym
->ns
!= NULL
&& sym
->ns
->proc_name
!= NULL
)
1330 if (sym
->ns
->proc_name
->attr
.is_bind_c
== 1)
1332 is_c_interop
= (gfc_verify_c_interop(&(sym
->ts
)) ? 1 : 0);
1334 if (is_c_interop
!= 1)
1336 /* Make personalized messages to give better feedback. */
1337 if (sym
->ts
.type
== BT_DERIVED
)
1338 gfc_error ("Variable %qs at %L is a dummy argument to the "
1339 "BIND(C) procedure %qs but is not C interoperable "
1340 "because derived type %qs is not C interoperable",
1341 sym
->name
, &(sym
->declared_at
),
1342 sym
->ns
->proc_name
->name
,
1343 sym
->ts
.u
.derived
->name
);
1344 else if (sym
->ts
.type
== BT_CLASS
)
1345 gfc_error ("Variable %qs at %L is a dummy argument to the "
1346 "BIND(C) procedure %qs but is not C interoperable "
1347 "because it is polymorphic",
1348 sym
->name
, &(sym
->declared_at
),
1349 sym
->ns
->proc_name
->name
);
1350 else if (warn_c_binding_type
)
1351 gfc_warning (OPT_Wc_binding_type
,
1352 "Variable %qs at %L is a dummy argument of the "
1353 "BIND(C) procedure %qs but may not be C "
1355 sym
->name
, &(sym
->declared_at
),
1356 sym
->ns
->proc_name
->name
);
1359 /* Character strings are only C interoperable if they have a
1361 if (sym
->ts
.type
== BT_CHARACTER
)
1363 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
1364 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
1365 || mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
1367 gfc_error ("Character argument %qs at %L "
1368 "must be length 1 because "
1369 "procedure %qs is BIND(C)",
1370 sym
->name
, &sym
->declared_at
,
1371 sym
->ns
->proc_name
->name
);
1376 /* We have to make sure that any param to a bind(c) routine does
1377 not have the allocatable, pointer, or optional attributes,
1378 according to J3/04-007, section 5.1. */
1379 if (sym
->attr
.allocatable
== 1
1380 && !gfc_notify_std (GFC_STD_F2008_TS
, "Variable %qs at %L with "
1381 "ALLOCATABLE attribute in procedure %qs "
1382 "with BIND(C)", sym
->name
,
1383 &(sym
->declared_at
),
1384 sym
->ns
->proc_name
->name
))
1387 if (sym
->attr
.pointer
== 1
1388 && !gfc_notify_std (GFC_STD_F2008_TS
, "Variable %qs at %L with "
1389 "POINTER attribute in procedure %qs "
1390 "with BIND(C)", sym
->name
,
1391 &(sym
->declared_at
),
1392 sym
->ns
->proc_name
->name
))
1395 if ((sym
->attr
.allocatable
|| sym
->attr
.pointer
) && !sym
->as
)
1397 gfc_error ("Scalar variable %qs at %L with POINTER or "
1398 "ALLOCATABLE in procedure %qs with BIND(C) is not yet"
1399 " supported", sym
->name
, &(sym
->declared_at
),
1400 sym
->ns
->proc_name
->name
);
1404 if (sym
->attr
.optional
== 1 && sym
->attr
.value
)
1406 gfc_error ("Variable %qs at %L cannot have both the OPTIONAL "
1407 "and the VALUE attribute because procedure %qs "
1408 "is BIND(C)", sym
->name
, &(sym
->declared_at
),
1409 sym
->ns
->proc_name
->name
);
1412 else if (sym
->attr
.optional
== 1
1413 && !gfc_notify_std (GFC_STD_F2008_TS
, "Variable %qs "
1414 "at %L with OPTIONAL attribute in "
1415 "procedure %qs which is BIND(C)",
1416 sym
->name
, &(sym
->declared_at
),
1417 sym
->ns
->proc_name
->name
))
1420 /* Make sure that if it has the dimension attribute, that it is
1421 either assumed size or explicit shape. Deferred shape is already
1422 covered by the pointer/allocatable attribute. */
1423 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SHAPE
1424 && !gfc_notify_std (GFC_STD_F2008_TS
, "Assumed-shape array %qs "
1425 "at %L as dummy argument to the BIND(C) "
1426 "procedure %qs at %L", sym
->name
,
1427 &(sym
->declared_at
),
1428 sym
->ns
->proc_name
->name
,
1429 &(sym
->ns
->proc_name
->declared_at
)))
1439 /* Function called by variable_decl() that adds a name to the symbol table. */
1442 build_sym (const char *name
, gfc_charlen
*cl
, bool cl_deferred
,
1443 gfc_array_spec
**as
, locus
*var_locus
)
1445 symbol_attribute attr
;
1450 /* Symbols in a submodule are host associated from the parent module or
1451 submodules. Therefore, they can be overridden by declarations in the
1452 submodule scope. Deal with this by attaching the existing symbol to
1453 a new symtree and recycling the old symtree with a new symbol... */
1454 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
1455 if (st
!= NULL
&& gfc_state_stack
->state
== COMP_SUBMODULE
1456 && st
->n
.sym
!= NULL
1457 && st
->n
.sym
->attr
.host_assoc
&& st
->n
.sym
->attr
.used_in_submodule
)
1459 gfc_symtree
*s
= gfc_get_unique_symtree (gfc_current_ns
);
1460 s
->n
.sym
= st
->n
.sym
;
1461 sym
= gfc_new_symbol (name
, gfc_current_ns
);
1466 gfc_set_sym_referenced (sym
);
1468 /* ...Otherwise generate a new symtree and new symbol. */
1469 else if (gfc_get_symbol (name
, NULL
, &sym
))
1472 /* Check if the name has already been defined as a type. The
1473 first letter of the symtree will be in upper case then. Of
1474 course, this is only necessary if the upper case letter is
1475 actually different. */
1477 upper
= TOUPPER(name
[0]);
1478 if (upper
!= name
[0])
1480 char u_name
[GFC_MAX_SYMBOL_LEN
+ 1];
1483 gcc_assert (strlen(name
) <= GFC_MAX_SYMBOL_LEN
);
1484 strcpy (u_name
, name
);
1487 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, u_name
);
1489 /* STRUCTURE types can alias symbol names */
1490 if (st
!= 0 && st
->n
.sym
->attr
.flavor
!= FL_STRUCT
)
1492 gfc_error ("Symbol %qs at %C also declared as a type at %L", name
,
1493 &st
->n
.sym
->declared_at
);
1498 /* Start updating the symbol table. Add basic type attribute if present. */
1499 if (current_ts
.type
!= BT_UNKNOWN
1500 && (sym
->attr
.implicit_type
== 0
1501 || !gfc_compare_types (&sym
->ts
, ¤t_ts
))
1502 && !gfc_add_type (sym
, ¤t_ts
, var_locus
))
1505 if (sym
->ts
.type
== BT_CHARACTER
)
1508 sym
->ts
.deferred
= cl_deferred
;
1511 /* Add dimension attribute if present. */
1512 if (!gfc_set_array_spec (sym
, *as
, var_locus
))
1516 /* Add attribute to symbol. The copy is so that we can reset the
1517 dimension attribute. */
1518 attr
= current_attr
;
1520 attr
.codimension
= 0;
1522 if (!gfc_copy_attr (&sym
->attr
, &attr
, var_locus
))
1525 /* Finish any work that may need to be done for the binding label,
1526 if it's a bind(c). The bind(c) attr is found before the symbol
1527 is made, and before the symbol name (for data decls), so the
1528 current_ts is holding the binding label, or nothing if the
1529 name= attr wasn't given. Therefore, test here if we're dealing
1530 with a bind(c) and make sure the binding label is set correctly. */
1531 if (sym
->attr
.is_bind_c
== 1)
1533 if (!sym
->binding_label
)
1535 /* Set the binding label and verify that if a NAME= was specified
1536 then only one identifier was in the entity-decl-list. */
1537 if (!set_binding_label (&sym
->binding_label
, sym
->name
,
1538 num_idents_on_line
))
1543 /* See if we know we're in a common block, and if it's a bind(c)
1544 common then we need to make sure we're an interoperable type. */
1545 if (sym
->attr
.in_common
== 1)
1547 /* Test the common block object. */
1548 if (sym
->common_block
!= NULL
&& sym
->common_block
->is_bind_c
== 1
1549 && sym
->ts
.is_c_interop
!= 1)
1551 gfc_error_now ("Variable %qs in common block %qs at %C "
1552 "must be declared with a C interoperable "
1553 "kind since common block %qs is BIND(C)",
1554 sym
->name
, sym
->common_block
->name
,
1555 sym
->common_block
->name
);
1560 sym
->attr
.implied_index
= 0;
1562 /* Use the parameter expressions for a parameterized derived type. */
1563 if ((sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
1564 && sym
->ts
.u
.derived
->attr
.pdt_type
&& type_param_spec_list
)
1565 sym
->param_list
= gfc_copy_actual_arglist (type_param_spec_list
);
1567 if (sym
->ts
.type
== BT_CLASS
)
1568 return gfc_build_class_symbol (&sym
->ts
, &sym
->attr
, &sym
->as
);
1574 /* Set character constant to the given length. The constant will be padded or
1575 truncated. If we're inside an array constructor without a typespec, we
1576 additionally check that all elements have the same length; check_len -1
1577 means no checking. */
1580 gfc_set_constant_character_len (gfc_charlen_t len
, gfc_expr
*expr
,
1581 gfc_charlen_t check_len
)
1586 if (expr
->ts
.type
!= BT_CHARACTER
)
1589 if (expr
->expr_type
!= EXPR_CONSTANT
)
1591 gfc_error_now ("CHARACTER length must be a constant at %L", &expr
->where
);
1595 slen
= expr
->value
.character
.length
;
1598 s
= gfc_get_wide_string (len
+ 1);
1599 memcpy (s
, expr
->value
.character
.string
,
1600 MIN (len
, slen
) * sizeof (gfc_char_t
));
1602 gfc_wide_memset (&s
[slen
], ' ', len
- slen
);
1604 if (warn_character_truncation
&& slen
> len
)
1605 gfc_warning_now (OPT_Wcharacter_truncation
,
1606 "CHARACTER expression at %L is being truncated "
1607 "(%ld/%ld)", &expr
->where
,
1608 (long) slen
, (long) len
);
1610 /* Apply the standard by 'hand' otherwise it gets cleared for
1612 if (check_len
!= -1 && slen
!= check_len
1613 && !(gfc_option
.allow_std
& GFC_STD_GNU
))
1614 gfc_error_now ("The CHARACTER elements of the array constructor "
1615 "at %L must have the same length (%ld/%ld)",
1616 &expr
->where
, (long) slen
,
1620 free (expr
->value
.character
.string
);
1621 expr
->value
.character
.string
= s
;
1622 expr
->value
.character
.length
= len
;
1627 /* Function to create and update the enumerator history
1628 using the information passed as arguments.
1629 Pointer "max_enum" is also updated, to point to
1630 enum history node containing largest initializer.
1632 SYM points to the symbol node of enumerator.
1633 INIT points to its enumerator value. */
1636 create_enum_history (gfc_symbol
*sym
, gfc_expr
*init
)
1638 enumerator_history
*new_enum_history
;
1639 gcc_assert (sym
!= NULL
&& init
!= NULL
);
1641 new_enum_history
= XCNEW (enumerator_history
);
1643 new_enum_history
->sym
= sym
;
1644 new_enum_history
->initializer
= init
;
1645 new_enum_history
->next
= NULL
;
1647 if (enum_history
== NULL
)
1649 enum_history
= new_enum_history
;
1650 max_enum
= enum_history
;
1654 new_enum_history
->next
= enum_history
;
1655 enum_history
= new_enum_history
;
1657 if (mpz_cmp (max_enum
->initializer
->value
.integer
,
1658 new_enum_history
->initializer
->value
.integer
) < 0)
1659 max_enum
= new_enum_history
;
1664 /* Function to free enum kind history. */
1667 gfc_free_enum_history (void)
1669 enumerator_history
*current
= enum_history
;
1670 enumerator_history
*next
;
1672 while (current
!= NULL
)
1674 next
= current
->next
;
1679 enum_history
= NULL
;
1683 /* Function called by variable_decl() that adds an initialization
1684 expression to a symbol. */
1687 add_init_expr_to_sym (const char *name
, gfc_expr
**initp
, locus
*var_locus
)
1689 symbol_attribute attr
;
1694 if (find_special (name
, &sym
, false))
1699 /* If this symbol is confirming an implicit parameter type,
1700 then an initialization expression is not allowed. */
1701 if (attr
.flavor
== FL_PARAMETER
1702 && sym
->value
!= NULL
1705 gfc_error ("Initializer not allowed for PARAMETER %qs at %C",
1712 /* An initializer is required for PARAMETER declarations. */
1713 if (attr
.flavor
== FL_PARAMETER
)
1715 gfc_error ("PARAMETER at %L is missing an initializer", var_locus
);
1721 /* If a variable appears in a DATA block, it cannot have an
1725 gfc_error ("Variable %qs at %C with an initializer already "
1726 "appears in a DATA statement", sym
->name
);
1730 /* Check if the assignment can happen. This has to be put off
1731 until later for derived type variables and procedure pointers. */
1732 if (!gfc_bt_struct (sym
->ts
.type
) && !gfc_bt_struct (init
->ts
.type
)
1733 && sym
->ts
.type
!= BT_CLASS
&& init
->ts
.type
!= BT_CLASS
1734 && !sym
->attr
.proc_pointer
1735 && !gfc_check_assign_symbol (sym
, NULL
, init
))
1738 if (sym
->ts
.type
== BT_CHARACTER
&& sym
->ts
.u
.cl
1739 && init
->ts
.type
== BT_CHARACTER
)
1741 /* Update symbol character length according initializer. */
1742 if (!gfc_check_assign_symbol (sym
, NULL
, init
))
1745 if (sym
->ts
.u
.cl
->length
== NULL
)
1748 /* If there are multiple CHARACTER variables declared on the
1749 same line, we don't want them to share the same length. */
1750 sym
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1752 if (sym
->attr
.flavor
== FL_PARAMETER
)
1754 if (init
->expr_type
== EXPR_CONSTANT
)
1756 clen
= init
->value
.character
.length
;
1757 sym
->ts
.u
.cl
->length
1758 = gfc_get_int_expr (gfc_charlen_int_kind
,
1761 else if (init
->expr_type
== EXPR_ARRAY
)
1763 if (init
->ts
.u
.cl
&& init
->ts
.u
.cl
->length
)
1765 const gfc_expr
*length
= init
->ts
.u
.cl
->length
;
1766 if (length
->expr_type
!= EXPR_CONSTANT
)
1768 gfc_error ("Cannot initialize parameter array "
1770 "with variable length elements",
1774 clen
= mpz_get_si (length
->value
.integer
);
1776 else if (init
->value
.constructor
)
1779 c
= gfc_constructor_first (init
->value
.constructor
);
1780 clen
= c
->expr
->value
.character
.length
;
1784 sym
->ts
.u
.cl
->length
1785 = gfc_get_int_expr (gfc_charlen_int_kind
,
1788 else if (init
->ts
.u
.cl
&& init
->ts
.u
.cl
->length
)
1789 sym
->ts
.u
.cl
->length
=
1790 gfc_copy_expr (sym
->value
->ts
.u
.cl
->length
);
1793 /* Update initializer character length according symbol. */
1794 else if (sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1796 if (!gfc_specification_expr (sym
->ts
.u
.cl
->length
))
1799 int k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
,
1801 /* resolve_charlen will complain later on if the length
1802 is too large. Just skeep the initialization in that case. */
1803 if (mpz_cmp (sym
->ts
.u
.cl
->length
->value
.integer
,
1804 gfc_integer_kinds
[k
].huge
) <= 0)
1807 = gfc_mpz_get_hwi (sym
->ts
.u
.cl
->length
->value
.integer
);
1809 if (init
->expr_type
== EXPR_CONSTANT
)
1810 gfc_set_constant_character_len (len
, init
, -1);
1811 else if (init
->expr_type
== EXPR_ARRAY
)
1815 /* Build a new charlen to prevent simplification from
1816 deleting the length before it is resolved. */
1817 init
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1818 init
->ts
.u
.cl
->length
1819 = gfc_copy_expr (sym
->ts
.u
.cl
->length
);
1821 for (c
= gfc_constructor_first (init
->value
.constructor
);
1822 c
; c
= gfc_constructor_next (c
))
1823 gfc_set_constant_character_len (len
, c
->expr
, -1);
1829 /* If sym is implied-shape, set its upper bounds from init. */
1830 if (sym
->attr
.flavor
== FL_PARAMETER
&& sym
->attr
.dimension
1831 && sym
->as
->type
== AS_IMPLIED_SHAPE
)
1835 if (init
->rank
== 0)
1837 gfc_error ("Can't initialize implied-shape array at %L"
1838 " with scalar", &sym
->declared_at
);
1842 /* Shape should be present, we get an initialization expression. */
1843 gcc_assert (init
->shape
);
1845 for (dim
= 0; dim
< sym
->as
->rank
; ++dim
)
1848 gfc_expr
*e
, *lower
;
1850 lower
= sym
->as
->lower
[dim
];
1852 /* If the lower bound is an array element from another
1853 parameterized array, then it is marked with EXPR_VARIABLE and
1854 is an initialization expression. Try to reduce it. */
1855 if (lower
->expr_type
== EXPR_VARIABLE
)
1856 gfc_reduce_init_expr (lower
);
1858 if (lower
->expr_type
== EXPR_CONSTANT
)
1860 /* All dimensions must be without upper bound. */
1861 gcc_assert (!sym
->as
->upper
[dim
]);
1864 e
= gfc_get_constant_expr (BT_INTEGER
, k
, &sym
->declared_at
);
1865 mpz_add (e
->value
.integer
, lower
->value
.integer
,
1867 mpz_sub_ui (e
->value
.integer
, e
->value
.integer
, 1);
1868 sym
->as
->upper
[dim
] = e
;
1872 gfc_error ("Non-constant lower bound in implied-shape"
1873 " declaration at %L", &lower
->where
);
1878 sym
->as
->type
= AS_EXPLICIT
;
1881 /* Need to check if the expression we initialized this
1882 to was one of the iso_c_binding named constants. If so,
1883 and we're a parameter (constant), let it be iso_c.
1885 integer(c_int), parameter :: my_int = c_int
1886 integer(my_int) :: my_int_2
1887 If we mark my_int as iso_c (since we can see it's value
1888 is equal to one of the named constants), then my_int_2
1889 will be considered C interoperable. */
1890 if (sym
->ts
.type
!= BT_CHARACTER
&& !gfc_bt_struct (sym
->ts
.type
))
1892 sym
->ts
.is_iso_c
|= init
->ts
.is_iso_c
;
1893 sym
->ts
.is_c_interop
|= init
->ts
.is_c_interop
;
1894 /* attr bits needed for module files. */
1895 sym
->attr
.is_iso_c
|= init
->ts
.is_iso_c
;
1896 sym
->attr
.is_c_interop
|= init
->ts
.is_c_interop
;
1897 if (init
->ts
.is_iso_c
)
1898 sym
->ts
.f90_type
= init
->ts
.f90_type
;
1901 /* Add initializer. Make sure we keep the ranks sane. */
1902 if (sym
->attr
.dimension
&& init
->rank
== 0)
1907 if (sym
->attr
.flavor
== FL_PARAMETER
1908 && init
->expr_type
== EXPR_CONSTANT
1909 && spec_size (sym
->as
, &size
)
1910 && mpz_cmp_si (size
, 0) > 0)
1912 array
= gfc_get_array_expr (init
->ts
.type
, init
->ts
.kind
,
1914 for (n
= 0; n
< (int)mpz_get_si (size
); n
++)
1915 gfc_constructor_append_expr (&array
->value
.constructor
,
1918 : gfc_copy_expr (init
),
1921 array
->shape
= gfc_get_shape (sym
->as
->rank
);
1922 for (n
= 0; n
< sym
->as
->rank
; n
++)
1923 spec_dimen_size (sym
->as
, n
, &array
->shape
[n
]);
1928 init
->rank
= sym
->as
->rank
;
1932 if (sym
->attr
.save
== SAVE_NONE
)
1933 sym
->attr
.save
= SAVE_IMPLICIT
;
1941 /* Function called by variable_decl() that adds a name to a structure
1945 build_struct (const char *name
, gfc_charlen
*cl
, gfc_expr
**init
,
1946 gfc_array_spec
**as
)
1951 /* F03:C438/C439. If the current symbol is of the same derived type that we're
1952 constructing, it must have the pointer attribute. */
1953 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
1954 && current_ts
.u
.derived
== gfc_current_block ()
1955 && current_attr
.pointer
== 0)
1957 if (current_attr
.allocatable
1958 && !gfc_notify_std(GFC_STD_F2008
, "Component at %C "
1959 "must have the POINTER attribute"))
1963 else if (current_attr
.allocatable
== 0)
1965 gfc_error ("Component at %C must have the POINTER attribute");
1971 if (current_ts
.type
== BT_CLASS
1972 && !(current_attr
.pointer
|| current_attr
.allocatable
))
1974 gfc_error ("Component %qs with CLASS at %C must be allocatable "
1975 "or pointer", name
);
1979 if (gfc_current_block ()->attr
.pointer
&& (*as
)->rank
!= 0)
1981 if ((*as
)->type
!= AS_DEFERRED
&& (*as
)->type
!= AS_EXPLICIT
)
1983 gfc_error ("Array component of structure at %C must have explicit "
1984 "or deferred shape");
1989 /* If we are in a nested union/map definition, gfc_add_component will not
1990 properly find repeated components because:
1991 (i) gfc_add_component does a flat search, where components of unions
1992 and maps are implicity chained so nested components may conflict.
1993 (ii) Unions and maps are not linked as components of their parent
1994 structures until after they are parsed.
1995 For (i) we use gfc_find_component which searches recursively, and for (ii)
1996 we search each block directly from the parse stack until we find the top
1999 s
= gfc_state_stack
;
2000 if (s
->state
== COMP_UNION
|| s
->state
== COMP_MAP
)
2002 while (s
->state
== COMP_UNION
|| gfc_comp_struct (s
->state
))
2004 c
= gfc_find_component (s
->sym
, name
, true, true, NULL
);
2007 gfc_error_now ("Component %qs at %C already declared at %L",
2011 /* Break after we've searched the entire chain. */
2012 if (s
->state
== COMP_DERIVED
|| s
->state
== COMP_STRUCTURE
)
2018 if (!gfc_add_component (gfc_current_block(), name
, &c
))
2022 if (c
->ts
.type
== BT_CHARACTER
)
2025 if (c
->ts
.type
!= BT_CLASS
&& c
->ts
.type
!= BT_DERIVED
2026 && (c
->ts
.kind
== 0 || c
->ts
.type
== BT_CHARACTER
)
2027 && saved_kind_expr
!= NULL
)
2028 c
->kind_expr
= gfc_copy_expr (saved_kind_expr
);
2030 c
->attr
= current_attr
;
2032 c
->initializer
= *init
;
2039 c
->attr
.codimension
= 1;
2041 c
->attr
.dimension
= 1;
2045 gfc_apply_init (&c
->ts
, &c
->attr
, c
->initializer
);
2047 /* Check array components. */
2048 if (!c
->attr
.dimension
)
2051 if (c
->attr
.pointer
)
2053 if (c
->as
->type
!= AS_DEFERRED
)
2055 gfc_error ("Pointer array component of structure at %C must have a "
2060 else if (c
->attr
.allocatable
)
2062 if (c
->as
->type
!= AS_DEFERRED
)
2064 gfc_error ("Allocatable component of structure at %C must have a "
2071 if (c
->as
->type
!= AS_EXPLICIT
)
2073 gfc_error ("Array component of structure at %C must have an "
2080 if (c
->ts
.type
== BT_CLASS
)
2081 return gfc_build_class_symbol (&c
->ts
, &c
->attr
, &c
->as
);
2083 if (c
->attr
.pdt_kind
|| c
->attr
.pdt_len
)
2086 gfc_find_symbol (c
->name
, gfc_current_block ()->f2k_derived
,
2090 gfc_error ("Type parameter %qs at %C has no corresponding entry "
2091 "in the type parameter name list at %L",
2092 c
->name
, &gfc_current_block ()->declared_at
);
2096 sym
->attr
.pdt_kind
= c
->attr
.pdt_kind
;
2097 sym
->attr
.pdt_len
= c
->attr
.pdt_len
;
2099 sym
->value
= gfc_copy_expr (c
->initializer
);
2100 sym
->attr
.flavor
= FL_VARIABLE
;
2103 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
2104 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_template
2105 && decl_type_param_list
)
2106 c
->param_list
= gfc_copy_actual_arglist (decl_type_param_list
);
2112 /* Match a 'NULL()', and possibly take care of some side effects. */
2115 gfc_match_null (gfc_expr
**result
)
2118 match m
, m2
= MATCH_NO
;
2120 if ((m
= gfc_match (" null ( )")) == MATCH_ERROR
)
2126 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2128 if ((m2
= gfc_match (" null (")) != MATCH_YES
)
2131 old_loc
= gfc_current_locus
;
2132 if ((m2
= gfc_match (" %n ) ", name
)) == MATCH_ERROR
)
2135 && ((m2
= gfc_match (" mold = %n )", name
)) == MATCH_ERROR
))
2139 gfc_current_locus
= old_loc
;
2144 /* The NULL symbol now has to be/become an intrinsic function. */
2145 if (gfc_get_symbol ("null", NULL
, &sym
))
2147 gfc_error ("NULL() initialization at %C is ambiguous");
2151 gfc_intrinsic_symbol (sym
);
2153 if (sym
->attr
.proc
!= PROC_INTRINSIC
2154 && !(sym
->attr
.use_assoc
&& sym
->attr
.intrinsic
)
2155 && (!gfc_add_procedure(&sym
->attr
, PROC_INTRINSIC
, sym
->name
, NULL
)
2156 || !gfc_add_function (&sym
->attr
, sym
->name
, NULL
)))
2159 *result
= gfc_get_null_expr (&gfc_current_locus
);
2161 /* Invalid per F2008, C512. */
2162 if (m2
== MATCH_YES
)
2164 gfc_error ("NULL() initialization at %C may not have MOLD");
2172 /* Match the initialization expr for a data pointer or procedure pointer. */
2175 match_pointer_init (gfc_expr
**init
, int procptr
)
2179 if (gfc_pure (NULL
) && !gfc_comp_struct (gfc_state_stack
->state
))
2181 gfc_error ("Initialization of pointer at %C is not allowed in "
2182 "a PURE procedure");
2185 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
2187 /* Match NULL() initialization. */
2188 m
= gfc_match_null (init
);
2192 /* Match non-NULL initialization. */
2193 gfc_matching_ptr_assignment
= !procptr
;
2194 gfc_matching_procptr_assignment
= procptr
;
2195 m
= gfc_match_rvalue (init
);
2196 gfc_matching_ptr_assignment
= 0;
2197 gfc_matching_procptr_assignment
= 0;
2198 if (m
== MATCH_ERROR
)
2200 else if (m
== MATCH_NO
)
2202 gfc_error ("Error in pointer initialization at %C");
2206 if (!procptr
&& !gfc_resolve_expr (*init
))
2209 if (!gfc_notify_std (GFC_STD_F2008
, "non-NULL pointer "
2210 "initialization at %C"))
2218 check_function_name (char *name
)
2220 /* In functions that have a RESULT variable defined, the function name always
2221 refers to function calls. Therefore, the name is not allowed to appear in
2222 specification statements. When checking this, be careful about
2223 'hidden' procedure pointer results ('ppr@'). */
2225 if (gfc_current_state () == COMP_FUNCTION
)
2227 gfc_symbol
*block
= gfc_current_block ();
2228 if (block
&& block
->result
&& block
->result
!= block
2229 && strcmp (block
->result
->name
, "ppr@") != 0
2230 && strcmp (block
->name
, name
) == 0)
2232 gfc_error ("Function name %qs not allowed at %C", name
);
2241 /* Match a variable name with an optional initializer. When this
2242 subroutine is called, a variable is expected to be parsed next.
2243 Depending on what is happening at the moment, updates either the
2244 symbol table or the current interface. */
2247 variable_decl (int elem
)
2249 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2250 static unsigned int fill_id
= 0;
2251 gfc_expr
*initializer
, *char_len
;
2253 gfc_array_spec
*cp_as
; /* Extra copy for Cray Pointees. */
2265 /* When we get here, we've just matched a list of attributes and
2266 maybe a type and a double colon. The next thing we expect to see
2267 is the name of the symbol. */
2269 /* If we are parsing a structure with legacy support, we allow the symbol
2270 name to be '%FILL' which gives it an anonymous (inaccessible) name. */
2272 gfc_gobble_whitespace ();
2273 if (gfc_peek_ascii_char () == '%')
2275 gfc_next_ascii_char ();
2276 m
= gfc_match ("fill");
2281 m
= gfc_match_name (name
);
2289 if (gfc_current_state () != COMP_STRUCTURE
)
2291 if (flag_dec_structure
)
2292 gfc_error ("%qs not allowed outside STRUCTURE at %C", "%FILL");
2294 gfc_error ("%qs at %C is a DEC extension, enable with "
2295 "%<-fdec-structure%>", "%FILL");
2301 gfc_error ("%qs entity cannot have attributes at %C", "%FILL");
2305 /* %FILL components are given invalid fortran names. */
2306 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "%%FILL%u", fill_id
++);
2310 var_locus
= gfc_current_locus
;
2312 /* Now we could see the optional array spec. or character length. */
2313 m
= gfc_match_array_spec (&as
, true, true);
2314 if (m
== MATCH_ERROR
)
2318 as
= gfc_copy_array_spec (current_as
);
2320 && !merge_array_spec (current_as
, as
, true))
2326 if (flag_cray_pointer
)
2327 cp_as
= gfc_copy_array_spec (as
);
2329 /* At this point, we know for sure if the symbol is PARAMETER and can thus
2330 determine (and check) whether it can be implied-shape. If it
2331 was parsed as assumed-size, change it because PARAMETERs can not
2334 An explicit-shape-array cannot appear under several conditions.
2335 That check is done here as well. */
2338 if (as
->type
== AS_IMPLIED_SHAPE
&& current_attr
.flavor
!= FL_PARAMETER
)
2341 gfc_error ("Non-PARAMETER symbol %qs at %L can't be implied-shape",
2346 if (as
->type
== AS_ASSUMED_SIZE
&& as
->rank
== 1
2347 && current_attr
.flavor
== FL_PARAMETER
)
2348 as
->type
= AS_IMPLIED_SHAPE
;
2350 if (as
->type
== AS_IMPLIED_SHAPE
2351 && !gfc_notify_std (GFC_STD_F2008
, "Implied-shape array at %L",
2358 /* F2018:C830 (R816) An explicit-shape-spec whose bounds are not
2359 constant expressions shall appear only in a subprogram, derived
2360 type definition, BLOCK construct, or interface body. */
2361 if (as
->type
== AS_EXPLICIT
2362 && gfc_current_state () != COMP_BLOCK
2363 && gfc_current_state () != COMP_DERIVED
2364 && gfc_current_state () != COMP_FUNCTION
2365 && gfc_current_state () != COMP_INTERFACE
2366 && gfc_current_state () != COMP_SUBROUTINE
)
2369 bool not_constant
= false;
2371 for (int i
= 0; i
< as
->rank
; i
++)
2373 e
= gfc_copy_expr (as
->lower
[i
]);
2374 gfc_resolve_expr (e
);
2375 gfc_simplify_expr (e
, 0);
2376 if (e
&& (e
->expr_type
!= EXPR_CONSTANT
))
2378 not_constant
= true;
2383 e
= gfc_copy_expr (as
->upper
[i
]);
2384 gfc_resolve_expr (e
);
2385 gfc_simplify_expr (e
, 0);
2386 if (e
&& (e
->expr_type
!= EXPR_CONSTANT
))
2388 not_constant
= true;
2396 gfc_error ("Explicit shaped array with nonconstant bounds at %C");
2405 cl_deferred
= false;
2407 if (current_ts
.type
== BT_CHARACTER
)
2409 switch (match_char_length (&char_len
, &cl_deferred
, false))
2412 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2414 cl
->length
= char_len
;
2417 /* Non-constant lengths need to be copied after the first
2418 element. Also copy assumed lengths. */
2421 && (current_ts
.u
.cl
->length
== NULL
2422 || current_ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
2424 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2425 cl
->length
= gfc_copy_expr (current_ts
.u
.cl
->length
);
2428 cl
= current_ts
.u
.cl
;
2430 cl_deferred
= current_ts
.deferred
;
2439 /* The dummy arguments and result of the abreviated form of MODULE
2440 PROCEDUREs, used in SUBMODULES should not be redefined. */
2441 if (gfc_current_ns
->proc_name
2442 && gfc_current_ns
->proc_name
->abr_modproc_decl
)
2444 gfc_find_symbol (name
, gfc_current_ns
, 1, &sym
);
2445 if (sym
!= NULL
&& (sym
->attr
.dummy
|| sym
->attr
.result
))
2448 gfc_error ("%qs at %C is a redefinition of the declaration "
2449 "in the corresponding interface for MODULE "
2450 "PROCEDURE %qs", sym
->name
,
2451 gfc_current_ns
->proc_name
->name
);
2456 /* %FILL components may not have initializers. */
2457 if (strncmp (name
, "%FILL", 5) == 0 && gfc_match_eos () != MATCH_YES
)
2459 gfc_error ("%qs entity cannot have an initializer at %C", "%FILL");
2464 /* If this symbol has already shown up in a Cray Pointer declaration,
2465 and this is not a component declaration,
2466 then we want to set the type & bail out. */
2467 if (flag_cray_pointer
&& !gfc_comp_struct (gfc_current_state ()))
2469 gfc_find_symbol (name
, gfc_current_ns
, 1, &sym
);
2470 if (sym
!= NULL
&& sym
->attr
.cray_pointee
)
2472 sym
->ts
.type
= current_ts
.type
;
2473 sym
->ts
.kind
= current_ts
.kind
;
2475 sym
->ts
.u
.derived
= current_ts
.u
.derived
;
2476 sym
->ts
.is_c_interop
= current_ts
.is_c_interop
;
2477 sym
->ts
.is_iso_c
= current_ts
.is_iso_c
;
2480 /* Check to see if we have an array specification. */
2483 if (sym
->as
!= NULL
)
2485 gfc_error ("Duplicate array spec for Cray pointee at %C");
2486 gfc_free_array_spec (cp_as
);
2492 if (!gfc_set_array_spec (sym
, cp_as
, &var_locus
))
2493 gfc_internal_error ("Couldn't set pointee array spec.");
2495 /* Fix the array spec. */
2496 m
= gfc_mod_pointee_as (sym
->as
);
2497 if (m
== MATCH_ERROR
)
2505 gfc_free_array_spec (cp_as
);
2509 /* Procedure pointer as function result. */
2510 if (gfc_current_state () == COMP_FUNCTION
2511 && strcmp ("ppr@", gfc_current_block ()->name
) == 0
2512 && strcmp (name
, gfc_current_block ()->ns
->proc_name
->name
) == 0)
2513 strcpy (name
, "ppr@");
2515 if (gfc_current_state () == COMP_FUNCTION
2516 && strcmp (name
, gfc_current_block ()->name
) == 0
2517 && gfc_current_block ()->result
2518 && strcmp ("ppr@", gfc_current_block ()->result
->name
) == 0)
2519 strcpy (name
, "ppr@");
2521 /* OK, we've successfully matched the declaration. Now put the
2522 symbol in the current namespace, because it might be used in the
2523 optional initialization expression for this symbol, e.g. this is
2526 integer, parameter :: i = huge(i)
2528 This is only true for parameters or variables of a basic type.
2529 For components of derived types, it is not true, so we don't
2530 create a symbol for those yet. If we fail to create the symbol,
2532 if (!gfc_comp_struct (gfc_current_state ())
2533 && !build_sym (name
, cl
, cl_deferred
, &as
, &var_locus
))
2539 if (!check_function_name (name
))
2545 /* We allow old-style initializations of the form
2546 integer i /2/, j(4) /3*3, 1/
2547 (if no colon has been seen). These are different from data
2548 statements in that initializers are only allowed to apply to the
2549 variable immediately preceding, i.e.
2551 is not allowed. Therefore we have to do some work manually, that
2552 could otherwise be left to the matchers for DATA statements. */
2554 if (!colon_seen
&& gfc_match (" /") == MATCH_YES
)
2556 if (!gfc_notify_std (GFC_STD_GNU
, "Old-style "
2557 "initialization at %C"))
2560 /* Allow old style initializations for components of STRUCTUREs and MAPs
2561 but not components of derived types. */
2562 else if (gfc_current_state () == COMP_DERIVED
)
2564 gfc_error ("Invalid old style initialization for derived type "
2570 /* For structure components, read the initializer as a special
2571 expression and let the rest of this function apply the initializer
2573 else if (gfc_comp_struct (gfc_current_state ()))
2575 m
= match_clist_expr (&initializer
, ¤t_ts
, as
);
2577 gfc_error ("Syntax error in old style initialization of %s at %C",
2583 /* Otherwise we treat the old style initialization just like a
2584 DATA declaration for the current variable. */
2586 return match_old_style_init (name
);
2589 /* The double colon must be present in order to have initializers.
2590 Otherwise the statement is ambiguous with an assignment statement. */
2593 if (gfc_match (" =>") == MATCH_YES
)
2595 if (!current_attr
.pointer
)
2597 gfc_error ("Initialization at %C isn't for a pointer variable");
2602 m
= match_pointer_init (&initializer
, 0);
2606 else if (gfc_match_char ('=') == MATCH_YES
)
2608 if (current_attr
.pointer
)
2610 gfc_error ("Pointer initialization at %C requires %<=>%>, "
2616 m
= gfc_match_init_expr (&initializer
);
2619 gfc_error ("Expected an initialization expression at %C");
2623 if (current_attr
.flavor
!= FL_PARAMETER
&& gfc_pure (NULL
)
2624 && !gfc_comp_struct (gfc_state_stack
->state
))
2626 gfc_error ("Initialization of variable at %C is not allowed in "
2627 "a PURE procedure");
2631 if (current_attr
.flavor
!= FL_PARAMETER
2632 && !gfc_comp_struct (gfc_state_stack
->state
))
2633 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
2640 if (initializer
!= NULL
&& current_attr
.allocatable
2641 && gfc_comp_struct (gfc_current_state ()))
2643 gfc_error ("Initialization of allocatable component at %C is not "
2649 if (gfc_current_state () == COMP_DERIVED
2650 && gfc_current_block ()->attr
.pdt_template
)
2653 gfc_find_symbol (name
, gfc_current_block ()->f2k_derived
,
2655 if (!param
&& (current_attr
.pdt_kind
|| current_attr
.pdt_len
))
2657 gfc_error ("The component with KIND or LEN attribute at %C does not "
2658 "not appear in the type parameter list at %L",
2659 &gfc_current_block ()->declared_at
);
2663 else if (param
&& !(current_attr
.pdt_kind
|| current_attr
.pdt_len
))
2665 gfc_error ("The component at %C that appears in the type parameter "
2666 "list at %L has neither the KIND nor LEN attribute",
2667 &gfc_current_block ()->declared_at
);
2671 else if (as
&& (current_attr
.pdt_kind
|| current_attr
.pdt_len
))
2673 gfc_error ("The component at %C which is a type parameter must be "
2678 else if (param
&& initializer
)
2679 param
->value
= gfc_copy_expr (initializer
);
2682 /* Add the initializer. Note that it is fine if initializer is
2683 NULL here, because we sometimes also need to check if a
2684 declaration *must* have an initialization expression. */
2685 if (!gfc_comp_struct (gfc_current_state ()))
2686 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
2689 if (current_ts
.type
== BT_DERIVED
2690 && !current_attr
.pointer
&& !initializer
)
2691 initializer
= gfc_default_initializer (¤t_ts
);
2692 t
= build_struct (name
, cl
, &initializer
, &as
);
2694 /* If we match a nested structure definition we expect to see the
2695 * body even if the variable declarations blow up, so we need to keep
2696 * the structure declaration around. */
2697 if (gfc_new_block
&& gfc_new_block
->attr
.flavor
== FL_STRUCT
)
2698 gfc_commit_symbol (gfc_new_block
);
2701 m
= (t
) ? MATCH_YES
: MATCH_ERROR
;
2704 /* Free stuff up and return. */
2705 gfc_free_expr (initializer
);
2706 gfc_free_array_spec (as
);
2712 /* Match an extended-f77 "TYPESPEC*bytesize"-style kind specification.
2713 This assumes that the byte size is equal to the kind number for
2714 non-COMPLEX types, and equal to twice the kind number for COMPLEX. */
2717 gfc_match_old_kind_spec (gfc_typespec
*ts
)
2722 if (gfc_match_char ('*') != MATCH_YES
)
2725 m
= gfc_match_small_literal_int (&ts
->kind
, NULL
);
2729 original_kind
= ts
->kind
;
2731 /* Massage the kind numbers for complex types. */
2732 if (ts
->type
== BT_COMPLEX
)
2736 gfc_error ("Old-style type declaration %s*%d not supported at %C",
2737 gfc_basic_typename (ts
->type
), original_kind
);
2744 if (ts
->type
== BT_INTEGER
&& ts
->kind
== 4 && flag_integer4_kind
== 8)
2747 if (ts
->type
== BT_REAL
|| ts
->type
== BT_COMPLEX
)
2751 if (flag_real4_kind
== 8)
2753 if (flag_real4_kind
== 10)
2755 if (flag_real4_kind
== 16)
2761 if (flag_real8_kind
== 4)
2763 if (flag_real8_kind
== 10)
2765 if (flag_real8_kind
== 16)
2770 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
2772 gfc_error ("Old-style type declaration %s*%d not supported at %C",
2773 gfc_basic_typename (ts
->type
), original_kind
);
2777 if (!gfc_notify_std (GFC_STD_GNU
,
2778 "Nonstandard type declaration %s*%d at %C",
2779 gfc_basic_typename(ts
->type
), original_kind
))
2786 /* Match a kind specification. Since kinds are generally optional, we
2787 usually return MATCH_NO if something goes wrong. If a "kind="
2788 string is found, then we know we have an error. */
2791 gfc_match_kind_spec (gfc_typespec
*ts
, bool kind_expr_only
)
2801 saved_kind_expr
= NULL
;
2803 where
= loc
= gfc_current_locus
;
2808 if (gfc_match_char ('(') == MATCH_NO
)
2811 /* Also gobbles optional text. */
2812 if (gfc_match (" kind = ") == MATCH_YES
)
2815 loc
= gfc_current_locus
;
2819 n
= gfc_match_init_expr (&e
);
2821 if (gfc_derived_parameter_expr (e
))
2824 saved_kind_expr
= gfc_copy_expr (e
);
2825 goto close_brackets
;
2830 if (gfc_matching_function
)
2832 /* The function kind expression might include use associated or
2833 imported parameters and try again after the specification
2835 if (gfc_match_char (')') != MATCH_YES
)
2837 gfc_error ("Missing right parenthesis at %C");
2843 gfc_undo_symbols ();
2848 /* ....or else, the match is real. */
2850 gfc_error ("Expected initialization expression at %C");
2858 gfc_error ("Expected scalar initialization expression at %C");
2863 if (gfc_extract_int (e
, &ts
->kind
, 1))
2869 /* Before throwing away the expression, let's see if we had a
2870 C interoperable kind (and store the fact). */
2871 if (e
->ts
.is_c_interop
== 1)
2873 /* Mark this as C interoperable if being declared with one
2874 of the named constants from iso_c_binding. */
2875 ts
->is_c_interop
= e
->ts
.is_iso_c
;
2876 ts
->f90_type
= e
->ts
.f90_type
;
2878 ts
->interop_kind
= e
->symtree
->n
.sym
;
2884 /* Ignore errors to this point, if we've gotten here. This means
2885 we ignore the m=MATCH_ERROR from above. */
2886 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
2888 gfc_error ("Kind %d not supported for type %s at %C", ts
->kind
,
2889 gfc_basic_typename (ts
->type
));
2890 gfc_current_locus
= where
;
2894 /* Warn if, e.g., c_int is used for a REAL variable, but not
2895 if, e.g., c_double is used for COMPLEX as the standard
2896 explicitly says that the kind type parameter for complex and real
2897 variable is the same, i.e. c_float == c_float_complex. */
2898 if (ts
->f90_type
!= BT_UNKNOWN
&& ts
->f90_type
!= ts
->type
2899 && !((ts
->f90_type
== BT_REAL
&& ts
->type
== BT_COMPLEX
)
2900 || (ts
->f90_type
== BT_COMPLEX
&& ts
->type
== BT_REAL
)))
2901 gfc_warning_now (0, "C kind type parameter is for type %s but type at %L "
2902 "is %s", gfc_basic_typename (ts
->f90_type
), &where
,
2903 gfc_basic_typename (ts
->type
));
2907 gfc_gobble_whitespace ();
2908 if ((c
= gfc_next_ascii_char ()) != ')'
2909 && (ts
->type
!= BT_CHARACTER
|| c
!= ','))
2911 if (ts
->type
== BT_CHARACTER
)
2912 gfc_error ("Missing right parenthesis or comma at %C");
2914 gfc_error ("Missing right parenthesis at %C");
2918 /* All tests passed. */
2921 if(m
== MATCH_ERROR
)
2922 gfc_current_locus
= where
;
2924 if (ts
->type
== BT_INTEGER
&& ts
->kind
== 4 && flag_integer4_kind
== 8)
2927 if (ts
->type
== BT_REAL
|| ts
->type
== BT_COMPLEX
)
2931 if (flag_real4_kind
== 8)
2933 if (flag_real4_kind
== 10)
2935 if (flag_real4_kind
== 16)
2941 if (flag_real8_kind
== 4)
2943 if (flag_real8_kind
== 10)
2945 if (flag_real8_kind
== 16)
2950 /* Return what we know from the test(s). */
2955 gfc_current_locus
= where
;
2961 match_char_kind (int * kind
, int * is_iso_c
)
2970 where
= gfc_current_locus
;
2972 n
= gfc_match_init_expr (&e
);
2974 if (n
!= MATCH_YES
&& gfc_matching_function
)
2976 /* The expression might include use-associated or imported
2977 parameters and try again after the specification
2980 gfc_undo_symbols ();
2985 gfc_error ("Expected initialization expression at %C");
2991 gfc_error ("Expected scalar initialization expression at %C");
2996 if (gfc_derived_parameter_expr (e
))
2998 saved_kind_expr
= e
;
3003 fail
= gfc_extract_int (e
, kind
, 1);
3004 *is_iso_c
= e
->ts
.is_iso_c
;
3013 /* Ignore errors to this point, if we've gotten here. This means
3014 we ignore the m=MATCH_ERROR from above. */
3015 if (gfc_validate_kind (BT_CHARACTER
, *kind
, true) < 0)
3017 gfc_error ("Kind %d is not supported for CHARACTER at %C", *kind
);
3021 /* All tests passed. */
3024 if (m
== MATCH_ERROR
)
3025 gfc_current_locus
= where
;
3027 /* Return what we know from the test(s). */
3032 gfc_current_locus
= where
;
3037 /* Match the various kind/length specifications in a CHARACTER
3038 declaration. We don't return MATCH_NO. */
3041 gfc_match_char_spec (gfc_typespec
*ts
)
3043 int kind
, seen_length
, is_iso_c
;
3055 /* Try the old-style specification first. */
3056 old_char_selector
= 0;
3058 m
= match_char_length (&len
, &deferred
, true);
3062 old_char_selector
= 1;
3067 m
= gfc_match_char ('(');
3070 m
= MATCH_YES
; /* Character without length is a single char. */
3074 /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ). */
3075 if (gfc_match (" kind =") == MATCH_YES
)
3077 m
= match_char_kind (&kind
, &is_iso_c
);
3079 if (m
== MATCH_ERROR
)
3084 if (gfc_match (" , len =") == MATCH_NO
)
3087 m
= char_len_param_value (&len
, &deferred
);
3090 if (m
== MATCH_ERROR
)
3097 /* Try to match "LEN = <len-param>" or "LEN = <len-param>, KIND = <int>". */
3098 if (gfc_match (" len =") == MATCH_YES
)
3100 m
= char_len_param_value (&len
, &deferred
);
3103 if (m
== MATCH_ERROR
)
3107 if (gfc_match_char (')') == MATCH_YES
)
3110 if (gfc_match (" , kind =") != MATCH_YES
)
3113 if (match_char_kind (&kind
, &is_iso_c
) == MATCH_ERROR
)
3119 /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ). */
3120 m
= char_len_param_value (&len
, &deferred
);
3123 if (m
== MATCH_ERROR
)
3127 m
= gfc_match_char (')');
3131 if (gfc_match_char (',') != MATCH_YES
)
3134 gfc_match (" kind ="); /* Gobble optional text. */
3136 m
= match_char_kind (&kind
, &is_iso_c
);
3137 if (m
== MATCH_ERROR
)
3143 /* Require a right-paren at this point. */
3144 m
= gfc_match_char (')');
3149 gfc_error ("Syntax error in CHARACTER declaration at %C");
3151 gfc_free_expr (len
);
3155 /* Deal with character functions after USE and IMPORT statements. */
3156 if (gfc_matching_function
)
3158 gfc_free_expr (len
);
3159 gfc_undo_symbols ();
3165 gfc_free_expr (len
);
3169 /* Do some final massaging of the length values. */
3170 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
3172 if (seen_length
== 0)
3173 cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
, 1);
3176 /* If gfortran ends up here, then the len may be reducible to a
3177 constant. Try to do that here. If it does not reduce, simply
3178 assign len to the charlen. */
3179 if (len
&& len
->expr_type
!= EXPR_CONSTANT
)
3182 e
= gfc_copy_expr (len
);
3183 gfc_reduce_init_expr (e
);
3184 if (e
->expr_type
== EXPR_CONSTANT
)
3185 gfc_replace_expr (len
, e
);
3195 ts
->kind
= kind
== 0 ? gfc_default_character_kind
: kind
;
3196 ts
->deferred
= deferred
;
3198 /* We have to know if it was a C interoperable kind so we can
3199 do accurate type checking of bind(c) procs, etc. */
3201 /* Mark this as C interoperable if being declared with one
3202 of the named constants from iso_c_binding. */
3203 ts
->is_c_interop
= is_iso_c
;
3204 else if (len
!= NULL
)
3205 /* Here, we might have parsed something such as: character(c_char)
3206 In this case, the parsing code above grabs the c_char when
3207 looking for the length (line 1690, roughly). it's the last
3208 testcase for parsing the kind params of a character variable.
3209 However, it's not actually the length. this seems like it
3211 To see if the user used a C interop kind, test the expr
3212 of the so called length, and see if it's C interoperable. */
3213 ts
->is_c_interop
= len
->ts
.is_iso_c
;
3219 /* Matches a RECORD declaration. */
3222 match_record_decl (char *name
)
3225 old_loc
= gfc_current_locus
;
3228 m
= gfc_match (" record /");
3231 if (!flag_dec_structure
)
3233 gfc_current_locus
= old_loc
;
3234 gfc_error ("RECORD at %C is an extension, enable it with "
3238 m
= gfc_match (" %n/", name
);
3243 gfc_current_locus
= old_loc
;
3244 if (flag_dec_structure
3245 && (gfc_match (" record% ") == MATCH_YES
3246 || gfc_match (" record%t") == MATCH_YES
))
3247 gfc_error ("Structure name expected after RECORD at %C");
3255 /* This function uses the gfc_actual_arglist 'type_param_spec_list' as a source
3256 of expressions to substitute into the possibly parameterized expression
3257 'e'. Using a list is inefficient but should not be too bad since the
3258 number of type parameters is not likely to be large. */
3260 insert_parameter_exprs (gfc_expr
* e
, gfc_symbol
* sym ATTRIBUTE_UNUSED
,
3263 gfc_actual_arglist
*param
;
3266 if (e
->expr_type
!= EXPR_VARIABLE
)
3269 gcc_assert (e
->symtree
);
3270 if (e
->symtree
->n
.sym
->attr
.pdt_kind
3271 || (*f
!= 0 && e
->symtree
->n
.sym
->attr
.pdt_len
))
3273 for (param
= type_param_spec_list
; param
; param
= param
->next
)
3274 if (strcmp (e
->symtree
->n
.sym
->name
, param
->name
) == 0)
3279 copy
= gfc_copy_expr (param
->expr
);
3290 gfc_insert_kind_parameter_exprs (gfc_expr
*e
)
3292 return gfc_traverse_expr (e
, NULL
, &insert_parameter_exprs
, 0);
3297 gfc_insert_parameter_exprs (gfc_expr
*e
, gfc_actual_arglist
*param_list
)
3299 gfc_actual_arglist
*old_param_spec_list
= type_param_spec_list
;
3300 type_param_spec_list
= param_list
;
3301 return gfc_traverse_expr (e
, NULL
, &insert_parameter_exprs
, 1);
3302 type_param_spec_list
= NULL
;
3303 type_param_spec_list
= old_param_spec_list
;
3306 /* Determines the instance of a parameterized derived type to be used by
3307 matching determining the values of the kind parameters and using them
3308 in the name of the instance. If the instance exists, it is used, otherwise
3309 a new derived type is created. */
3311 gfc_get_pdt_instance (gfc_actual_arglist
*param_list
, gfc_symbol
**sym
,
3312 gfc_actual_arglist
**ext_param_list
)
3314 /* The PDT template symbol. */
3315 gfc_symbol
*pdt
= *sym
;
3316 /* The symbol for the parameter in the template f2k_namespace. */
3318 /* The hoped for instance of the PDT. */
3319 gfc_symbol
*instance
;
3320 /* The list of parameters appearing in the PDT declaration. */
3321 gfc_formal_arglist
*type_param_name_list
;
3322 /* Used to store the parameter specification list during recursive calls. */
3323 gfc_actual_arglist
*old_param_spec_list
;
3324 /* Pointers to the parameter specification being used. */
3325 gfc_actual_arglist
*actual_param
;
3326 gfc_actual_arglist
*tail
= NULL
;
3327 /* Used to build up the name of the PDT instance. The prefix uses 4
3328 characters and each KIND parameter 2 more. Allow 8 of the latter. */
3329 char name
[GFC_MAX_SYMBOL_LEN
+ 21];
3331 bool name_seen
= (param_list
== NULL
);
3332 bool assumed_seen
= false;
3333 bool deferred_seen
= false;
3334 bool spec_error
= false;
3336 gfc_expr
*kind_expr
;
3337 gfc_component
*c1
, *c2
;
3340 type_param_spec_list
= NULL
;
3342 type_param_name_list
= pdt
->formal
;
3343 actual_param
= param_list
;
3344 sprintf (name
, "Pdt%s", pdt
->name
);
3346 /* Run through the parameter name list and pick up the actual
3347 parameter values or use the default values in the PDT declaration. */
3348 for (; type_param_name_list
;
3349 type_param_name_list
= type_param_name_list
->next
)
3351 if (actual_param
&& actual_param
->spec_type
!= SPEC_EXPLICIT
)
3353 if (actual_param
->spec_type
== SPEC_ASSUMED
)
3354 spec_error
= deferred_seen
;
3356 spec_error
= assumed_seen
;
3360 gfc_error ("The type parameter spec list at %C cannot contain "
3361 "both ASSUMED and DEFERRED parameters");
3366 if (actual_param
&& actual_param
->name
)
3368 param
= type_param_name_list
->sym
;
3370 if (!param
|| !param
->name
)
3373 c1
= gfc_find_component (pdt
, param
->name
, false, true, NULL
);
3374 /* An error should already have been thrown in resolve.c
3375 (resolve_fl_derived0). */
3376 if (!pdt
->attr
.use_assoc
&& !c1
)
3382 if (!actual_param
&& !(c1
&& c1
->initializer
))
3384 gfc_error ("The type parameter spec list at %C does not contain "
3385 "enough parameter expressions");
3388 else if (!actual_param
&& c1
&& c1
->initializer
)
3389 kind_expr
= gfc_copy_expr (c1
->initializer
);
3390 else if (actual_param
&& actual_param
->spec_type
== SPEC_EXPLICIT
)
3391 kind_expr
= gfc_copy_expr (actual_param
->expr
);
3395 actual_param
= param_list
;
3396 for (;actual_param
; actual_param
= actual_param
->next
)
3397 if (actual_param
->name
3398 && strcmp (actual_param
->name
, param
->name
) == 0)
3400 if (actual_param
&& actual_param
->spec_type
== SPEC_EXPLICIT
)
3401 kind_expr
= gfc_copy_expr (actual_param
->expr
);
3404 if (c1
->initializer
)
3405 kind_expr
= gfc_copy_expr (c1
->initializer
);
3406 else if (!(actual_param
&& param
->attr
.pdt_len
))
3408 gfc_error ("The derived parameter %qs at %C does not "
3409 "have a default value", param
->name
);
3415 /* Store the current parameter expressions in a temporary actual
3416 arglist 'list' so that they can be substituted in the corresponding
3417 expressions in the PDT instance. */
3418 if (type_param_spec_list
== NULL
)
3420 type_param_spec_list
= gfc_get_actual_arglist ();
3421 tail
= type_param_spec_list
;
3425 tail
->next
= gfc_get_actual_arglist ();
3428 tail
->name
= param
->name
;
3432 /* Try simplification even for LEN expressions. */
3433 gfc_resolve_expr (kind_expr
);
3434 gfc_simplify_expr (kind_expr
, 1);
3435 /* Variable expressions seem to default to BT_PROCEDURE.
3436 TODO find out why this is and fix it. */
3437 if (kind_expr
->ts
.type
!= BT_INTEGER
3438 && kind_expr
->ts
.type
!= BT_PROCEDURE
)
3440 gfc_error ("The parameter expression at %C must be of "
3441 "INTEGER type and not %s type",
3442 gfc_basic_typename (kind_expr
->ts
.type
));
3446 tail
->expr
= gfc_copy_expr (kind_expr
);
3450 tail
->spec_type
= actual_param
->spec_type
;
3452 if (!param
->attr
.pdt_kind
)
3454 if (!name_seen
&& actual_param
)
3455 actual_param
= actual_param
->next
;
3458 gfc_free_expr (kind_expr
);
3465 && (actual_param
->spec_type
== SPEC_ASSUMED
3466 || actual_param
->spec_type
== SPEC_DEFERRED
))
3468 gfc_error ("The KIND parameter %qs at %C cannot either be "
3469 "ASSUMED or DEFERRED", param
->name
);
3473 if (!kind_expr
|| !gfc_is_constant_expr (kind_expr
))
3475 gfc_error ("The value for the KIND parameter %qs at %C does not "
3476 "reduce to a constant expression", param
->name
);
3480 gfc_extract_int (kind_expr
, &kind_value
);
3481 sprintf (name
+ strlen (name
), "_%d", kind_value
);
3483 if (!name_seen
&& actual_param
)
3484 actual_param
= actual_param
->next
;
3485 gfc_free_expr (kind_expr
);
3488 if (!name_seen
&& actual_param
)
3490 gfc_error ("The type parameter spec list at %C contains too many "
3491 "parameter expressions");
3495 /* Now we search for the PDT instance 'name'. If it doesn't exist, we
3496 build it, using 'pdt' as a template. */
3497 if (gfc_get_symbol (name
, pdt
->ns
, &instance
))
3499 gfc_error ("Parameterized derived type at %C is ambiguous");
3505 if (instance
->attr
.flavor
== FL_DERIVED
3506 && instance
->attr
.pdt_type
)
3510 *ext_param_list
= type_param_spec_list
;
3512 gfc_commit_symbols ();
3516 /* Start building the new instance of the parameterized type. */
3517 gfc_copy_attr (&instance
->attr
, &pdt
->attr
, &pdt
->declared_at
);
3518 instance
->attr
.pdt_template
= 0;
3519 instance
->attr
.pdt_type
= 1;
3520 instance
->declared_at
= gfc_current_locus
;
3522 /* Add the components, replacing the parameters in all expressions
3523 with the expressions for their values in 'type_param_spec_list'. */
3524 c1
= pdt
->components
;
3525 tail
= type_param_spec_list
;
3526 for (; c1
; c1
= c1
->next
)
3528 gfc_add_component (instance
, c1
->name
, &c2
);
3531 c2
->attr
= c1
->attr
;
3533 /* The order of declaration of the type_specs might not be the
3534 same as that of the components. */
3535 if (c1
->attr
.pdt_kind
|| c1
->attr
.pdt_len
)
3537 for (tail
= type_param_spec_list
; tail
; tail
= tail
->next
)
3538 if (strcmp (c1
->name
, tail
->name
) == 0)
3542 /* Deal with type extension by recursively calling this function
3543 to obtain the instance of the extended type. */
3544 if (gfc_current_state () != COMP_DERIVED
3545 && c1
== pdt
->components
3546 && (c1
->ts
.type
== BT_DERIVED
|| c1
->ts
.type
== BT_CLASS
)
3547 && c1
->ts
.u
.derived
&& c1
->ts
.u
.derived
->attr
.pdt_template
3548 && gfc_get_derived_super_type (*sym
) == c2
->ts
.u
.derived
)
3550 gfc_formal_arglist
*f
;
3552 old_param_spec_list
= type_param_spec_list
;
3554 /* Obtain a spec list appropriate to the extended type..*/
3555 actual_param
= gfc_copy_actual_arglist (type_param_spec_list
);
3556 type_param_spec_list
= actual_param
;
3557 for (f
= c1
->ts
.u
.derived
->formal
; f
&& f
->next
; f
= f
->next
)
3558 actual_param
= actual_param
->next
;
3561 gfc_free_actual_arglist (actual_param
->next
);
3562 actual_param
->next
= NULL
;
3565 /* Now obtain the PDT instance for the extended type. */
3566 c2
->param_list
= type_param_spec_list
;
3567 m
= gfc_get_pdt_instance (type_param_spec_list
, &c2
->ts
.u
.derived
,
3569 type_param_spec_list
= old_param_spec_list
;
3571 c2
->ts
.u
.derived
->refs
++;
3572 gfc_set_sym_referenced (c2
->ts
.u
.derived
);
3574 /* Set extension level. */
3575 if (c2
->ts
.u
.derived
->attr
.extension
== 255)
3577 /* Since the extension field is 8 bit wide, we can only have
3578 up to 255 extension levels. */
3579 gfc_error ("Maximum extension level reached with type %qs at %L",
3580 c2
->ts
.u
.derived
->name
,
3581 &c2
->ts
.u
.derived
->declared_at
);
3584 instance
->attr
.extension
= c2
->ts
.u
.derived
->attr
.extension
+ 1;
3589 /* Set the component kind using the parameterized expression. */
3590 if ((c1
->ts
.kind
== 0 || c1
->ts
.type
== BT_CHARACTER
)
3591 && c1
->kind_expr
!= NULL
)
3593 gfc_expr
*e
= gfc_copy_expr (c1
->kind_expr
);
3594 gfc_insert_kind_parameter_exprs (e
);
3595 gfc_simplify_expr (e
, 1);
3596 gfc_extract_int (e
, &c2
->ts
.kind
);
3598 if (gfc_validate_kind (c2
->ts
.type
, c2
->ts
.kind
, true) < 0)
3600 gfc_error ("Kind %d not supported for type %s at %C",
3601 c2
->ts
.kind
, gfc_basic_typename (c2
->ts
.type
));
3606 /* Similarly, set the string length if parameterized. */
3607 if (c1
->ts
.type
== BT_CHARACTER
3608 && c1
->ts
.u
.cl
->length
3609 && gfc_derived_parameter_expr (c1
->ts
.u
.cl
->length
))
3612 e
= gfc_copy_expr (c1
->ts
.u
.cl
->length
);
3613 gfc_insert_kind_parameter_exprs (e
);
3614 gfc_simplify_expr (e
, 1);
3615 c2
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
3616 c2
->ts
.u
.cl
->length
= e
;
3617 c2
->attr
.pdt_string
= 1;
3620 /* Set up either the KIND/LEN initializer, if constant,
3621 or the parameterized expression. Use the template
3622 initializer if one is not already set in this instance. */
3623 if (c2
->attr
.pdt_kind
|| c2
->attr
.pdt_len
)
3625 if (tail
&& tail
->expr
&& gfc_is_constant_expr (tail
->expr
))
3626 c2
->initializer
= gfc_copy_expr (tail
->expr
);
3627 else if (tail
&& tail
->expr
)
3629 c2
->param_list
= gfc_get_actual_arglist ();
3630 c2
->param_list
->name
= tail
->name
;
3631 c2
->param_list
->expr
= gfc_copy_expr (tail
->expr
);
3632 c2
->param_list
->next
= NULL
;
3635 if (!c2
->initializer
&& c1
->initializer
)
3636 c2
->initializer
= gfc_copy_expr (c1
->initializer
);
3639 /* Copy the array spec. */
3640 c2
->as
= gfc_copy_array_spec (c1
->as
);
3641 if (c1
->ts
.type
== BT_CLASS
)
3642 CLASS_DATA (c2
)->as
= gfc_copy_array_spec (CLASS_DATA (c1
)->as
);
3644 /* Determine if an array spec is parameterized. If so, substitute
3645 in the parameter expressions for the bounds and set the pdt_array
3646 attribute. Notice that this attribute must be unconditionally set
3647 if this is an array of parameterized character length. */
3648 if (c1
->as
&& c1
->as
->type
== AS_EXPLICIT
)
3650 bool pdt_array
= false;
3652 /* Are the bounds of the array parameterized? */
3653 for (i
= 0; i
< c1
->as
->rank
; i
++)
3655 if (gfc_derived_parameter_expr (c1
->as
->lower
[i
]))
3657 if (gfc_derived_parameter_expr (c1
->as
->upper
[i
]))
3661 /* If they are, free the expressions for the bounds and
3662 replace them with the template expressions with substitute
3664 for (i
= 0; pdt_array
&& i
< c1
->as
->rank
; i
++)
3667 e
= gfc_copy_expr (c1
->as
->lower
[i
]);
3668 gfc_insert_kind_parameter_exprs (e
);
3669 gfc_simplify_expr (e
, 1);
3670 gfc_free_expr (c2
->as
->lower
[i
]);
3671 c2
->as
->lower
[i
] = e
;
3672 e
= gfc_copy_expr (c1
->as
->upper
[i
]);
3673 gfc_insert_kind_parameter_exprs (e
);
3674 gfc_simplify_expr (e
, 1);
3675 gfc_free_expr (c2
->as
->upper
[i
]);
3676 c2
->as
->upper
[i
] = e
;
3678 c2
->attr
.pdt_array
= pdt_array
? 1 : c2
->attr
.pdt_string
;
3679 if (c1
->initializer
)
3681 c2
->initializer
= gfc_copy_expr (c1
->initializer
);
3682 gfc_insert_kind_parameter_exprs (c2
->initializer
);
3683 gfc_simplify_expr (c2
->initializer
, 1);
3687 /* Recurse into this function for PDT components. */
3688 if ((c1
->ts
.type
== BT_DERIVED
|| c1
->ts
.type
== BT_CLASS
)
3689 && c1
->ts
.u
.derived
&& c1
->ts
.u
.derived
->attr
.pdt_template
)
3691 gfc_actual_arglist
*params
;
3692 /* The component in the template has a list of specification
3693 expressions derived from its declaration. */
3694 params
= gfc_copy_actual_arglist (c1
->param_list
);
3695 actual_param
= params
;
3696 /* Substitute the template parameters with the expressions
3697 from the specification list. */
3698 for (;actual_param
; actual_param
= actual_param
->next
)
3699 gfc_insert_parameter_exprs (actual_param
->expr
,
3700 type_param_spec_list
);
3702 /* Now obtain the PDT instance for the component. */
3703 old_param_spec_list
= type_param_spec_list
;
3704 m
= gfc_get_pdt_instance (params
, &c2
->ts
.u
.derived
, NULL
);
3705 type_param_spec_list
= old_param_spec_list
;
3707 c2
->param_list
= params
;
3708 if (!(c2
->attr
.pointer
|| c2
->attr
.allocatable
))
3709 c2
->initializer
= gfc_default_initializer (&c2
->ts
);
3711 if (c2
->attr
.allocatable
)
3712 instance
->attr
.alloc_comp
= 1;
3716 gfc_commit_symbol (instance
);
3718 *ext_param_list
= type_param_spec_list
;
3723 gfc_free_actual_arglist (type_param_spec_list
);
3728 /* Matches a declaration-type-spec (F03:R502). If successful, sets the ts
3729 structure to the matched specification. This is necessary for FUNCTION and
3730 IMPLICIT statements.
3732 If implicit_flag is nonzero, then we don't check for the optional
3733 kind specification. Not doing so is needed for matching an IMPLICIT
3734 statement correctly. */
3737 gfc_match_decl_type_spec (gfc_typespec
*ts
, int implicit_flag
)
3739 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3740 gfc_symbol
*sym
, *dt_sym
;
3743 bool seen_deferred_kind
, matched_type
;
3744 const char *dt_name
;
3746 decl_type_param_list
= NULL
;
3748 /* A belt and braces check that the typespec is correctly being treated
3749 as a deferred characteristic association. */
3750 seen_deferred_kind
= (gfc_current_state () == COMP_FUNCTION
)
3751 && (gfc_current_block ()->result
->ts
.kind
== -1)
3752 && (ts
->kind
== -1);
3754 if (seen_deferred_kind
)
3757 /* Clear the current binding label, in case one is given. */
3758 curr_binding_label
= NULL
;
3760 if (gfc_match (" byte") == MATCH_YES
)
3762 if (!gfc_notify_std (GFC_STD_GNU
, "BYTE type at %C"))
3765 if (gfc_validate_kind (BT_INTEGER
, 1, true) < 0)
3767 gfc_error ("BYTE type used at %C "
3768 "is not available on the target machine");
3772 ts
->type
= BT_INTEGER
;
3778 m
= gfc_match (" type (");
3779 matched_type
= (m
== MATCH_YES
);
3782 gfc_gobble_whitespace ();
3783 if (gfc_peek_ascii_char () == '*')
3785 if ((m
= gfc_match ("*)")) != MATCH_YES
)
3787 if (gfc_comp_struct (gfc_current_state ()))
3789 gfc_error ("Assumed type at %C is not allowed for components");
3792 if (!gfc_notify_std (GFC_STD_F2008_TS
, "Assumed type "
3795 ts
->type
= BT_ASSUMED
;
3799 m
= gfc_match ("%n", name
);
3800 matched_type
= (m
== MATCH_YES
);
3803 if ((matched_type
&& strcmp ("integer", name
) == 0)
3804 || (!matched_type
&& gfc_match (" integer") == MATCH_YES
))
3806 ts
->type
= BT_INTEGER
;
3807 ts
->kind
= gfc_default_integer_kind
;
3811 if ((matched_type
&& strcmp ("character", name
) == 0)
3812 || (!matched_type
&& gfc_match (" character") == MATCH_YES
))
3815 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
3816 "intrinsic-type-spec at %C"))
3819 ts
->type
= BT_CHARACTER
;
3820 if (implicit_flag
== 0)
3821 m
= gfc_match_char_spec (ts
);
3825 if (matched_type
&& m
== MATCH_YES
&& gfc_match_char (')') != MATCH_YES
)
3831 if ((matched_type
&& strcmp ("real", name
) == 0)
3832 || (!matched_type
&& gfc_match (" real") == MATCH_YES
))
3835 ts
->kind
= gfc_default_real_kind
;
3840 && (strcmp ("doubleprecision", name
) == 0
3841 || (strcmp ("double", name
) == 0
3842 && gfc_match (" precision") == MATCH_YES
)))
3843 || (!matched_type
&& gfc_match (" double precision") == MATCH_YES
))
3846 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
3847 "intrinsic-type-spec at %C"))
3849 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
3853 ts
->kind
= gfc_default_double_kind
;
3857 if ((matched_type
&& strcmp ("complex", name
) == 0)
3858 || (!matched_type
&& gfc_match (" complex") == MATCH_YES
))
3860 ts
->type
= BT_COMPLEX
;
3861 ts
->kind
= gfc_default_complex_kind
;
3866 && (strcmp ("doublecomplex", name
) == 0
3867 || (strcmp ("double", name
) == 0
3868 && gfc_match (" complex") == MATCH_YES
)))
3869 || (!matched_type
&& gfc_match (" double complex") == MATCH_YES
))
3871 if (!gfc_notify_std (GFC_STD_GNU
, "DOUBLE COMPLEX at %C"))
3875 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
3876 "intrinsic-type-spec at %C"))
3879 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
3882 ts
->type
= BT_COMPLEX
;
3883 ts
->kind
= gfc_default_double_kind
;
3887 if ((matched_type
&& strcmp ("logical", name
) == 0)
3888 || (!matched_type
&& gfc_match (" logical") == MATCH_YES
))
3890 ts
->type
= BT_LOGICAL
;
3891 ts
->kind
= gfc_default_logical_kind
;
3897 m
= gfc_match_actual_arglist (1, &decl_type_param_list
, true);
3898 if (m
== MATCH_ERROR
)
3901 m
= gfc_match_char (')');
3905 m
= match_record_decl (name
);
3907 if (matched_type
|| m
== MATCH_YES
)
3909 ts
->type
= BT_DERIVED
;
3910 /* We accept record/s/ or type(s) where s is a structure, but we
3911 * don't need all the extra derived-type stuff for structures. */
3912 if (gfc_find_symbol (gfc_dt_upper_string (name
), NULL
, 1, &sym
))
3914 gfc_error ("Type name %qs at %C is ambiguous", name
);
3918 if (sym
&& sym
->attr
.flavor
== FL_DERIVED
3919 && sym
->attr
.pdt_template
3920 && gfc_current_state () != COMP_DERIVED
)
3922 m
= gfc_get_pdt_instance (decl_type_param_list
, &sym
, NULL
);
3925 gcc_assert (!sym
->attr
.pdt_template
&& sym
->attr
.pdt_type
);
3926 ts
->u
.derived
= sym
;
3927 strcpy (name
, gfc_dt_lower_string (sym
->name
));
3930 if (sym
&& sym
->attr
.flavor
== FL_STRUCT
)
3932 ts
->u
.derived
= sym
;
3935 /* Actually a derived type. */
3940 /* Match nested STRUCTURE declarations; only valid within another
3941 structure declaration. */
3942 if (flag_dec_structure
3943 && (gfc_current_state () == COMP_STRUCTURE
3944 || gfc_current_state () == COMP_MAP
))
3946 m
= gfc_match (" structure");
3949 m
= gfc_match_structure_decl ();
3952 /* gfc_new_block is updated by match_structure_decl. */
3953 ts
->type
= BT_DERIVED
;
3954 ts
->u
.derived
= gfc_new_block
;
3958 if (m
== MATCH_ERROR
)
3962 /* Match CLASS declarations. */
3963 m
= gfc_match (" class ( * )");
3964 if (m
== MATCH_ERROR
)
3966 else if (m
== MATCH_YES
)
3970 ts
->type
= BT_CLASS
;
3971 gfc_find_symbol ("STAR", gfc_current_ns
, 1, &upe
);
3974 upe
= gfc_new_symbol ("STAR", gfc_current_ns
);
3975 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "STAR");
3977 gfc_set_sym_referenced (upe
);
3979 upe
->ts
.type
= BT_VOID
;
3980 upe
->attr
.unlimited_polymorphic
= 1;
3981 /* This is essential to force the construction of
3982 unlimited polymorphic component class containers. */
3983 upe
->attr
.zero_comp
= 1;
3984 if (!gfc_add_flavor (&upe
->attr
, FL_DERIVED
, NULL
,
3985 &gfc_current_locus
))
3990 st
= gfc_get_tbp_symtree (&gfc_current_ns
->sym_root
, "STAR");
3994 ts
->u
.derived
= upe
;
3998 m
= gfc_match (" class (");
4001 m
= gfc_match ("%n", name
);
4007 ts
->type
= BT_CLASS
;
4009 if (!gfc_notify_std (GFC_STD_F2003
, "CLASS statement at %C"))
4012 m
= gfc_match_actual_arglist (1, &decl_type_param_list
, true);
4013 if (m
== MATCH_ERROR
)
4016 m
= gfc_match_char (')');
4021 /* Defer association of the derived type until the end of the
4022 specification block. However, if the derived type can be
4023 found, add it to the typespec. */
4024 if (gfc_matching_function
)
4026 ts
->u
.derived
= NULL
;
4027 if (gfc_current_state () != COMP_INTERFACE
4028 && !gfc_find_symbol (name
, NULL
, 1, &sym
) && sym
)
4030 sym
= gfc_find_dt_in_generic (sym
);
4031 ts
->u
.derived
= sym
;
4036 /* Search for the name but allow the components to be defined later. If
4037 type = -1, this typespec has been seen in a function declaration but
4038 the type could not be accessed at that point. The actual derived type is
4039 stored in a symtree with the first letter of the name capitalized; the
4040 symtree with the all lower-case name contains the associated
4041 generic function. */
4042 dt_name
= gfc_dt_upper_string (name
);
4047 gfc_get_ha_symbol (name
, &sym
);
4048 if (sym
->generic
&& gfc_find_symbol (dt_name
, NULL
, 0, &dt_sym
))
4050 gfc_error ("Type name %qs at %C is ambiguous", name
);
4053 if (sym
->generic
&& !dt_sym
)
4054 dt_sym
= gfc_find_dt_in_generic (sym
);
4056 /* Host associated PDTs can get confused with their constructors
4057 because they ar instantiated in the template's namespace. */
4060 if (gfc_find_symbol (dt_name
, NULL
, 1, &dt_sym
))
4062 gfc_error ("Type name %qs at %C is ambiguous", name
);
4065 if (dt_sym
&& !dt_sym
->attr
.pdt_type
)
4069 else if (ts
->kind
== -1)
4071 int iface
= gfc_state_stack
->previous
->state
!= COMP_INTERFACE
4072 || gfc_current_ns
->has_import_set
;
4073 gfc_find_symbol (name
, NULL
, iface
, &sym
);
4074 if (sym
&& sym
->generic
&& gfc_find_symbol (dt_name
, NULL
, 1, &dt_sym
))
4076 gfc_error ("Type name %qs at %C is ambiguous", name
);
4079 if (sym
&& sym
->generic
&& !dt_sym
)
4080 dt_sym
= gfc_find_dt_in_generic (sym
);
4087 if ((sym
->attr
.flavor
!= FL_UNKNOWN
&& sym
->attr
.flavor
!= FL_STRUCT
4088 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.generic
))
4089 || sym
->attr
.subroutine
)
4091 gfc_error ("Type name %qs at %C conflicts with previously declared "
4092 "entity at %L, which has the same name", name
,
4097 if (sym
&& sym
->attr
.flavor
== FL_DERIVED
4098 && sym
->attr
.pdt_template
4099 && gfc_current_state () != COMP_DERIVED
)
4101 m
= gfc_get_pdt_instance (decl_type_param_list
, &sym
, NULL
);
4104 gcc_assert (!sym
->attr
.pdt_template
&& sym
->attr
.pdt_type
);
4105 ts
->u
.derived
= sym
;
4106 strcpy (name
, gfc_dt_lower_string (sym
->name
));
4109 gfc_save_symbol_data (sym
);
4110 gfc_set_sym_referenced (sym
);
4111 if (!sym
->attr
.generic
4112 && !gfc_add_generic (&sym
->attr
, sym
->name
, NULL
))
4115 if (!sym
->attr
.function
4116 && !gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
4119 if (dt_sym
&& dt_sym
->attr
.flavor
== FL_DERIVED
4120 && dt_sym
->attr
.pdt_template
4121 && gfc_current_state () != COMP_DERIVED
)
4123 m
= gfc_get_pdt_instance (decl_type_param_list
, &dt_sym
, NULL
);
4126 gcc_assert (!dt_sym
->attr
.pdt_template
&& dt_sym
->attr
.pdt_type
);
4131 gfc_interface
*intr
, *head
;
4133 /* Use upper case to save the actual derived-type symbol. */
4134 gfc_get_symbol (dt_name
, NULL
, &dt_sym
);
4135 dt_sym
->name
= gfc_get_string ("%s", sym
->name
);
4136 head
= sym
->generic
;
4137 intr
= gfc_get_interface ();
4139 intr
->where
= gfc_current_locus
;
4141 sym
->generic
= intr
;
4142 sym
->attr
.if_source
= IFSRC_DECL
;
4145 gfc_save_symbol_data (dt_sym
);
4147 gfc_set_sym_referenced (dt_sym
);
4149 if (dt_sym
->attr
.flavor
!= FL_DERIVED
&& dt_sym
->attr
.flavor
!= FL_STRUCT
4150 && !gfc_add_flavor (&dt_sym
->attr
, FL_DERIVED
, sym
->name
, NULL
))
4153 ts
->u
.derived
= dt_sym
;
4159 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
4160 "intrinsic-type-spec at %C"))
4163 /* For all types except double, derived and character, look for an
4164 optional kind specifier. MATCH_NO is actually OK at this point. */
4165 if (implicit_flag
== 1)
4167 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
4173 if (gfc_current_form
== FORM_FREE
)
4175 c
= gfc_peek_ascii_char ();
4176 if (!gfc_is_whitespace (c
) && c
!= '*' && c
!= '('
4177 && c
!= ':' && c
!= ',')
4179 if (matched_type
&& c
== ')')
4181 gfc_next_ascii_char ();
4188 m
= gfc_match_kind_spec (ts
, false);
4189 if (m
== MATCH_NO
&& ts
->type
!= BT_CHARACTER
)
4191 m
= gfc_match_old_kind_spec (ts
);
4192 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) == -1)
4196 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
4199 /* Defer association of the KIND expression of function results
4200 until after USE and IMPORT statements. */
4201 if ((gfc_current_state () == COMP_NONE
&& gfc_error_flag_test ())
4202 || gfc_matching_function
)
4206 m
= MATCH_YES
; /* No kind specifier found. */
4212 /* Match an IMPLICIT NONE statement. Actually, this statement is
4213 already matched in parse.c, or we would not end up here in the
4214 first place. So the only thing we need to check, is if there is
4215 trailing garbage. If not, the match is successful. */
4218 gfc_match_implicit_none (void)
4222 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4224 bool external
= false;
4225 locus cur_loc
= gfc_current_locus
;
4227 if (gfc_current_ns
->seen_implicit_none
4228 || gfc_current_ns
->has_implicit_none_export
)
4230 gfc_error ("Duplicate IMPLICIT NONE statement at %C");
4234 gfc_gobble_whitespace ();
4235 c
= gfc_peek_ascii_char ();
4238 (void) gfc_next_ascii_char ();
4239 if (!gfc_notify_std (GFC_STD_F2018
, "IMPORT NONE with spec list at %C"))
4242 gfc_gobble_whitespace ();
4243 if (gfc_peek_ascii_char () == ')')
4245 (void) gfc_next_ascii_char ();
4251 m
= gfc_match (" %n", name
);
4255 if (strcmp (name
, "type") == 0)
4257 else if (strcmp (name
, "external") == 0)
4262 gfc_gobble_whitespace ();
4263 c
= gfc_next_ascii_char ();
4274 if (gfc_match_eos () != MATCH_YES
)
4277 gfc_set_implicit_none (type
, external
, &cur_loc
);
4283 /* Match the letter range(s) of an IMPLICIT statement. */
4286 match_implicit_range (void)
4292 cur_loc
= gfc_current_locus
;
4294 gfc_gobble_whitespace ();
4295 c
= gfc_next_ascii_char ();
4298 gfc_error ("Missing character range in IMPLICIT at %C");
4305 gfc_gobble_whitespace ();
4306 c1
= gfc_next_ascii_char ();
4310 gfc_gobble_whitespace ();
4311 c
= gfc_next_ascii_char ();
4316 inner
= 0; /* Fall through. */
4323 gfc_gobble_whitespace ();
4324 c2
= gfc_next_ascii_char ();
4328 gfc_gobble_whitespace ();
4329 c
= gfc_next_ascii_char ();
4331 if ((c
!= ',') && (c
!= ')'))
4344 gfc_error ("Letters must be in alphabetic order in "
4345 "IMPLICIT statement at %C");
4349 /* See if we can add the newly matched range to the pending
4350 implicits from this IMPLICIT statement. We do not check for
4351 conflicts with whatever earlier IMPLICIT statements may have
4352 set. This is done when we've successfully finished matching
4354 if (!gfc_add_new_implicit_range (c1
, c2
))
4361 gfc_syntax_error (ST_IMPLICIT
);
4363 gfc_current_locus
= cur_loc
;
4368 /* Match an IMPLICIT statement, storing the types for
4369 gfc_set_implicit() if the statement is accepted by the parser.
4370 There is a strange looking, but legal syntactic construction
4371 possible. It looks like:
4373 IMPLICIT INTEGER (a-b) (c-d)
4375 This is legal if "a-b" is a constant expression that happens to
4376 equal one of the legal kinds for integers. The real problem
4377 happens with an implicit specification that looks like:
4379 IMPLICIT INTEGER (a-b)
4381 In this case, a typespec matcher that is "greedy" (as most of the
4382 matchers are) gobbles the character range as a kindspec, leaving
4383 nothing left. We therefore have to go a bit more slowly in the
4384 matching process by inhibiting the kindspec checking during
4385 typespec matching and checking for a kind later. */
4388 gfc_match_implicit (void)
4395 if (gfc_current_ns
->seen_implicit_none
)
4397 gfc_error ("IMPLICIT statement at %C following an IMPLICIT NONE (type) "
4404 /* We don't allow empty implicit statements. */
4405 if (gfc_match_eos () == MATCH_YES
)
4407 gfc_error ("Empty IMPLICIT statement at %C");
4413 /* First cleanup. */
4414 gfc_clear_new_implicit ();
4416 /* A basic type is mandatory here. */
4417 m
= gfc_match_decl_type_spec (&ts
, 1);
4418 if (m
== MATCH_ERROR
)
4423 cur_loc
= gfc_current_locus
;
4424 m
= match_implicit_range ();
4428 /* We may have <TYPE> (<RANGE>). */
4429 gfc_gobble_whitespace ();
4430 c
= gfc_peek_ascii_char ();
4431 if (c
== ',' || c
== '\n' || c
== ';' || c
== '!')
4433 /* Check for CHARACTER with no length parameter. */
4434 if (ts
.type
== BT_CHARACTER
&& !ts
.u
.cl
)
4436 ts
.kind
= gfc_default_character_kind
;
4437 ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4438 ts
.u
.cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
,
4442 /* Record the Successful match. */
4443 if (!gfc_merge_new_implicit (&ts
))
4446 c
= gfc_next_ascii_char ();
4447 else if (gfc_match_eos () == MATCH_ERROR
)
4452 gfc_current_locus
= cur_loc
;
4455 /* Discard the (incorrectly) matched range. */
4456 gfc_clear_new_implicit ();
4458 /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
4459 if (ts
.type
== BT_CHARACTER
)
4460 m
= gfc_match_char_spec (&ts
);
4463 m
= gfc_match_kind_spec (&ts
, false);
4466 m
= gfc_match_old_kind_spec (&ts
);
4467 if (m
== MATCH_ERROR
)
4473 if (m
== MATCH_ERROR
)
4476 m
= match_implicit_range ();
4477 if (m
== MATCH_ERROR
)
4482 gfc_gobble_whitespace ();
4483 c
= gfc_next_ascii_char ();
4484 if (c
!= ',' && gfc_match_eos () != MATCH_YES
)
4487 if (!gfc_merge_new_implicit (&ts
))
4495 gfc_syntax_error (ST_IMPLICIT
);
4503 gfc_match_import (void)
4505 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4510 if (gfc_current_ns
->proc_name
== NULL
4511 || gfc_current_ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
4513 gfc_error ("IMPORT statement at %C only permitted in "
4514 "an INTERFACE body");
4518 if (gfc_current_ns
->proc_name
->attr
.module_procedure
)
4520 gfc_error ("F2008: C1210 IMPORT statement at %C is not permitted "
4521 "in a module procedure interface body");
4525 if (!gfc_notify_std (GFC_STD_F2003
, "IMPORT statement at %C"))
4528 if (gfc_match_eos () == MATCH_YES
)
4530 /* All host variables should be imported. */
4531 gfc_current_ns
->has_import_set
= 1;
4535 if (gfc_match (" ::") == MATCH_YES
)
4537 if (gfc_match_eos () == MATCH_YES
)
4539 gfc_error ("Expecting list of named entities at %C");
4547 m
= gfc_match (" %n", name
);
4551 if (gfc_current_ns
->parent
!= NULL
4552 && gfc_find_symbol (name
, gfc_current_ns
->parent
, 1, &sym
))
4554 gfc_error ("Type name %qs at %C is ambiguous", name
);
4557 else if (!sym
&& gfc_current_ns
->proc_name
->ns
->parent
!= NULL
4558 && gfc_find_symbol (name
,
4559 gfc_current_ns
->proc_name
->ns
->parent
,
4562 gfc_error ("Type name %qs at %C is ambiguous", name
);
4568 gfc_error ("Cannot IMPORT %qs from host scoping unit "
4569 "at %C - does not exist.", name
);
4573 if (gfc_find_symtree (gfc_current_ns
->sym_root
, name
))
4575 gfc_warning (0, "%qs is already IMPORTed from host scoping unit "
4580 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, name
);
4583 sym
->attr
.imported
= 1;
4585 if (sym
->attr
.generic
&& (sym
= gfc_find_dt_in_generic (sym
)))
4587 /* The actual derived type is stored in a symtree with the first
4588 letter of the name capitalized; the symtree with the all
4589 lower-case name contains the associated generic function. */
4590 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
,
4591 gfc_dt_upper_string (name
));
4594 sym
->attr
.imported
= 1;
4607 if (gfc_match_eos () == MATCH_YES
)
4609 if (gfc_match_char (',') != MATCH_YES
)
4616 gfc_error ("Syntax error in IMPORT statement at %C");
4621 /* A minimal implementation of gfc_match without whitespace, escape
4622 characters or variable arguments. Returns true if the next
4623 characters match the TARGET template exactly. */
4626 match_string_p (const char *target
)
4630 for (p
= target
; *p
; p
++)
4631 if ((char) gfc_next_ascii_char () != *p
)
4636 /* Matches an attribute specification including array specs. If
4637 successful, leaves the variables current_attr and current_as
4638 holding the specification. Also sets the colon_seen variable for
4639 later use by matchers associated with initializations.
4641 This subroutine is a little tricky in the sense that we don't know
4642 if we really have an attr-spec until we hit the double colon.
4643 Until that time, we can only return MATCH_NO. This forces us to
4644 check for duplicate specification at this level. */
4647 match_attr_spec (void)
4649 /* Modifiers that can exist in a type statement. */
4651 { GFC_DECL_BEGIN
= 0,
4652 DECL_ALLOCATABLE
= GFC_DECL_BEGIN
, DECL_DIMENSION
, DECL_EXTERNAL
,
4653 DECL_IN
, DECL_OUT
, DECL_INOUT
, DECL_INTRINSIC
, DECL_OPTIONAL
,
4654 DECL_PARAMETER
, DECL_POINTER
, DECL_PROTECTED
, DECL_PRIVATE
,
4655 DECL_STATIC
, DECL_AUTOMATIC
,
4656 DECL_PUBLIC
, DECL_SAVE
, DECL_TARGET
, DECL_VALUE
, DECL_VOLATILE
,
4657 DECL_IS_BIND_C
, DECL_CODIMENSION
, DECL_ASYNCHRONOUS
, DECL_CONTIGUOUS
,
4658 DECL_LEN
, DECL_KIND
, DECL_NONE
, GFC_DECL_END
/* Sentinel */
4661 /* GFC_DECL_END is the sentinel, index starts at 0. */
4662 #define NUM_DECL GFC_DECL_END
4664 locus start
, seen_at
[NUM_DECL
];
4671 gfc_clear_attr (¤t_attr
);
4672 start
= gfc_current_locus
;
4678 /* See if we get all of the keywords up to the final double colon. */
4679 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
4687 gfc_gobble_whitespace ();
4689 ch
= gfc_next_ascii_char ();
4692 /* This is the successful exit condition for the loop. */
4693 if (gfc_next_ascii_char () == ':')
4698 gfc_gobble_whitespace ();
4699 switch (gfc_peek_ascii_char ())
4702 gfc_next_ascii_char ();
4703 switch (gfc_next_ascii_char ())
4706 if (match_string_p ("locatable"))
4708 /* Matched "allocatable". */
4709 d
= DECL_ALLOCATABLE
;
4714 if (match_string_p ("ynchronous"))
4716 /* Matched "asynchronous". */
4717 d
= DECL_ASYNCHRONOUS
;
4722 if (match_string_p ("tomatic"))
4724 /* Matched "automatic". */
4732 /* Try and match the bind(c). */
4733 m
= gfc_match_bind_c (NULL
, true);
4736 else if (m
== MATCH_ERROR
)
4741 gfc_next_ascii_char ();
4742 if ('o' != gfc_next_ascii_char ())
4744 switch (gfc_next_ascii_char ())
4747 if (match_string_p ("imension"))
4749 d
= DECL_CODIMENSION
;
4754 if (match_string_p ("tiguous"))
4756 d
= DECL_CONTIGUOUS
;
4763 if (match_string_p ("dimension"))
4768 if (match_string_p ("external"))
4773 if (match_string_p ("int"))
4775 ch
= gfc_next_ascii_char ();
4778 if (match_string_p ("nt"))
4780 /* Matched "intent". */
4781 /* TODO: Call match_intent_spec from here. */
4782 if (gfc_match (" ( in out )") == MATCH_YES
)
4784 else if (gfc_match (" ( in )") == MATCH_YES
)
4786 else if (gfc_match (" ( out )") == MATCH_YES
)
4792 if (match_string_p ("insic"))
4794 /* Matched "intrinsic". */
4802 if (match_string_p ("kind"))
4807 if (match_string_p ("len"))
4812 if (match_string_p ("optional"))
4817 gfc_next_ascii_char ();
4818 switch (gfc_next_ascii_char ())
4821 if (match_string_p ("rameter"))
4823 /* Matched "parameter". */
4829 if (match_string_p ("inter"))
4831 /* Matched "pointer". */
4837 ch
= gfc_next_ascii_char ();
4840 if (match_string_p ("vate"))
4842 /* Matched "private". */
4848 if (match_string_p ("tected"))
4850 /* Matched "protected". */
4857 if (match_string_p ("blic"))
4859 /* Matched "public". */
4867 gfc_next_ascii_char ();
4868 switch (gfc_next_ascii_char ())
4871 if (match_string_p ("ve"))
4873 /* Matched "save". */
4879 if (match_string_p ("atic"))
4881 /* Matched "static". */
4889 if (match_string_p ("target"))
4894 gfc_next_ascii_char ();
4895 ch
= gfc_next_ascii_char ();
4898 if (match_string_p ("lue"))
4900 /* Matched "value". */
4906 if (match_string_p ("latile"))
4908 /* Matched "volatile". */
4916 /* No double colon and no recognizable decl_type, so assume that
4917 we've been looking at something else the whole time. */
4924 /* Check to make sure any parens are paired up correctly. */
4925 if (gfc_match_parens () == MATCH_ERROR
)
4932 seen_at
[d
] = gfc_current_locus
;
4934 if (d
== DECL_DIMENSION
|| d
== DECL_CODIMENSION
)
4936 gfc_array_spec
*as
= NULL
;
4938 m
= gfc_match_array_spec (&as
, d
== DECL_DIMENSION
,
4939 d
== DECL_CODIMENSION
);
4941 if (current_as
== NULL
)
4943 else if (m
== MATCH_YES
)
4945 if (!merge_array_spec (as
, current_as
, false))
4952 if (d
== DECL_CODIMENSION
)
4953 gfc_error ("Missing codimension specification at %C");
4955 gfc_error ("Missing dimension specification at %C");
4959 if (m
== MATCH_ERROR
)
4964 /* Since we've seen a double colon, we have to be looking at an
4965 attr-spec. This means that we can now issue errors. */
4966 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
4971 case DECL_ALLOCATABLE
:
4972 attr
= "ALLOCATABLE";
4974 case DECL_ASYNCHRONOUS
:
4975 attr
= "ASYNCHRONOUS";
4977 case DECL_CODIMENSION
:
4978 attr
= "CODIMENSION";
4980 case DECL_CONTIGUOUS
:
4981 attr
= "CONTIGUOUS";
4983 case DECL_DIMENSION
:
4990 attr
= "INTENT (IN)";
4993 attr
= "INTENT (OUT)";
4996 attr
= "INTENT (IN OUT)";
4998 case DECL_INTRINSIC
:
5010 case DECL_PARAMETER
:
5016 case DECL_PROTECTED
:
5031 case DECL_AUTOMATIC
:
5037 case DECL_IS_BIND_C
:
5047 attr
= NULL
; /* This shouldn't happen. */
5050 gfc_error ("Duplicate %s attribute at %L", attr
, &seen_at
[d
]);
5055 /* Now that we've dealt with duplicate attributes, add the attributes
5056 to the current attribute. */
5057 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
5064 if ((d
== DECL_STATIC
|| d
== DECL_AUTOMATIC
)
5065 && !flag_dec_static
)
5067 gfc_error ("%s at %L is a DEC extension, enable with "
5069 d
== DECL_STATIC
? "STATIC" : "AUTOMATIC", &seen_at
[d
]);
5073 /* Allow SAVE with STATIC, but don't complain. */
5074 if (d
== DECL_STATIC
&& seen
[DECL_SAVE
])
5077 if (gfc_current_state () == COMP_DERIVED
5078 && d
!= DECL_DIMENSION
&& d
!= DECL_CODIMENSION
5079 && d
!= DECL_POINTER
&& d
!= DECL_PRIVATE
5080 && d
!= DECL_PUBLIC
&& d
!= DECL_CONTIGUOUS
&& d
!= DECL_NONE
)
5082 if (d
== DECL_ALLOCATABLE
)
5084 if (!gfc_notify_std (GFC_STD_F2003
, "ALLOCATABLE "
5085 "attribute at %C in a TYPE definition"))
5091 else if (d
== DECL_KIND
)
5093 if (!gfc_notify_std (GFC_STD_F2003
, "KIND "
5094 "attribute at %C in a TYPE definition"))
5099 if (current_ts
.type
!= BT_INTEGER
)
5101 gfc_error ("Component with KIND attribute at %C must be "
5106 if (current_ts
.kind
!= gfc_default_integer_kind
)
5108 gfc_error ("Component with KIND attribute at %C must be "
5109 "default integer kind (%d)",
5110 gfc_default_integer_kind
);
5115 else if (d
== DECL_LEN
)
5117 if (!gfc_notify_std (GFC_STD_F2003
, "LEN "
5118 "attribute at %C in a TYPE definition"))
5123 if (current_ts
.type
!= BT_INTEGER
)
5125 gfc_error ("Component with LEN attribute at %C must be "
5130 if (current_ts
.kind
!= gfc_default_integer_kind
)
5132 gfc_error ("Component with LEN attribute at %C must be "
5133 "default integer kind (%d)",
5134 gfc_default_integer_kind
);
5141 gfc_error ("Attribute at %L is not allowed in a TYPE definition",
5148 if ((d
== DECL_PRIVATE
|| d
== DECL_PUBLIC
)
5149 && gfc_current_state () != COMP_MODULE
)
5151 if (d
== DECL_PRIVATE
)
5155 if (gfc_current_state () == COMP_DERIVED
5156 && gfc_state_stack
->previous
5157 && gfc_state_stack
->previous
->state
== COMP_MODULE
)
5159 if (!gfc_notify_std (GFC_STD_F2003
, "Attribute %s "
5160 "at %L in a TYPE definition", attr
,
5169 gfc_error ("%s attribute at %L is not allowed outside of the "
5170 "specification part of a module", attr
, &seen_at
[d
]);
5176 if (gfc_current_state () != COMP_DERIVED
5177 && (d
== DECL_KIND
|| d
== DECL_LEN
))
5179 gfc_error ("Attribute at %L is not allowed outside a TYPE "
5180 "definition", &seen_at
[d
]);
5187 case DECL_ALLOCATABLE
:
5188 t
= gfc_add_allocatable (¤t_attr
, &seen_at
[d
]);
5191 case DECL_ASYNCHRONOUS
:
5192 if (!gfc_notify_std (GFC_STD_F2003
, "ASYNCHRONOUS attribute at %C"))
5195 t
= gfc_add_asynchronous (¤t_attr
, NULL
, &seen_at
[d
]);
5198 case DECL_CODIMENSION
:
5199 t
= gfc_add_codimension (¤t_attr
, NULL
, &seen_at
[d
]);
5202 case DECL_CONTIGUOUS
:
5203 if (!gfc_notify_std (GFC_STD_F2008
, "CONTIGUOUS attribute at %C"))
5206 t
= gfc_add_contiguous (¤t_attr
, NULL
, &seen_at
[d
]);
5209 case DECL_DIMENSION
:
5210 t
= gfc_add_dimension (¤t_attr
, NULL
, &seen_at
[d
]);
5214 t
= gfc_add_external (¤t_attr
, &seen_at
[d
]);
5218 t
= gfc_add_intent (¤t_attr
, INTENT_IN
, &seen_at
[d
]);
5222 t
= gfc_add_intent (¤t_attr
, INTENT_OUT
, &seen_at
[d
]);
5226 t
= gfc_add_intent (¤t_attr
, INTENT_INOUT
, &seen_at
[d
]);
5229 case DECL_INTRINSIC
:
5230 t
= gfc_add_intrinsic (¤t_attr
, &seen_at
[d
]);
5234 t
= gfc_add_optional (¤t_attr
, &seen_at
[d
]);
5238 t
= gfc_add_kind (¤t_attr
, &seen_at
[d
]);
5242 t
= gfc_add_len (¤t_attr
, &seen_at
[d
]);
5245 case DECL_PARAMETER
:
5246 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, &seen_at
[d
]);
5250 t
= gfc_add_pointer (¤t_attr
, &seen_at
[d
]);
5253 case DECL_PROTECTED
:
5254 if (gfc_current_state () != COMP_MODULE
5255 || (gfc_current_ns
->proc_name
5256 && gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
))
5258 gfc_error ("PROTECTED at %C only allowed in specification "
5259 "part of a module");
5264 if (!gfc_notify_std (GFC_STD_F2003
, "PROTECTED attribute at %C"))
5267 t
= gfc_add_protected (¤t_attr
, NULL
, &seen_at
[d
]);
5271 t
= gfc_add_access (¤t_attr
, ACCESS_PRIVATE
, NULL
,
5276 t
= gfc_add_access (¤t_attr
, ACCESS_PUBLIC
, NULL
,
5282 t
= gfc_add_save (¤t_attr
, SAVE_EXPLICIT
, NULL
, &seen_at
[d
]);
5285 case DECL_AUTOMATIC
:
5286 t
= gfc_add_automatic (¤t_attr
, NULL
, &seen_at
[d
]);
5290 t
= gfc_add_target (¤t_attr
, &seen_at
[d
]);
5293 case DECL_IS_BIND_C
:
5294 t
= gfc_add_is_bind_c(¤t_attr
, NULL
, &seen_at
[d
], 0);
5298 if (!gfc_notify_std (GFC_STD_F2003
, "VALUE attribute at %C"))
5301 t
= gfc_add_value (¤t_attr
, NULL
, &seen_at
[d
]);
5305 if (!gfc_notify_std (GFC_STD_F2003
, "VOLATILE attribute at %C"))
5308 t
= gfc_add_volatile (¤t_attr
, NULL
, &seen_at
[d
]);
5312 gfc_internal_error ("match_attr_spec(): Bad attribute");
5322 /* Since Fortran 2008 module variables implicitly have the SAVE attribute. */
5323 if ((gfc_current_state () == COMP_MODULE
5324 || gfc_current_state () == COMP_SUBMODULE
)
5325 && !current_attr
.save
5326 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
5327 current_attr
.save
= SAVE_IMPLICIT
;
5333 gfc_current_locus
= start
;
5334 gfc_free_array_spec (current_as
);
5341 /* Set the binding label, dest_label, either with the binding label
5342 stored in the given gfc_typespec, ts, or if none was provided, it
5343 will be the symbol name in all lower case, as required by the draft
5344 (J3/04-007, section 15.4.1). If a binding label was given and
5345 there is more than one argument (num_idents), it is an error. */
5348 set_binding_label (const char **dest_label
, const char *sym_name
,
5351 if (num_idents
> 1 && has_name_equals
)
5353 gfc_error ("Multiple identifiers provided with "
5354 "single NAME= specifier at %C");
5358 if (curr_binding_label
)
5359 /* Binding label given; store in temp holder till have sym. */
5360 *dest_label
= curr_binding_label
;
5363 /* No binding label given, and the NAME= specifier did not exist,
5364 which means there was no NAME="". */
5365 if (sym_name
!= NULL
&& has_name_equals
== 0)
5366 *dest_label
= IDENTIFIER_POINTER (get_identifier (sym_name
));
5373 /* Set the status of the given common block as being BIND(C) or not,
5374 depending on the given parameter, is_bind_c. */
5377 set_com_block_bind_c (gfc_common_head
*com_block
, int is_bind_c
)
5379 com_block
->is_bind_c
= is_bind_c
;
5384 /* Verify that the given gfc_typespec is for a C interoperable type. */
5387 gfc_verify_c_interop (gfc_typespec
*ts
)
5389 if (ts
->type
== BT_DERIVED
&& ts
->u
.derived
!= NULL
)
5390 return (ts
->u
.derived
->ts
.is_c_interop
|| ts
->u
.derived
->attr
.is_bind_c
)
5392 else if (ts
->type
== BT_CLASS
)
5394 else if (ts
->is_c_interop
!= 1 && ts
->type
!= BT_ASSUMED
)
5401 /* Verify that the variables of a given common block, which has been
5402 defined with the attribute specifier bind(c), to be of a C
5403 interoperable type. Errors will be reported here, if
5407 verify_com_block_vars_c_interop (gfc_common_head
*com_block
)
5409 gfc_symbol
*curr_sym
= NULL
;
5412 curr_sym
= com_block
->head
;
5414 /* Make sure we have at least one symbol. */
5415 if (curr_sym
== NULL
)
5418 /* Here we know we have a symbol, so we'll execute this loop
5422 /* The second to last param, 1, says this is in a common block. */
5423 retval
= verify_bind_c_sym (curr_sym
, &(curr_sym
->ts
), 1, com_block
);
5424 curr_sym
= curr_sym
->common_next
;
5425 } while (curr_sym
!= NULL
);
5431 /* Verify that a given BIND(C) symbol is C interoperable. If it is not,
5432 an appropriate error message is reported. */
5435 verify_bind_c_sym (gfc_symbol
*tmp_sym
, gfc_typespec
*ts
,
5436 int is_in_common
, gfc_common_head
*com_block
)
5438 bool bind_c_function
= false;
5441 if (tmp_sym
->attr
.function
&& tmp_sym
->attr
.is_bind_c
)
5442 bind_c_function
= true;
5444 if (tmp_sym
->attr
.function
&& tmp_sym
->result
!= NULL
)
5446 tmp_sym
= tmp_sym
->result
;
5447 /* Make sure it wasn't an implicitly typed result. */
5448 if (tmp_sym
->attr
.implicit_type
&& warn_c_binding_type
)
5450 gfc_warning (OPT_Wc_binding_type
,
5451 "Implicitly declared BIND(C) function %qs at "
5452 "%L may not be C interoperable", tmp_sym
->name
,
5453 &tmp_sym
->declared_at
);
5454 tmp_sym
->ts
.f90_type
= tmp_sym
->ts
.type
;
5455 /* Mark it as C interoperable to prevent duplicate warnings. */
5456 tmp_sym
->ts
.is_c_interop
= 1;
5457 tmp_sym
->attr
.is_c_interop
= 1;
5461 /* Here, we know we have the bind(c) attribute, so if we have
5462 enough type info, then verify that it's a C interop kind.
5463 The info could be in the symbol already, or possibly still in
5464 the given ts (current_ts), so look in both. */
5465 if (tmp_sym
->ts
.type
!= BT_UNKNOWN
|| ts
->type
!= BT_UNKNOWN
)
5467 if (!gfc_verify_c_interop (&(tmp_sym
->ts
)))
5469 /* See if we're dealing with a sym in a common block or not. */
5470 if (is_in_common
== 1 && warn_c_binding_type
)
5472 gfc_warning (OPT_Wc_binding_type
,
5473 "Variable %qs in common block %qs at %L "
5474 "may not be a C interoperable "
5475 "kind though common block %qs is BIND(C)",
5476 tmp_sym
->name
, com_block
->name
,
5477 &(tmp_sym
->declared_at
), com_block
->name
);
5481 if (tmp_sym
->ts
.type
== BT_DERIVED
|| ts
->type
== BT_DERIVED
)
5482 gfc_error ("Type declaration %qs at %L is not C "
5483 "interoperable but it is BIND(C)",
5484 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5485 else if (warn_c_binding_type
)
5486 gfc_warning (OPT_Wc_binding_type
, "Variable %qs at %L "
5487 "may not be a C interoperable "
5488 "kind but it is BIND(C)",
5489 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5493 /* Variables declared w/in a common block can't be bind(c)
5494 since there's no way for C to see these variables, so there's
5495 semantically no reason for the attribute. */
5496 if (is_in_common
== 1 && tmp_sym
->attr
.is_bind_c
== 1)
5498 gfc_error ("Variable %qs in common block %qs at "
5499 "%L cannot be declared with BIND(C) "
5500 "since it is not a global",
5501 tmp_sym
->name
, com_block
->name
,
5502 &(tmp_sym
->declared_at
));
5506 /* Scalar variables that are bind(c) can not have the pointer
5507 or allocatable attributes. */
5508 if (tmp_sym
->attr
.is_bind_c
== 1)
5510 if (tmp_sym
->attr
.pointer
== 1)
5512 gfc_error ("Variable %qs at %L cannot have both the "
5513 "POINTER and BIND(C) attributes",
5514 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5518 if (tmp_sym
->attr
.allocatable
== 1)
5520 gfc_error ("Variable %qs at %L cannot have both the "
5521 "ALLOCATABLE and BIND(C) attributes",
5522 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5528 /* If it is a BIND(C) function, make sure the return value is a
5529 scalar value. The previous tests in this function made sure
5530 the type is interoperable. */
5531 if (bind_c_function
&& tmp_sym
->as
!= NULL
)
5532 gfc_error ("Return type of BIND(C) function %qs at %L cannot "
5533 "be an array", tmp_sym
->name
, &(tmp_sym
->declared_at
));
5535 /* BIND(C) functions can not return a character string. */
5536 if (bind_c_function
&& tmp_sym
->ts
.type
== BT_CHARACTER
)
5537 if (tmp_sym
->ts
.u
.cl
== NULL
|| tmp_sym
->ts
.u
.cl
->length
== NULL
5538 || tmp_sym
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
5539 || mpz_cmp_si (tmp_sym
->ts
.u
.cl
->length
->value
.integer
, 1) != 0)
5540 gfc_error ("Return type of BIND(C) function %qs at %L cannot "
5541 "be a character string", tmp_sym
->name
,
5542 &(tmp_sym
->declared_at
));
5545 /* See if the symbol has been marked as private. If it has, make sure
5546 there is no binding label and warn the user if there is one. */
5547 if (tmp_sym
->attr
.access
== ACCESS_PRIVATE
5548 && tmp_sym
->binding_label
)
5549 /* Use gfc_warning_now because we won't say that the symbol fails
5550 just because of this. */
5551 gfc_warning_now (0, "Symbol %qs at %L is marked PRIVATE but has been "
5552 "given the binding label %qs", tmp_sym
->name
,
5553 &(tmp_sym
->declared_at
), tmp_sym
->binding_label
);
5559 /* Set the appropriate fields for a symbol that's been declared as
5560 BIND(C) (the is_bind_c flag and the binding label), and verify that
5561 the type is C interoperable. Errors are reported by the functions
5562 used to set/test these fields. */
5565 set_verify_bind_c_sym (gfc_symbol
*tmp_sym
, int num_idents
)
5569 /* TODO: Do we need to make sure the vars aren't marked private? */
5571 /* Set the is_bind_c bit in symbol_attribute. */
5572 gfc_add_is_bind_c (&(tmp_sym
->attr
), tmp_sym
->name
, &gfc_current_locus
, 0);
5574 if (!set_binding_label (&tmp_sym
->binding_label
, tmp_sym
->name
, num_idents
))
5581 /* Set the fields marking the given common block as BIND(C), including
5582 a binding label, and report any errors encountered. */
5585 set_verify_bind_c_com_block (gfc_common_head
*com_block
, int num_idents
)
5589 /* destLabel, common name, typespec (which may have binding label). */
5590 if (!set_binding_label (&com_block
->binding_label
, com_block
->name
,
5594 /* Set the given common block (com_block) to being bind(c) (1). */
5595 set_com_block_bind_c (com_block
, 1);
5601 /* Retrieve the list of one or more identifiers that the given bind(c)
5602 attribute applies to. */
5605 get_bind_c_idents (void)
5607 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5609 gfc_symbol
*tmp_sym
= NULL
;
5611 gfc_common_head
*com_block
= NULL
;
5613 if (gfc_match_name (name
) == MATCH_YES
)
5615 found_id
= MATCH_YES
;
5616 gfc_get_ha_symbol (name
, &tmp_sym
);
5618 else if (match_common_name (name
) == MATCH_YES
)
5620 found_id
= MATCH_YES
;
5621 com_block
= gfc_get_common (name
, 0);
5625 gfc_error ("Need either entity or common block name for "
5626 "attribute specification statement at %C");
5630 /* Save the current identifier and look for more. */
5633 /* Increment the number of identifiers found for this spec stmt. */
5636 /* Make sure we have a sym or com block, and verify that it can
5637 be bind(c). Set the appropriate field(s) and look for more
5639 if (tmp_sym
!= NULL
|| com_block
!= NULL
)
5641 if (tmp_sym
!= NULL
)
5643 if (!set_verify_bind_c_sym (tmp_sym
, num_idents
))
5648 if (!set_verify_bind_c_com_block (com_block
, num_idents
))
5652 /* Look to see if we have another identifier. */
5654 if (gfc_match_eos () == MATCH_YES
)
5655 found_id
= MATCH_NO
;
5656 else if (gfc_match_char (',') != MATCH_YES
)
5657 found_id
= MATCH_NO
;
5658 else if (gfc_match_name (name
) == MATCH_YES
)
5660 found_id
= MATCH_YES
;
5661 gfc_get_ha_symbol (name
, &tmp_sym
);
5663 else if (match_common_name (name
) == MATCH_YES
)
5665 found_id
= MATCH_YES
;
5666 com_block
= gfc_get_common (name
, 0);
5670 gfc_error ("Missing entity or common block name for "
5671 "attribute specification statement at %C");
5677 gfc_internal_error ("Missing symbol");
5679 } while (found_id
== MATCH_YES
);
5681 /* if we get here we were successful */
5686 /* Try and match a BIND(C) attribute specification statement. */
5689 gfc_match_bind_c_stmt (void)
5691 match found_match
= MATCH_NO
;
5696 /* This may not be necessary. */
5698 /* Clear the temporary binding label holder. */
5699 curr_binding_label
= NULL
;
5701 /* Look for the bind(c). */
5702 found_match
= gfc_match_bind_c (NULL
, true);
5704 if (found_match
== MATCH_YES
)
5706 if (!gfc_notify_std (GFC_STD_F2003
, "BIND(C) statement at %C"))
5709 /* Look for the :: now, but it is not required. */
5712 /* Get the identifier(s) that needs to be updated. This may need to
5713 change to hand the flag(s) for the attr specified so all identifiers
5714 found can have all appropriate parts updated (assuming that the same
5715 spec stmt can have multiple attrs, such as both bind(c) and
5717 if (!get_bind_c_idents ())
5718 /* Error message should have printed already. */
5726 /* Match a data declaration statement. */
5729 gfc_match_data_decl (void)
5735 type_param_spec_list
= NULL
;
5736 decl_type_param_list
= NULL
;
5738 num_idents_on_line
= 0;
5740 m
= gfc_match_decl_type_spec (¤t_ts
, 0);
5744 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
5745 && !gfc_comp_struct (gfc_current_state ()))
5747 sym
= gfc_use_derived (current_ts
.u
.derived
);
5755 current_ts
.u
.derived
= sym
;
5758 m
= match_attr_spec ();
5759 if (m
== MATCH_ERROR
)
5765 if (current_ts
.type
== BT_CLASS
5766 && current_ts
.u
.derived
->attr
.unlimited_polymorphic
)
5769 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
5770 && current_ts
.u
.derived
->components
== NULL
5771 && !current_ts
.u
.derived
->attr
.zero_comp
)
5774 if (current_attr
.pointer
&& gfc_comp_struct (gfc_current_state ()))
5777 if (current_attr
.allocatable
&& gfc_current_state () == COMP_DERIVED
5778 && current_ts
.u
.derived
== gfc_current_block ())
5781 gfc_find_symbol (current_ts
.u
.derived
->name
,
5782 current_ts
.u
.derived
->ns
, 1, &sym
);
5784 /* Any symbol that we find had better be a type definition
5785 which has its components defined, or be a structure definition
5786 actively being parsed. */
5787 if (sym
!= NULL
&& gfc_fl_struct (sym
->attr
.flavor
)
5788 && (current_ts
.u
.derived
->components
!= NULL
5789 || current_ts
.u
.derived
->attr
.zero_comp
5790 || current_ts
.u
.derived
== gfc_new_block
))
5793 gfc_error ("Derived type at %C has not been previously defined "
5794 "and so cannot appear in a derived type definition");
5800 /* If we have an old-style character declaration, and no new-style
5801 attribute specifications, then there a comma is optional between
5802 the type specification and the variable list. */
5803 if (m
== MATCH_NO
&& current_ts
.type
== BT_CHARACTER
&& old_char_selector
)
5804 gfc_match_char (',');
5806 /* Give the types/attributes to symbols that follow. Give the element
5807 a number so that repeat character length expressions can be copied. */
5811 num_idents_on_line
++;
5812 m
= variable_decl (elem
++);
5813 if (m
== MATCH_ERROR
)
5818 if (gfc_match_eos () == MATCH_YES
)
5820 if (gfc_match_char (',') != MATCH_YES
)
5824 if (!gfc_error_flag_test ())
5826 /* An anonymous structure declaration is unambiguous; if we matched one
5827 according to gfc_match_structure_decl, we need to return MATCH_YES
5828 here to avoid confusing the remaining matchers, even if there was an
5829 error during variable_decl. We must flush any such errors. Note this
5830 causes the parser to gracefully continue parsing the remaining input
5831 as a structure body, which likely follows. */
5832 if (current_ts
.type
== BT_DERIVED
&& current_ts
.u
.derived
5833 && gfc_fl_struct (current_ts
.u
.derived
->attr
.flavor
))
5835 gfc_error_now ("Syntax error in anonymous structure declaration"
5837 /* Skip the bad variable_decl and line up for the start of the
5839 gfc_error_recovery ();
5844 gfc_error ("Syntax error in data declaration at %C");
5849 gfc_free_data_all (gfc_current_ns
);
5852 if (saved_kind_expr
)
5853 gfc_free_expr (saved_kind_expr
);
5854 if (type_param_spec_list
)
5855 gfc_free_actual_arglist (type_param_spec_list
);
5856 if (decl_type_param_list
)
5857 gfc_free_actual_arglist (decl_type_param_list
);
5858 saved_kind_expr
= NULL
;
5859 gfc_free_array_spec (current_as
);
5865 /* Match a prefix associated with a function or subroutine
5866 declaration. If the typespec pointer is nonnull, then a typespec
5867 can be matched. Note that if nothing matches, MATCH_YES is
5868 returned (the null string was matched). */
5871 gfc_match_prefix (gfc_typespec
*ts
)
5877 gfc_clear_attr (¤t_attr
);
5879 seen_impure
= false;
5881 gcc_assert (!gfc_matching_prefix
);
5882 gfc_matching_prefix
= true;
5886 found_prefix
= false;
5888 /* MODULE is a prefix like PURE, ELEMENTAL, etc., having a
5889 corresponding attribute seems natural and distinguishes these
5890 procedures from procedure types of PROC_MODULE, which these are
5892 if (gfc_match ("module% ") == MATCH_YES
)
5894 if (!gfc_notify_std (GFC_STD_F2008
, "MODULE prefix at %C"))
5897 current_attr
.module_procedure
= 1;
5898 found_prefix
= true;
5901 if (!seen_type
&& ts
!= NULL
5902 && gfc_match_decl_type_spec (ts
, 0) == MATCH_YES
5903 && gfc_match_space () == MATCH_YES
)
5907 found_prefix
= true;
5910 if (gfc_match ("elemental% ") == MATCH_YES
)
5912 if (!gfc_add_elemental (¤t_attr
, NULL
))
5915 found_prefix
= true;
5918 if (gfc_match ("pure% ") == MATCH_YES
)
5920 if (!gfc_add_pure (¤t_attr
, NULL
))
5923 found_prefix
= true;
5926 if (gfc_match ("recursive% ") == MATCH_YES
)
5928 if (!gfc_add_recursive (¤t_attr
, NULL
))
5931 found_prefix
= true;
5934 /* IMPURE is a somewhat special case, as it needs not set an actual
5935 attribute but rather only prevents ELEMENTAL routines from being
5936 automatically PURE. */
5937 if (gfc_match ("impure% ") == MATCH_YES
)
5939 if (!gfc_notify_std (GFC_STD_F2008
, "IMPURE procedure at %C"))
5943 found_prefix
= true;
5946 while (found_prefix
);
5948 /* IMPURE and PURE must not both appear, of course. */
5949 if (seen_impure
&& current_attr
.pure
)
5951 gfc_error ("PURE and IMPURE must not appear both at %C");
5955 /* If IMPURE it not seen but the procedure is ELEMENTAL, mark it as PURE. */
5956 if (!seen_impure
&& current_attr
.elemental
&& !current_attr
.pure
)
5958 if (!gfc_add_pure (¤t_attr
, NULL
))
5962 /* At this point, the next item is not a prefix. */
5963 gcc_assert (gfc_matching_prefix
);
5965 gfc_matching_prefix
= false;
5969 gcc_assert (gfc_matching_prefix
);
5970 gfc_matching_prefix
= false;
5975 /* Copy attributes matched by gfc_match_prefix() to attributes on a symbol. */
5978 copy_prefix (symbol_attribute
*dest
, locus
*where
)
5980 if (dest
->module_procedure
)
5982 if (current_attr
.elemental
)
5983 dest
->elemental
= 1;
5985 if (current_attr
.pure
)
5988 if (current_attr
.recursive
)
5989 dest
->recursive
= 1;
5991 /* Module procedures are unusual in that the 'dest' is copied from
5992 the interface declaration. However, this is an oportunity to
5993 check that the submodule declaration is compliant with the
5995 if (dest
->elemental
&& !current_attr
.elemental
)
5997 gfc_error ("ELEMENTAL prefix in MODULE PROCEDURE interface is "
5998 "missing at %L", where
);
6002 if (dest
->pure
&& !current_attr
.pure
)
6004 gfc_error ("PURE prefix in MODULE PROCEDURE interface is "
6005 "missing at %L", where
);
6009 if (dest
->recursive
&& !current_attr
.recursive
)
6011 gfc_error ("RECURSIVE prefix in MODULE PROCEDURE interface is "
6012 "missing at %L", where
);
6019 if (current_attr
.elemental
&& !gfc_add_elemental (dest
, where
))
6022 if (current_attr
.pure
&& !gfc_add_pure (dest
, where
))
6025 if (current_attr
.recursive
&& !gfc_add_recursive (dest
, where
))
6032 /* Match a formal argument list or, if typeparam is true, a
6033 type_param_name_list. */
6036 gfc_match_formal_arglist (gfc_symbol
*progname
, int st_flag
,
6037 int null_flag
, bool typeparam
)
6039 gfc_formal_arglist
*head
, *tail
, *p
, *q
;
6040 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6043 gfc_formal_arglist
*formal
= NULL
;
6047 /* Keep the interface formal argument list and null it so that the
6048 matching for the new declaration can be done. The numbers and
6049 names of the arguments are checked here. The interface formal
6050 arguments are retained in formal_arglist and the characteristics
6051 are compared in resolve.c(resolve_fl_procedure). See the remark
6052 in get_proc_name about the eventual need to copy the formal_arglist
6053 and populate the formal namespace of the interface symbol. */
6054 if (progname
->attr
.module_procedure
6055 && progname
->attr
.host_assoc
)
6057 formal
= progname
->formal
;
6058 progname
->formal
= NULL
;
6061 if (gfc_match_char ('(') != MATCH_YES
)
6068 if (gfc_match_char (')') == MATCH_YES
)
6073 if (gfc_match_char ('*') == MATCH_YES
)
6076 if (!typeparam
&& !gfc_notify_std (GFC_STD_F95_OBS
,
6077 "Alternate-return argument at %C"))
6083 gfc_error_now ("A parameter name is required at %C");
6087 m
= gfc_match_name (name
);
6091 gfc_error_now ("A parameter name is required at %C");
6095 if (!typeparam
&& gfc_get_symbol (name
, NULL
, &sym
))
6098 && gfc_get_symbol (name
, progname
->f2k_derived
, &sym
))
6102 p
= gfc_get_formal_arglist ();
6114 /* We don't add the VARIABLE flavor because the name could be a
6115 dummy procedure. We don't apply these attributes to formal
6116 arguments of statement functions. */
6117 if (sym
!= NULL
&& !st_flag
6118 && (!gfc_add_dummy(&sym
->attr
, sym
->name
, NULL
)
6119 || !gfc_missing_attr (&sym
->attr
, NULL
)))
6125 /* The name of a program unit can be in a different namespace,
6126 so check for it explicitly. After the statement is accepted,
6127 the name is checked for especially in gfc_get_symbol(). */
6128 if (gfc_new_block
!= NULL
&& sym
!= NULL
&& !typeparam
6129 && strcmp (sym
->name
, gfc_new_block
->name
) == 0)
6131 gfc_error ("Name %qs at %C is the name of the procedure",
6137 if (gfc_match_char (')') == MATCH_YES
)
6140 m
= gfc_match_char (',');
6144 gfc_error_now ("Expected parameter list in type declaration "
6147 gfc_error ("Unexpected junk in formal argument list at %C");
6153 /* Check for duplicate symbols in the formal argument list. */
6156 for (p
= head
; p
->next
; p
= p
->next
)
6161 for (q
= p
->next
; q
; q
= q
->next
)
6162 if (p
->sym
== q
->sym
)
6165 gfc_error_now ("Duplicate name %qs in parameter "
6166 "list at %C", p
->sym
->name
);
6168 gfc_error ("Duplicate symbol %qs in formal argument "
6169 "list at %C", p
->sym
->name
);
6177 if (!gfc_add_explicit_interface (progname
, IFSRC_DECL
, head
, NULL
))
6183 /* gfc_error_now used in following and return with MATCH_YES because
6184 doing otherwise results in a cascade of extraneous errors and in
6185 some cases an ICE in symbol.c(gfc_release_symbol). */
6186 if (progname
->attr
.module_procedure
&& progname
->attr
.host_assoc
)
6188 bool arg_count_mismatch
= false;
6190 if (!formal
&& head
)
6191 arg_count_mismatch
= true;
6193 /* Abbreviated module procedure declaration is not meant to have any
6194 formal arguments! */
6195 if (!progname
->abr_modproc_decl
&& formal
&& !head
)
6196 arg_count_mismatch
= true;
6198 for (p
= formal
, q
= head
; p
&& q
; p
= p
->next
, q
= q
->next
)
6200 if ((p
->next
!= NULL
&& q
->next
== NULL
)
6201 || (p
->next
== NULL
&& q
->next
!= NULL
))
6202 arg_count_mismatch
= true;
6203 else if ((p
->sym
== NULL
&& q
->sym
== NULL
)
6204 || strcmp (p
->sym
->name
, q
->sym
->name
) == 0)
6207 gfc_error_now ("Mismatch in MODULE PROCEDURE formal "
6208 "argument names (%s/%s) at %C",
6209 p
->sym
->name
, q
->sym
->name
);
6212 if (arg_count_mismatch
)
6213 gfc_error_now ("Mismatch in number of MODULE PROCEDURE "
6214 "formal arguments at %C");
6220 gfc_free_formal_arglist (head
);
6225 /* Match a RESULT specification following a function declaration or
6226 ENTRY statement. Also matches the end-of-statement. */
6229 match_result (gfc_symbol
*function
, gfc_symbol
**result
)
6231 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6235 if (gfc_match (" result (") != MATCH_YES
)
6238 m
= gfc_match_name (name
);
6242 /* Get the right paren, and that's it because there could be the
6243 bind(c) attribute after the result clause. */
6244 if (gfc_match_char (')') != MATCH_YES
)
6246 /* TODO: should report the missing right paren here. */
6250 if (strcmp (function
->name
, name
) == 0)
6252 gfc_error ("RESULT variable at %C must be different than function name");
6256 if (gfc_get_symbol (name
, NULL
, &r
))
6259 if (!gfc_add_result (&r
->attr
, r
->name
, NULL
))
6268 /* Match a function suffix, which could be a combination of a result
6269 clause and BIND(C), either one, or neither. The draft does not
6270 require them to come in a specific order. */
6273 gfc_match_suffix (gfc_symbol
*sym
, gfc_symbol
**result
)
6275 match is_bind_c
; /* Found bind(c). */
6276 match is_result
; /* Found result clause. */
6277 match found_match
; /* Status of whether we've found a good match. */
6278 char peek_char
; /* Character we're going to peek at. */
6279 bool allow_binding_name
;
6281 /* Initialize to having found nothing. */
6282 found_match
= MATCH_NO
;
6283 is_bind_c
= MATCH_NO
;
6284 is_result
= MATCH_NO
;
6286 /* Get the next char to narrow between result and bind(c). */
6287 gfc_gobble_whitespace ();
6288 peek_char
= gfc_peek_ascii_char ();
6290 /* C binding names are not allowed for internal procedures. */
6291 if (gfc_current_state () == COMP_CONTAINS
6292 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
6293 allow_binding_name
= false;
6295 allow_binding_name
= true;
6300 /* Look for result clause. */
6301 is_result
= match_result (sym
, result
);
6302 if (is_result
== MATCH_YES
)
6304 /* Now see if there is a bind(c) after it. */
6305 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
6306 /* We've found the result clause and possibly bind(c). */
6307 found_match
= MATCH_YES
;
6310 /* This should only be MATCH_ERROR. */
6311 found_match
= is_result
;
6314 /* Look for bind(c) first. */
6315 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
6316 if (is_bind_c
== MATCH_YES
)
6318 /* Now see if a result clause followed it. */
6319 is_result
= match_result (sym
, result
);
6320 found_match
= MATCH_YES
;
6324 /* Should only be a MATCH_ERROR if we get here after seeing 'b'. */
6325 found_match
= MATCH_ERROR
;
6329 gfc_error ("Unexpected junk after function declaration at %C");
6330 found_match
= MATCH_ERROR
;
6334 if (is_bind_c
== MATCH_YES
)
6336 /* Fortran 2008 draft allows BIND(C) for internal procedures. */
6337 if (gfc_current_state () == COMP_CONTAINS
6338 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
6339 && !gfc_notify_std (GFC_STD_F2008
, "BIND(C) attribute "
6340 "at %L may not be specified for an internal "
6341 "procedure", &gfc_current_locus
))
6344 if (!gfc_add_is_bind_c (&(sym
->attr
), sym
->name
, &gfc_current_locus
, 1))
6352 /* Procedure pointer return value without RESULT statement:
6353 Add "hidden" result variable named "ppr@". */
6356 add_hidden_procptr_result (gfc_symbol
*sym
)
6360 if (gfc_notification_std (GFC_STD_F2003
) == ERROR
)
6363 /* First usage case: PROCEDURE and EXTERNAL statements. */
6364 case1
= gfc_current_state () == COMP_FUNCTION
&& gfc_current_block ()
6365 && strcmp (gfc_current_block ()->name
, sym
->name
) == 0
6366 && sym
->attr
.external
;
6367 /* Second usage case: INTERFACE statements. */
6368 case2
= gfc_current_state () == COMP_INTERFACE
&& gfc_state_stack
->previous
6369 && gfc_state_stack
->previous
->state
== COMP_FUNCTION
6370 && strcmp (gfc_state_stack
->previous
->sym
->name
, sym
->name
) == 0;
6376 gfc_get_sym_tree ("ppr@", gfc_current_ns
, &stree
, false);
6380 gfc_get_sym_tree ("ppr@", gfc_current_ns
->parent
, &stree
, false);
6381 st2
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "ppr@");
6382 st2
->n
.sym
= stree
->n
.sym
;
6383 stree
->n
.sym
->refs
++;
6385 sym
->result
= stree
->n
.sym
;
6387 sym
->result
->attr
.proc_pointer
= sym
->attr
.proc_pointer
;
6388 sym
->result
->attr
.pointer
= sym
->attr
.pointer
;
6389 sym
->result
->attr
.external
= sym
->attr
.external
;
6390 sym
->result
->attr
.referenced
= sym
->attr
.referenced
;
6391 sym
->result
->ts
= sym
->ts
;
6392 sym
->attr
.proc_pointer
= 0;
6393 sym
->attr
.pointer
= 0;
6394 sym
->attr
.external
= 0;
6395 if (sym
->result
->attr
.external
&& sym
->result
->attr
.pointer
)
6397 sym
->result
->attr
.pointer
= 0;
6398 sym
->result
->attr
.proc_pointer
= 1;
6401 return gfc_add_result (&sym
->result
->attr
, sym
->result
->name
, NULL
);
6403 /* POINTER after PROCEDURE/EXTERNAL/INTERFACE statement. */
6404 else if (sym
->attr
.function
&& !sym
->attr
.external
&& sym
->attr
.pointer
6405 && sym
->result
&& sym
->result
!= sym
&& sym
->result
->attr
.external
6406 && sym
== gfc_current_ns
->proc_name
6407 && sym
== sym
->result
->ns
->proc_name
6408 && strcmp ("ppr@", sym
->result
->name
) == 0)
6410 sym
->result
->attr
.proc_pointer
= 1;
6411 sym
->attr
.pointer
= 0;
6419 /* Match the interface for a PROCEDURE declaration,
6420 including brackets (R1212). */
6423 match_procedure_interface (gfc_symbol
**proc_if
)
6427 locus old_loc
, entry_loc
;
6428 gfc_namespace
*old_ns
= gfc_current_ns
;
6429 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6431 old_loc
= entry_loc
= gfc_current_locus
;
6432 gfc_clear_ts (¤t_ts
);
6434 if (gfc_match (" (") != MATCH_YES
)
6436 gfc_current_locus
= entry_loc
;
6440 /* Get the type spec. for the procedure interface. */
6441 old_loc
= gfc_current_locus
;
6442 m
= gfc_match_decl_type_spec (¤t_ts
, 0);
6443 gfc_gobble_whitespace ();
6444 if (m
== MATCH_YES
|| (m
== MATCH_NO
&& gfc_peek_ascii_char () == ')'))
6447 if (m
== MATCH_ERROR
)
6450 /* Procedure interface is itself a procedure. */
6451 gfc_current_locus
= old_loc
;
6452 m
= gfc_match_name (name
);
6454 /* First look to see if it is already accessible in the current
6455 namespace because it is use associated or contained. */
6457 if (gfc_find_sym_tree (name
, NULL
, 0, &st
))
6460 /* If it is still not found, then try the parent namespace, if it
6461 exists and create the symbol there if it is still not found. */
6462 if (gfc_current_ns
->parent
)
6463 gfc_current_ns
= gfc_current_ns
->parent
;
6464 if (st
== NULL
&& gfc_get_ha_sym_tree (name
, &st
))
6467 gfc_current_ns
= old_ns
;
6468 *proc_if
= st
->n
.sym
;
6473 /* Resolve interface if possible. That way, attr.procedure is only set
6474 if it is declared by a later procedure-declaration-stmt, which is
6475 invalid per F08:C1216 (cf. resolve_procedure_interface). */
6476 while ((*proc_if
)->ts
.interface
6477 && *proc_if
!= (*proc_if
)->ts
.interface
)
6478 *proc_if
= (*proc_if
)->ts
.interface
;
6480 if ((*proc_if
)->attr
.flavor
== FL_UNKNOWN
6481 && (*proc_if
)->ts
.type
== BT_UNKNOWN
6482 && !gfc_add_flavor (&(*proc_if
)->attr
, FL_PROCEDURE
,
6483 (*proc_if
)->name
, NULL
))
6488 if (gfc_match (" )") != MATCH_YES
)
6490 gfc_current_locus
= entry_loc
;
6498 /* Match a PROCEDURE declaration (R1211). */
6501 match_procedure_decl (void)
6504 gfc_symbol
*sym
, *proc_if
= NULL
;
6506 gfc_expr
*initializer
= NULL
;
6508 /* Parse interface (with brackets). */
6509 m
= match_procedure_interface (&proc_if
);
6513 /* Parse attributes (with colons). */
6514 m
= match_attr_spec();
6515 if (m
== MATCH_ERROR
)
6518 if (proc_if
&& proc_if
->attr
.is_bind_c
&& !current_attr
.is_bind_c
)
6520 current_attr
.is_bind_c
= 1;
6521 has_name_equals
= 0;
6522 curr_binding_label
= NULL
;
6525 /* Get procedure symbols. */
6528 m
= gfc_match_symbol (&sym
, 0);
6531 else if (m
== MATCH_ERROR
)
6534 /* Add current_attr to the symbol attributes. */
6535 if (!gfc_copy_attr (&sym
->attr
, ¤t_attr
, NULL
))
6538 if (sym
->attr
.is_bind_c
)
6540 /* Check for C1218. */
6541 if (!proc_if
|| !proc_if
->attr
.is_bind_c
)
6543 gfc_error ("BIND(C) attribute at %C requires "
6544 "an interface with BIND(C)");
6547 /* Check for C1217. */
6548 if (has_name_equals
&& sym
->attr
.pointer
)
6550 gfc_error ("BIND(C) procedure with NAME may not have "
6551 "POINTER attribute at %C");
6554 if (has_name_equals
&& sym
->attr
.dummy
)
6556 gfc_error ("Dummy procedure at %C may not have "
6557 "BIND(C) attribute with NAME");
6560 /* Set binding label for BIND(C). */
6561 if (!set_binding_label (&sym
->binding_label
, sym
->name
, num
))
6565 if (!gfc_add_external (&sym
->attr
, NULL
))
6568 if (add_hidden_procptr_result (sym
))
6571 if (!gfc_add_proc (&sym
->attr
, sym
->name
, NULL
))
6574 /* Set interface. */
6575 if (proc_if
!= NULL
)
6577 if (sym
->ts
.type
!= BT_UNKNOWN
)
6579 gfc_error ("Procedure %qs at %L already has basic type of %s",
6580 sym
->name
, &gfc_current_locus
,
6581 gfc_basic_typename (sym
->ts
.type
));
6584 sym
->ts
.interface
= proc_if
;
6585 sym
->attr
.untyped
= 1;
6586 sym
->attr
.if_source
= IFSRC_IFBODY
;
6588 else if (current_ts
.type
!= BT_UNKNOWN
)
6590 if (!gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
6592 sym
->ts
.interface
= gfc_new_symbol ("", gfc_current_ns
);
6593 sym
->ts
.interface
->ts
= current_ts
;
6594 sym
->ts
.interface
->attr
.flavor
= FL_PROCEDURE
;
6595 sym
->ts
.interface
->attr
.function
= 1;
6596 sym
->attr
.function
= 1;
6597 sym
->attr
.if_source
= IFSRC_UNKNOWN
;
6600 if (gfc_match (" =>") == MATCH_YES
)
6602 if (!current_attr
.pointer
)
6604 gfc_error ("Initialization at %C isn't for a pointer variable");
6609 m
= match_pointer_init (&initializer
, 1);
6613 if (!add_init_expr_to_sym (sym
->name
, &initializer
, &gfc_current_locus
))
6618 if (gfc_match_eos () == MATCH_YES
)
6620 if (gfc_match_char (',') != MATCH_YES
)
6625 gfc_error ("Syntax error in PROCEDURE statement at %C");
6629 /* Free stuff up and return. */
6630 gfc_free_expr (initializer
);
6636 match_binding_attributes (gfc_typebound_proc
* ba
, bool generic
, bool ppc
);
6639 /* Match a procedure pointer component declaration (R445). */
6642 match_ppc_decl (void)
6645 gfc_symbol
*proc_if
= NULL
;
6649 gfc_expr
*initializer
= NULL
;
6650 gfc_typebound_proc
* tb
;
6651 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6653 /* Parse interface (with brackets). */
6654 m
= match_procedure_interface (&proc_if
);
6658 /* Parse attributes. */
6659 tb
= XCNEW (gfc_typebound_proc
);
6660 tb
->where
= gfc_current_locus
;
6661 m
= match_binding_attributes (tb
, false, true);
6662 if (m
== MATCH_ERROR
)
6665 gfc_clear_attr (¤t_attr
);
6666 current_attr
.procedure
= 1;
6667 current_attr
.proc_pointer
= 1;
6668 current_attr
.access
= tb
->access
;
6669 current_attr
.flavor
= FL_PROCEDURE
;
6671 /* Match the colons (required). */
6672 if (gfc_match (" ::") != MATCH_YES
)
6674 gfc_error ("Expected %<::%> after binding-attributes at %C");
6678 /* Check for C450. */
6679 if (!tb
->nopass
&& proc_if
== NULL
)
6681 gfc_error("NOPASS or explicit interface required at %C");
6685 if (!gfc_notify_std (GFC_STD_F2003
, "Procedure pointer component at %C"))
6688 /* Match PPC names. */
6692 m
= gfc_match_name (name
);
6695 else if (m
== MATCH_ERROR
)
6698 if (!gfc_add_component (gfc_current_block(), name
, &c
))
6701 /* Add current_attr to the symbol attributes. */
6702 if (!gfc_copy_attr (&c
->attr
, ¤t_attr
, NULL
))
6705 if (!gfc_add_external (&c
->attr
, NULL
))
6708 if (!gfc_add_proc (&c
->attr
, name
, NULL
))
6715 c
->tb
= XCNEW (gfc_typebound_proc
);
6716 c
->tb
->where
= gfc_current_locus
;
6720 /* Set interface. */
6721 if (proc_if
!= NULL
)
6723 c
->ts
.interface
= proc_if
;
6724 c
->attr
.untyped
= 1;
6725 c
->attr
.if_source
= IFSRC_IFBODY
;
6727 else if (ts
.type
!= BT_UNKNOWN
)
6730 c
->ts
.interface
= gfc_new_symbol ("", gfc_current_ns
);
6731 c
->ts
.interface
->result
= c
->ts
.interface
;
6732 c
->ts
.interface
->ts
= ts
;
6733 c
->ts
.interface
->attr
.flavor
= FL_PROCEDURE
;
6734 c
->ts
.interface
->attr
.function
= 1;
6735 c
->attr
.function
= 1;
6736 c
->attr
.if_source
= IFSRC_UNKNOWN
;
6739 if (gfc_match (" =>") == MATCH_YES
)
6741 m
= match_pointer_init (&initializer
, 1);
6744 gfc_free_expr (initializer
);
6747 c
->initializer
= initializer
;
6750 if (gfc_match_eos () == MATCH_YES
)
6752 if (gfc_match_char (',') != MATCH_YES
)
6757 gfc_error ("Syntax error in procedure pointer component at %C");
6762 /* Match a PROCEDURE declaration inside an interface (R1206). */
6765 match_procedure_in_interface (void)
6769 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6772 if (current_interface
.type
== INTERFACE_NAMELESS
6773 || current_interface
.type
== INTERFACE_ABSTRACT
)
6775 gfc_error ("PROCEDURE at %C must be in a generic interface");
6779 /* Check if the F2008 optional double colon appears. */
6780 gfc_gobble_whitespace ();
6781 old_locus
= gfc_current_locus
;
6782 if (gfc_match ("::") == MATCH_YES
)
6784 if (!gfc_notify_std (GFC_STD_F2008
, "double colon in "
6785 "MODULE PROCEDURE statement at %L", &old_locus
))
6789 gfc_current_locus
= old_locus
;
6793 m
= gfc_match_name (name
);
6796 else if (m
== MATCH_ERROR
)
6798 if (gfc_get_symbol (name
, gfc_current_ns
->parent
, &sym
))
6801 if (!gfc_add_interface (sym
))
6804 if (gfc_match_eos () == MATCH_YES
)
6806 if (gfc_match_char (',') != MATCH_YES
)
6813 gfc_error ("Syntax error in PROCEDURE statement at %C");
6818 /* General matcher for PROCEDURE declarations. */
6820 static match
match_procedure_in_type (void);
6823 gfc_match_procedure (void)
6827 switch (gfc_current_state ())
6832 case COMP_SUBMODULE
:
6833 case COMP_SUBROUTINE
:
6836 m
= match_procedure_decl ();
6838 case COMP_INTERFACE
:
6839 m
= match_procedure_in_interface ();
6842 m
= match_ppc_decl ();
6844 case COMP_DERIVED_CONTAINS
:
6845 m
= match_procedure_in_type ();
6854 if (!gfc_notify_std (GFC_STD_F2003
, "PROCEDURE statement at %C"))
6861 /* Warn if a matched procedure has the same name as an intrinsic; this is
6862 simply a wrapper around gfc_warn_intrinsic_shadow that interprets the current
6863 parser-state-stack to find out whether we're in a module. */
6866 do_warn_intrinsic_shadow (const gfc_symbol
* sym
, bool func
)
6870 in_module
= (gfc_state_stack
->previous
6871 && (gfc_state_stack
->previous
->state
== COMP_MODULE
6872 || gfc_state_stack
->previous
->state
== COMP_SUBMODULE
));
6874 gfc_warn_intrinsic_shadow (sym
, in_module
, func
);
6878 /* Match a function declaration. */
6881 gfc_match_function_decl (void)
6883 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6884 gfc_symbol
*sym
, *result
;
6888 match found_match
; /* Status returned by match func. */
6890 if (gfc_current_state () != COMP_NONE
6891 && gfc_current_state () != COMP_INTERFACE
6892 && gfc_current_state () != COMP_CONTAINS
)
6895 gfc_clear_ts (¤t_ts
);
6897 old_loc
= gfc_current_locus
;
6899 m
= gfc_match_prefix (¤t_ts
);
6902 gfc_current_locus
= old_loc
;
6906 if (gfc_match ("function% %n", name
) != MATCH_YES
)
6908 gfc_current_locus
= old_loc
;
6912 if (get_proc_name (name
, &sym
, false))
6915 if (add_hidden_procptr_result (sym
))
6918 if (current_attr
.module_procedure
)
6919 sym
->attr
.module_procedure
= 1;
6921 gfc_new_block
= sym
;
6923 m
= gfc_match_formal_arglist (sym
, 0, 0);
6926 gfc_error ("Expected formal argument list in function "
6927 "definition at %C");
6931 else if (m
== MATCH_ERROR
)
6936 /* According to the draft, the bind(c) and result clause can
6937 come in either order after the formal_arg_list (i.e., either
6938 can be first, both can exist together or by themselves or neither
6939 one). Therefore, the match_result can't match the end of the
6940 string, and check for the bind(c) or result clause in either order. */
6941 found_match
= gfc_match_eos ();
6943 /* Make sure that it isn't already declared as BIND(C). If it is, it
6944 must have been marked BIND(C) with a BIND(C) attribute and that is
6945 not allowed for procedures. */
6946 if (sym
->attr
.is_bind_c
== 1)
6948 sym
->attr
.is_bind_c
= 0;
6949 if (sym
->old_symbol
!= NULL
)
6950 gfc_error_now ("BIND(C) attribute at %L can only be used for "
6951 "variables or common blocks",
6952 &(sym
->old_symbol
->declared_at
));
6954 gfc_error_now ("BIND(C) attribute at %L can only be used for "
6955 "variables or common blocks", &gfc_current_locus
);
6958 if (found_match
!= MATCH_YES
)
6960 /* If we haven't found the end-of-statement, look for a suffix. */
6961 suffix_match
= gfc_match_suffix (sym
, &result
);
6962 if (suffix_match
== MATCH_YES
)
6963 /* Need to get the eos now. */
6964 found_match
= gfc_match_eos ();
6966 found_match
= suffix_match
;
6969 if(found_match
!= MATCH_YES
)
6973 /* Make changes to the symbol. */
6976 if (!gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
6979 if (!gfc_missing_attr (&sym
->attr
, NULL
))
6982 if (!copy_prefix (&sym
->attr
, &sym
->declared_at
))
6984 if(!sym
->attr
.module_procedure
)
6990 /* Delay matching the function characteristics until after the
6991 specification block by signalling kind=-1. */
6992 sym
->declared_at
= old_loc
;
6993 if (current_ts
.type
!= BT_UNKNOWN
)
6994 current_ts
.kind
= -1;
6996 current_ts
.kind
= 0;
7000 if (current_ts
.type
!= BT_UNKNOWN
7001 && !gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
7007 if (current_ts
.type
!= BT_UNKNOWN
7008 && !gfc_add_type (result
, ¤t_ts
, &gfc_current_locus
))
7010 sym
->result
= result
;
7013 /* Warn if this procedure has the same name as an intrinsic. */
7014 do_warn_intrinsic_shadow (sym
, true);
7020 gfc_current_locus
= old_loc
;
7025 /* This is mostly a copy of parse.c(add_global_procedure) but modified to
7026 pass the name of the entry, rather than the gfc_current_block name, and
7027 to return false upon finding an existing global entry. */
7030 add_global_entry (const char *name
, const char *binding_label
, bool sub
,
7034 enum gfc_symbol_type type
;
7036 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
7038 /* Only in Fortran 2003: For procedures with a binding label also the Fortran
7039 name is a global identifier. */
7040 if (!binding_label
|| gfc_notification_std (GFC_STD_F2008
))
7042 s
= gfc_get_gsymbol (name
);
7044 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= type
))
7046 gfc_global_used (s
, where
);
7055 s
->ns
= gfc_current_ns
;
7059 /* Don't add the symbol multiple times. */
7061 && (!gfc_notification_std (GFC_STD_F2008
)
7062 || strcmp (name
, binding_label
) != 0))
7064 s
= gfc_get_gsymbol (binding_label
);
7066 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= type
))
7068 gfc_global_used (s
, where
);
7075 s
->binding_label
= binding_label
;
7078 s
->ns
= gfc_current_ns
;
7086 /* Match an ENTRY statement. */
7089 gfc_match_entry (void)
7094 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7095 gfc_compile_state state
;
7099 bool module_procedure
;
7103 m
= gfc_match_name (name
);
7107 if (!gfc_notify_std (GFC_STD_F2008_OBS
, "ENTRY statement at %C"))
7110 state
= gfc_current_state ();
7111 if (state
!= COMP_SUBROUTINE
&& state
!= COMP_FUNCTION
)
7116 gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
7119 gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
7121 case COMP_SUBMODULE
:
7122 gfc_error ("ENTRY statement at %C cannot appear within a SUBMODULE");
7124 case COMP_BLOCK_DATA
:
7125 gfc_error ("ENTRY statement at %C cannot appear within "
7128 case COMP_INTERFACE
:
7129 gfc_error ("ENTRY statement at %C cannot appear within "
7132 case COMP_STRUCTURE
:
7133 gfc_error ("ENTRY statement at %C cannot appear within "
7134 "a STRUCTURE block");
7137 gfc_error ("ENTRY statement at %C cannot appear within "
7138 "a DERIVED TYPE block");
7141 gfc_error ("ENTRY statement at %C cannot appear within "
7142 "an IF-THEN block");
7145 case COMP_DO_CONCURRENT
:
7146 gfc_error ("ENTRY statement at %C cannot appear within "
7150 gfc_error ("ENTRY statement at %C cannot appear within "
7154 gfc_error ("ENTRY statement at %C cannot appear within "
7158 gfc_error ("ENTRY statement at %C cannot appear within "
7162 gfc_error ("ENTRY statement at %C cannot appear within "
7163 "a contained subprogram");
7166 gfc_error ("Unexpected ENTRY statement at %C");
7171 if ((state
== COMP_SUBROUTINE
|| state
== COMP_FUNCTION
)
7172 && gfc_state_stack
->previous
->state
== COMP_INTERFACE
)
7174 gfc_error ("ENTRY statement at %C cannot appear within an INTERFACE");
7178 module_procedure
= gfc_current_ns
->parent
!= NULL
7179 && gfc_current_ns
->parent
->proc_name
7180 && gfc_current_ns
->parent
->proc_name
->attr
.flavor
7183 if (gfc_current_ns
->parent
!= NULL
7184 && gfc_current_ns
->parent
->proc_name
7185 && !module_procedure
)
7187 gfc_error("ENTRY statement at %C cannot appear in a "
7188 "contained procedure");
7192 /* Module function entries need special care in get_proc_name
7193 because previous references within the function will have
7194 created symbols attached to the current namespace. */
7195 if (get_proc_name (name
, &entry
,
7196 gfc_current_ns
->parent
!= NULL
7197 && module_procedure
))
7200 proc
= gfc_current_block ();
7202 /* Make sure that it isn't already declared as BIND(C). If it is, it
7203 must have been marked BIND(C) with a BIND(C) attribute and that is
7204 not allowed for procedures. */
7205 if (entry
->attr
.is_bind_c
== 1)
7207 entry
->attr
.is_bind_c
= 0;
7208 if (entry
->old_symbol
!= NULL
)
7209 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7210 "variables or common blocks",
7211 &(entry
->old_symbol
->declared_at
));
7213 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7214 "variables or common blocks", &gfc_current_locus
);
7217 /* Check what next non-whitespace character is so we can tell if there
7218 is the required parens if we have a BIND(C). */
7219 old_loc
= gfc_current_locus
;
7220 gfc_gobble_whitespace ();
7221 peek_char
= gfc_peek_ascii_char ();
7223 if (state
== COMP_SUBROUTINE
)
7225 m
= gfc_match_formal_arglist (entry
, 0, 1);
7229 /* Call gfc_match_bind_c with allow_binding_name = true as ENTRY can
7230 never be an internal procedure. */
7231 is_bind_c
= gfc_match_bind_c (entry
, true);
7232 if (is_bind_c
== MATCH_ERROR
)
7234 if (is_bind_c
== MATCH_YES
)
7236 if (peek_char
!= '(')
7238 gfc_error ("Missing required parentheses before BIND(C) at %C");
7241 if (!gfc_add_is_bind_c (&(entry
->attr
), entry
->name
,
7242 &(entry
->declared_at
), 1))
7246 if (!gfc_current_ns
->parent
7247 && !add_global_entry (name
, entry
->binding_label
, true,
7251 /* An entry in a subroutine. */
7252 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
7253 || !gfc_add_subroutine (&entry
->attr
, entry
->name
, NULL
))
7258 /* An entry in a function.
7259 We need to take special care because writing
7264 ENTRY f() RESULT (r)
7266 ENTRY f RESULT (r). */
7267 if (gfc_match_eos () == MATCH_YES
)
7269 gfc_current_locus
= old_loc
;
7270 /* Match the empty argument list, and add the interface to
7272 m
= gfc_match_formal_arglist (entry
, 0, 1);
7275 m
= gfc_match_formal_arglist (entry
, 0, 0);
7282 if (gfc_match_eos () == MATCH_YES
)
7284 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
7285 || !gfc_add_function (&entry
->attr
, entry
->name
, NULL
))
7288 entry
->result
= entry
;
7292 m
= gfc_match_suffix (entry
, &result
);
7294 gfc_syntax_error (ST_ENTRY
);
7300 if (!gfc_add_result (&result
->attr
, result
->name
, NULL
)
7301 || !gfc_add_entry (&entry
->attr
, result
->name
, NULL
)
7302 || !gfc_add_function (&entry
->attr
, result
->name
, NULL
))
7304 entry
->result
= result
;
7308 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
7309 || !gfc_add_function (&entry
->attr
, entry
->name
, NULL
))
7311 entry
->result
= entry
;
7315 if (!gfc_current_ns
->parent
7316 && !add_global_entry (name
, entry
->binding_label
, false,
7321 if (gfc_match_eos () != MATCH_YES
)
7323 gfc_syntax_error (ST_ENTRY
);
7327 entry
->attr
.recursive
= proc
->attr
.recursive
;
7328 entry
->attr
.elemental
= proc
->attr
.elemental
;
7329 entry
->attr
.pure
= proc
->attr
.pure
;
7331 el
= gfc_get_entry_list ();
7333 el
->next
= gfc_current_ns
->entries
;
7334 gfc_current_ns
->entries
= el
;
7336 el
->id
= el
->next
->id
+ 1;
7340 new_st
.op
= EXEC_ENTRY
;
7341 new_st
.ext
.entry
= el
;
7347 /* Match a subroutine statement, including optional prefixes. */
7350 gfc_match_subroutine (void)
7352 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7357 bool allow_binding_name
;
7359 if (gfc_current_state () != COMP_NONE
7360 && gfc_current_state () != COMP_INTERFACE
7361 && gfc_current_state () != COMP_CONTAINS
)
7364 m
= gfc_match_prefix (NULL
);
7368 m
= gfc_match ("subroutine% %n", name
);
7372 if (get_proc_name (name
, &sym
, false))
7375 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
7376 the symbol existed before. */
7377 sym
->declared_at
= gfc_current_locus
;
7379 if (current_attr
.module_procedure
)
7380 sym
->attr
.module_procedure
= 1;
7382 if (add_hidden_procptr_result (sym
))
7385 gfc_new_block
= sym
;
7387 /* Check what next non-whitespace character is so we can tell if there
7388 is the required parens if we have a BIND(C). */
7389 gfc_gobble_whitespace ();
7390 peek_char
= gfc_peek_ascii_char ();
7392 if (!gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
))
7395 if (gfc_match_formal_arglist (sym
, 0, 1) != MATCH_YES
)
7398 /* Make sure that it isn't already declared as BIND(C). If it is, it
7399 must have been marked BIND(C) with a BIND(C) attribute and that is
7400 not allowed for procedures. */
7401 if (sym
->attr
.is_bind_c
== 1)
7403 sym
->attr
.is_bind_c
= 0;
7404 if (sym
->old_symbol
!= NULL
)
7405 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7406 "variables or common blocks",
7407 &(sym
->old_symbol
->declared_at
));
7409 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7410 "variables or common blocks", &gfc_current_locus
);
7413 /* C binding names are not allowed for internal procedures. */
7414 if (gfc_current_state () == COMP_CONTAINS
7415 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
7416 allow_binding_name
= false;
7418 allow_binding_name
= true;
7420 /* Here, we are just checking if it has the bind(c) attribute, and if
7421 so, then we need to make sure it's all correct. If it doesn't,
7422 we still need to continue matching the rest of the subroutine line. */
7423 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
7424 if (is_bind_c
== MATCH_ERROR
)
7426 /* There was an attempt at the bind(c), but it was wrong. An
7427 error message should have been printed w/in the gfc_match_bind_c
7428 so here we'll just return the MATCH_ERROR. */
7432 if (is_bind_c
== MATCH_YES
)
7434 /* The following is allowed in the Fortran 2008 draft. */
7435 if (gfc_current_state () == COMP_CONTAINS
7436 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
7437 && !gfc_notify_std (GFC_STD_F2008
, "BIND(C) attribute "
7438 "at %L may not be specified for an internal "
7439 "procedure", &gfc_current_locus
))
7442 if (peek_char
!= '(')
7444 gfc_error ("Missing required parentheses before BIND(C) at %C");
7447 if (!gfc_add_is_bind_c (&(sym
->attr
), sym
->name
,
7448 &(sym
->declared_at
), 1))
7452 if (gfc_match_eos () != MATCH_YES
)
7454 gfc_syntax_error (ST_SUBROUTINE
);
7458 if (!copy_prefix (&sym
->attr
, &sym
->declared_at
))
7460 if(!sym
->attr
.module_procedure
)
7466 /* Warn if it has the same name as an intrinsic. */
7467 do_warn_intrinsic_shadow (sym
, false);
7473 /* Check that the NAME identifier in a BIND attribute or statement
7474 is conform to C identifier rules. */
7477 check_bind_name_identifier (char **name
)
7479 char *n
= *name
, *p
;
7481 /* Remove leading spaces. */
7485 /* On an empty string, free memory and set name to NULL. */
7493 /* Remove trailing spaces. */
7494 p
= n
+ strlen(n
) - 1;
7498 /* Insert the identifier into the symbol table. */
7503 /* Now check that identifier is valid under C rules. */
7506 gfc_error ("Invalid C identifier in NAME= specifier at %C");
7511 if (!(ISALNUM (*p
) || *p
== '_' || *p
== '$'))
7513 gfc_error ("Invalid C identifier in NAME= specifier at %C");
7521 /* Match a BIND(C) specifier, with the optional 'name=' specifier if
7522 given, and set the binding label in either the given symbol (if not
7523 NULL), or in the current_ts. The symbol may be NULL because we may
7524 encounter the BIND(C) before the declaration itself. Return
7525 MATCH_NO if what we're looking at isn't a BIND(C) specifier,
7526 MATCH_ERROR if it is a BIND(C) clause but an error was encountered,
7527 or MATCH_YES if the specifier was correct and the binding label and
7528 bind(c) fields were set correctly for the given symbol or the
7529 current_ts. If allow_binding_name is false, no binding name may be
7533 gfc_match_bind_c (gfc_symbol
*sym
, bool allow_binding_name
)
7535 char *binding_label
= NULL
;
7538 /* Initialize the flag that specifies whether we encountered a NAME=
7539 specifier or not. */
7540 has_name_equals
= 0;
7542 /* This much we have to be able to match, in this order, if
7543 there is a bind(c) label. */
7544 if (gfc_match (" bind ( c ") != MATCH_YES
)
7547 /* Now see if there is a binding label, or if we've reached the
7548 end of the bind(c) attribute without one. */
7549 if (gfc_match_char (',') == MATCH_YES
)
7551 if (gfc_match (" name = ") != MATCH_YES
)
7553 gfc_error ("Syntax error in NAME= specifier for binding label "
7555 /* should give an error message here */
7559 has_name_equals
= 1;
7561 if (gfc_match_init_expr (&e
) != MATCH_YES
)
7567 if (!gfc_simplify_expr(e
, 0))
7569 gfc_error ("NAME= specifier at %C should be a constant expression");
7574 if (e
->expr_type
!= EXPR_CONSTANT
|| e
->ts
.type
!= BT_CHARACTER
7575 || e
->ts
.kind
!= gfc_default_character_kind
|| e
->rank
!= 0)
7577 gfc_error ("NAME= specifier at %C should be a scalar of "
7578 "default character kind");
7583 // Get a C string from the Fortran string constant
7584 binding_label
= gfc_widechar_to_char (e
->value
.character
.string
,
7585 e
->value
.character
.length
);
7588 // Check that it is valid (old gfc_match_name_C)
7589 if (check_bind_name_identifier (&binding_label
) != MATCH_YES
)
7593 /* Get the required right paren. */
7594 if (gfc_match_char (')') != MATCH_YES
)
7596 gfc_error ("Missing closing paren for binding label at %C");
7600 if (has_name_equals
&& !allow_binding_name
)
7602 gfc_error ("No binding name is allowed in BIND(C) at %C");
7606 if (has_name_equals
&& sym
!= NULL
&& sym
->attr
.dummy
)
7608 gfc_error ("For dummy procedure %s, no binding name is "
7609 "allowed in BIND(C) at %C", sym
->name
);
7614 /* Save the binding label to the symbol. If sym is null, we're
7615 probably matching the typespec attributes of a declaration and
7616 haven't gotten the name yet, and therefore, no symbol yet. */
7620 sym
->binding_label
= binding_label
;
7622 curr_binding_label
= binding_label
;
7624 else if (allow_binding_name
)
7626 /* No binding label, but if symbol isn't null, we
7627 can set the label for it here.
7628 If name="" or allow_binding_name is false, no C binding name is
7630 if (sym
!= NULL
&& sym
->name
!= NULL
&& has_name_equals
== 0)
7631 sym
->binding_label
= IDENTIFIER_POINTER (get_identifier (sym
->name
));
7634 if (has_name_equals
&& gfc_current_state () == COMP_INTERFACE
7635 && current_interface
.type
== INTERFACE_ABSTRACT
)
7637 gfc_error ("NAME not allowed on BIND(C) for ABSTRACT INTERFACE at %C");
7645 /* Return nonzero if we're currently compiling a contained procedure. */
7648 contained_procedure (void)
7650 gfc_state_data
*s
= gfc_state_stack
;
7652 if ((s
->state
== COMP_SUBROUTINE
|| s
->state
== COMP_FUNCTION
)
7653 && s
->previous
!= NULL
&& s
->previous
->state
== COMP_CONTAINS
)
7659 /* Set the kind of each enumerator. The kind is selected such that it is
7660 interoperable with the corresponding C enumeration type, making
7661 sure that -fshort-enums is honored. */
7666 enumerator_history
*current_history
= NULL
;
7670 if (max_enum
== NULL
|| enum_history
== NULL
)
7673 if (!flag_short_enums
)
7679 kind
= gfc_integer_kinds
[i
++].kind
;
7681 while (kind
< gfc_c_int_kind
7682 && gfc_check_integer_range (max_enum
->initializer
->value
.integer
,
7685 current_history
= enum_history
;
7686 while (current_history
!= NULL
)
7688 current_history
->sym
->ts
.kind
= kind
;
7689 current_history
= current_history
->next
;
7694 /* Match any of the various end-block statements. Returns the type of
7695 END to the caller. The END INTERFACE, END IF, END DO, END SELECT
7696 and END BLOCK statements cannot be replaced by a single END statement. */
7699 gfc_match_end (gfc_statement
*st
)
7701 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7702 gfc_compile_state state
;
7704 const char *block_name
;
7708 gfc_namespace
*parent_ns
, *ns
, *prev_ns
;
7709 gfc_namespace
**nsp
;
7710 bool abreviated_modproc_decl
= false;
7711 bool got_matching_end
= false;
7713 old_loc
= gfc_current_locus
;
7714 if (gfc_match ("end") != MATCH_YES
)
7717 state
= gfc_current_state ();
7718 block_name
= gfc_current_block () == NULL
7719 ? NULL
: gfc_current_block ()->name
;
7723 case COMP_ASSOCIATE
:
7725 if (!strncmp (block_name
, "block@", strlen("block@")))
7730 case COMP_DERIVED_CONTAINS
:
7731 state
= gfc_state_stack
->previous
->state
;
7732 block_name
= gfc_state_stack
->previous
->sym
== NULL
7733 ? NULL
: gfc_state_stack
->previous
->sym
->name
;
7734 abreviated_modproc_decl
= gfc_state_stack
->previous
->sym
7735 && gfc_state_stack
->previous
->sym
->abr_modproc_decl
;
7742 if (!abreviated_modproc_decl
)
7743 abreviated_modproc_decl
= gfc_current_block ()
7744 && gfc_current_block ()->abr_modproc_decl
;
7750 *st
= ST_END_PROGRAM
;
7751 target
= " program";
7755 case COMP_SUBROUTINE
:
7756 *st
= ST_END_SUBROUTINE
;
7757 if (!abreviated_modproc_decl
)
7758 target
= " subroutine";
7760 target
= " procedure";
7761 eos_ok
= !contained_procedure ();
7765 *st
= ST_END_FUNCTION
;
7766 if (!abreviated_modproc_decl
)
7767 target
= " function";
7769 target
= " procedure";
7770 eos_ok
= !contained_procedure ();
7773 case COMP_BLOCK_DATA
:
7774 *st
= ST_END_BLOCK_DATA
;
7775 target
= " block data";
7780 *st
= ST_END_MODULE
;
7785 case COMP_SUBMODULE
:
7786 *st
= ST_END_SUBMODULE
;
7787 target
= " submodule";
7791 case COMP_INTERFACE
:
7792 *st
= ST_END_INTERFACE
;
7793 target
= " interface";
7809 case COMP_STRUCTURE
:
7810 *st
= ST_END_STRUCTURE
;
7811 target
= " structure";
7816 case COMP_DERIVED_CONTAINS
:
7822 case COMP_ASSOCIATE
:
7823 *st
= ST_END_ASSOCIATE
;
7824 target
= " associate";
7841 case COMP_DO_CONCURRENT
:
7848 *st
= ST_END_CRITICAL
;
7849 target
= " critical";
7854 case COMP_SELECT_TYPE
:
7855 *st
= ST_END_SELECT
;
7861 *st
= ST_END_FORALL
;
7876 last_initializer
= NULL
;
7878 gfc_free_enum_history ();
7882 gfc_error ("Unexpected END statement at %C");
7886 old_loc
= gfc_current_locus
;
7887 if (gfc_match_eos () == MATCH_YES
)
7889 if (!eos_ok
&& (*st
== ST_END_SUBROUTINE
|| *st
== ST_END_FUNCTION
))
7891 if (!gfc_notify_std (GFC_STD_F2008
, "END statement "
7892 "instead of %s statement at %L",
7893 abreviated_modproc_decl
? "END PROCEDURE"
7894 : gfc_ascii_statement(*st
), &old_loc
))
7899 /* We would have required END [something]. */
7900 gfc_error ("%s statement expected at %L",
7901 gfc_ascii_statement (*st
), &old_loc
);
7908 /* Verify that we've got the sort of end-block that we're expecting. */
7909 if (gfc_match (target
) != MATCH_YES
)
7911 gfc_error ("Expecting %s statement at %L", abreviated_modproc_decl
7912 ? "END PROCEDURE" : gfc_ascii_statement(*st
), &old_loc
);
7916 got_matching_end
= true;
7918 old_loc
= gfc_current_locus
;
7919 /* If we're at the end, make sure a block name wasn't required. */
7920 if (gfc_match_eos () == MATCH_YES
)
7923 if (*st
!= ST_ENDDO
&& *st
!= ST_ENDIF
&& *st
!= ST_END_SELECT
7924 && *st
!= ST_END_FORALL
&& *st
!= ST_END_WHERE
&& *st
!= ST_END_BLOCK
7925 && *st
!= ST_END_ASSOCIATE
&& *st
!= ST_END_CRITICAL
)
7931 gfc_error ("Expected block name of %qs in %s statement at %L",
7932 block_name
, gfc_ascii_statement (*st
), &old_loc
);
7937 /* END INTERFACE has a special handler for its several possible endings. */
7938 if (*st
== ST_END_INTERFACE
)
7939 return gfc_match_end_interface ();
7941 /* We haven't hit the end of statement, so what is left must be an
7943 m
= gfc_match_space ();
7945 m
= gfc_match_name (name
);
7948 gfc_error ("Expected terminating name at %C");
7952 if (block_name
== NULL
)
7955 /* We have to pick out the declared submodule name from the composite
7956 required by F2008:11.2.3 para 2, which ends in the declared name. */
7957 if (state
== COMP_SUBMODULE
)
7958 block_name
= strchr (block_name
, '.') + 1;
7960 if (strcmp (name
, block_name
) != 0 && strcmp (block_name
, "ppr@") != 0)
7962 gfc_error ("Expected label %qs for %s statement at %C", block_name
,
7963 gfc_ascii_statement (*st
));
7966 /* Procedure pointer as function result. */
7967 else if (strcmp (block_name
, "ppr@") == 0
7968 && strcmp (name
, gfc_current_block ()->ns
->proc_name
->name
) != 0)
7970 gfc_error ("Expected label %qs for %s statement at %C",
7971 gfc_current_block ()->ns
->proc_name
->name
,
7972 gfc_ascii_statement (*st
));
7976 if (gfc_match_eos () == MATCH_YES
)
7980 gfc_syntax_error (*st
);
7983 gfc_current_locus
= old_loc
;
7985 /* If we are missing an END BLOCK, we created a half-ready namespace.
7986 Remove it from the parent namespace's sibling list. */
7988 while (state
== COMP_BLOCK
&& !got_matching_end
)
7990 parent_ns
= gfc_current_ns
->parent
;
7992 nsp
= &(gfc_state_stack
->previous
->tail
->ext
.block
.ns
);
7998 if (ns
== gfc_current_ns
)
8000 if (prev_ns
== NULL
)
8003 prev_ns
->sibling
= ns
->sibling
;
8009 gfc_free_namespace (gfc_current_ns
);
8010 gfc_current_ns
= parent_ns
;
8011 gfc_state_stack
= gfc_state_stack
->previous
;
8012 state
= gfc_current_state ();
8020 /***************** Attribute declaration statements ****************/
8022 /* Set the attribute of a single variable. */
8027 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8030 /* Workaround -Wmaybe-uninitialized false positive during
8031 profiledbootstrap by initializing them. */
8032 gfc_symbol
*sym
= NULL
;
8038 m
= gfc_match_name (name
);
8042 if (find_special (name
, &sym
, false))
8045 if (!check_function_name (name
))
8051 var_locus
= gfc_current_locus
;
8053 /* Deal with possible array specification for certain attributes. */
8054 if (current_attr
.dimension
8055 || current_attr
.codimension
8056 || current_attr
.allocatable
8057 || current_attr
.pointer
8058 || current_attr
.target
)
8060 m
= gfc_match_array_spec (&as
, !current_attr
.codimension
,
8061 !current_attr
.dimension
8062 && !current_attr
.pointer
8063 && !current_attr
.target
);
8064 if (m
== MATCH_ERROR
)
8067 if (current_attr
.dimension
&& m
== MATCH_NO
)
8069 gfc_error ("Missing array specification at %L in DIMENSION "
8070 "statement", &var_locus
);
8075 if (current_attr
.dimension
&& sym
->value
)
8077 gfc_error ("Dimensions specified for %s at %L after its "
8078 "initialization", sym
->name
, &var_locus
);
8083 if (current_attr
.codimension
&& m
== MATCH_NO
)
8085 gfc_error ("Missing array specification at %L in CODIMENSION "
8086 "statement", &var_locus
);
8091 if ((current_attr
.allocatable
|| current_attr
.pointer
)
8092 && (m
== MATCH_YES
) && (as
->type
!= AS_DEFERRED
))
8094 gfc_error ("Array specification must be deferred at %L", &var_locus
);
8100 /* Update symbol table. DIMENSION attribute is set in
8101 gfc_set_array_spec(). For CLASS variables, this must be applied
8102 to the first component, or '_data' field. */
8103 if (sym
->ts
.type
== BT_CLASS
&& sym
->ts
.u
.derived
->attr
.is_class
)
8105 if (!gfc_copy_attr (&CLASS_DATA(sym
)->attr
, ¤t_attr
, &var_locus
))
8113 if (current_attr
.dimension
== 0 && current_attr
.codimension
== 0
8114 && !gfc_copy_attr (&sym
->attr
, ¤t_attr
, &var_locus
))
8121 if (sym
->ts
.type
== BT_CLASS
8122 && !gfc_build_class_symbol (&sym
->ts
, &sym
->attr
, &sym
->as
))
8128 if (!gfc_set_array_spec (sym
, as
, &var_locus
))
8134 if (sym
->attr
.cray_pointee
&& sym
->as
!= NULL
)
8136 /* Fix the array spec. */
8137 m
= gfc_mod_pointee_as (sym
->as
);
8138 if (m
== MATCH_ERROR
)
8142 if (!gfc_add_attribute (&sym
->attr
, &var_locus
))
8148 if ((current_attr
.external
|| current_attr
.intrinsic
)
8149 && sym
->attr
.flavor
!= FL_PROCEDURE
8150 && !gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, NULL
))
8156 add_hidden_procptr_result (sym
);
8161 gfc_free_array_spec (as
);
8166 /* Generic attribute declaration subroutine. Used for attributes that
8167 just have a list of names. */
8174 /* Gobble the optional double colon, by simply ignoring the result
8184 if (gfc_match_eos () == MATCH_YES
)
8190 if (gfc_match_char (',') != MATCH_YES
)
8192 gfc_error ("Unexpected character in variable list at %C");
8202 /* This routine matches Cray Pointer declarations of the form:
8203 pointer ( <pointer>, <pointee> )
8205 pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...
8206 The pointer, if already declared, should be an integer. Otherwise, we
8207 set it as BT_INTEGER with kind gfc_index_integer_kind. The pointee may
8208 be either a scalar, or an array declaration. No space is allocated for
8209 the pointee. For the statement
8210 pointer (ipt, ar(10))
8211 any subsequent uses of ar will be translated (in C-notation) as
8212 ar(i) => ((<type> *) ipt)(i)
8213 After gimplification, pointee variable will disappear in the code. */
8216 cray_pointer_decl (void)
8219 gfc_array_spec
*as
= NULL
;
8220 gfc_symbol
*cptr
; /* Pointer symbol. */
8221 gfc_symbol
*cpte
; /* Pointee symbol. */
8227 if (gfc_match_char ('(') != MATCH_YES
)
8229 gfc_error ("Expected %<(%> at %C");
8233 /* Match pointer. */
8234 var_locus
= gfc_current_locus
;
8235 gfc_clear_attr (¤t_attr
);
8236 gfc_add_cray_pointer (¤t_attr
, &var_locus
);
8237 current_ts
.type
= BT_INTEGER
;
8238 current_ts
.kind
= gfc_index_integer_kind
;
8240 m
= gfc_match_symbol (&cptr
, 0);
8243 gfc_error ("Expected variable name at %C");
8247 if (!gfc_add_cray_pointer (&cptr
->attr
, &var_locus
))
8250 gfc_set_sym_referenced (cptr
);
8252 if (cptr
->ts
.type
== BT_UNKNOWN
) /* Override the type, if necessary. */
8254 cptr
->ts
.type
= BT_INTEGER
;
8255 cptr
->ts
.kind
= gfc_index_integer_kind
;
8257 else if (cptr
->ts
.type
!= BT_INTEGER
)
8259 gfc_error ("Cray pointer at %C must be an integer");
8262 else if (cptr
->ts
.kind
< gfc_index_integer_kind
)
8263 gfc_warning (0, "Cray pointer at %C has %d bytes of precision;"
8264 " memory addresses require %d bytes",
8265 cptr
->ts
.kind
, gfc_index_integer_kind
);
8267 if (gfc_match_char (',') != MATCH_YES
)
8269 gfc_error ("Expected \",\" at %C");
8273 /* Match Pointee. */
8274 var_locus
= gfc_current_locus
;
8275 gfc_clear_attr (¤t_attr
);
8276 gfc_add_cray_pointee (¤t_attr
, &var_locus
);
8277 current_ts
.type
= BT_UNKNOWN
;
8278 current_ts
.kind
= 0;
8280 m
= gfc_match_symbol (&cpte
, 0);
8283 gfc_error ("Expected variable name at %C");
8287 /* Check for an optional array spec. */
8288 m
= gfc_match_array_spec (&as
, true, false);
8289 if (m
== MATCH_ERROR
)
8291 gfc_free_array_spec (as
);
8294 else if (m
== MATCH_NO
)
8296 gfc_free_array_spec (as
);
8300 if (!gfc_add_cray_pointee (&cpte
->attr
, &var_locus
))
8303 gfc_set_sym_referenced (cpte
);
8305 if (cpte
->as
== NULL
)
8307 if (!gfc_set_array_spec (cpte
, as
, &var_locus
))
8308 gfc_internal_error ("Couldn't set Cray pointee array spec.");
8310 else if (as
!= NULL
)
8312 gfc_error ("Duplicate array spec for Cray pointee at %C");
8313 gfc_free_array_spec (as
);
8319 if (cpte
->as
!= NULL
)
8321 /* Fix array spec. */
8322 m
= gfc_mod_pointee_as (cpte
->as
);
8323 if (m
== MATCH_ERROR
)
8327 /* Point the Pointee at the Pointer. */
8328 cpte
->cp_pointer
= cptr
;
8330 if (gfc_match_char (')') != MATCH_YES
)
8332 gfc_error ("Expected \")\" at %C");
8335 m
= gfc_match_char (',');
8337 done
= true; /* Stop searching for more declarations. */
8341 if (m
== MATCH_ERROR
/* Failed when trying to find ',' above. */
8342 || gfc_match_eos () != MATCH_YES
)
8344 gfc_error ("Expected %<,%> or end of statement at %C");
8352 gfc_match_external (void)
8355 gfc_clear_attr (¤t_attr
);
8356 current_attr
.external
= 1;
8358 return attr_decl ();
8363 gfc_match_intent (void)
8367 /* This is not allowed within a BLOCK construct! */
8368 if (gfc_current_state () == COMP_BLOCK
)
8370 gfc_error ("INTENT is not allowed inside of BLOCK at %C");
8374 intent
= match_intent_spec ();
8375 if (intent
== INTENT_UNKNOWN
)
8378 gfc_clear_attr (¤t_attr
);
8379 current_attr
.intent
= intent
;
8381 return attr_decl ();
8386 gfc_match_intrinsic (void)
8389 gfc_clear_attr (¤t_attr
);
8390 current_attr
.intrinsic
= 1;
8392 return attr_decl ();
8397 gfc_match_optional (void)
8399 /* This is not allowed within a BLOCK construct! */
8400 if (gfc_current_state () == COMP_BLOCK
)
8402 gfc_error ("OPTIONAL is not allowed inside of BLOCK at %C");
8406 gfc_clear_attr (¤t_attr
);
8407 current_attr
.optional
= 1;
8409 return attr_decl ();
8414 gfc_match_pointer (void)
8416 gfc_gobble_whitespace ();
8417 if (gfc_peek_ascii_char () == '(')
8419 if (!flag_cray_pointer
)
8421 gfc_error ("Cray pointer declaration at %C requires -fcray-pointer "
8425 return cray_pointer_decl ();
8429 gfc_clear_attr (¤t_attr
);
8430 current_attr
.pointer
= 1;
8432 return attr_decl ();
8438 gfc_match_allocatable (void)
8440 gfc_clear_attr (¤t_attr
);
8441 current_attr
.allocatable
= 1;
8443 return attr_decl ();
8448 gfc_match_codimension (void)
8450 gfc_clear_attr (¤t_attr
);
8451 current_attr
.codimension
= 1;
8453 return attr_decl ();
8458 gfc_match_contiguous (void)
8460 if (!gfc_notify_std (GFC_STD_F2008
, "CONTIGUOUS statement at %C"))
8463 gfc_clear_attr (¤t_attr
);
8464 current_attr
.contiguous
= 1;
8466 return attr_decl ();
8471 gfc_match_dimension (void)
8473 gfc_clear_attr (¤t_attr
);
8474 current_attr
.dimension
= 1;
8476 return attr_decl ();
8481 gfc_match_target (void)
8483 gfc_clear_attr (¤t_attr
);
8484 current_attr
.target
= 1;
8486 return attr_decl ();
8490 /* Match the list of entities being specified in a PUBLIC or PRIVATE
8494 access_attr_decl (gfc_statement st
)
8496 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8497 interface_type type
;
8499 gfc_symbol
*sym
, *dt_sym
;
8500 gfc_intrinsic_op op
;
8503 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
8508 m
= gfc_match_generic_spec (&type
, name
, &op
);
8511 if (m
== MATCH_ERROR
)
8516 case INTERFACE_NAMELESS
:
8517 case INTERFACE_ABSTRACT
:
8520 case INTERFACE_GENERIC
:
8521 case INTERFACE_DTIO
:
8523 if (gfc_get_symbol (name
, NULL
, &sym
))
8526 if (type
== INTERFACE_DTIO
8527 && gfc_current_ns
->proc_name
8528 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
8529 && sym
->attr
.flavor
== FL_UNKNOWN
)
8530 sym
->attr
.flavor
= FL_PROCEDURE
;
8532 if (!gfc_add_access (&sym
->attr
,
8534 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
,
8538 if (sym
->attr
.generic
&& (dt_sym
= gfc_find_dt_in_generic (sym
))
8539 && !gfc_add_access (&dt_sym
->attr
,
8541 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
,
8547 case INTERFACE_INTRINSIC_OP
:
8548 if (gfc_current_ns
->operator_access
[op
] == ACCESS_UNKNOWN
)
8550 gfc_intrinsic_op other_op
;
8552 gfc_current_ns
->operator_access
[op
] =
8553 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
8555 /* Handle the case if there is another op with the same
8556 function, for INTRINSIC_EQ vs. INTRINSIC_EQ_OS and so on. */
8557 other_op
= gfc_equivalent_op (op
);
8559 if (other_op
!= INTRINSIC_NONE
)
8560 gfc_current_ns
->operator_access
[other_op
] =
8561 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
8566 gfc_error ("Access specification of the %s operator at %C has "
8567 "already been specified", gfc_op2string (op
));
8573 case INTERFACE_USER_OP
:
8574 uop
= gfc_get_uop (name
);
8576 if (uop
->access
== ACCESS_UNKNOWN
)
8578 uop
->access
= (st
== ST_PUBLIC
)
8579 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
8583 gfc_error ("Access specification of the .%s. operator at %C "
8584 "has already been specified", sym
->name
);
8591 if (gfc_match_char (',') == MATCH_NO
)
8595 if (gfc_match_eos () != MATCH_YES
)
8600 gfc_syntax_error (st
);
8608 gfc_match_protected (void)
8613 if (!gfc_current_ns
->proc_name
8614 || gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
8616 gfc_error ("PROTECTED at %C only allowed in specification "
8617 "part of a module");
8622 if (!gfc_notify_std (GFC_STD_F2003
, "PROTECTED statement at %C"))
8625 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
8630 if (gfc_match_eos () == MATCH_YES
)
8635 m
= gfc_match_symbol (&sym
, 0);
8639 if (!gfc_add_protected (&sym
->attr
, sym
->name
, &gfc_current_locus
))
8651 if (gfc_match_eos () == MATCH_YES
)
8653 if (gfc_match_char (',') != MATCH_YES
)
8660 gfc_error ("Syntax error in PROTECTED statement at %C");
8665 /* The PRIVATE statement is a bit weird in that it can be an attribute
8666 declaration, but also works as a standalone statement inside of a
8667 type declaration or a module. */
8670 gfc_match_private (gfc_statement
*st
)
8673 if (gfc_match ("private") != MATCH_YES
)
8676 if (gfc_current_state () != COMP_MODULE
8677 && !(gfc_current_state () == COMP_DERIVED
8678 && gfc_state_stack
->previous
8679 && gfc_state_stack
->previous
->state
== COMP_MODULE
)
8680 && !(gfc_current_state () == COMP_DERIVED_CONTAINS
8681 && gfc_state_stack
->previous
&& gfc_state_stack
->previous
->previous
8682 && gfc_state_stack
->previous
->previous
->state
== COMP_MODULE
))
8684 gfc_error ("PRIVATE statement at %C is only allowed in the "
8685 "specification part of a module");
8689 if (gfc_current_state () == COMP_DERIVED
)
8691 if (gfc_match_eos () == MATCH_YES
)
8697 gfc_syntax_error (ST_PRIVATE
);
8701 if (gfc_match_eos () == MATCH_YES
)
8708 return access_attr_decl (ST_PRIVATE
);
8713 gfc_match_public (gfc_statement
*st
)
8716 if (gfc_match ("public") != MATCH_YES
)
8719 if (gfc_current_state () != COMP_MODULE
)
8721 gfc_error ("PUBLIC statement at %C is only allowed in the "
8722 "specification part of a module");
8726 if (gfc_match_eos () == MATCH_YES
)
8733 return access_attr_decl (ST_PUBLIC
);
8737 /* Workhorse for gfc_match_parameter. */
8747 m
= gfc_match_symbol (&sym
, 0);
8749 gfc_error ("Expected variable name at %C in PARAMETER statement");
8754 if (gfc_match_char ('=') == MATCH_NO
)
8756 gfc_error ("Expected = sign in PARAMETER statement at %C");
8760 m
= gfc_match_init_expr (&init
);
8762 gfc_error ("Expected expression at %C in PARAMETER statement");
8766 if (sym
->ts
.type
== BT_UNKNOWN
8767 && !gfc_set_default_type (sym
, 1, NULL
))
8773 if (!gfc_check_assign_symbol (sym
, NULL
, init
)
8774 || !gfc_add_flavor (&sym
->attr
, FL_PARAMETER
, sym
->name
, NULL
))
8782 gfc_error ("Initializing already initialized variable at %C");
8787 t
= add_init_expr_to_sym (sym
->name
, &init
, &gfc_current_locus
);
8788 return (t
) ? MATCH_YES
: MATCH_ERROR
;
8791 gfc_free_expr (init
);
8796 /* Match a parameter statement, with the weird syntax that these have. */
8799 gfc_match_parameter (void)
8801 const char *term
= " )%t";
8804 if (gfc_match_char ('(') == MATCH_NO
)
8806 /* With legacy PARAMETER statements, don't expect a terminating ')'. */
8807 if (!gfc_notify_std (GFC_STD_LEGACY
, "PARAMETER without '()' at %C"))
8818 if (gfc_match (term
) == MATCH_YES
)
8821 if (gfc_match_char (',') != MATCH_YES
)
8823 gfc_error ("Unexpected characters in PARAMETER statement at %C");
8834 gfc_match_automatic (void)
8838 bool seen_symbol
= false;
8840 if (!flag_dec_static
)
8842 gfc_error ("%s at %C is a DEC extension, enable with "
8853 m
= gfc_match_symbol (&sym
, 0);
8863 if (!gfc_add_automatic (&sym
->attr
, sym
->name
, &gfc_current_locus
))
8869 if (gfc_match_eos () == MATCH_YES
)
8871 if (gfc_match_char (',') != MATCH_YES
)
8877 gfc_error ("Expected entity-list in AUTOMATIC statement at %C");
8884 gfc_error ("Syntax error in AUTOMATIC statement at %C");
8890 gfc_match_static (void)
8894 bool seen_symbol
= false;
8896 if (!flag_dec_static
)
8898 gfc_error ("%s at %C is a DEC extension, enable with "
8908 m
= gfc_match_symbol (&sym
, 0);
8918 if (!gfc_add_save (&sym
->attr
, SAVE_EXPLICIT
, sym
->name
,
8919 &gfc_current_locus
))
8925 if (gfc_match_eos () == MATCH_YES
)
8927 if (gfc_match_char (',') != MATCH_YES
)
8933 gfc_error ("Expected entity-list in STATIC statement at %C");
8940 gfc_error ("Syntax error in STATIC statement at %C");
8945 /* Save statements have a special syntax. */
8948 gfc_match_save (void)
8950 char n
[GFC_MAX_SYMBOL_LEN
+1];
8955 if (gfc_match_eos () == MATCH_YES
)
8957 if (gfc_current_ns
->seen_save
)
8959 if (!gfc_notify_std (GFC_STD_LEGACY
, "Blanket SAVE statement at %C "
8960 "follows previous SAVE statement"))
8964 gfc_current_ns
->save_all
= gfc_current_ns
->seen_save
= 1;
8968 if (gfc_current_ns
->save_all
)
8970 if (!gfc_notify_std (GFC_STD_LEGACY
, "SAVE statement at %C follows "
8971 "blanket SAVE statement"))
8979 m
= gfc_match_symbol (&sym
, 0);
8983 if (!gfc_add_save (&sym
->attr
, SAVE_EXPLICIT
, sym
->name
,
8984 &gfc_current_locus
))
8995 m
= gfc_match (" / %n /", &n
);
8996 if (m
== MATCH_ERROR
)
9001 c
= gfc_get_common (n
, 0);
9004 gfc_current_ns
->seen_save
= 1;
9007 if (gfc_match_eos () == MATCH_YES
)
9009 if (gfc_match_char (',') != MATCH_YES
)
9016 gfc_error ("Syntax error in SAVE statement at %C");
9022 gfc_match_value (void)
9027 /* This is not allowed within a BLOCK construct! */
9028 if (gfc_current_state () == COMP_BLOCK
)
9030 gfc_error ("VALUE is not allowed inside of BLOCK at %C");
9034 if (!gfc_notify_std (GFC_STD_F2003
, "VALUE statement at %C"))
9037 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
9042 if (gfc_match_eos () == MATCH_YES
)
9047 m
= gfc_match_symbol (&sym
, 0);
9051 if (!gfc_add_value (&sym
->attr
, sym
->name
, &gfc_current_locus
))
9063 if (gfc_match_eos () == MATCH_YES
)
9065 if (gfc_match_char (',') != MATCH_YES
)
9072 gfc_error ("Syntax error in VALUE statement at %C");
9078 gfc_match_volatile (void)
9083 if (!gfc_notify_std (GFC_STD_F2003
, "VOLATILE statement at %C"))
9086 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
9091 if (gfc_match_eos () == MATCH_YES
)
9096 /* VOLATILE is special because it can be added to host-associated
9097 symbols locally. Except for coarrays. */
9098 m
= gfc_match_symbol (&sym
, 1);
9102 /* F2008, C560+C561. VOLATILE for host-/use-associated variable or
9103 for variable in a BLOCK which is defined outside of the BLOCK. */
9104 if (sym
->ns
!= gfc_current_ns
&& sym
->attr
.codimension
)
9106 gfc_error ("Specifying VOLATILE for coarray variable %qs at "
9107 "%C, which is use-/host-associated", sym
->name
);
9110 if (!gfc_add_volatile (&sym
->attr
, sym
->name
, &gfc_current_locus
))
9122 if (gfc_match_eos () == MATCH_YES
)
9124 if (gfc_match_char (',') != MATCH_YES
)
9131 gfc_error ("Syntax error in VOLATILE statement at %C");
9137 gfc_match_asynchronous (void)
9142 if (!gfc_notify_std (GFC_STD_F2003
, "ASYNCHRONOUS statement at %C"))
9145 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
9150 if (gfc_match_eos () == MATCH_YES
)
9155 /* ASYNCHRONOUS is special because it can be added to host-associated
9157 m
= gfc_match_symbol (&sym
, 1);
9161 if (!gfc_add_asynchronous (&sym
->attr
, sym
->name
, &gfc_current_locus
))
9173 if (gfc_match_eos () == MATCH_YES
)
9175 if (gfc_match_char (',') != MATCH_YES
)
9182 gfc_error ("Syntax error in ASYNCHRONOUS statement at %C");
9187 /* Match a module procedure statement in a submodule. */
9190 gfc_match_submod_proc (void)
9192 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9193 gfc_symbol
*sym
, *fsym
;
9195 gfc_formal_arglist
*formal
, *head
, *tail
;
9197 if (gfc_current_state () != COMP_CONTAINS
9198 || !(gfc_state_stack
->previous
9199 && (gfc_state_stack
->previous
->state
== COMP_SUBMODULE
9200 || gfc_state_stack
->previous
->state
== COMP_MODULE
)))
9203 m
= gfc_match (" module% procedure% %n", name
);
9207 if (!gfc_notify_std (GFC_STD_F2008
, "MODULE PROCEDURE declaration "
9211 if (get_proc_name (name
, &sym
, false))
9214 /* Make sure that the result field is appropriately filled, even though
9215 the result symbol will be replaced later on. */
9216 if (sym
->tlink
&& sym
->tlink
->attr
.function
)
9218 if (sym
->tlink
->result
9219 && sym
->tlink
->result
!= sym
->tlink
)
9220 sym
->result
= sym
->tlink
->result
;
9225 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
9226 the symbol existed before. */
9227 sym
->declared_at
= gfc_current_locus
;
9229 if (!sym
->attr
.module_procedure
)
9232 /* Signal match_end to expect "end procedure". */
9233 sym
->abr_modproc_decl
= 1;
9235 /* Change from IFSRC_IFBODY coming from the interface declaration. */
9236 sym
->attr
.if_source
= IFSRC_DECL
;
9238 gfc_new_block
= sym
;
9240 /* Make a new formal arglist with the symbols in the procedure
9243 for (formal
= sym
->formal
; formal
&& formal
->sym
; formal
= formal
->next
)
9245 if (formal
== sym
->formal
)
9246 head
= tail
= gfc_get_formal_arglist ();
9249 tail
->next
= gfc_get_formal_arglist ();
9253 if (gfc_copy_dummy_sym (&fsym
, formal
->sym
, 0))
9257 gfc_set_sym_referenced (fsym
);
9260 /* The dummy symbols get cleaned up, when the formal_namespace of the
9261 interface declaration is cleared. This allows us to add the
9262 explicit interface as is done for other type of procedure. */
9263 if (!gfc_add_explicit_interface (sym
, IFSRC_DECL
, head
,
9264 &gfc_current_locus
))
9267 if (gfc_match_eos () != MATCH_YES
)
9269 gfc_syntax_error (ST_MODULE_PROC
);
9276 gfc_free_formal_arglist (head
);
9281 /* Match a module procedure statement. Note that we have to modify
9282 symbols in the parent's namespace because the current one was there
9283 to receive symbols that are in an interface's formal argument list. */
9286 gfc_match_modproc (void)
9288 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9292 gfc_namespace
*module_ns
;
9293 gfc_interface
*old_interface_head
, *interface
;
9295 if (gfc_state_stack
->state
!= COMP_INTERFACE
9296 || gfc_state_stack
->previous
== NULL
9297 || current_interface
.type
== INTERFACE_NAMELESS
9298 || current_interface
.type
== INTERFACE_ABSTRACT
)
9300 gfc_error ("MODULE PROCEDURE at %C must be in a generic module "
9305 module_ns
= gfc_current_ns
->parent
;
9306 for (; module_ns
; module_ns
= module_ns
->parent
)
9307 if (module_ns
->proc_name
->attr
.flavor
== FL_MODULE
9308 || module_ns
->proc_name
->attr
.flavor
== FL_PROGRAM
9309 || (module_ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
9310 && !module_ns
->proc_name
->attr
.contained
))
9313 if (module_ns
== NULL
)
9316 /* Store the current state of the interface. We will need it if we
9317 end up with a syntax error and need to recover. */
9318 old_interface_head
= gfc_current_interface_head ();
9320 /* Check if the F2008 optional double colon appears. */
9321 gfc_gobble_whitespace ();
9322 old_locus
= gfc_current_locus
;
9323 if (gfc_match ("::") == MATCH_YES
)
9325 if (!gfc_notify_std (GFC_STD_F2008
, "double colon in "
9326 "MODULE PROCEDURE statement at %L", &old_locus
))
9330 gfc_current_locus
= old_locus
;
9335 old_locus
= gfc_current_locus
;
9337 m
= gfc_match_name (name
);
9343 /* Check for syntax error before starting to add symbols to the
9344 current namespace. */
9345 if (gfc_match_eos () == MATCH_YES
)
9348 if (!last
&& gfc_match_char (',') != MATCH_YES
)
9351 /* Now we're sure the syntax is valid, we process this item
9353 if (gfc_get_symbol (name
, module_ns
, &sym
))
9356 if (sym
->attr
.intrinsic
)
9358 gfc_error ("Intrinsic procedure at %L cannot be a MODULE "
9359 "PROCEDURE", &old_locus
);
9363 if (sym
->attr
.proc
!= PROC_MODULE
9364 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
9367 if (!gfc_add_interface (sym
))
9370 sym
->attr
.mod_proc
= 1;
9371 sym
->declared_at
= old_locus
;
9380 /* Restore the previous state of the interface. */
9381 interface
= gfc_current_interface_head ();
9382 gfc_set_current_interface_head (old_interface_head
);
9384 /* Free the new interfaces. */
9385 while (interface
!= old_interface_head
)
9387 gfc_interface
*i
= interface
->next
;
9392 /* And issue a syntax error. */
9393 gfc_syntax_error (ST_MODULE_PROC
);
9398 /* Check a derived type that is being extended. */
9401 check_extended_derived_type (char *name
)
9403 gfc_symbol
*extended
;
9405 if (gfc_find_symbol (name
, gfc_current_ns
, 1, &extended
))
9407 gfc_error ("Ambiguous symbol in TYPE definition at %C");
9411 extended
= gfc_find_dt_in_generic (extended
);
9416 gfc_error ("Symbol %qs at %C has not been previously defined", name
);
9420 if (extended
->attr
.flavor
!= FL_DERIVED
)
9422 gfc_error ("%qs in EXTENDS expression at %C is not a "
9423 "derived type", name
);
9427 if (extended
->attr
.is_bind_c
)
9429 gfc_error ("%qs cannot be extended at %C because it "
9430 "is BIND(C)", extended
->name
);
9434 if (extended
->attr
.sequence
)
9436 gfc_error ("%qs cannot be extended at %C because it "
9437 "is a SEQUENCE type", extended
->name
);
9445 /* Match the optional attribute specifiers for a type declaration.
9446 Return MATCH_ERROR if an error is encountered in one of the handled
9447 attributes (public, private, bind(c)), MATCH_NO if what's found is
9448 not a handled attribute, and MATCH_YES otherwise. TODO: More error
9449 checking on attribute conflicts needs to be done. */
9452 gfc_get_type_attr_spec (symbol_attribute
*attr
, char *name
)
9454 /* See if the derived type is marked as private. */
9455 if (gfc_match (" , private") == MATCH_YES
)
9457 if (gfc_current_state () != COMP_MODULE
)
9459 gfc_error ("Derived type at %C can only be PRIVATE in the "
9460 "specification part of a module");
9464 if (!gfc_add_access (attr
, ACCESS_PRIVATE
, NULL
, NULL
))
9467 else if (gfc_match (" , public") == MATCH_YES
)
9469 if (gfc_current_state () != COMP_MODULE
)
9471 gfc_error ("Derived type at %C can only be PUBLIC in the "
9472 "specification part of a module");
9476 if (!gfc_add_access (attr
, ACCESS_PUBLIC
, NULL
, NULL
))
9479 else if (gfc_match (" , bind ( c )") == MATCH_YES
)
9481 /* If the type is defined to be bind(c) it then needs to make
9482 sure that all fields are interoperable. This will
9483 need to be a semantic check on the finished derived type.
9484 See 15.2.3 (lines 9-12) of F2003 draft. */
9485 if (!gfc_add_is_bind_c (attr
, NULL
, &gfc_current_locus
, 0))
9488 /* TODO: attr conflicts need to be checked, probably in symbol.c. */
9490 else if (gfc_match (" , abstract") == MATCH_YES
)
9492 if (!gfc_notify_std (GFC_STD_F2003
, "ABSTRACT type at %C"))
9495 if (!gfc_add_abstract (attr
, &gfc_current_locus
))
9498 else if (name
&& gfc_match (" , extends ( %n )", name
) == MATCH_YES
)
9500 if (!gfc_add_extension (attr
, &gfc_current_locus
))
9506 /* If we get here, something matched. */
9511 /* Common function for type declaration blocks similar to derived types, such
9512 as STRUCTURES and MAPs. Unlike derived types, a structure type
9513 does NOT have a generic symbol matching the name given by the user.
9514 STRUCTUREs can share names with variables and PARAMETERs so we must allow
9515 for the creation of an independent symbol.
9516 Other parameters are a message to prefix errors with, the name of the new
9517 type to be created, and the flavor to add to the resulting symbol. */
9520 get_struct_decl (const char *name
, sym_flavor fl
, locus
*decl
,
9521 gfc_symbol
**result
)
9526 gcc_assert (name
[0] == (char) TOUPPER (name
[0]));
9531 where
= gfc_current_locus
;
9533 if (gfc_get_symbol (name
, NULL
, &sym
))
9538 gfc_internal_error ("Failed to create structure type '%s' at %C", name
);
9542 if (sym
->components
!= NULL
|| sym
->attr
.zero_comp
)
9544 gfc_error ("Type definition of %qs at %C was already defined at %L",
9545 sym
->name
, &sym
->declared_at
);
9549 sym
->declared_at
= where
;
9551 if (sym
->attr
.flavor
!= fl
9552 && !gfc_add_flavor (&sym
->attr
, fl
, sym
->name
, NULL
))
9555 if (!sym
->hash_value
)
9556 /* Set the hash for the compound name for this type. */
9557 sym
->hash_value
= gfc_hash_value (sym
);
9559 /* Normally the type is expected to have been completely parsed by the time
9560 a field declaration with this type is seen. For unions, maps, and nested
9561 structure declarations, we need to indicate that it is okay that we
9562 haven't seen any components yet. This will be updated after the structure
9564 sym
->attr
.zero_comp
= 0;
9566 /* Structures always act like derived-types with the SEQUENCE attribute */
9567 gfc_add_sequence (&sym
->attr
, sym
->name
, NULL
);
9569 if (result
) *result
= sym
;
9575 /* Match the opening of a MAP block. Like a struct within a union in C;
9576 behaves identical to STRUCTURE blocks. */
9579 gfc_match_map (void)
9581 /* Counter used to give unique internal names to map structures. */
9582 static unsigned int gfc_map_id
= 0;
9583 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9587 old_loc
= gfc_current_locus
;
9589 if (gfc_match_eos () != MATCH_YES
)
9591 gfc_error ("Junk after MAP statement at %C");
9592 gfc_current_locus
= old_loc
;
9596 /* Map blocks are anonymous so we make up unique names for the symbol table
9597 which are invalid Fortran identifiers. */
9598 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "MM$%u", gfc_map_id
++);
9600 if (!get_struct_decl (name
, FL_STRUCT
, &old_loc
, &sym
))
9603 gfc_new_block
= sym
;
9609 /* Match the opening of a UNION block. */
9612 gfc_match_union (void)
9614 /* Counter used to give unique internal names to union types. */
9615 static unsigned int gfc_union_id
= 0;
9616 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9620 old_loc
= gfc_current_locus
;
9622 if (gfc_match_eos () != MATCH_YES
)
9624 gfc_error ("Junk after UNION statement at %C");
9625 gfc_current_locus
= old_loc
;
9629 /* Unions are anonymous so we make up unique names for the symbol table
9630 which are invalid Fortran identifiers. */
9631 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "UU$%u", gfc_union_id
++);
9633 if (!get_struct_decl (name
, FL_UNION
, &old_loc
, &sym
))
9636 gfc_new_block
= sym
;
9642 /* Match the beginning of a STRUCTURE declaration. This is similar to
9643 matching the beginning of a derived type declaration with a few
9644 twists. The resulting type symbol has no access control or other
9645 interesting attributes. */
9648 gfc_match_structure_decl (void)
9650 /* Counter used to give unique internal names to anonymous structures. */
9651 static unsigned int gfc_structure_id
= 0;
9652 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9657 if (!flag_dec_structure
)
9659 gfc_error ("%s at %C is a DEC extension, enable with "
9660 "%<-fdec-structure%>",
9667 m
= gfc_match (" /%n/", name
);
9670 /* Non-nested structure declarations require a structure name. */
9671 if (!gfc_comp_struct (gfc_current_state ()))
9673 gfc_error ("Structure name expected in non-nested structure "
9674 "declaration at %C");
9677 /* This is an anonymous structure; make up a unique name for it
9678 (upper-case letters never make it to symbol names from the source).
9679 The important thing is initializing the type variable
9680 and setting gfc_new_symbol, which is immediately used by
9681 parse_structure () and variable_decl () to add components of
9683 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "SS$%u", gfc_structure_id
++);
9686 where
= gfc_current_locus
;
9687 /* No field list allowed after non-nested structure declaration. */
9688 if (!gfc_comp_struct (gfc_current_state ())
9689 && gfc_match_eos () != MATCH_YES
)
9691 gfc_error ("Junk after non-nested STRUCTURE statement at %C");
9695 /* Make sure the name is not the name of an intrinsic type. */
9696 if (gfc_is_intrinsic_typename (name
))
9698 gfc_error ("Structure name %qs at %C cannot be the same as an"
9699 " intrinsic type", name
);
9703 /* Store the actual type symbol for the structure with an upper-case first
9704 letter (an invalid Fortran identifier). */
9706 if (!get_struct_decl (gfc_dt_upper_string (name
), FL_STRUCT
, &where
, &sym
))
9709 gfc_new_block
= sym
;
9714 /* This function does some work to determine which matcher should be used to
9715 * match a statement beginning with "TYPE". This is used to disambiguate TYPE
9716 * as an alias for PRINT from derived type declarations, TYPE IS statements,
9717 * and derived type data declarations. */
9720 gfc_match_type (gfc_statement
*st
)
9722 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9726 /* Requires -fdec. */
9730 m
= gfc_match ("type");
9733 /* If we already have an error in the buffer, it is probably from failing to
9734 * match a derived type data declaration. Let it happen. */
9735 else if (gfc_error_flag_test ())
9738 old_loc
= gfc_current_locus
;
9741 /* If we see an attribute list before anything else it's definitely a derived
9742 * type declaration. */
9743 if (gfc_match (" ,") == MATCH_YES
|| gfc_match (" ::") == MATCH_YES
)
9745 gfc_current_locus
= old_loc
;
9746 *st
= ST_DERIVED_DECL
;
9747 return gfc_match_derived_decl ();
9750 /* By now "TYPE" has already been matched. If we do not see a name, this may
9751 * be something like "TYPE *" or "TYPE <fmt>". */
9752 m
= gfc_match_name (name
);
9755 /* Let print match if it can, otherwise throw an error from
9756 * gfc_match_derived_decl. */
9757 gfc_current_locus
= old_loc
;
9758 if (gfc_match_print () == MATCH_YES
)
9763 gfc_current_locus
= old_loc
;
9764 *st
= ST_DERIVED_DECL
;
9765 return gfc_match_derived_decl ();
9768 /* A derived type declaration requires an EOS. Without it, assume print. */
9769 m
= gfc_match_eos ();
9772 /* Check manually for TYPE IS (... - this is invalid print syntax. */
9773 if (strncmp ("is", name
, 3) == 0
9774 && gfc_match (" (", name
) == MATCH_YES
)
9776 gfc_current_locus
= old_loc
;
9777 gcc_assert (gfc_match (" is") == MATCH_YES
);
9779 return gfc_match_type_is ();
9781 gfc_current_locus
= old_loc
;
9783 return gfc_match_print ();
9787 /* By now we have "TYPE <name> <EOS>". Check first if the name is an
9788 * intrinsic typename - if so let gfc_match_derived_decl dump an error.
9789 * Otherwise if gfc_match_derived_decl fails it's probably an existing
9790 * symbol which can be printed. */
9791 gfc_current_locus
= old_loc
;
9792 m
= gfc_match_derived_decl ();
9793 if (gfc_is_intrinsic_typename (name
) || m
== MATCH_YES
)
9795 *st
= ST_DERIVED_DECL
;
9798 gfc_current_locus
= old_loc
;
9800 return gfc_match_print ();
9807 /* Match the beginning of a derived type declaration. If a type name
9808 was the result of a function, then it is possible to have a symbol
9809 already to be known as a derived type yet have no components. */
9812 gfc_match_derived_decl (void)
9814 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9815 char parent
[GFC_MAX_SYMBOL_LEN
+ 1];
9816 symbol_attribute attr
;
9817 gfc_symbol
*sym
, *gensym
;
9818 gfc_symbol
*extended
;
9820 match is_type_attr_spec
= MATCH_NO
;
9821 bool seen_attr
= false;
9822 gfc_interface
*intr
= NULL
, *head
;
9823 bool parameterized_type
= false;
9824 bool seen_colons
= false;
9826 if (gfc_comp_struct (gfc_current_state ()))
9831 gfc_clear_attr (&attr
);
9836 is_type_attr_spec
= gfc_get_type_attr_spec (&attr
, parent
);
9837 if (is_type_attr_spec
== MATCH_ERROR
)
9839 if (is_type_attr_spec
== MATCH_YES
)
9841 } while (is_type_attr_spec
== MATCH_YES
);
9843 /* Deal with derived type extensions. The extension attribute has
9844 been added to 'attr' but now the parent type must be found and
9847 extended
= check_extended_derived_type (parent
);
9849 if (parent
[0] && !extended
)
9852 m
= gfc_match (" ::");
9859 gfc_error ("Expected :: in TYPE definition at %C");
9863 m
= gfc_match (" %n ", name
);
9867 /* Make sure that we don't identify TYPE IS (...) as a parameterized
9868 derived type named 'is'.
9869 TODO Expand the check, when 'name' = "is" by matching " (tname) "
9870 and checking if this is a(n intrinsic) typename. his picks up
9871 misplaced TYPE IS statements such as in select_type_1.f03. */
9872 if (gfc_peek_ascii_char () == '(')
9874 if (gfc_current_state () == COMP_SELECT_TYPE
9875 || (!seen_colons
&& !strcmp (name
, "is")))
9877 parameterized_type
= true;
9880 m
= gfc_match_eos ();
9881 if (m
!= MATCH_YES
&& !parameterized_type
)
9884 /* Make sure the name is not the name of an intrinsic type. */
9885 if (gfc_is_intrinsic_typename (name
))
9887 gfc_error ("Type name %qs at %C cannot be the same as an intrinsic "
9892 if (gfc_get_symbol (name
, NULL
, &gensym
))
9895 if (!gensym
->attr
.generic
&& gensym
->ts
.type
!= BT_UNKNOWN
)
9897 gfc_error ("Derived type name %qs at %C already has a basic type "
9898 "of %s", gensym
->name
, gfc_typename (&gensym
->ts
));
9902 if (!gensym
->attr
.generic
9903 && !gfc_add_generic (&gensym
->attr
, gensym
->name
, NULL
))
9906 if (!gensym
->attr
.function
9907 && !gfc_add_function (&gensym
->attr
, gensym
->name
, NULL
))
9910 sym
= gfc_find_dt_in_generic (gensym
);
9912 if (sym
&& (sym
->components
!= NULL
|| sym
->attr
.zero_comp
))
9914 gfc_error ("Derived type definition of %qs at %C has already been "
9915 "defined", sym
->name
);
9921 /* Use upper case to save the actual derived-type symbol. */
9922 gfc_get_symbol (gfc_dt_upper_string (gensym
->name
), NULL
, &sym
);
9923 sym
->name
= gfc_get_string ("%s", gensym
->name
);
9924 head
= gensym
->generic
;
9925 intr
= gfc_get_interface ();
9927 intr
->where
= gfc_current_locus
;
9928 intr
->sym
->declared_at
= gfc_current_locus
;
9930 gensym
->generic
= intr
;
9931 gensym
->attr
.if_source
= IFSRC_DECL
;
9934 /* The symbol may already have the derived attribute without the
9935 components. The ways this can happen is via a function
9936 definition, an INTRINSIC statement or a subtype in another
9937 derived type that is a pointer. The first part of the AND clause
9938 is true if the symbol is not the return value of a function. */
9939 if (sym
->attr
.flavor
!= FL_DERIVED
9940 && !gfc_add_flavor (&sym
->attr
, FL_DERIVED
, sym
->name
, NULL
))
9943 if (attr
.access
!= ACCESS_UNKNOWN
9944 && !gfc_add_access (&sym
->attr
, attr
.access
, sym
->name
, NULL
))
9946 else if (sym
->attr
.access
== ACCESS_UNKNOWN
9947 && gensym
->attr
.access
!= ACCESS_UNKNOWN
9948 && !gfc_add_access (&sym
->attr
, gensym
->attr
.access
,
9952 if (sym
->attr
.access
!= ACCESS_UNKNOWN
9953 && gensym
->attr
.access
== ACCESS_UNKNOWN
)
9954 gensym
->attr
.access
= sym
->attr
.access
;
9956 /* See if the derived type was labeled as bind(c). */
9957 if (attr
.is_bind_c
!= 0)
9958 sym
->attr
.is_bind_c
= attr
.is_bind_c
;
9960 /* Construct the f2k_derived namespace if it is not yet there. */
9961 if (!sym
->f2k_derived
)
9962 sym
->f2k_derived
= gfc_get_namespace (NULL
, 0);
9964 if (parameterized_type
)
9966 /* Ignore error or mismatches by going to the end of the statement
9967 in order to avoid the component declarations causing problems. */
9968 m
= gfc_match_formal_arglist (sym
, 0, 0, true);
9970 gfc_error_recovery ();
9971 m
= gfc_match_eos ();
9974 gfc_error_recovery ();
9975 gfc_error_now ("Garbage after PARAMETERIZED TYPE declaration at %C");
9977 sym
->attr
.pdt_template
= 1;
9980 if (extended
&& !sym
->components
)
9983 gfc_formal_arglist
*f
, *g
, *h
;
9985 /* Add the extended derived type as the first component. */
9986 gfc_add_component (sym
, parent
, &p
);
9988 gfc_set_sym_referenced (extended
);
9990 p
->ts
.type
= BT_DERIVED
;
9991 p
->ts
.u
.derived
= extended
;
9992 p
->initializer
= gfc_default_initializer (&p
->ts
);
9994 /* Set extension level. */
9995 if (extended
->attr
.extension
== 255)
9997 /* Since the extension field is 8 bit wide, we can only have
9998 up to 255 extension levels. */
9999 gfc_error ("Maximum extension level reached with type %qs at %L",
10000 extended
->name
, &extended
->declared_at
);
10001 return MATCH_ERROR
;
10003 sym
->attr
.extension
= extended
->attr
.extension
+ 1;
10005 /* Provide the links between the extended type and its extension. */
10006 if (!extended
->f2k_derived
)
10007 extended
->f2k_derived
= gfc_get_namespace (NULL
, 0);
10009 /* Copy the extended type-param-name-list from the extended type,
10010 append those of the extension and add the whole lot to the
10012 if (extended
->attr
.pdt_template
)
10015 sym
->attr
.pdt_template
= 1;
10016 for (f
= extended
->formal
; f
; f
= f
->next
)
10018 if (f
== extended
->formal
)
10020 g
= gfc_get_formal_arglist ();
10025 g
->next
= gfc_get_formal_arglist ();
10030 g
->next
= sym
->formal
;
10035 if (!sym
->hash_value
)
10036 /* Set the hash for the compound name for this type. */
10037 sym
->hash_value
= gfc_hash_value (sym
);
10039 /* Take over the ABSTRACT attribute. */
10040 sym
->attr
.abstract
= attr
.abstract
;
10042 gfc_new_block
= sym
;
10048 /* Cray Pointees can be declared as:
10049 pointer (ipt, a (n,m,...,*)) */
10052 gfc_mod_pointee_as (gfc_array_spec
*as
)
10054 as
->cray_pointee
= true; /* This will be useful to know later. */
10055 if (as
->type
== AS_ASSUMED_SIZE
)
10056 as
->cp_was_assumed
= true;
10057 else if (as
->type
== AS_ASSUMED_SHAPE
)
10059 gfc_error ("Cray Pointee at %C cannot be assumed shape array");
10060 return MATCH_ERROR
;
10066 /* Match the enum definition statement, here we are trying to match
10067 the first line of enum definition statement.
10068 Returns MATCH_YES if match is found. */
10071 gfc_match_enum (void)
10075 m
= gfc_match_eos ();
10076 if (m
!= MATCH_YES
)
10079 if (!gfc_notify_std (GFC_STD_F2003
, "ENUM and ENUMERATOR at %C"))
10080 return MATCH_ERROR
;
10086 /* Returns an initializer whose value is one higher than the value of the
10087 LAST_INITIALIZER argument. If the argument is NULL, the
10088 initializers value will be set to zero. The initializer's kind
10089 will be set to gfc_c_int_kind.
10091 If -fshort-enums is given, the appropriate kind will be selected
10092 later after all enumerators have been parsed. A warning is issued
10093 here if an initializer exceeds gfc_c_int_kind. */
10096 enum_initializer (gfc_expr
*last_initializer
, locus where
)
10099 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_c_int_kind
, &where
);
10101 mpz_init (result
->value
.integer
);
10103 if (last_initializer
!= NULL
)
10105 mpz_add_ui (result
->value
.integer
, last_initializer
->value
.integer
, 1);
10106 result
->where
= last_initializer
->where
;
10108 if (gfc_check_integer_range (result
->value
.integer
,
10109 gfc_c_int_kind
) != ARITH_OK
)
10111 gfc_error ("Enumerator exceeds the C integer type at %C");
10117 /* Control comes here, if it's the very first enumerator and no
10118 initializer has been given. It will be initialized to zero. */
10119 mpz_set_si (result
->value
.integer
, 0);
10126 /* Match a variable name with an optional initializer. When this
10127 subroutine is called, a variable is expected to be parsed next.
10128 Depending on what is happening at the moment, updates either the
10129 symbol table or the current interface. */
10132 enumerator_decl (void)
10134 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10135 gfc_expr
*initializer
;
10136 gfc_array_spec
*as
= NULL
;
10143 initializer
= NULL
;
10144 old_locus
= gfc_current_locus
;
10146 /* When we get here, we've just matched a list of attributes and
10147 maybe a type and a double colon. The next thing we expect to see
10148 is the name of the symbol. */
10149 m
= gfc_match_name (name
);
10150 if (m
!= MATCH_YES
)
10153 var_locus
= gfc_current_locus
;
10155 /* OK, we've successfully matched the declaration. Now put the
10156 symbol in the current namespace. If we fail to create the symbol,
10158 if (!build_sym (name
, NULL
, false, &as
, &var_locus
))
10164 /* The double colon must be present in order to have initializers.
10165 Otherwise the statement is ambiguous with an assignment statement. */
10168 if (gfc_match_char ('=') == MATCH_YES
)
10170 m
= gfc_match_init_expr (&initializer
);
10173 gfc_error ("Expected an initialization expression at %C");
10177 if (m
!= MATCH_YES
)
10182 /* If we do not have an initializer, the initialization value of the
10183 previous enumerator (stored in last_initializer) is incremented
10184 by 1 and is used to initialize the current enumerator. */
10185 if (initializer
== NULL
)
10186 initializer
= enum_initializer (last_initializer
, old_locus
);
10188 if (initializer
== NULL
|| initializer
->ts
.type
!= BT_INTEGER
)
10190 gfc_error ("ENUMERATOR %L not initialized with integer expression",
10196 /* Store this current initializer, for the next enumerator variable
10197 to be parsed. add_init_expr_to_sym() zeros initializer, so we
10198 use last_initializer below. */
10199 last_initializer
= initializer
;
10200 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
10202 /* Maintain enumerator history. */
10203 gfc_find_symbol (name
, NULL
, 0, &sym
);
10204 create_enum_history (sym
, last_initializer
);
10206 return (t
) ? MATCH_YES
: MATCH_ERROR
;
10209 /* Free stuff up and return. */
10210 gfc_free_expr (initializer
);
10216 /* Match the enumerator definition statement. */
10219 gfc_match_enumerator_def (void)
10224 gfc_clear_ts (¤t_ts
);
10226 m
= gfc_match (" enumerator");
10227 if (m
!= MATCH_YES
)
10230 m
= gfc_match (" :: ");
10231 if (m
== MATCH_ERROR
)
10234 colon_seen
= (m
== MATCH_YES
);
10236 if (gfc_current_state () != COMP_ENUM
)
10238 gfc_error ("ENUM definition statement expected before %C");
10239 gfc_free_enum_history ();
10240 return MATCH_ERROR
;
10243 (¤t_ts
)->type
= BT_INTEGER
;
10244 (¤t_ts
)->kind
= gfc_c_int_kind
;
10246 gfc_clear_attr (¤t_attr
);
10247 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, NULL
);
10256 m
= enumerator_decl ();
10257 if (m
== MATCH_ERROR
)
10259 gfc_free_enum_history ();
10265 if (gfc_match_eos () == MATCH_YES
)
10267 if (gfc_match_char (',') != MATCH_YES
)
10271 if (gfc_current_state () == COMP_ENUM
)
10273 gfc_free_enum_history ();
10274 gfc_error ("Syntax error in ENUMERATOR definition at %C");
10279 gfc_free_array_spec (current_as
);
10286 /* Match binding attributes. */
10289 match_binding_attributes (gfc_typebound_proc
* ba
, bool generic
, bool ppc
)
10291 bool found_passing
= false;
10292 bool seen_ptr
= false;
10293 match m
= MATCH_YES
;
10295 /* Initialize to defaults. Do so even before the MATCH_NO check so that in
10296 this case the defaults are in there. */
10297 ba
->access
= ACCESS_UNKNOWN
;
10298 ba
->pass_arg
= NULL
;
10299 ba
->pass_arg_num
= 0;
10301 ba
->non_overridable
= 0;
10305 /* If we find a comma, we believe there are binding attributes. */
10306 m
= gfc_match_char (',');
10312 /* Access specifier. */
10314 m
= gfc_match (" public");
10315 if (m
== MATCH_ERROR
)
10317 if (m
== MATCH_YES
)
10319 if (ba
->access
!= ACCESS_UNKNOWN
)
10321 gfc_error ("Duplicate access-specifier at %C");
10325 ba
->access
= ACCESS_PUBLIC
;
10329 m
= gfc_match (" private");
10330 if (m
== MATCH_ERROR
)
10332 if (m
== MATCH_YES
)
10334 if (ba
->access
!= ACCESS_UNKNOWN
)
10336 gfc_error ("Duplicate access-specifier at %C");
10340 ba
->access
= ACCESS_PRIVATE
;
10344 /* If inside GENERIC, the following is not allowed. */
10349 m
= gfc_match (" nopass");
10350 if (m
== MATCH_ERROR
)
10352 if (m
== MATCH_YES
)
10356 gfc_error ("Binding attributes already specify passing,"
10357 " illegal NOPASS at %C");
10361 found_passing
= true;
10366 /* PASS possibly including argument. */
10367 m
= gfc_match (" pass");
10368 if (m
== MATCH_ERROR
)
10370 if (m
== MATCH_YES
)
10372 char arg
[GFC_MAX_SYMBOL_LEN
+ 1];
10376 gfc_error ("Binding attributes already specify passing,"
10377 " illegal PASS at %C");
10381 m
= gfc_match (" ( %n )", arg
);
10382 if (m
== MATCH_ERROR
)
10384 if (m
== MATCH_YES
)
10385 ba
->pass_arg
= gfc_get_string ("%s", arg
);
10386 gcc_assert ((m
== MATCH_YES
) == (ba
->pass_arg
!= NULL
));
10388 found_passing
= true;
10395 /* POINTER flag. */
10396 m
= gfc_match (" pointer");
10397 if (m
== MATCH_ERROR
)
10399 if (m
== MATCH_YES
)
10403 gfc_error ("Duplicate POINTER attribute at %C");
10413 /* NON_OVERRIDABLE flag. */
10414 m
= gfc_match (" non_overridable");
10415 if (m
== MATCH_ERROR
)
10417 if (m
== MATCH_YES
)
10419 if (ba
->non_overridable
)
10421 gfc_error ("Duplicate NON_OVERRIDABLE at %C");
10425 ba
->non_overridable
= 1;
10429 /* DEFERRED flag. */
10430 m
= gfc_match (" deferred");
10431 if (m
== MATCH_ERROR
)
10433 if (m
== MATCH_YES
)
10437 gfc_error ("Duplicate DEFERRED at %C");
10448 /* Nothing matching found. */
10450 gfc_error ("Expected access-specifier at %C");
10452 gfc_error ("Expected binding attribute at %C");
10455 while (gfc_match_char (',') == MATCH_YES
);
10457 /* NON_OVERRIDABLE and DEFERRED exclude themselves. */
10458 if (ba
->non_overridable
&& ba
->deferred
)
10460 gfc_error ("NON_OVERRIDABLE and DEFERRED can't both appear at %C");
10467 if (ba
->access
== ACCESS_UNKNOWN
)
10468 ba
->access
= gfc_typebound_default_access
;
10470 if (ppc
&& !seen_ptr
)
10472 gfc_error ("POINTER attribute is required for procedure pointer component"
10480 return MATCH_ERROR
;
10484 /* Match a PROCEDURE specific binding inside a derived type. */
10487 match_procedure_in_type (void)
10489 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10490 char target_buf
[GFC_MAX_SYMBOL_LEN
+ 1];
10491 char* target
= NULL
, *ifc
= NULL
;
10492 gfc_typebound_proc tb
;
10496 gfc_symtree
* stree
;
10501 /* Check current state. */
10502 gcc_assert (gfc_state_stack
->state
== COMP_DERIVED_CONTAINS
);
10503 block
= gfc_state_stack
->previous
->sym
;
10504 gcc_assert (block
);
10506 /* Try to match PROCEDURE(interface). */
10507 if (gfc_match (" (") == MATCH_YES
)
10509 m
= gfc_match_name (target_buf
);
10510 if (m
== MATCH_ERROR
)
10512 if (m
!= MATCH_YES
)
10514 gfc_error ("Interface-name expected after %<(%> at %C");
10515 return MATCH_ERROR
;
10518 if (gfc_match (" )") != MATCH_YES
)
10520 gfc_error ("%<)%> expected at %C");
10521 return MATCH_ERROR
;
10527 /* Construct the data structure. */
10528 memset (&tb
, 0, sizeof (tb
));
10529 tb
.where
= gfc_current_locus
;
10531 /* Match binding attributes. */
10532 m
= match_binding_attributes (&tb
, false, false);
10533 if (m
== MATCH_ERROR
)
10535 seen_attrs
= (m
== MATCH_YES
);
10537 /* Check that attribute DEFERRED is given if an interface is specified. */
10538 if (tb
.deferred
&& !ifc
)
10540 gfc_error ("Interface must be specified for DEFERRED binding at %C");
10541 return MATCH_ERROR
;
10543 if (ifc
&& !tb
.deferred
)
10545 gfc_error ("PROCEDURE(interface) at %C should be declared DEFERRED");
10546 return MATCH_ERROR
;
10549 /* Match the colons. */
10550 m
= gfc_match (" ::");
10551 if (m
== MATCH_ERROR
)
10553 seen_colons
= (m
== MATCH_YES
);
10554 if (seen_attrs
&& !seen_colons
)
10556 gfc_error ("Expected %<::%> after binding-attributes at %C");
10557 return MATCH_ERROR
;
10560 /* Match the binding names. */
10563 m
= gfc_match_name (name
);
10564 if (m
== MATCH_ERROR
)
10568 gfc_error ("Expected binding name at %C");
10569 return MATCH_ERROR
;
10572 if (num
>1 && !gfc_notify_std (GFC_STD_F2008
, "PROCEDURE list at %C"))
10573 return MATCH_ERROR
;
10575 /* Try to match the '=> target', if it's there. */
10577 m
= gfc_match (" =>");
10578 if (m
== MATCH_ERROR
)
10580 if (m
== MATCH_YES
)
10584 gfc_error ("%<=> target%> is invalid for DEFERRED binding at %C");
10585 return MATCH_ERROR
;
10590 gfc_error ("%<::%> needed in PROCEDURE binding with explicit target"
10592 return MATCH_ERROR
;
10595 m
= gfc_match_name (target_buf
);
10596 if (m
== MATCH_ERROR
)
10600 gfc_error ("Expected binding target after %<=>%> at %C");
10601 return MATCH_ERROR
;
10603 target
= target_buf
;
10606 /* If no target was found, it has the same name as the binding. */
10610 /* Get the namespace to insert the symbols into. */
10611 ns
= block
->f2k_derived
;
10614 /* If the binding is DEFERRED, check that the containing type is ABSTRACT. */
10615 if (tb
.deferred
&& !block
->attr
.abstract
)
10617 gfc_error ("Type %qs containing DEFERRED binding at %C "
10618 "is not ABSTRACT", block
->name
);
10619 return MATCH_ERROR
;
10622 /* See if we already have a binding with this name in the symtree which
10623 would be an error. If a GENERIC already targeted this binding, it may
10624 be already there but then typebound is still NULL. */
10625 stree
= gfc_find_symtree (ns
->tb_sym_root
, name
);
10626 if (stree
&& stree
->n
.tb
)
10628 gfc_error ("There is already a procedure with binding name %qs for "
10629 "the derived type %qs at %C", name
, block
->name
);
10630 return MATCH_ERROR
;
10633 /* Insert it and set attributes. */
10637 stree
= gfc_new_symtree (&ns
->tb_sym_root
, name
);
10638 gcc_assert (stree
);
10640 stree
->n
.tb
= gfc_get_typebound_proc (&tb
);
10642 if (gfc_get_sym_tree (target
, gfc_current_ns
, &stree
->n
.tb
->u
.specific
,
10644 return MATCH_ERROR
;
10645 gfc_set_sym_referenced (stree
->n
.tb
->u
.specific
->n
.sym
);
10646 gfc_add_flavor(&stree
->n
.tb
->u
.specific
->n
.sym
->attr
, FL_PROCEDURE
,
10647 target
, &stree
->n
.tb
->u
.specific
->n
.sym
->declared_at
);
10649 if (gfc_match_eos () == MATCH_YES
)
10651 if (gfc_match_char (',') != MATCH_YES
)
10656 gfc_error ("Syntax error in PROCEDURE statement at %C");
10657 return MATCH_ERROR
;
10661 /* Match a GENERIC procedure binding inside a derived type. */
10664 gfc_match_generic (void)
10666 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10667 char bind_name
[GFC_MAX_SYMBOL_LEN
+ 16]; /* Allow space for OPERATOR(...). */
10669 gfc_typebound_proc tbattr
; /* Used for match_binding_attributes. */
10670 gfc_typebound_proc
* tb
;
10672 interface_type op_type
;
10673 gfc_intrinsic_op op
;
10676 /* Check current state. */
10677 if (gfc_current_state () == COMP_DERIVED
)
10679 gfc_error ("GENERIC at %C must be inside a derived-type CONTAINS");
10680 return MATCH_ERROR
;
10682 if (gfc_current_state () != COMP_DERIVED_CONTAINS
)
10684 block
= gfc_state_stack
->previous
->sym
;
10685 ns
= block
->f2k_derived
;
10686 gcc_assert (block
&& ns
);
10688 memset (&tbattr
, 0, sizeof (tbattr
));
10689 tbattr
.where
= gfc_current_locus
;
10691 /* See if we get an access-specifier. */
10692 m
= match_binding_attributes (&tbattr
, true, false);
10693 if (m
== MATCH_ERROR
)
10696 /* Now the colons, those are required. */
10697 if (gfc_match (" ::") != MATCH_YES
)
10699 gfc_error ("Expected %<::%> at %C");
10703 /* Match the binding name; depending on type (operator / generic) format
10704 it for future error messages into bind_name. */
10706 m
= gfc_match_generic_spec (&op_type
, name
, &op
);
10707 if (m
== MATCH_ERROR
)
10708 return MATCH_ERROR
;
10711 gfc_error ("Expected generic name or operator descriptor at %C");
10717 case INTERFACE_GENERIC
:
10718 case INTERFACE_DTIO
:
10719 snprintf (bind_name
, sizeof (bind_name
), "%s", name
);
10722 case INTERFACE_USER_OP
:
10723 snprintf (bind_name
, sizeof (bind_name
), "OPERATOR(.%s.)", name
);
10726 case INTERFACE_INTRINSIC_OP
:
10727 snprintf (bind_name
, sizeof (bind_name
), "OPERATOR(%s)",
10728 gfc_op2string (op
));
10731 case INTERFACE_NAMELESS
:
10732 gfc_error ("Malformed GENERIC statement at %C");
10737 gcc_unreachable ();
10740 /* Match the required =>. */
10741 if (gfc_match (" =>") != MATCH_YES
)
10743 gfc_error ("Expected %<=>%> at %C");
10747 /* Try to find existing GENERIC binding with this name / for this operator;
10748 if there is something, check that it is another GENERIC and then extend
10749 it rather than building a new node. Otherwise, create it and put it
10750 at the right position. */
10754 case INTERFACE_DTIO
:
10755 case INTERFACE_USER_OP
:
10756 case INTERFACE_GENERIC
:
10758 const bool is_op
= (op_type
== INTERFACE_USER_OP
);
10761 st
= gfc_find_symtree (is_op
? ns
->tb_uop_root
: ns
->tb_sym_root
, name
);
10762 tb
= st
? st
->n
.tb
: NULL
;
10766 case INTERFACE_INTRINSIC_OP
:
10767 tb
= ns
->tb_op
[op
];
10771 gcc_unreachable ();
10776 if (!tb
->is_generic
)
10778 gcc_assert (op_type
== INTERFACE_GENERIC
);
10779 gfc_error ("There's already a non-generic procedure with binding name"
10780 " %qs for the derived type %qs at %C",
10781 bind_name
, block
->name
);
10785 if (tb
->access
!= tbattr
.access
)
10787 gfc_error ("Binding at %C must have the same access as already"
10788 " defined binding %qs", bind_name
);
10794 tb
= gfc_get_typebound_proc (NULL
);
10795 tb
->where
= gfc_current_locus
;
10796 tb
->access
= tbattr
.access
;
10797 tb
->is_generic
= 1;
10798 tb
->u
.generic
= NULL
;
10802 case INTERFACE_DTIO
:
10803 case INTERFACE_GENERIC
:
10804 case INTERFACE_USER_OP
:
10806 const bool is_op
= (op_type
== INTERFACE_USER_OP
);
10807 gfc_symtree
* st
= gfc_get_tbp_symtree (is_op
? &ns
->tb_uop_root
:
10808 &ns
->tb_sym_root
, name
);
10815 case INTERFACE_INTRINSIC_OP
:
10816 ns
->tb_op
[op
] = tb
;
10820 gcc_unreachable ();
10824 /* Now, match all following names as specific targets. */
10827 gfc_symtree
* target_st
;
10828 gfc_tbp_generic
* target
;
10830 m
= gfc_match_name (name
);
10831 if (m
== MATCH_ERROR
)
10835 gfc_error ("Expected specific binding name at %C");
10839 target_st
= gfc_get_tbp_symtree (&ns
->tb_sym_root
, name
);
10841 /* See if this is a duplicate specification. */
10842 for (target
= tb
->u
.generic
; target
; target
= target
->next
)
10843 if (target_st
== target
->specific_st
)
10845 gfc_error ("%qs already defined as specific binding for the"
10846 " generic %qs at %C", name
, bind_name
);
10850 target
= gfc_get_tbp_generic ();
10851 target
->specific_st
= target_st
;
10852 target
->specific
= NULL
;
10853 target
->next
= tb
->u
.generic
;
10854 target
->is_operator
= ((op_type
== INTERFACE_USER_OP
)
10855 || (op_type
== INTERFACE_INTRINSIC_OP
));
10856 tb
->u
.generic
= target
;
10858 while (gfc_match (" ,") == MATCH_YES
);
10860 /* Here should be the end. */
10861 if (gfc_match_eos () != MATCH_YES
)
10863 gfc_error ("Junk after GENERIC binding at %C");
10870 return MATCH_ERROR
;
10874 /* Match a FINAL declaration inside a derived type. */
10877 gfc_match_final_decl (void)
10879 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10882 gfc_namespace
* module_ns
;
10886 if (gfc_current_form
== FORM_FREE
)
10888 char c
= gfc_peek_ascii_char ();
10889 if (!gfc_is_whitespace (c
) && c
!= ':')
10893 if (gfc_state_stack
->state
!= COMP_DERIVED_CONTAINS
)
10895 if (gfc_current_form
== FORM_FIXED
)
10898 gfc_error ("FINAL declaration at %C must be inside a derived type "
10899 "CONTAINS section");
10900 return MATCH_ERROR
;
10903 block
= gfc_state_stack
->previous
->sym
;
10904 gcc_assert (block
);
10906 if (!gfc_state_stack
->previous
|| !gfc_state_stack
->previous
->previous
10907 || gfc_state_stack
->previous
->previous
->state
!= COMP_MODULE
)
10909 gfc_error ("Derived type declaration with FINAL at %C must be in the"
10910 " specification part of a MODULE");
10911 return MATCH_ERROR
;
10914 module_ns
= gfc_current_ns
;
10915 gcc_assert (module_ns
);
10916 gcc_assert (module_ns
->proc_name
->attr
.flavor
== FL_MODULE
);
10918 /* Match optional ::, don't care about MATCH_YES or MATCH_NO. */
10919 if (gfc_match (" ::") == MATCH_ERROR
)
10920 return MATCH_ERROR
;
10922 /* Match the sequence of procedure names. */
10929 if (first
&& gfc_match_eos () == MATCH_YES
)
10931 gfc_error ("Empty FINAL at %C");
10932 return MATCH_ERROR
;
10935 m
= gfc_match_name (name
);
10938 gfc_error ("Expected module procedure name at %C");
10939 return MATCH_ERROR
;
10941 else if (m
!= MATCH_YES
)
10942 return MATCH_ERROR
;
10944 if (gfc_match_eos () == MATCH_YES
)
10946 if (!last
&& gfc_match_char (',') != MATCH_YES
)
10948 gfc_error ("Expected %<,%> at %C");
10949 return MATCH_ERROR
;
10952 if (gfc_get_symbol (name
, module_ns
, &sym
))
10954 gfc_error ("Unknown procedure name %qs at %C", name
);
10955 return MATCH_ERROR
;
10958 /* Mark the symbol as module procedure. */
10959 if (sym
->attr
.proc
!= PROC_MODULE
10960 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
10961 return MATCH_ERROR
;
10963 /* Check if we already have this symbol in the list, this is an error. */
10964 for (f
= block
->f2k_derived
->finalizers
; f
; f
= f
->next
)
10965 if (f
->proc_sym
== sym
)
10967 gfc_error ("%qs at %C is already defined as FINAL procedure",
10969 return MATCH_ERROR
;
10972 /* Add this symbol to the list of finalizers. */
10973 gcc_assert (block
->f2k_derived
);
10975 f
= XCNEW (gfc_finalizer
);
10977 f
->proc_tree
= NULL
;
10978 f
->where
= gfc_current_locus
;
10979 f
->next
= block
->f2k_derived
->finalizers
;
10980 block
->f2k_derived
->finalizers
= f
;
10990 const ext_attr_t ext_attr_list
[] = {
10991 { "dllimport", EXT_ATTR_DLLIMPORT
, "dllimport" },
10992 { "dllexport", EXT_ATTR_DLLEXPORT
, "dllexport" },
10993 { "cdecl", EXT_ATTR_CDECL
, "cdecl" },
10994 { "stdcall", EXT_ATTR_STDCALL
, "stdcall" },
10995 { "fastcall", EXT_ATTR_FASTCALL
, "fastcall" },
10996 { "no_arg_check", EXT_ATTR_NO_ARG_CHECK
, NULL
},
10997 { NULL
, EXT_ATTR_LAST
, NULL
}
11000 /* Match a !GCC$ ATTRIBUTES statement of the form:
11001 !GCC$ ATTRIBUTES attribute-list :: var-name [, var-name] ...
11002 When we come here, we have already matched the !GCC$ ATTRIBUTES string.
11004 TODO: We should support all GCC attributes using the same syntax for
11005 the attribute list, i.e. the list in C
11006 __attributes(( attribute-list ))
11008 !GCC$ ATTRIBUTES attribute-list ::
11009 Cf. c-parser.c's c_parser_attributes; the data can then directly be
11012 As there is absolutely no risk of confusion, we should never return
11015 gfc_match_gcc_attributes (void)
11017 symbol_attribute attr
;
11018 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
11023 gfc_clear_attr (&attr
);
11028 if (gfc_match_name (name
) != MATCH_YES
)
11029 return MATCH_ERROR
;
11031 for (id
= 0; id
< EXT_ATTR_LAST
; id
++)
11032 if (strcmp (name
, ext_attr_list
[id
].name
) == 0)
11035 if (id
== EXT_ATTR_LAST
)
11037 gfc_error ("Unknown attribute in !GCC$ ATTRIBUTES statement at %C");
11038 return MATCH_ERROR
;
11041 if (!gfc_add_ext_attribute (&attr
, (ext_attr_id_t
)id
, &gfc_current_locus
))
11042 return MATCH_ERROR
;
11044 gfc_gobble_whitespace ();
11045 ch
= gfc_next_ascii_char ();
11048 /* This is the successful exit condition for the loop. */
11049 if (gfc_next_ascii_char () == ':')
11059 if (gfc_match_eos () == MATCH_YES
)
11064 m
= gfc_match_name (name
);
11065 if (m
!= MATCH_YES
)
11068 if (find_special (name
, &sym
, true))
11069 return MATCH_ERROR
;
11071 sym
->attr
.ext_attr
|= attr
.ext_attr
;
11073 if (gfc_match_eos () == MATCH_YES
)
11076 if (gfc_match_char (',') != MATCH_YES
)
11083 gfc_error ("Syntax error in !GCC$ ATTRIBUTES statement at %C");
11084 return MATCH_ERROR
;
11088 /* Match a !GCC$ UNROLL statement of the form:
11091 The parameter n is the number of times we are supposed to unroll.
11093 When we come here, we have already matched the !GCC$ UNROLL string. */
11095 gfc_match_gcc_unroll (void)
11099 if (gfc_match_small_int (&value
) == MATCH_YES
)
11101 if (value
< 0 || value
> USHRT_MAX
)
11103 gfc_error ("%<GCC unroll%> directive requires a"
11104 " non-negative integral constant"
11105 " less than or equal to %u at %C",
11108 return MATCH_ERROR
;
11110 if (gfc_match_eos () == MATCH_YES
)
11112 directive_unroll
= value
== 0 ? 1 : value
;
11117 gfc_error ("Syntax error in !GCC$ UNROLL directive at %C");
11118 return MATCH_ERROR
;