1 /* Declaration statement matcher
2 Copyright (C) 2002-2018 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
23 #include "coretypes.h"
27 #include "stringpool.h"
30 #include "constructor.h"
32 /* Macros to access allocate memory for gfc_data_variable,
33 gfc_data_value and gfc_data. */
34 #define gfc_get_data_variable() XCNEW (gfc_data_variable)
35 #define gfc_get_data_value() XCNEW (gfc_data_value)
36 #define gfc_get_data() XCNEW (gfc_data)
39 static bool set_binding_label (const char **, const char *, int);
42 /* This flag is set if an old-style length selector is matched
43 during a type-declaration statement. */
45 static int old_char_selector
;
47 /* When variables acquire types and attributes from a declaration
48 statement, they get them from the following static variables. The
49 first part of a declaration sets these variables and the second
50 part copies these into symbol structures. */
52 static gfc_typespec current_ts
;
54 static symbol_attribute current_attr
;
55 static gfc_array_spec
*current_as
;
56 static int colon_seen
;
59 /* The current binding label (if any). */
60 static const char* curr_binding_label
;
61 /* Need to know how many identifiers are on the current data declaration
62 line in case we're given the BIND(C) attribute with a NAME= specifier. */
63 static int num_idents_on_line
;
64 /* Need to know if a NAME= specifier was found during gfc_match_bind_c so we
65 can supply a name if the curr_binding_label is nil and NAME= was not. */
66 static int has_name_equals
= 0;
68 /* Initializer of the previous enumerator. */
70 static gfc_expr
*last_initializer
;
72 /* History of all the enumerators is maintained, so that
73 kind values of all the enumerators could be updated depending
74 upon the maximum initialized value. */
76 typedef struct enumerator_history
79 gfc_expr
*initializer
;
80 struct enumerator_history
*next
;
84 /* Header of enum history chain. */
86 static enumerator_history
*enum_history
= NULL
;
88 /* Pointer of enum history node containing largest initializer. */
90 static enumerator_history
*max_enum
= NULL
;
92 /* gfc_new_block points to the symbol of a newly matched block. */
94 gfc_symbol
*gfc_new_block
;
96 bool gfc_matching_function
;
98 /* Set upon parsing a !GCC$ unroll n directive for use in the next loop. */
99 int directive_unroll
= -1;
101 /* If a kind expression of a component of a parameterized derived type is
102 parameterized, temporarily store the expression here. */
103 static gfc_expr
*saved_kind_expr
= NULL
;
105 /* Used to store the parameter list arising in a PDT declaration and
106 in the typespec of a PDT variable or component. */
107 static gfc_actual_arglist
*decl_type_param_list
;
108 static gfc_actual_arglist
*type_param_spec_list
;
110 /********************* DATA statement subroutines *********************/
112 static bool in_match_data
= false;
115 gfc_in_match_data (void)
117 return in_match_data
;
121 set_in_match_data (bool set_value
)
123 in_match_data
= set_value
;
126 /* Free a gfc_data_variable structure and everything beneath it. */
129 free_variable (gfc_data_variable
*p
)
131 gfc_data_variable
*q
;
136 gfc_free_expr (p
->expr
);
137 gfc_free_iterator (&p
->iter
, 0);
138 free_variable (p
->list
);
144 /* Free a gfc_data_value structure and everything beneath it. */
147 free_value (gfc_data_value
*p
)
154 mpz_clear (p
->repeat
);
155 gfc_free_expr (p
->expr
);
161 /* Free a list of gfc_data structures. */
164 gfc_free_data (gfc_data
*p
)
171 free_variable (p
->var
);
172 free_value (p
->value
);
178 /* Free all data in a namespace. */
181 gfc_free_data_all (gfc_namespace
*ns
)
193 /* Reject data parsed since the last restore point was marked. */
196 gfc_reject_data (gfc_namespace
*ns
)
200 while (ns
->data
&& ns
->data
!= ns
->old_data
)
208 static match
var_element (gfc_data_variable
*);
210 /* Match a list of variables terminated by an iterator and a right
214 var_list (gfc_data_variable
*parent
)
216 gfc_data_variable
*tail
, var
;
219 m
= var_element (&var
);
220 if (m
== MATCH_ERROR
)
225 tail
= gfc_get_data_variable ();
232 if (gfc_match_char (',') != MATCH_YES
)
235 m
= gfc_match_iterator (&parent
->iter
, 1);
238 if (m
== MATCH_ERROR
)
241 m
= var_element (&var
);
242 if (m
== MATCH_ERROR
)
247 tail
->next
= gfc_get_data_variable ();
253 if (gfc_match_char (')') != MATCH_YES
)
258 gfc_syntax_error (ST_DATA
);
263 /* Match a single element in a data variable list, which can be a
264 variable-iterator list. */
267 var_element (gfc_data_variable
*new_var
)
272 memset (new_var
, 0, sizeof (gfc_data_variable
));
274 if (gfc_match_char ('(') == MATCH_YES
)
275 return var_list (new_var
);
277 m
= gfc_match_variable (&new_var
->expr
, 0);
281 sym
= new_var
->expr
->symtree
->n
.sym
;
283 /* Symbol should already have an associated type. */
284 if (!gfc_check_symbol_typed (sym
, gfc_current_ns
, false, gfc_current_locus
))
287 if (!sym
->attr
.function
&& gfc_current_ns
->parent
288 && gfc_current_ns
->parent
== sym
->ns
)
290 gfc_error ("Host associated variable %qs may not be in the DATA "
291 "statement at %C", sym
->name
);
295 if (gfc_current_state () != COMP_BLOCK_DATA
296 && sym
->attr
.in_common
297 && !gfc_notify_std (GFC_STD_GNU
, "initialization of "
298 "common block variable %qs in DATA statement at %C",
302 if (!gfc_add_data (&sym
->attr
, sym
->name
, &new_var
->expr
->where
))
309 /* Match the top-level list of data variables. */
312 top_var_list (gfc_data
*d
)
314 gfc_data_variable var
, *tail
, *new_var
;
321 m
= var_element (&var
);
324 if (m
== MATCH_ERROR
)
327 new_var
= gfc_get_data_variable ();
333 tail
->next
= new_var
;
337 if (gfc_match_char ('/') == MATCH_YES
)
339 if (gfc_match_char (',') != MATCH_YES
)
346 gfc_syntax_error (ST_DATA
);
347 gfc_free_data_all (gfc_current_ns
);
353 match_data_constant (gfc_expr
**result
)
355 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
356 gfc_symbol
*sym
, *dt_sym
= NULL
;
361 m
= gfc_match_literal_constant (&expr
, 1);
368 if (m
== MATCH_ERROR
)
371 m
= gfc_match_null (result
);
375 old_loc
= gfc_current_locus
;
377 /* Should this be a structure component, try to match it
378 before matching a name. */
379 m
= gfc_match_rvalue (result
);
380 if (m
== MATCH_ERROR
)
383 if (m
== MATCH_YES
&& (*result
)->expr_type
== EXPR_STRUCTURE
)
385 if (!gfc_simplify_expr (*result
, 0))
389 else if (m
== MATCH_YES
)
390 gfc_free_expr (*result
);
392 gfc_current_locus
= old_loc
;
394 m
= gfc_match_name (name
);
398 if (gfc_find_symbol (name
, NULL
, 1, &sym
))
401 if (sym
&& sym
->attr
.generic
)
402 dt_sym
= gfc_find_dt_in_generic (sym
);
405 || (sym
->attr
.flavor
!= FL_PARAMETER
406 && (!dt_sym
|| !gfc_fl_struct (dt_sym
->attr
.flavor
))))
408 gfc_error ("Symbol %qs must be a PARAMETER in DATA statement at %C",
413 else if (dt_sym
&& gfc_fl_struct (dt_sym
->attr
.flavor
))
414 return gfc_match_structure_constructor (dt_sym
, result
);
416 /* Check to see if the value is an initialization array expression. */
417 if (sym
->value
->expr_type
== EXPR_ARRAY
)
419 gfc_current_locus
= old_loc
;
421 m
= gfc_match_init_expr (result
);
422 if (m
== MATCH_ERROR
)
427 if (!gfc_simplify_expr (*result
, 0))
430 if ((*result
)->expr_type
== EXPR_CONSTANT
)
434 gfc_error ("Invalid initializer %s in Data statement at %C", name
);
440 *result
= gfc_copy_expr (sym
->value
);
445 /* Match a list of values in a DATA statement. The leading '/' has
446 already been seen at this point. */
449 top_val_list (gfc_data
*data
)
451 gfc_data_value
*new_val
, *tail
;
459 m
= match_data_constant (&expr
);
462 if (m
== MATCH_ERROR
)
465 new_val
= gfc_get_data_value ();
466 mpz_init (new_val
->repeat
);
469 data
->value
= new_val
;
471 tail
->next
= new_val
;
475 if (expr
->ts
.type
!= BT_INTEGER
|| gfc_match_char ('*') != MATCH_YES
)
478 mpz_set_ui (tail
->repeat
, 1);
482 mpz_set (tail
->repeat
, expr
->value
.integer
);
483 gfc_free_expr (expr
);
485 m
= match_data_constant (&tail
->expr
);
488 if (m
== MATCH_ERROR
)
492 if (gfc_match_char ('/') == MATCH_YES
)
494 if (gfc_match_char (',') == MATCH_NO
)
501 gfc_syntax_error (ST_DATA
);
502 gfc_free_data_all (gfc_current_ns
);
507 /* Matches an old style initialization. */
510 match_old_style_init (const char *name
)
517 /* Set up data structure to hold initializers. */
518 gfc_find_sym_tree (name
, NULL
, 0, &st
);
521 newdata
= gfc_get_data ();
522 newdata
->var
= gfc_get_data_variable ();
523 newdata
->var
->expr
= gfc_get_variable_expr (st
);
524 newdata
->where
= gfc_current_locus
;
526 /* Match initial value list. This also eats the terminal '/'. */
527 m
= top_val_list (newdata
);
536 gfc_error ("Initialization at %C is not allowed in a PURE procedure");
540 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
542 /* Mark the variable as having appeared in a data statement. */
543 if (!gfc_add_data (&sym
->attr
, sym
->name
, &sym
->declared_at
))
549 /* Chain in namespace list of DATA initializers. */
550 newdata
->next
= gfc_current_ns
->data
;
551 gfc_current_ns
->data
= newdata
;
557 /* Match the stuff following a DATA statement. If ERROR_FLAG is set,
558 we are matching a DATA statement and are therefore issuing an error
559 if we encounter something unexpected, if not, we're trying to match
560 an old-style initialization expression of the form INTEGER I /2/. */
563 gfc_match_data (void)
568 /* Before parsing the rest of a DATA statement, check F2008:c1206. */
569 if ((gfc_current_state () == COMP_FUNCTION
570 || gfc_current_state () == COMP_SUBROUTINE
)
571 && gfc_state_stack
->previous
->state
== COMP_INTERFACE
)
573 gfc_error ("DATA statement at %C cannot appear within an INTERFACE");
577 set_in_match_data (true);
581 new_data
= gfc_get_data ();
582 new_data
->where
= gfc_current_locus
;
584 m
= top_var_list (new_data
);
588 if (new_data
->var
->iter
.var
589 && new_data
->var
->iter
.var
->ts
.type
== BT_INTEGER
590 && new_data
->var
->iter
.var
->symtree
->n
.sym
->attr
.implied_index
== 1
591 && new_data
->var
->list
592 && new_data
->var
->list
->expr
593 && new_data
->var
->list
->expr
->ts
.type
== BT_CHARACTER
594 && new_data
->var
->list
->expr
->ref
595 && new_data
->var
->list
->expr
->ref
->type
== REF_SUBSTRING
)
597 gfc_error ("Invalid substring in data-implied-do at %L in DATA "
598 "statement", &new_data
->var
->list
->expr
->where
);
602 m
= top_val_list (new_data
);
606 new_data
->next
= gfc_current_ns
->data
;
607 gfc_current_ns
->data
= new_data
;
609 if (gfc_match_eos () == MATCH_YES
)
612 gfc_match_char (','); /* Optional comma */
615 set_in_match_data (false);
619 gfc_error ("DATA statement at %C is not allowed in a PURE procedure");
622 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
627 set_in_match_data (false);
628 gfc_free_data (new_data
);
633 /************************ Declaration statements *********************/
636 /* Like gfc_match_init_expr, but matches a 'clist' (old-style initialization
637 list). The difference here is the expression is a list of constants
638 and is surrounded by '/'.
639 The typespec ts must match the typespec of the variable which the
640 clist is initializing.
641 The arrayspec tells whether this should match a list of constants
642 corresponding to array elements or a scalar (as == NULL). */
645 match_clist_expr (gfc_expr
**result
, gfc_typespec
*ts
, gfc_array_spec
*as
)
647 gfc_constructor_base array_head
= NULL
;
648 gfc_expr
*expr
= NULL
;
651 mpz_t repeat
, cons_size
, as_size
;
657 mpz_init_set_ui (repeat
, 0);
658 scalar
= !as
|| !as
->rank
;
660 /* We have already matched '/' - now look for a constant list, as with
661 top_val_list from decl.c, but append the result to an array. */
662 if (gfc_match ("/") == MATCH_YES
)
664 gfc_error ("Empty old style initializer list at %C");
668 where
= gfc_current_locus
;
671 m
= match_data_constant (&expr
);
673 expr
= NULL
; /* match_data_constant may set expr to garbage */
676 if (m
== MATCH_ERROR
)
679 /* Found r in repeat spec r*c; look for the constant to repeat. */
680 if ( gfc_match_char ('*') == MATCH_YES
)
684 gfc_error ("Repeat spec invalid in scalar initializer at %C");
687 if (expr
->ts
.type
!= BT_INTEGER
)
689 gfc_error ("Repeat spec must be an integer at %C");
692 mpz_set (repeat
, expr
->value
.integer
);
693 gfc_free_expr (expr
);
696 m
= match_data_constant (&expr
);
698 gfc_error ("Expected data constant after repeat spec at %C");
702 /* No repeat spec, we matched the data constant itself. */
704 mpz_set_ui (repeat
, 1);
708 /* Add the constant initializer as many times as repeated. */
709 for (; mpz_cmp_ui (repeat
, 0) > 0; mpz_sub_ui (repeat
, repeat
, 1))
711 /* Make sure types of elements match */
712 if(ts
&& !gfc_compare_types (&expr
->ts
, ts
)
713 && !gfc_convert_type (expr
, ts
, 1))
716 gfc_constructor_append_expr (&array_head
,
717 gfc_copy_expr (expr
), &gfc_current_locus
);
720 gfc_free_expr (expr
);
724 /* For scalar initializers quit after one element. */
727 if(gfc_match_char ('/') != MATCH_YES
)
729 gfc_error ("End of scalar initializer expected at %C");
735 if (gfc_match_char ('/') == MATCH_YES
)
737 if (gfc_match_char (',') == MATCH_NO
)
741 /* Set up expr as an array constructor. */
744 expr
= gfc_get_array_expr (ts
->type
, ts
->kind
, &where
);
746 expr
->value
.constructor
= array_head
;
748 expr
->rank
= as
->rank
;
749 expr
->shape
= gfc_get_shape (expr
->rank
);
751 /* Validate sizes. We built expr ourselves, so cons_size will be
752 constant (we fail above for non-constant expressions).
753 We still need to verify that the array-spec has constant size. */
755 gcc_assert (gfc_array_size (expr
, &cons_size
));
756 if (!spec_size (as
, &as_size
))
758 gfc_error ("Expected constant array-spec in initializer list at %L",
759 as
->type
== AS_EXPLICIT
? &as
->upper
[0]->where
: &where
);
764 /* Make sure the specs are of the same size. */
765 cmp
= mpz_cmp (cons_size
, as_size
);
767 gfc_error ("Not enough elements in array initializer at %C");
769 gfc_error ("Too many elements in array initializer at %C");
772 mpz_clear (cons_size
);
777 /* Make sure scalar types match. */
778 else if (!gfc_compare_types (&expr
->ts
, ts
)
779 && !gfc_convert_type (expr
, ts
, 1))
783 expr
->ts
.u
.cl
->length_from_typespec
= 1;
790 gfc_error ("Syntax error in old style initializer list at %C");
794 expr
->value
.constructor
= NULL
;
795 gfc_free_expr (expr
);
796 gfc_constructor_free (array_head
);
802 /* Auxiliary function to merge DIMENSION and CODIMENSION array specs. */
805 merge_array_spec (gfc_array_spec
*from
, gfc_array_spec
*to
, bool copy
)
809 if ((from
->type
== AS_ASSUMED_RANK
&& to
->corank
)
810 || (to
->type
== AS_ASSUMED_RANK
&& from
->corank
))
812 gfc_error ("The assumed-rank array at %C shall not have a codimension");
816 if (to
->rank
== 0 && from
->rank
> 0)
818 to
->rank
= from
->rank
;
819 to
->type
= from
->type
;
820 to
->cray_pointee
= from
->cray_pointee
;
821 to
->cp_was_assumed
= from
->cp_was_assumed
;
823 for (i
= 0; i
< to
->corank
; i
++)
825 /* Do not exceed the limits on lower[] and upper[]. gfortran
826 cleans up elsewhere. */
828 if (j
>= GFC_MAX_DIMENSIONS
)
831 to
->lower
[j
] = to
->lower
[i
];
832 to
->upper
[j
] = to
->upper
[i
];
834 for (i
= 0; i
< from
->rank
; i
++)
838 to
->lower
[i
] = gfc_copy_expr (from
->lower
[i
]);
839 to
->upper
[i
] = gfc_copy_expr (from
->upper
[i
]);
843 to
->lower
[i
] = from
->lower
[i
];
844 to
->upper
[i
] = from
->upper
[i
];
848 else if (to
->corank
== 0 && from
->corank
> 0)
850 to
->corank
= from
->corank
;
851 to
->cotype
= from
->cotype
;
853 for (i
= 0; i
< from
->corank
; i
++)
855 /* Do not exceed the limits on lower[] and upper[]. gfortran
856 cleans up elsewhere. */
858 if (j
>= GFC_MAX_DIMENSIONS
)
863 to
->lower
[j
] = gfc_copy_expr (from
->lower
[i
]);
864 to
->upper
[j
] = gfc_copy_expr (from
->upper
[i
]);
868 to
->lower
[j
] = from
->lower
[i
];
869 to
->upper
[j
] = from
->upper
[i
];
874 if (to
->rank
+ to
->corank
> GFC_MAX_DIMENSIONS
)
876 gfc_error ("Sum of array rank %d and corank %d at %C exceeds maximum "
877 "allowed dimensions of %d",
878 to
->rank
, to
->corank
, GFC_MAX_DIMENSIONS
);
879 to
->corank
= GFC_MAX_DIMENSIONS
- to
->rank
;
886 /* Match an intent specification. Since this can only happen after an
887 INTENT word, a legal intent-spec must follow. */
890 match_intent_spec (void)
893 if (gfc_match (" ( in out )") == MATCH_YES
)
895 if (gfc_match (" ( in )") == MATCH_YES
)
897 if (gfc_match (" ( out )") == MATCH_YES
)
900 gfc_error ("Bad INTENT specification at %C");
901 return INTENT_UNKNOWN
;
905 /* Matches a character length specification, which is either a
906 specification expression, '*', or ':'. */
909 char_len_param_value (gfc_expr
**expr
, bool *deferred
)
916 if (gfc_match_char ('*') == MATCH_YES
)
919 if (gfc_match_char (':') == MATCH_YES
)
921 if (!gfc_notify_std (GFC_STD_F2003
, "deferred type parameter at %C"))
929 m
= gfc_match_expr (expr
);
931 if (m
== MATCH_NO
|| m
== MATCH_ERROR
)
934 if (!gfc_expr_check_typed (*expr
, gfc_current_ns
, false))
937 if ((*expr
)->expr_type
== EXPR_FUNCTION
)
939 if ((*expr
)->ts
.type
== BT_INTEGER
940 || ((*expr
)->ts
.type
== BT_UNKNOWN
941 && strcmp((*expr
)->symtree
->name
, "null") != 0))
946 else if ((*expr
)->expr_type
== EXPR_CONSTANT
)
948 /* F2008, 4.4.3.1: The length is a type parameter; its kind is
949 processor dependent and its value is greater than or equal to zero.
950 F2008, 4.4.3.2: If the character length parameter value evaluates
951 to a negative value, the length of character entities declared
954 if ((*expr
)->ts
.type
== BT_INTEGER
)
956 if (mpz_cmp_si ((*expr
)->value
.integer
, 0) < 0)
957 mpz_set_si ((*expr
)->value
.integer
, 0);
962 else if ((*expr
)->expr_type
== EXPR_ARRAY
)
964 else if ((*expr
)->expr_type
== EXPR_VARIABLE
)
969 e
= gfc_copy_expr (*expr
);
971 /* This catches the invalid code "[character(m(2:3)) :: 'x', 'y']",
972 which causes an ICE if gfc_reduce_init_expr() is called. */
973 if (e
->ref
&& e
->ref
->type
== REF_ARRAY
974 && e
->ref
->u
.ar
.type
== AR_UNKNOWN
975 && e
->ref
->u
.ar
.dimen_type
[0] == DIMEN_RANGE
)
978 t
= gfc_reduce_init_expr (e
);
980 if (!t
&& e
->ts
.type
== BT_UNKNOWN
981 && e
->symtree
->n
.sym
->attr
.untyped
== 1
982 && (flag_implicit_none
983 || e
->symtree
->n
.sym
->ns
->seen_implicit_none
== 1
984 || e
->symtree
->n
.sym
->ns
->parent
->seen_implicit_none
== 1))
990 if ((e
->ref
&& e
->ref
->type
== REF_ARRAY
991 && e
->ref
->u
.ar
.type
!= AR_ELEMENT
)
992 || (!e
->ref
&& e
->expr_type
== EXPR_ARRAY
))
1004 gfc_error ("Scalar INTEGER expression expected at %L", &(*expr
)->where
);
1009 /* A character length is a '*' followed by a literal integer or a
1010 char_len_param_value in parenthesis. */
1013 match_char_length (gfc_expr
**expr
, bool *deferred
, bool obsolescent_check
)
1019 m
= gfc_match_char ('*');
1023 m
= gfc_match_small_literal_int (&length
, NULL
);
1024 if (m
== MATCH_ERROR
)
1029 if (obsolescent_check
1030 && !gfc_notify_std (GFC_STD_F95_OBS
, "Old-style character length at %C"))
1032 *expr
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
, length
);
1036 if (gfc_match_char ('(') == MATCH_NO
)
1039 m
= char_len_param_value (expr
, deferred
);
1040 if (m
!= MATCH_YES
&& gfc_matching_function
)
1042 gfc_undo_symbols ();
1046 if (m
== MATCH_ERROR
)
1051 if (gfc_match_char (')') == MATCH_NO
)
1053 gfc_free_expr (*expr
);
1061 gfc_error ("Syntax error in character length specification at %C");
1066 /* Special subroutine for finding a symbol. Check if the name is found
1067 in the current name space. If not, and we're compiling a function or
1068 subroutine and the parent compilation unit is an interface, then check
1069 to see if the name we've been given is the name of the interface
1070 (located in another namespace). */
1073 find_special (const char *name
, gfc_symbol
**result
, bool allow_subroutine
)
1079 i
= gfc_get_sym_tree (name
, NULL
, &st
, allow_subroutine
);
1082 *result
= st
? st
->n
.sym
: NULL
;
1086 if (gfc_current_state () != COMP_SUBROUTINE
1087 && gfc_current_state () != COMP_FUNCTION
)
1090 s
= gfc_state_stack
->previous
;
1094 if (s
->state
!= COMP_INTERFACE
)
1097 goto end
; /* Nameless interface. */
1099 if (strcmp (name
, s
->sym
->name
) == 0)
1110 /* Special subroutine for getting a symbol node associated with a
1111 procedure name, used in SUBROUTINE and FUNCTION statements. The
1112 symbol is created in the parent using with symtree node in the
1113 child unit pointing to the symbol. If the current namespace has no
1114 parent, then the symbol is just created in the current unit. */
1117 get_proc_name (const char *name
, gfc_symbol
**result
, bool module_fcn_entry
)
1123 /* Module functions have to be left in their own namespace because
1124 they have potentially (almost certainly!) already been referenced.
1125 In this sense, they are rather like external functions. This is
1126 fixed up in resolve.c(resolve_entries), where the symbol name-
1127 space is set to point to the master function, so that the fake
1128 result mechanism can work. */
1129 if (module_fcn_entry
)
1131 /* Present if entry is declared to be a module procedure. */
1132 rc
= gfc_find_symbol (name
, gfc_current_ns
->parent
, 0, result
);
1134 if (*result
== NULL
)
1135 rc
= gfc_get_symbol (name
, NULL
, result
);
1136 else if (!gfc_get_symbol (name
, NULL
, &sym
) && sym
1137 && (*result
)->ts
.type
== BT_UNKNOWN
1138 && sym
->attr
.flavor
== FL_UNKNOWN
)
1139 /* Pick up the typespec for the entry, if declared in the function
1140 body. Note that this symbol is FL_UNKNOWN because it will
1141 only have appeared in a type declaration. The local symtree
1142 is set to point to the module symbol and a unique symtree
1143 to the local version. This latter ensures a correct clearing
1146 /* If the ENTRY proceeds its specification, we need to ensure
1147 that this does not raise a "has no IMPLICIT type" error. */
1148 if (sym
->ts
.type
== BT_UNKNOWN
)
1149 sym
->attr
.untyped
= 1;
1151 (*result
)->ts
= sym
->ts
;
1153 /* Put the symbol in the procedure namespace so that, should
1154 the ENTRY precede its specification, the specification
1156 (*result
)->ns
= gfc_current_ns
;
1158 gfc_find_sym_tree (name
, gfc_current_ns
, 0, &st
);
1159 st
->n
.sym
= *result
;
1160 st
= gfc_get_unique_symtree (gfc_current_ns
);
1166 rc
= gfc_get_symbol (name
, gfc_current_ns
->parent
, result
);
1172 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
1175 if (sym
->attr
.module_procedure
&& sym
->attr
.if_source
== IFSRC_IFBODY
)
1177 /* Create a partially populated interface symbol to carry the
1178 characteristics of the procedure and the result. */
1179 sym
->tlink
= gfc_new_symbol (name
, sym
->ns
);
1180 gfc_add_type (sym
->tlink
, &(sym
->ts
), &gfc_current_locus
);
1181 gfc_copy_attr (&sym
->tlink
->attr
, &sym
->attr
, NULL
);
1182 if (sym
->attr
.dimension
)
1183 sym
->tlink
->as
= gfc_copy_array_spec (sym
->as
);
1185 /* Ideally, at this point, a copy would be made of the formal
1186 arguments and their namespace. However, this does not appear
1187 to be necessary, albeit at the expense of not being able to
1188 use gfc_compare_interfaces directly. */
1190 if (sym
->result
&& sym
->result
!= sym
)
1192 sym
->tlink
->result
= sym
->result
;
1195 else if (sym
->result
)
1197 sym
->tlink
->result
= sym
->tlink
;
1200 else if (sym
&& !sym
->gfc_new
1201 && gfc_current_state () != COMP_INTERFACE
)
1203 /* Trap another encompassed procedure with the same name. All
1204 these conditions are necessary to avoid picking up an entry
1205 whose name clashes with that of the encompassing procedure;
1206 this is handled using gsymbols to register unique, globally
1207 accessible names. */
1208 if (sym
->attr
.flavor
!= 0
1209 && sym
->attr
.proc
!= 0
1210 && (sym
->attr
.subroutine
|| sym
->attr
.function
|| sym
->attr
.entry
)
1211 && sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
1212 gfc_error_now ("Procedure %qs at %C is already defined at %L",
1213 name
, &sym
->declared_at
);
1215 if (sym
->attr
.flavor
!= 0
1216 && sym
->attr
.entry
&& sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
1217 gfc_error_now ("Procedure %qs at %C is already defined at %L",
1218 name
, &sym
->declared_at
);
1220 if (sym
->attr
.external
&& sym
->attr
.procedure
1221 && gfc_current_state () == COMP_CONTAINS
)
1222 gfc_error_now ("Contained procedure %qs at %C clashes with "
1223 "procedure defined at %L",
1224 name
, &sym
->declared_at
);
1226 /* Trap a procedure with a name the same as interface in the
1227 encompassing scope. */
1228 if (sym
->attr
.generic
!= 0
1229 && (sym
->attr
.subroutine
|| sym
->attr
.function
)
1230 && !sym
->attr
.mod_proc
)
1231 gfc_error_now ("Name %qs at %C is already defined"
1232 " as a generic interface at %L",
1233 name
, &sym
->declared_at
);
1235 /* Trap declarations of attributes in encompassing scope. The
1236 signature for this is that ts.kind is set. Legitimate
1237 references only set ts.type. */
1238 if (sym
->ts
.kind
!= 0
1239 && !sym
->attr
.implicit_type
1240 && sym
->attr
.proc
== 0
1241 && gfc_current_ns
->parent
!= NULL
1242 && sym
->attr
.access
== 0
1243 && !module_fcn_entry
)
1244 gfc_error_now ("Procedure %qs at %C has an explicit interface "
1245 "from a previous declaration", name
);
1248 /* C1246 (R1225) MODULE shall appear only in the function-stmt or
1249 subroutine-stmt of a module subprogram or of a nonabstract interface
1250 body that is declared in the scoping unit of a module or submodule. */
1251 if (sym
->attr
.external
1252 && (sym
->attr
.subroutine
|| sym
->attr
.function
)
1253 && sym
->attr
.if_source
== IFSRC_IFBODY
1254 && !current_attr
.module_procedure
1255 && sym
->attr
.proc
== PROC_MODULE
1256 && gfc_state_stack
->state
== COMP_CONTAINS
)
1257 gfc_error_now ("Procedure %qs defined in interface body at %L "
1258 "clashes with internal procedure defined at %C",
1259 name
, &sym
->declared_at
);
1261 if (sym
&& !sym
->gfc_new
1262 && sym
->attr
.flavor
!= FL_UNKNOWN
1263 && sym
->attr
.referenced
== 0 && sym
->attr
.subroutine
== 1
1264 && gfc_state_stack
->state
== COMP_CONTAINS
1265 && gfc_state_stack
->previous
->state
== COMP_SUBROUTINE
)
1266 gfc_error_now ("Procedure %qs at %C is already defined at %L",
1267 name
, &sym
->declared_at
);
1269 if (gfc_current_ns
->parent
== NULL
|| *result
== NULL
)
1272 /* Module function entries will already have a symtree in
1273 the current namespace but will need one at module level. */
1274 if (module_fcn_entry
)
1276 /* Present if entry is declared to be a module procedure. */
1277 rc
= gfc_find_sym_tree (name
, gfc_current_ns
->parent
, 0, &st
);
1279 st
= gfc_new_symtree (&gfc_current_ns
->parent
->sym_root
, name
);
1282 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, name
);
1287 /* See if the procedure should be a module procedure. */
1289 if (((sym
->ns
->proc_name
!= NULL
1290 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
1291 && sym
->attr
.proc
!= PROC_MODULE
)
1292 || (module_fcn_entry
&& sym
->attr
.proc
!= PROC_MODULE
))
1293 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
1300 /* Verify that the given symbol representing a parameter is C
1301 interoperable, by checking to see if it was marked as such after
1302 its declaration. If the given symbol is not interoperable, a
1303 warning is reported, thus removing the need to return the status to
1304 the calling function. The standard does not require the user use
1305 one of the iso_c_binding named constants to declare an
1306 interoperable parameter, but we can't be sure if the param is C
1307 interop or not if the user doesn't. For example, integer(4) may be
1308 legal Fortran, but doesn't have meaning in C. It may interop with
1309 a number of the C types, which causes a problem because the
1310 compiler can't know which one. This code is almost certainly not
1311 portable, and the user will get what they deserve if the C type
1312 across platforms isn't always interoperable with integer(4). If
1313 the user had used something like integer(c_int) or integer(c_long),
1314 the compiler could have automatically handled the varying sizes
1315 across platforms. */
1318 gfc_verify_c_interop_param (gfc_symbol
*sym
)
1320 int is_c_interop
= 0;
1323 /* We check implicitly typed variables in symbol.c:gfc_set_default_type().
1324 Don't repeat the checks here. */
1325 if (sym
->attr
.implicit_type
)
1328 /* For subroutines or functions that are passed to a BIND(C) procedure,
1329 they're interoperable if they're BIND(C) and their params are all
1331 if (sym
->attr
.flavor
== FL_PROCEDURE
)
1333 if (sym
->attr
.is_bind_c
== 0)
1335 gfc_error_now ("Procedure %qs at %L must have the BIND(C) "
1336 "attribute to be C interoperable", sym
->name
,
1337 &(sym
->declared_at
));
1342 if (sym
->attr
.is_c_interop
== 1)
1343 /* We've already checked this procedure; don't check it again. */
1346 return verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
1351 /* See if we've stored a reference to a procedure that owns sym. */
1352 if (sym
->ns
!= NULL
&& sym
->ns
->proc_name
!= NULL
)
1354 if (sym
->ns
->proc_name
->attr
.is_bind_c
== 1)
1356 is_c_interop
= (gfc_verify_c_interop(&(sym
->ts
)) ? 1 : 0);
1358 if (is_c_interop
!= 1)
1360 /* Make personalized messages to give better feedback. */
1361 if (sym
->ts
.type
== BT_DERIVED
)
1362 gfc_error ("Variable %qs at %L is a dummy argument to the "
1363 "BIND(C) procedure %qs but is not C interoperable "
1364 "because derived type %qs is not C interoperable",
1365 sym
->name
, &(sym
->declared_at
),
1366 sym
->ns
->proc_name
->name
,
1367 sym
->ts
.u
.derived
->name
);
1368 else if (sym
->ts
.type
== BT_CLASS
)
1369 gfc_error ("Variable %qs at %L is a dummy argument to the "
1370 "BIND(C) procedure %qs but is not C interoperable "
1371 "because it is polymorphic",
1372 sym
->name
, &(sym
->declared_at
),
1373 sym
->ns
->proc_name
->name
);
1374 else if (warn_c_binding_type
)
1375 gfc_warning (OPT_Wc_binding_type
,
1376 "Variable %qs at %L is a dummy argument of the "
1377 "BIND(C) procedure %qs but may not be C "
1379 sym
->name
, &(sym
->declared_at
),
1380 sym
->ns
->proc_name
->name
);
1383 /* Character strings are only C interoperable if they have a
1385 if (sym
->ts
.type
== BT_CHARACTER
)
1387 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
1388 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
1389 || mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
1391 gfc_error ("Character argument %qs at %L "
1392 "must be length 1 because "
1393 "procedure %qs is BIND(C)",
1394 sym
->name
, &sym
->declared_at
,
1395 sym
->ns
->proc_name
->name
);
1400 /* We have to make sure that any param to a bind(c) routine does
1401 not have the allocatable, pointer, or optional attributes,
1402 according to J3/04-007, section 5.1. */
1403 if (sym
->attr
.allocatable
== 1
1404 && !gfc_notify_std (GFC_STD_F2008_TS
, "Variable %qs at %L with "
1405 "ALLOCATABLE attribute in procedure %qs "
1406 "with BIND(C)", sym
->name
,
1407 &(sym
->declared_at
),
1408 sym
->ns
->proc_name
->name
))
1411 if (sym
->attr
.pointer
== 1
1412 && !gfc_notify_std (GFC_STD_F2008_TS
, "Variable %qs at %L with "
1413 "POINTER attribute in procedure %qs "
1414 "with BIND(C)", sym
->name
,
1415 &(sym
->declared_at
),
1416 sym
->ns
->proc_name
->name
))
1419 if ((sym
->attr
.allocatable
|| sym
->attr
.pointer
) && !sym
->as
)
1421 gfc_error ("Scalar variable %qs at %L with POINTER or "
1422 "ALLOCATABLE in procedure %qs with BIND(C) is not yet"
1423 " supported", sym
->name
, &(sym
->declared_at
),
1424 sym
->ns
->proc_name
->name
);
1428 if (sym
->attr
.optional
== 1 && sym
->attr
.value
)
1430 gfc_error ("Variable %qs at %L cannot have both the OPTIONAL "
1431 "and the VALUE attribute because procedure %qs "
1432 "is BIND(C)", sym
->name
, &(sym
->declared_at
),
1433 sym
->ns
->proc_name
->name
);
1436 else if (sym
->attr
.optional
== 1
1437 && !gfc_notify_std (GFC_STD_F2008_TS
, "Variable %qs "
1438 "at %L with OPTIONAL attribute in "
1439 "procedure %qs which is BIND(C)",
1440 sym
->name
, &(sym
->declared_at
),
1441 sym
->ns
->proc_name
->name
))
1444 /* Make sure that if it has the dimension attribute, that it is
1445 either assumed size or explicit shape. Deferred shape is already
1446 covered by the pointer/allocatable attribute. */
1447 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SHAPE
1448 && !gfc_notify_std (GFC_STD_F2008_TS
, "Assumed-shape array %qs "
1449 "at %L as dummy argument to the BIND(C) "
1450 "procedure %qs at %L", sym
->name
,
1451 &(sym
->declared_at
),
1452 sym
->ns
->proc_name
->name
,
1453 &(sym
->ns
->proc_name
->declared_at
)))
1463 /* Function called by variable_decl() that adds a name to the symbol table. */
1466 build_sym (const char *name
, gfc_charlen
*cl
, bool cl_deferred
,
1467 gfc_array_spec
**as
, locus
*var_locus
)
1469 symbol_attribute attr
;
1474 /* Symbols in a submodule are host associated from the parent module or
1475 submodules. Therefore, they can be overridden by declarations in the
1476 submodule scope. Deal with this by attaching the existing symbol to
1477 a new symtree and recycling the old symtree with a new symbol... */
1478 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
1479 if (st
!= NULL
&& gfc_state_stack
->state
== COMP_SUBMODULE
1480 && st
->n
.sym
!= NULL
1481 && st
->n
.sym
->attr
.host_assoc
&& st
->n
.sym
->attr
.used_in_submodule
)
1483 gfc_symtree
*s
= gfc_get_unique_symtree (gfc_current_ns
);
1484 s
->n
.sym
= st
->n
.sym
;
1485 sym
= gfc_new_symbol (name
, gfc_current_ns
);
1490 gfc_set_sym_referenced (sym
);
1492 /* ...Otherwise generate a new symtree and new symbol. */
1493 else if (gfc_get_symbol (name
, NULL
, &sym
))
1496 /* Check if the name has already been defined as a type. The
1497 first letter of the symtree will be in upper case then. Of
1498 course, this is only necessary if the upper case letter is
1499 actually different. */
1501 upper
= TOUPPER(name
[0]);
1502 if (upper
!= name
[0])
1504 char u_name
[GFC_MAX_SYMBOL_LEN
+ 1];
1507 gcc_assert (strlen(name
) <= GFC_MAX_SYMBOL_LEN
);
1508 strcpy (u_name
, name
);
1511 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, u_name
);
1513 /* STRUCTURE types can alias symbol names */
1514 if (st
!= 0 && st
->n
.sym
->attr
.flavor
!= FL_STRUCT
)
1516 gfc_error ("Symbol %qs at %C also declared as a type at %L", name
,
1517 &st
->n
.sym
->declared_at
);
1522 /* Start updating the symbol table. Add basic type attribute if present. */
1523 if (current_ts
.type
!= BT_UNKNOWN
1524 && (sym
->attr
.implicit_type
== 0
1525 || !gfc_compare_types (&sym
->ts
, ¤t_ts
))
1526 && !gfc_add_type (sym
, ¤t_ts
, var_locus
))
1529 if (sym
->ts
.type
== BT_CHARACTER
)
1532 sym
->ts
.deferred
= cl_deferred
;
1535 /* Add dimension attribute if present. */
1536 if (!gfc_set_array_spec (sym
, *as
, var_locus
))
1540 /* Add attribute to symbol. The copy is so that we can reset the
1541 dimension attribute. */
1542 attr
= current_attr
;
1544 attr
.codimension
= 0;
1546 if (!gfc_copy_attr (&sym
->attr
, &attr
, var_locus
))
1549 /* Finish any work that may need to be done for the binding label,
1550 if it's a bind(c). The bind(c) attr is found before the symbol
1551 is made, and before the symbol name (for data decls), so the
1552 current_ts is holding the binding label, or nothing if the
1553 name= attr wasn't given. Therefore, test here if we're dealing
1554 with a bind(c) and make sure the binding label is set correctly. */
1555 if (sym
->attr
.is_bind_c
== 1)
1557 if (!sym
->binding_label
)
1559 /* Set the binding label and verify that if a NAME= was specified
1560 then only one identifier was in the entity-decl-list. */
1561 if (!set_binding_label (&sym
->binding_label
, sym
->name
,
1562 num_idents_on_line
))
1567 /* See if we know we're in a common block, and if it's a bind(c)
1568 common then we need to make sure we're an interoperable type. */
1569 if (sym
->attr
.in_common
== 1)
1571 /* Test the common block object. */
1572 if (sym
->common_block
!= NULL
&& sym
->common_block
->is_bind_c
== 1
1573 && sym
->ts
.is_c_interop
!= 1)
1575 gfc_error_now ("Variable %qs in common block %qs at %C "
1576 "must be declared with a C interoperable "
1577 "kind since common block %qs is BIND(C)",
1578 sym
->name
, sym
->common_block
->name
,
1579 sym
->common_block
->name
);
1584 sym
->attr
.implied_index
= 0;
1586 /* Use the parameter expressions for a parameterized derived type. */
1587 if ((sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
1588 && sym
->ts
.u
.derived
->attr
.pdt_type
&& type_param_spec_list
)
1589 sym
->param_list
= gfc_copy_actual_arglist (type_param_spec_list
);
1591 if (sym
->ts
.type
== BT_CLASS
)
1592 return gfc_build_class_symbol (&sym
->ts
, &sym
->attr
, &sym
->as
);
1598 /* Set character constant to the given length. The constant will be padded or
1599 truncated. If we're inside an array constructor without a typespec, we
1600 additionally check that all elements have the same length; check_len -1
1601 means no checking. */
1604 gfc_set_constant_character_len (gfc_charlen_t len
, gfc_expr
*expr
,
1605 gfc_charlen_t check_len
)
1610 if (expr
->ts
.type
!= BT_CHARACTER
)
1613 if (expr
->expr_type
!= EXPR_CONSTANT
)
1615 gfc_error_now ("CHARACTER length must be a constant at %L", &expr
->where
);
1619 slen
= expr
->value
.character
.length
;
1622 s
= gfc_get_wide_string (len
+ 1);
1623 memcpy (s
, expr
->value
.character
.string
,
1624 MIN (len
, slen
) * sizeof (gfc_char_t
));
1626 gfc_wide_memset (&s
[slen
], ' ', len
- slen
);
1628 if (warn_character_truncation
&& slen
> len
)
1629 gfc_warning_now (OPT_Wcharacter_truncation
,
1630 "CHARACTER expression at %L is being truncated "
1631 "(%ld/%ld)", &expr
->where
,
1632 (long) slen
, (long) len
);
1634 /* Apply the standard by 'hand' otherwise it gets cleared for
1636 if (check_len
!= -1 && slen
!= check_len
1637 && !(gfc_option
.allow_std
& GFC_STD_GNU
))
1638 gfc_error_now ("The CHARACTER elements of the array constructor "
1639 "at %L must have the same length (%ld/%ld)",
1640 &expr
->where
, (long) slen
,
1644 free (expr
->value
.character
.string
);
1645 expr
->value
.character
.string
= s
;
1646 expr
->value
.character
.length
= len
;
1651 /* Function to create and update the enumerator history
1652 using the information passed as arguments.
1653 Pointer "max_enum" is also updated, to point to
1654 enum history node containing largest initializer.
1656 SYM points to the symbol node of enumerator.
1657 INIT points to its enumerator value. */
1660 create_enum_history (gfc_symbol
*sym
, gfc_expr
*init
)
1662 enumerator_history
*new_enum_history
;
1663 gcc_assert (sym
!= NULL
&& init
!= NULL
);
1665 new_enum_history
= XCNEW (enumerator_history
);
1667 new_enum_history
->sym
= sym
;
1668 new_enum_history
->initializer
= init
;
1669 new_enum_history
->next
= NULL
;
1671 if (enum_history
== NULL
)
1673 enum_history
= new_enum_history
;
1674 max_enum
= enum_history
;
1678 new_enum_history
->next
= enum_history
;
1679 enum_history
= new_enum_history
;
1681 if (mpz_cmp (max_enum
->initializer
->value
.integer
,
1682 new_enum_history
->initializer
->value
.integer
) < 0)
1683 max_enum
= new_enum_history
;
1688 /* Function to free enum kind history. */
1691 gfc_free_enum_history (void)
1693 enumerator_history
*current
= enum_history
;
1694 enumerator_history
*next
;
1696 while (current
!= NULL
)
1698 next
= current
->next
;
1703 enum_history
= NULL
;
1707 /* Function called by variable_decl() that adds an initialization
1708 expression to a symbol. */
1711 add_init_expr_to_sym (const char *name
, gfc_expr
**initp
, locus
*var_locus
)
1713 symbol_attribute attr
;
1718 if (find_special (name
, &sym
, false))
1723 /* If this symbol is confirming an implicit parameter type,
1724 then an initialization expression is not allowed. */
1725 if (attr
.flavor
== FL_PARAMETER
1726 && sym
->value
!= NULL
1729 gfc_error ("Initializer not allowed for PARAMETER %qs at %C",
1736 /* An initializer is required for PARAMETER declarations. */
1737 if (attr
.flavor
== FL_PARAMETER
)
1739 gfc_error ("PARAMETER at %L is missing an initializer", var_locus
);
1745 /* If a variable appears in a DATA block, it cannot have an
1749 gfc_error ("Variable %qs at %C with an initializer already "
1750 "appears in a DATA statement", sym
->name
);
1754 /* Check if the assignment can happen. This has to be put off
1755 until later for derived type variables and procedure pointers. */
1756 if (!gfc_bt_struct (sym
->ts
.type
) && !gfc_bt_struct (init
->ts
.type
)
1757 && sym
->ts
.type
!= BT_CLASS
&& init
->ts
.type
!= BT_CLASS
1758 && !sym
->attr
.proc_pointer
1759 && !gfc_check_assign_symbol (sym
, NULL
, init
))
1762 if (sym
->ts
.type
== BT_CHARACTER
&& sym
->ts
.u
.cl
1763 && init
->ts
.type
== BT_CHARACTER
)
1765 /* Update symbol character length according initializer. */
1766 if (!gfc_check_assign_symbol (sym
, NULL
, init
))
1769 if (sym
->ts
.u
.cl
->length
== NULL
)
1772 /* If there are multiple CHARACTER variables declared on the
1773 same line, we don't want them to share the same length. */
1774 sym
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1776 if (sym
->attr
.flavor
== FL_PARAMETER
)
1778 if (init
->expr_type
== EXPR_CONSTANT
)
1780 clen
= init
->value
.character
.length
;
1781 sym
->ts
.u
.cl
->length
1782 = gfc_get_int_expr (gfc_charlen_int_kind
,
1785 else if (init
->expr_type
== EXPR_ARRAY
)
1787 if (init
->ts
.u
.cl
&& init
->ts
.u
.cl
->length
)
1789 const gfc_expr
*length
= init
->ts
.u
.cl
->length
;
1790 if (length
->expr_type
!= EXPR_CONSTANT
)
1792 gfc_error ("Cannot initialize parameter array "
1794 "with variable length elements",
1798 clen
= mpz_get_si (length
->value
.integer
);
1800 else if (init
->value
.constructor
)
1803 c
= gfc_constructor_first (init
->value
.constructor
);
1804 clen
= c
->expr
->value
.character
.length
;
1808 sym
->ts
.u
.cl
->length
1809 = gfc_get_int_expr (gfc_charlen_int_kind
,
1812 else if (init
->ts
.u
.cl
&& init
->ts
.u
.cl
->length
)
1813 sym
->ts
.u
.cl
->length
=
1814 gfc_copy_expr (sym
->value
->ts
.u
.cl
->length
);
1817 /* Update initializer character length according symbol. */
1818 else if (sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1820 if (!gfc_specification_expr (sym
->ts
.u
.cl
->length
))
1823 int k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
,
1825 /* resolve_charlen will complain later on if the length
1826 is too large. Just skeep the initialization in that case. */
1827 if (mpz_cmp (sym
->ts
.u
.cl
->length
->value
.integer
,
1828 gfc_integer_kinds
[k
].huge
) <= 0)
1831 = gfc_mpz_get_hwi (sym
->ts
.u
.cl
->length
->value
.integer
);
1833 if (init
->expr_type
== EXPR_CONSTANT
)
1834 gfc_set_constant_character_len (len
, init
, -1);
1835 else if (init
->expr_type
== EXPR_ARRAY
)
1839 /* Build a new charlen to prevent simplification from
1840 deleting the length before it is resolved. */
1841 init
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1842 init
->ts
.u
.cl
->length
1843 = gfc_copy_expr (sym
->ts
.u
.cl
->length
);
1845 for (c
= gfc_constructor_first (init
->value
.constructor
);
1846 c
; c
= gfc_constructor_next (c
))
1847 gfc_set_constant_character_len (len
, c
->expr
, -1);
1853 /* If sym is implied-shape, set its upper bounds from init. */
1854 if (sym
->attr
.flavor
== FL_PARAMETER
&& sym
->attr
.dimension
1855 && sym
->as
->type
== AS_IMPLIED_SHAPE
)
1859 if (init
->rank
== 0)
1861 gfc_error ("Can't initialize implied-shape array at %L"
1862 " with scalar", &sym
->declared_at
);
1866 /* Shape should be present, we get an initialization expression. */
1867 gcc_assert (init
->shape
);
1869 for (dim
= 0; dim
< sym
->as
->rank
; ++dim
)
1872 gfc_expr
*e
, *lower
;
1874 lower
= sym
->as
->lower
[dim
];
1876 /* If the lower bound is an array element from another
1877 parameterized array, then it is marked with EXPR_VARIABLE and
1878 is an initialization expression. Try to reduce it. */
1879 if (lower
->expr_type
== EXPR_VARIABLE
)
1880 gfc_reduce_init_expr (lower
);
1882 if (lower
->expr_type
== EXPR_CONSTANT
)
1884 /* All dimensions must be without upper bound. */
1885 gcc_assert (!sym
->as
->upper
[dim
]);
1888 e
= gfc_get_constant_expr (BT_INTEGER
, k
, &sym
->declared_at
);
1889 mpz_add (e
->value
.integer
, lower
->value
.integer
,
1891 mpz_sub_ui (e
->value
.integer
, e
->value
.integer
, 1);
1892 sym
->as
->upper
[dim
] = e
;
1896 gfc_error ("Non-constant lower bound in implied-shape"
1897 " declaration at %L", &lower
->where
);
1902 sym
->as
->type
= AS_EXPLICIT
;
1905 /* Need to check if the expression we initialized this
1906 to was one of the iso_c_binding named constants. If so,
1907 and we're a parameter (constant), let it be iso_c.
1909 integer(c_int), parameter :: my_int = c_int
1910 integer(my_int) :: my_int_2
1911 If we mark my_int as iso_c (since we can see it's value
1912 is equal to one of the named constants), then my_int_2
1913 will be considered C interoperable. */
1914 if (sym
->ts
.type
!= BT_CHARACTER
&& !gfc_bt_struct (sym
->ts
.type
))
1916 sym
->ts
.is_iso_c
|= init
->ts
.is_iso_c
;
1917 sym
->ts
.is_c_interop
|= init
->ts
.is_c_interop
;
1918 /* attr bits needed for module files. */
1919 sym
->attr
.is_iso_c
|= init
->ts
.is_iso_c
;
1920 sym
->attr
.is_c_interop
|= init
->ts
.is_c_interop
;
1921 if (init
->ts
.is_iso_c
)
1922 sym
->ts
.f90_type
= init
->ts
.f90_type
;
1925 /* Add initializer. Make sure we keep the ranks sane. */
1926 if (sym
->attr
.dimension
&& init
->rank
== 0)
1931 if (sym
->attr
.flavor
== FL_PARAMETER
1932 && init
->expr_type
== EXPR_CONSTANT
1933 && spec_size (sym
->as
, &size
)
1934 && mpz_cmp_si (size
, 0) > 0)
1936 array
= gfc_get_array_expr (init
->ts
.type
, init
->ts
.kind
,
1938 for (n
= 0; n
< (int)mpz_get_si (size
); n
++)
1939 gfc_constructor_append_expr (&array
->value
.constructor
,
1942 : gfc_copy_expr (init
),
1945 array
->shape
= gfc_get_shape (sym
->as
->rank
);
1946 for (n
= 0; n
< sym
->as
->rank
; n
++)
1947 spec_dimen_size (sym
->as
, n
, &array
->shape
[n
]);
1952 init
->rank
= sym
->as
->rank
;
1956 if (sym
->attr
.save
== SAVE_NONE
)
1957 sym
->attr
.save
= SAVE_IMPLICIT
;
1965 /* Function called by variable_decl() that adds a name to a structure
1969 build_struct (const char *name
, gfc_charlen
*cl
, gfc_expr
**init
,
1970 gfc_array_spec
**as
)
1975 /* F03:C438/C439. If the current symbol is of the same derived type that we're
1976 constructing, it must have the pointer attribute. */
1977 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
1978 && current_ts
.u
.derived
== gfc_current_block ()
1979 && current_attr
.pointer
== 0)
1981 if (current_attr
.allocatable
1982 && !gfc_notify_std(GFC_STD_F2008
, "Component at %C "
1983 "must have the POINTER attribute"))
1987 else if (current_attr
.allocatable
== 0)
1989 gfc_error ("Component at %C must have the POINTER attribute");
1995 if (current_ts
.type
== BT_CLASS
1996 && !(current_attr
.pointer
|| current_attr
.allocatable
))
1998 gfc_error ("Component %qs with CLASS at %C must be allocatable "
1999 "or pointer", name
);
2003 if (gfc_current_block ()->attr
.pointer
&& (*as
)->rank
!= 0)
2005 if ((*as
)->type
!= AS_DEFERRED
&& (*as
)->type
!= AS_EXPLICIT
)
2007 gfc_error ("Array component of structure at %C must have explicit "
2008 "or deferred shape");
2013 /* If we are in a nested union/map definition, gfc_add_component will not
2014 properly find repeated components because:
2015 (i) gfc_add_component does a flat search, where components of unions
2016 and maps are implicity chained so nested components may conflict.
2017 (ii) Unions and maps are not linked as components of their parent
2018 structures until after they are parsed.
2019 For (i) we use gfc_find_component which searches recursively, and for (ii)
2020 we search each block directly from the parse stack until we find the top
2023 s
= gfc_state_stack
;
2024 if (s
->state
== COMP_UNION
|| s
->state
== COMP_MAP
)
2026 while (s
->state
== COMP_UNION
|| gfc_comp_struct (s
->state
))
2028 c
= gfc_find_component (s
->sym
, name
, true, true, NULL
);
2031 gfc_error_now ("Component %qs at %C already declared at %L",
2035 /* Break after we've searched the entire chain. */
2036 if (s
->state
== COMP_DERIVED
|| s
->state
== COMP_STRUCTURE
)
2042 if (!gfc_add_component (gfc_current_block(), name
, &c
))
2046 if (c
->ts
.type
== BT_CHARACTER
)
2049 if (c
->ts
.type
!= BT_CLASS
&& c
->ts
.type
!= BT_DERIVED
2050 && (c
->ts
.kind
== 0 || c
->ts
.type
== BT_CHARACTER
)
2051 && saved_kind_expr
!= NULL
)
2052 c
->kind_expr
= gfc_copy_expr (saved_kind_expr
);
2054 c
->attr
= current_attr
;
2056 c
->initializer
= *init
;
2063 c
->attr
.codimension
= 1;
2065 c
->attr
.dimension
= 1;
2069 gfc_apply_init (&c
->ts
, &c
->attr
, c
->initializer
);
2071 /* Check array components. */
2072 if (!c
->attr
.dimension
)
2075 if (c
->attr
.pointer
)
2077 if (c
->as
->type
!= AS_DEFERRED
)
2079 gfc_error ("Pointer array component of structure at %C must have a "
2084 else if (c
->attr
.allocatable
)
2086 if (c
->as
->type
!= AS_DEFERRED
)
2088 gfc_error ("Allocatable component of structure at %C must have a "
2095 if (c
->as
->type
!= AS_EXPLICIT
)
2097 gfc_error ("Array component of structure at %C must have an "
2104 if (c
->ts
.type
== BT_CLASS
)
2105 return gfc_build_class_symbol (&c
->ts
, &c
->attr
, &c
->as
);
2107 if (c
->attr
.pdt_kind
|| c
->attr
.pdt_len
)
2110 gfc_find_symbol (c
->name
, gfc_current_block ()->f2k_derived
,
2114 gfc_error ("Type parameter %qs at %C has no corresponding entry "
2115 "in the type parameter name list at %L",
2116 c
->name
, &gfc_current_block ()->declared_at
);
2120 sym
->attr
.pdt_kind
= c
->attr
.pdt_kind
;
2121 sym
->attr
.pdt_len
= c
->attr
.pdt_len
;
2123 sym
->value
= gfc_copy_expr (c
->initializer
);
2124 sym
->attr
.flavor
= FL_VARIABLE
;
2127 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
2128 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_template
2129 && decl_type_param_list
)
2130 c
->param_list
= gfc_copy_actual_arglist (decl_type_param_list
);
2136 /* Match a 'NULL()', and possibly take care of some side effects. */
2139 gfc_match_null (gfc_expr
**result
)
2142 match m
, m2
= MATCH_NO
;
2144 if ((m
= gfc_match (" null ( )")) == MATCH_ERROR
)
2150 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2152 if ((m2
= gfc_match (" null (")) != MATCH_YES
)
2155 old_loc
= gfc_current_locus
;
2156 if ((m2
= gfc_match (" %n ) ", name
)) == MATCH_ERROR
)
2159 && ((m2
= gfc_match (" mold = %n )", name
)) == MATCH_ERROR
))
2163 gfc_current_locus
= old_loc
;
2168 /* The NULL symbol now has to be/become an intrinsic function. */
2169 if (gfc_get_symbol ("null", NULL
, &sym
))
2171 gfc_error ("NULL() initialization at %C is ambiguous");
2175 gfc_intrinsic_symbol (sym
);
2177 if (sym
->attr
.proc
!= PROC_INTRINSIC
2178 && !(sym
->attr
.use_assoc
&& sym
->attr
.intrinsic
)
2179 && (!gfc_add_procedure(&sym
->attr
, PROC_INTRINSIC
, sym
->name
, NULL
)
2180 || !gfc_add_function (&sym
->attr
, sym
->name
, NULL
)))
2183 *result
= gfc_get_null_expr (&gfc_current_locus
);
2185 /* Invalid per F2008, C512. */
2186 if (m2
== MATCH_YES
)
2188 gfc_error ("NULL() initialization at %C may not have MOLD");
2196 /* Match the initialization expr for a data pointer or procedure pointer. */
2199 match_pointer_init (gfc_expr
**init
, int procptr
)
2203 if (gfc_pure (NULL
) && !gfc_comp_struct (gfc_state_stack
->state
))
2205 gfc_error ("Initialization of pointer at %C is not allowed in "
2206 "a PURE procedure");
2209 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
2211 /* Match NULL() initialization. */
2212 m
= gfc_match_null (init
);
2216 /* Match non-NULL initialization. */
2217 gfc_matching_ptr_assignment
= !procptr
;
2218 gfc_matching_procptr_assignment
= procptr
;
2219 m
= gfc_match_rvalue (init
);
2220 gfc_matching_ptr_assignment
= 0;
2221 gfc_matching_procptr_assignment
= 0;
2222 if (m
== MATCH_ERROR
)
2224 else if (m
== MATCH_NO
)
2226 gfc_error ("Error in pointer initialization at %C");
2230 if (!procptr
&& !gfc_resolve_expr (*init
))
2233 if (!gfc_notify_std (GFC_STD_F2008
, "non-NULL pointer "
2234 "initialization at %C"))
2242 check_function_name (char *name
)
2244 /* In functions that have a RESULT variable defined, the function name always
2245 refers to function calls. Therefore, the name is not allowed to appear in
2246 specification statements. When checking this, be careful about
2247 'hidden' procedure pointer results ('ppr@'). */
2249 if (gfc_current_state () == COMP_FUNCTION
)
2251 gfc_symbol
*block
= gfc_current_block ();
2252 if (block
&& block
->result
&& block
->result
!= block
2253 && strcmp (block
->result
->name
, "ppr@") != 0
2254 && strcmp (block
->name
, name
) == 0)
2256 gfc_error ("RESULT variable %qs at %L prohibits FUNCTION name %qs at %C "
2257 "from appearing in a specification statement",
2258 block
->result
->name
, &block
->result
->declared_at
, name
);
2267 /* Match a variable name with an optional initializer. When this
2268 subroutine is called, a variable is expected to be parsed next.
2269 Depending on what is happening at the moment, updates either the
2270 symbol table or the current interface. */
2273 variable_decl (int elem
)
2275 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2276 static unsigned int fill_id
= 0;
2277 gfc_expr
*initializer
, *char_len
;
2279 gfc_array_spec
*cp_as
; /* Extra copy for Cray Pointees. */
2291 /* When we get here, we've just matched a list of attributes and
2292 maybe a type and a double colon. The next thing we expect to see
2293 is the name of the symbol. */
2295 /* If we are parsing a structure with legacy support, we allow the symbol
2296 name to be '%FILL' which gives it an anonymous (inaccessible) name. */
2298 gfc_gobble_whitespace ();
2299 if (gfc_peek_ascii_char () == '%')
2301 gfc_next_ascii_char ();
2302 m
= gfc_match ("fill");
2307 m
= gfc_match_name (name
);
2315 if (gfc_current_state () != COMP_STRUCTURE
)
2317 if (flag_dec_structure
)
2318 gfc_error ("%qs not allowed outside STRUCTURE at %C", "%FILL");
2320 gfc_error ("%qs at %C is a DEC extension, enable with "
2321 "%<-fdec-structure%>", "%FILL");
2327 gfc_error ("%qs entity cannot have attributes at %C", "%FILL");
2331 /* %FILL components are given invalid fortran names. */
2332 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "%%FILL%u", fill_id
++);
2336 var_locus
= gfc_current_locus
;
2338 /* Now we could see the optional array spec. or character length. */
2339 m
= gfc_match_array_spec (&as
, true, true);
2340 if (m
== MATCH_ERROR
)
2344 as
= gfc_copy_array_spec (current_as
);
2346 && !merge_array_spec (current_as
, as
, true))
2352 if (flag_cray_pointer
)
2353 cp_as
= gfc_copy_array_spec (as
);
2355 /* At this point, we know for sure if the symbol is PARAMETER and can thus
2356 determine (and check) whether it can be implied-shape. If it
2357 was parsed as assumed-size, change it because PARAMETERs can not
2360 An explicit-shape-array cannot appear under several conditions.
2361 That check is done here as well. */
2364 if (as
->type
== AS_IMPLIED_SHAPE
&& current_attr
.flavor
!= FL_PARAMETER
)
2367 gfc_error ("Non-PARAMETER symbol %qs at %L can't be implied-shape",
2372 if (as
->type
== AS_ASSUMED_SIZE
&& as
->rank
== 1
2373 && current_attr
.flavor
== FL_PARAMETER
)
2374 as
->type
= AS_IMPLIED_SHAPE
;
2376 if (as
->type
== AS_IMPLIED_SHAPE
2377 && !gfc_notify_std (GFC_STD_F2008
, "Implied-shape array at %L",
2384 /* F2018:C830 (R816) An explicit-shape-spec whose bounds are not
2385 constant expressions shall appear only in a subprogram, derived
2386 type definition, BLOCK construct, or interface body. */
2387 if (as
->type
== AS_EXPLICIT
2388 && gfc_current_state () != COMP_BLOCK
2389 && gfc_current_state () != COMP_DERIVED
2390 && gfc_current_state () != COMP_FUNCTION
2391 && gfc_current_state () != COMP_INTERFACE
2392 && gfc_current_state () != COMP_SUBROUTINE
)
2395 bool not_constant
= false;
2397 for (int i
= 0; i
< as
->rank
; i
++)
2399 e
= gfc_copy_expr (as
->lower
[i
]);
2400 gfc_resolve_expr (e
);
2401 gfc_simplify_expr (e
, 0);
2402 if (e
&& (e
->expr_type
!= EXPR_CONSTANT
))
2404 not_constant
= true;
2409 e
= gfc_copy_expr (as
->upper
[i
]);
2410 gfc_resolve_expr (e
);
2411 gfc_simplify_expr (e
, 0);
2412 if (e
&& (e
->expr_type
!= EXPR_CONSTANT
))
2414 not_constant
= true;
2422 gfc_error ("Explicit shaped array with nonconstant bounds at %C");
2431 cl_deferred
= false;
2433 if (current_ts
.type
== BT_CHARACTER
)
2435 switch (match_char_length (&char_len
, &cl_deferred
, false))
2438 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2440 cl
->length
= char_len
;
2443 /* Non-constant lengths need to be copied after the first
2444 element. Also copy assumed lengths. */
2447 && (current_ts
.u
.cl
->length
== NULL
2448 || current_ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
2450 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2451 cl
->length
= gfc_copy_expr (current_ts
.u
.cl
->length
);
2454 cl
= current_ts
.u
.cl
;
2456 cl_deferred
= current_ts
.deferred
;
2465 /* The dummy arguments and result of the abreviated form of MODULE
2466 PROCEDUREs, used in SUBMODULES should not be redefined. */
2467 if (gfc_current_ns
->proc_name
2468 && gfc_current_ns
->proc_name
->abr_modproc_decl
)
2470 gfc_find_symbol (name
, gfc_current_ns
, 1, &sym
);
2471 if (sym
!= NULL
&& (sym
->attr
.dummy
|| sym
->attr
.result
))
2474 gfc_error ("%qs at %C is a redefinition of the declaration "
2475 "in the corresponding interface for MODULE "
2476 "PROCEDURE %qs", sym
->name
,
2477 gfc_current_ns
->proc_name
->name
);
2482 /* %FILL components may not have initializers. */
2483 if (strncmp (name
, "%FILL", 5) == 0 && gfc_match_eos () != MATCH_YES
)
2485 gfc_error ("%qs entity cannot have an initializer at %C", "%FILL");
2490 /* If this symbol has already shown up in a Cray Pointer declaration,
2491 and this is not a component declaration,
2492 then we want to set the type & bail out. */
2493 if (flag_cray_pointer
&& !gfc_comp_struct (gfc_current_state ()))
2495 gfc_find_symbol (name
, gfc_current_ns
, 1, &sym
);
2496 if (sym
!= NULL
&& sym
->attr
.cray_pointee
)
2498 sym
->ts
.type
= current_ts
.type
;
2499 sym
->ts
.kind
= current_ts
.kind
;
2501 sym
->ts
.u
.derived
= current_ts
.u
.derived
;
2502 sym
->ts
.is_c_interop
= current_ts
.is_c_interop
;
2503 sym
->ts
.is_iso_c
= current_ts
.is_iso_c
;
2506 /* Check to see if we have an array specification. */
2509 if (sym
->as
!= NULL
)
2511 gfc_error ("Duplicate array spec for Cray pointee at %C");
2512 gfc_free_array_spec (cp_as
);
2518 if (!gfc_set_array_spec (sym
, cp_as
, &var_locus
))
2519 gfc_internal_error ("Couldn't set pointee array spec.");
2521 /* Fix the array spec. */
2522 m
= gfc_mod_pointee_as (sym
->as
);
2523 if (m
== MATCH_ERROR
)
2531 gfc_free_array_spec (cp_as
);
2535 /* Procedure pointer as function result. */
2536 if (gfc_current_state () == COMP_FUNCTION
2537 && strcmp ("ppr@", gfc_current_block ()->name
) == 0
2538 && strcmp (name
, gfc_current_block ()->ns
->proc_name
->name
) == 0)
2539 strcpy (name
, "ppr@");
2541 if (gfc_current_state () == COMP_FUNCTION
2542 && strcmp (name
, gfc_current_block ()->name
) == 0
2543 && gfc_current_block ()->result
2544 && strcmp ("ppr@", gfc_current_block ()->result
->name
) == 0)
2545 strcpy (name
, "ppr@");
2547 /* OK, we've successfully matched the declaration. Now put the
2548 symbol in the current namespace, because it might be used in the
2549 optional initialization expression for this symbol, e.g. this is
2552 integer, parameter :: i = huge(i)
2554 This is only true for parameters or variables of a basic type.
2555 For components of derived types, it is not true, so we don't
2556 create a symbol for those yet. If we fail to create the symbol,
2558 if (!gfc_comp_struct (gfc_current_state ())
2559 && !build_sym (name
, cl
, cl_deferred
, &as
, &var_locus
))
2565 if (!check_function_name (name
))
2571 /* We allow old-style initializations of the form
2572 integer i /2/, j(4) /3*3, 1/
2573 (if no colon has been seen). These are different from data
2574 statements in that initializers are only allowed to apply to the
2575 variable immediately preceding, i.e.
2577 is not allowed. Therefore we have to do some work manually, that
2578 could otherwise be left to the matchers for DATA statements. */
2580 if (!colon_seen
&& gfc_match (" /") == MATCH_YES
)
2582 if (!gfc_notify_std (GFC_STD_GNU
, "Old-style "
2583 "initialization at %C"))
2586 /* Allow old style initializations for components of STRUCTUREs and MAPs
2587 but not components of derived types. */
2588 else if (gfc_current_state () == COMP_DERIVED
)
2590 gfc_error ("Invalid old style initialization for derived type "
2596 /* For structure components, read the initializer as a special
2597 expression and let the rest of this function apply the initializer
2599 else if (gfc_comp_struct (gfc_current_state ()))
2601 m
= match_clist_expr (&initializer
, ¤t_ts
, as
);
2603 gfc_error ("Syntax error in old style initialization of %s at %C",
2609 /* Otherwise we treat the old style initialization just like a
2610 DATA declaration for the current variable. */
2612 return match_old_style_init (name
);
2615 /* The double colon must be present in order to have initializers.
2616 Otherwise the statement is ambiguous with an assignment statement. */
2619 if (gfc_match (" =>") == MATCH_YES
)
2621 if (!current_attr
.pointer
)
2623 gfc_error ("Initialization at %C isn't for a pointer variable");
2628 m
= match_pointer_init (&initializer
, 0);
2632 else if (gfc_match_char ('=') == MATCH_YES
)
2634 if (current_attr
.pointer
)
2636 gfc_error ("Pointer initialization at %C requires %<=>%>, "
2642 m
= gfc_match_init_expr (&initializer
);
2645 gfc_error ("Expected an initialization expression at %C");
2649 if (current_attr
.flavor
!= FL_PARAMETER
&& gfc_pure (NULL
)
2650 && !gfc_comp_struct (gfc_state_stack
->state
))
2652 gfc_error ("Initialization of variable at %C is not allowed in "
2653 "a PURE procedure");
2657 if (current_attr
.flavor
!= FL_PARAMETER
2658 && !gfc_comp_struct (gfc_state_stack
->state
))
2659 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
2666 if (initializer
!= NULL
&& current_attr
.allocatable
2667 && gfc_comp_struct (gfc_current_state ()))
2669 gfc_error ("Initialization of allocatable component at %C is not "
2675 if (gfc_current_state () == COMP_DERIVED
2676 && gfc_current_block ()->attr
.pdt_template
)
2679 gfc_find_symbol (name
, gfc_current_block ()->f2k_derived
,
2681 if (!param
&& (current_attr
.pdt_kind
|| current_attr
.pdt_len
))
2683 gfc_error ("The component with KIND or LEN attribute at %C does not "
2684 "not appear in the type parameter list at %L",
2685 &gfc_current_block ()->declared_at
);
2689 else if (param
&& !(current_attr
.pdt_kind
|| current_attr
.pdt_len
))
2691 gfc_error ("The component at %C that appears in the type parameter "
2692 "list at %L has neither the KIND nor LEN attribute",
2693 &gfc_current_block ()->declared_at
);
2697 else if (as
&& (current_attr
.pdt_kind
|| current_attr
.pdt_len
))
2699 gfc_error ("The component at %C which is a type parameter must be "
2704 else if (param
&& initializer
)
2705 param
->value
= gfc_copy_expr (initializer
);
2708 /* Add the initializer. Note that it is fine if initializer is
2709 NULL here, because we sometimes also need to check if a
2710 declaration *must* have an initialization expression. */
2711 if (!gfc_comp_struct (gfc_current_state ()))
2712 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
2715 if (current_ts
.type
== BT_DERIVED
2716 && !current_attr
.pointer
&& !initializer
)
2717 initializer
= gfc_default_initializer (¤t_ts
);
2718 t
= build_struct (name
, cl
, &initializer
, &as
);
2720 /* If we match a nested structure definition we expect to see the
2721 * body even if the variable declarations blow up, so we need to keep
2722 * the structure declaration around. */
2723 if (gfc_new_block
&& gfc_new_block
->attr
.flavor
== FL_STRUCT
)
2724 gfc_commit_symbol (gfc_new_block
);
2727 m
= (t
) ? MATCH_YES
: MATCH_ERROR
;
2730 /* Free stuff up and return. */
2731 gfc_free_expr (initializer
);
2732 gfc_free_array_spec (as
);
2738 /* Match an extended-f77 "TYPESPEC*bytesize"-style kind specification.
2739 This assumes that the byte size is equal to the kind number for
2740 non-COMPLEX types, and equal to twice the kind number for COMPLEX. */
2743 gfc_match_old_kind_spec (gfc_typespec
*ts
)
2748 if (gfc_match_char ('*') != MATCH_YES
)
2751 m
= gfc_match_small_literal_int (&ts
->kind
, NULL
);
2755 original_kind
= ts
->kind
;
2757 /* Massage the kind numbers for complex types. */
2758 if (ts
->type
== BT_COMPLEX
)
2762 gfc_error ("Old-style type declaration %s*%d not supported at %C",
2763 gfc_basic_typename (ts
->type
), original_kind
);
2770 if (ts
->type
== BT_INTEGER
&& ts
->kind
== 4 && flag_integer4_kind
== 8)
2773 if (ts
->type
== BT_REAL
|| ts
->type
== BT_COMPLEX
)
2777 if (flag_real4_kind
== 8)
2779 if (flag_real4_kind
== 10)
2781 if (flag_real4_kind
== 16)
2787 if (flag_real8_kind
== 4)
2789 if (flag_real8_kind
== 10)
2791 if (flag_real8_kind
== 16)
2796 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
2798 gfc_error ("Old-style type declaration %s*%d not supported at %C",
2799 gfc_basic_typename (ts
->type
), original_kind
);
2803 if (!gfc_notify_std (GFC_STD_GNU
,
2804 "Nonstandard type declaration %s*%d at %C",
2805 gfc_basic_typename(ts
->type
), original_kind
))
2812 /* Match a kind specification. Since kinds are generally optional, we
2813 usually return MATCH_NO if something goes wrong. If a "kind="
2814 string is found, then we know we have an error. */
2817 gfc_match_kind_spec (gfc_typespec
*ts
, bool kind_expr_only
)
2827 saved_kind_expr
= NULL
;
2829 where
= loc
= gfc_current_locus
;
2834 if (gfc_match_char ('(') == MATCH_NO
)
2837 /* Also gobbles optional text. */
2838 if (gfc_match (" kind = ") == MATCH_YES
)
2841 loc
= gfc_current_locus
;
2845 n
= gfc_match_init_expr (&e
);
2847 if (gfc_derived_parameter_expr (e
))
2850 saved_kind_expr
= gfc_copy_expr (e
);
2851 goto close_brackets
;
2856 if (gfc_matching_function
)
2858 /* The function kind expression might include use associated or
2859 imported parameters and try again after the specification
2861 if (gfc_match_char (')') != MATCH_YES
)
2863 gfc_error ("Missing right parenthesis at %C");
2869 gfc_undo_symbols ();
2874 /* ....or else, the match is real. */
2876 gfc_error ("Expected initialization expression at %C");
2884 gfc_error ("Expected scalar initialization expression at %C");
2889 if (gfc_extract_int (e
, &ts
->kind
, 1))
2895 /* Before throwing away the expression, let's see if we had a
2896 C interoperable kind (and store the fact). */
2897 if (e
->ts
.is_c_interop
== 1)
2899 /* Mark this as C interoperable if being declared with one
2900 of the named constants from iso_c_binding. */
2901 ts
->is_c_interop
= e
->ts
.is_iso_c
;
2902 ts
->f90_type
= e
->ts
.f90_type
;
2904 ts
->interop_kind
= e
->symtree
->n
.sym
;
2910 /* Ignore errors to this point, if we've gotten here. This means
2911 we ignore the m=MATCH_ERROR from above. */
2912 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
2914 gfc_error ("Kind %d not supported for type %s at %C", ts
->kind
,
2915 gfc_basic_typename (ts
->type
));
2916 gfc_current_locus
= where
;
2920 /* Warn if, e.g., c_int is used for a REAL variable, but not
2921 if, e.g., c_double is used for COMPLEX as the standard
2922 explicitly says that the kind type parameter for complex and real
2923 variable is the same, i.e. c_float == c_float_complex. */
2924 if (ts
->f90_type
!= BT_UNKNOWN
&& ts
->f90_type
!= ts
->type
2925 && !((ts
->f90_type
== BT_REAL
&& ts
->type
== BT_COMPLEX
)
2926 || (ts
->f90_type
== BT_COMPLEX
&& ts
->type
== BT_REAL
)))
2927 gfc_warning_now (0, "C kind type parameter is for type %s but type at %L "
2928 "is %s", gfc_basic_typename (ts
->f90_type
), &where
,
2929 gfc_basic_typename (ts
->type
));
2933 gfc_gobble_whitespace ();
2934 if ((c
= gfc_next_ascii_char ()) != ')'
2935 && (ts
->type
!= BT_CHARACTER
|| c
!= ','))
2937 if (ts
->type
== BT_CHARACTER
)
2938 gfc_error ("Missing right parenthesis or comma at %C");
2940 gfc_error ("Missing right parenthesis at %C");
2944 /* All tests passed. */
2947 if(m
== MATCH_ERROR
)
2948 gfc_current_locus
= where
;
2950 if (ts
->type
== BT_INTEGER
&& ts
->kind
== 4 && flag_integer4_kind
== 8)
2953 if (ts
->type
== BT_REAL
|| ts
->type
== BT_COMPLEX
)
2957 if (flag_real4_kind
== 8)
2959 if (flag_real4_kind
== 10)
2961 if (flag_real4_kind
== 16)
2967 if (flag_real8_kind
== 4)
2969 if (flag_real8_kind
== 10)
2971 if (flag_real8_kind
== 16)
2976 /* Return what we know from the test(s). */
2981 gfc_current_locus
= where
;
2987 match_char_kind (int * kind
, int * is_iso_c
)
2996 where
= gfc_current_locus
;
2998 n
= gfc_match_init_expr (&e
);
3000 if (n
!= MATCH_YES
&& gfc_matching_function
)
3002 /* The expression might include use-associated or imported
3003 parameters and try again after the specification
3006 gfc_undo_symbols ();
3011 gfc_error ("Expected initialization expression at %C");
3017 gfc_error ("Expected scalar initialization expression at %C");
3022 if (gfc_derived_parameter_expr (e
))
3024 saved_kind_expr
= e
;
3029 fail
= gfc_extract_int (e
, kind
, 1);
3030 *is_iso_c
= e
->ts
.is_iso_c
;
3039 /* Ignore errors to this point, if we've gotten here. This means
3040 we ignore the m=MATCH_ERROR from above. */
3041 if (gfc_validate_kind (BT_CHARACTER
, *kind
, true) < 0)
3043 gfc_error ("Kind %d is not supported for CHARACTER at %C", *kind
);
3047 /* All tests passed. */
3050 if (m
== MATCH_ERROR
)
3051 gfc_current_locus
= where
;
3053 /* Return what we know from the test(s). */
3058 gfc_current_locus
= where
;
3063 /* Match the various kind/length specifications in a CHARACTER
3064 declaration. We don't return MATCH_NO. */
3067 gfc_match_char_spec (gfc_typespec
*ts
)
3069 int kind
, seen_length
, is_iso_c
;
3081 /* Try the old-style specification first. */
3082 old_char_selector
= 0;
3084 m
= match_char_length (&len
, &deferred
, true);
3088 old_char_selector
= 1;
3093 m
= gfc_match_char ('(');
3096 m
= MATCH_YES
; /* Character without length is a single char. */
3100 /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ). */
3101 if (gfc_match (" kind =") == MATCH_YES
)
3103 m
= match_char_kind (&kind
, &is_iso_c
);
3105 if (m
== MATCH_ERROR
)
3110 if (gfc_match (" , len =") == MATCH_NO
)
3113 m
= char_len_param_value (&len
, &deferred
);
3116 if (m
== MATCH_ERROR
)
3123 /* Try to match "LEN = <len-param>" or "LEN = <len-param>, KIND = <int>". */
3124 if (gfc_match (" len =") == MATCH_YES
)
3126 m
= char_len_param_value (&len
, &deferred
);
3129 if (m
== MATCH_ERROR
)
3133 if (gfc_match_char (')') == MATCH_YES
)
3136 if (gfc_match (" , kind =") != MATCH_YES
)
3139 if (match_char_kind (&kind
, &is_iso_c
) == MATCH_ERROR
)
3145 /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ). */
3146 m
= char_len_param_value (&len
, &deferred
);
3149 if (m
== MATCH_ERROR
)
3153 m
= gfc_match_char (')');
3157 if (gfc_match_char (',') != MATCH_YES
)
3160 gfc_match (" kind ="); /* Gobble optional text. */
3162 m
= match_char_kind (&kind
, &is_iso_c
);
3163 if (m
== MATCH_ERROR
)
3169 /* Require a right-paren at this point. */
3170 m
= gfc_match_char (')');
3175 gfc_error ("Syntax error in CHARACTER declaration at %C");
3177 gfc_free_expr (len
);
3181 /* Deal with character functions after USE and IMPORT statements. */
3182 if (gfc_matching_function
)
3184 gfc_free_expr (len
);
3185 gfc_undo_symbols ();
3191 gfc_free_expr (len
);
3195 /* Do some final massaging of the length values. */
3196 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
3198 if (seen_length
== 0)
3199 cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
, 1);
3202 /* If gfortran ends up here, then the len may be reducible to a
3203 constant. Try to do that here. If it does not reduce, simply
3204 assign len to the charlen. */
3205 if (len
&& len
->expr_type
!= EXPR_CONSTANT
)
3208 e
= gfc_copy_expr (len
);
3209 gfc_reduce_init_expr (e
);
3210 if (e
->expr_type
== EXPR_CONSTANT
)
3211 gfc_replace_expr (len
, e
);
3221 ts
->kind
= kind
== 0 ? gfc_default_character_kind
: kind
;
3222 ts
->deferred
= deferred
;
3224 /* We have to know if it was a C interoperable kind so we can
3225 do accurate type checking of bind(c) procs, etc. */
3227 /* Mark this as C interoperable if being declared with one
3228 of the named constants from iso_c_binding. */
3229 ts
->is_c_interop
= is_iso_c
;
3230 else if (len
!= NULL
)
3231 /* Here, we might have parsed something such as: character(c_char)
3232 In this case, the parsing code above grabs the c_char when
3233 looking for the length (line 1690, roughly). it's the last
3234 testcase for parsing the kind params of a character variable.
3235 However, it's not actually the length. this seems like it
3237 To see if the user used a C interop kind, test the expr
3238 of the so called length, and see if it's C interoperable. */
3239 ts
->is_c_interop
= len
->ts
.is_iso_c
;
3245 /* Matches a RECORD declaration. */
3248 match_record_decl (char *name
)
3251 old_loc
= gfc_current_locus
;
3254 m
= gfc_match (" record /");
3257 if (!flag_dec_structure
)
3259 gfc_current_locus
= old_loc
;
3260 gfc_error ("RECORD at %C is an extension, enable it with "
3264 m
= gfc_match (" %n/", name
);
3269 gfc_current_locus
= old_loc
;
3270 if (flag_dec_structure
3271 && (gfc_match (" record% ") == MATCH_YES
3272 || gfc_match (" record%t") == MATCH_YES
))
3273 gfc_error ("Structure name expected after RECORD at %C");
3281 /* This function uses the gfc_actual_arglist 'type_param_spec_list' as a source
3282 of expressions to substitute into the possibly parameterized expression
3283 'e'. Using a list is inefficient but should not be too bad since the
3284 number of type parameters is not likely to be large. */
3286 insert_parameter_exprs (gfc_expr
* e
, gfc_symbol
* sym ATTRIBUTE_UNUSED
,
3289 gfc_actual_arglist
*param
;
3292 if (e
->expr_type
!= EXPR_VARIABLE
)
3295 gcc_assert (e
->symtree
);
3296 if (e
->symtree
->n
.sym
->attr
.pdt_kind
3297 || (*f
!= 0 && e
->symtree
->n
.sym
->attr
.pdt_len
))
3299 for (param
= type_param_spec_list
; param
; param
= param
->next
)
3300 if (strcmp (e
->symtree
->n
.sym
->name
, param
->name
) == 0)
3305 copy
= gfc_copy_expr (param
->expr
);
3316 gfc_insert_kind_parameter_exprs (gfc_expr
*e
)
3318 return gfc_traverse_expr (e
, NULL
, &insert_parameter_exprs
, 0);
3323 gfc_insert_parameter_exprs (gfc_expr
*e
, gfc_actual_arglist
*param_list
)
3325 gfc_actual_arglist
*old_param_spec_list
= type_param_spec_list
;
3326 type_param_spec_list
= param_list
;
3327 return gfc_traverse_expr (e
, NULL
, &insert_parameter_exprs
, 1);
3328 type_param_spec_list
= NULL
;
3329 type_param_spec_list
= old_param_spec_list
;
3332 /* Determines the instance of a parameterized derived type to be used by
3333 matching determining the values of the kind parameters and using them
3334 in the name of the instance. If the instance exists, it is used, otherwise
3335 a new derived type is created. */
3337 gfc_get_pdt_instance (gfc_actual_arglist
*param_list
, gfc_symbol
**sym
,
3338 gfc_actual_arglist
**ext_param_list
)
3340 /* The PDT template symbol. */
3341 gfc_symbol
*pdt
= *sym
;
3342 /* The symbol for the parameter in the template f2k_namespace. */
3344 /* The hoped for instance of the PDT. */
3345 gfc_symbol
*instance
;
3346 /* The list of parameters appearing in the PDT declaration. */
3347 gfc_formal_arglist
*type_param_name_list
;
3348 /* Used to store the parameter specification list during recursive calls. */
3349 gfc_actual_arglist
*old_param_spec_list
;
3350 /* Pointers to the parameter specification being used. */
3351 gfc_actual_arglist
*actual_param
;
3352 gfc_actual_arglist
*tail
= NULL
;
3353 /* Used to build up the name of the PDT instance. The prefix uses 4
3354 characters and each KIND parameter 2 more. Allow 8 of the latter. */
3355 char name
[GFC_MAX_SYMBOL_LEN
+ 21];
3357 bool name_seen
= (param_list
== NULL
);
3358 bool assumed_seen
= false;
3359 bool deferred_seen
= false;
3360 bool spec_error
= false;
3362 gfc_expr
*kind_expr
;
3363 gfc_component
*c1
, *c2
;
3366 type_param_spec_list
= NULL
;
3368 type_param_name_list
= pdt
->formal
;
3369 actual_param
= param_list
;
3370 sprintf (name
, "Pdt%s", pdt
->name
);
3372 /* Run through the parameter name list and pick up the actual
3373 parameter values or use the default values in the PDT declaration. */
3374 for (; type_param_name_list
;
3375 type_param_name_list
= type_param_name_list
->next
)
3377 if (actual_param
&& actual_param
->spec_type
!= SPEC_EXPLICIT
)
3379 if (actual_param
->spec_type
== SPEC_ASSUMED
)
3380 spec_error
= deferred_seen
;
3382 spec_error
= assumed_seen
;
3386 gfc_error ("The type parameter spec list at %C cannot contain "
3387 "both ASSUMED and DEFERRED parameters");
3392 if (actual_param
&& actual_param
->name
)
3394 param
= type_param_name_list
->sym
;
3396 if (!param
|| !param
->name
)
3399 c1
= gfc_find_component (pdt
, param
->name
, false, true, NULL
);
3400 /* An error should already have been thrown in resolve.c
3401 (resolve_fl_derived0). */
3402 if (!pdt
->attr
.use_assoc
&& !c1
)
3408 if (!actual_param
&& !(c1
&& c1
->initializer
))
3410 gfc_error ("The type parameter spec list at %C does not contain "
3411 "enough parameter expressions");
3414 else if (!actual_param
&& c1
&& c1
->initializer
)
3415 kind_expr
= gfc_copy_expr (c1
->initializer
);
3416 else if (actual_param
&& actual_param
->spec_type
== SPEC_EXPLICIT
)
3417 kind_expr
= gfc_copy_expr (actual_param
->expr
);
3421 actual_param
= param_list
;
3422 for (;actual_param
; actual_param
= actual_param
->next
)
3423 if (actual_param
->name
3424 && strcmp (actual_param
->name
, param
->name
) == 0)
3426 if (actual_param
&& actual_param
->spec_type
== SPEC_EXPLICIT
)
3427 kind_expr
= gfc_copy_expr (actual_param
->expr
);
3430 if (c1
->initializer
)
3431 kind_expr
= gfc_copy_expr (c1
->initializer
);
3432 else if (!(actual_param
&& param
->attr
.pdt_len
))
3434 gfc_error ("The derived parameter %qs at %C does not "
3435 "have a default value", param
->name
);
3441 /* Store the current parameter expressions in a temporary actual
3442 arglist 'list' so that they can be substituted in the corresponding
3443 expressions in the PDT instance. */
3444 if (type_param_spec_list
== NULL
)
3446 type_param_spec_list
= gfc_get_actual_arglist ();
3447 tail
= type_param_spec_list
;
3451 tail
->next
= gfc_get_actual_arglist ();
3454 tail
->name
= param
->name
;
3458 /* Try simplification even for LEN expressions. */
3459 gfc_resolve_expr (kind_expr
);
3460 gfc_simplify_expr (kind_expr
, 1);
3461 /* Variable expressions seem to default to BT_PROCEDURE.
3462 TODO find out why this is and fix it. */
3463 if (kind_expr
->ts
.type
!= BT_INTEGER
3464 && kind_expr
->ts
.type
!= BT_PROCEDURE
)
3466 gfc_error ("The parameter expression at %C must be of "
3467 "INTEGER type and not %s type",
3468 gfc_basic_typename (kind_expr
->ts
.type
));
3472 tail
->expr
= gfc_copy_expr (kind_expr
);
3476 tail
->spec_type
= actual_param
->spec_type
;
3478 if (!param
->attr
.pdt_kind
)
3480 if (!name_seen
&& actual_param
)
3481 actual_param
= actual_param
->next
;
3484 gfc_free_expr (kind_expr
);
3491 && (actual_param
->spec_type
== SPEC_ASSUMED
3492 || actual_param
->spec_type
== SPEC_DEFERRED
))
3494 gfc_error ("The KIND parameter %qs at %C cannot either be "
3495 "ASSUMED or DEFERRED", param
->name
);
3499 if (!kind_expr
|| !gfc_is_constant_expr (kind_expr
))
3501 gfc_error ("The value for the KIND parameter %qs at %C does not "
3502 "reduce to a constant expression", param
->name
);
3506 gfc_extract_int (kind_expr
, &kind_value
);
3507 sprintf (name
+ strlen (name
), "_%d", kind_value
);
3509 if (!name_seen
&& actual_param
)
3510 actual_param
= actual_param
->next
;
3511 gfc_free_expr (kind_expr
);
3514 if (!name_seen
&& actual_param
)
3516 gfc_error ("The type parameter spec list at %C contains too many "
3517 "parameter expressions");
3521 /* Now we search for the PDT instance 'name'. If it doesn't exist, we
3522 build it, using 'pdt' as a template. */
3523 if (gfc_get_symbol (name
, pdt
->ns
, &instance
))
3525 gfc_error ("Parameterized derived type at %C is ambiguous");
3531 if (instance
->attr
.flavor
== FL_DERIVED
3532 && instance
->attr
.pdt_type
)
3536 *ext_param_list
= type_param_spec_list
;
3538 gfc_commit_symbols ();
3542 /* Start building the new instance of the parameterized type. */
3543 gfc_copy_attr (&instance
->attr
, &pdt
->attr
, &pdt
->declared_at
);
3544 instance
->attr
.pdt_template
= 0;
3545 instance
->attr
.pdt_type
= 1;
3546 instance
->declared_at
= gfc_current_locus
;
3548 /* Add the components, replacing the parameters in all expressions
3549 with the expressions for their values in 'type_param_spec_list'. */
3550 c1
= pdt
->components
;
3551 tail
= type_param_spec_list
;
3552 for (; c1
; c1
= c1
->next
)
3554 gfc_add_component (instance
, c1
->name
, &c2
);
3557 c2
->attr
= c1
->attr
;
3559 /* The order of declaration of the type_specs might not be the
3560 same as that of the components. */
3561 if (c1
->attr
.pdt_kind
|| c1
->attr
.pdt_len
)
3563 for (tail
= type_param_spec_list
; tail
; tail
= tail
->next
)
3564 if (strcmp (c1
->name
, tail
->name
) == 0)
3568 /* Deal with type extension by recursively calling this function
3569 to obtain the instance of the extended type. */
3570 if (gfc_current_state () != COMP_DERIVED
3571 && c1
== pdt
->components
3572 && (c1
->ts
.type
== BT_DERIVED
|| c1
->ts
.type
== BT_CLASS
)
3573 && c1
->ts
.u
.derived
&& c1
->ts
.u
.derived
->attr
.pdt_template
3574 && gfc_get_derived_super_type (*sym
) == c2
->ts
.u
.derived
)
3576 gfc_formal_arglist
*f
;
3578 old_param_spec_list
= type_param_spec_list
;
3580 /* Obtain a spec list appropriate to the extended type..*/
3581 actual_param
= gfc_copy_actual_arglist (type_param_spec_list
);
3582 type_param_spec_list
= actual_param
;
3583 for (f
= c1
->ts
.u
.derived
->formal
; f
&& f
->next
; f
= f
->next
)
3584 actual_param
= actual_param
->next
;
3587 gfc_free_actual_arglist (actual_param
->next
);
3588 actual_param
->next
= NULL
;
3591 /* Now obtain the PDT instance for the extended type. */
3592 c2
->param_list
= type_param_spec_list
;
3593 m
= gfc_get_pdt_instance (type_param_spec_list
, &c2
->ts
.u
.derived
,
3595 type_param_spec_list
= old_param_spec_list
;
3597 c2
->ts
.u
.derived
->refs
++;
3598 gfc_set_sym_referenced (c2
->ts
.u
.derived
);
3600 /* Set extension level. */
3601 if (c2
->ts
.u
.derived
->attr
.extension
== 255)
3603 /* Since the extension field is 8 bit wide, we can only have
3604 up to 255 extension levels. */
3605 gfc_error ("Maximum extension level reached with type %qs at %L",
3606 c2
->ts
.u
.derived
->name
,
3607 &c2
->ts
.u
.derived
->declared_at
);
3610 instance
->attr
.extension
= c2
->ts
.u
.derived
->attr
.extension
+ 1;
3615 /* Set the component kind using the parameterized expression. */
3616 if ((c1
->ts
.kind
== 0 || c1
->ts
.type
== BT_CHARACTER
)
3617 && c1
->kind_expr
!= NULL
)
3619 gfc_expr
*e
= gfc_copy_expr (c1
->kind_expr
);
3620 gfc_insert_kind_parameter_exprs (e
);
3621 gfc_simplify_expr (e
, 1);
3622 gfc_extract_int (e
, &c2
->ts
.kind
);
3624 if (gfc_validate_kind (c2
->ts
.type
, c2
->ts
.kind
, true) < 0)
3626 gfc_error ("Kind %d not supported for type %s at %C",
3627 c2
->ts
.kind
, gfc_basic_typename (c2
->ts
.type
));
3632 /* Similarly, set the string length if parameterized. */
3633 if (c1
->ts
.type
== BT_CHARACTER
3634 && c1
->ts
.u
.cl
->length
3635 && gfc_derived_parameter_expr (c1
->ts
.u
.cl
->length
))
3638 e
= gfc_copy_expr (c1
->ts
.u
.cl
->length
);
3639 gfc_insert_kind_parameter_exprs (e
);
3640 gfc_simplify_expr (e
, 1);
3641 c2
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
3642 c2
->ts
.u
.cl
->length
= e
;
3643 c2
->attr
.pdt_string
= 1;
3646 /* Set up either the KIND/LEN initializer, if constant,
3647 or the parameterized expression. Use the template
3648 initializer if one is not already set in this instance. */
3649 if (c2
->attr
.pdt_kind
|| c2
->attr
.pdt_len
)
3651 if (tail
&& tail
->expr
&& gfc_is_constant_expr (tail
->expr
))
3652 c2
->initializer
= gfc_copy_expr (tail
->expr
);
3653 else if (tail
&& tail
->expr
)
3655 c2
->param_list
= gfc_get_actual_arglist ();
3656 c2
->param_list
->name
= tail
->name
;
3657 c2
->param_list
->expr
= gfc_copy_expr (tail
->expr
);
3658 c2
->param_list
->next
= NULL
;
3661 if (!c2
->initializer
&& c1
->initializer
)
3662 c2
->initializer
= gfc_copy_expr (c1
->initializer
);
3665 /* Copy the array spec. */
3666 c2
->as
= gfc_copy_array_spec (c1
->as
);
3667 if (c1
->ts
.type
== BT_CLASS
)
3668 CLASS_DATA (c2
)->as
= gfc_copy_array_spec (CLASS_DATA (c1
)->as
);
3670 /* Determine if an array spec is parameterized. If so, substitute
3671 in the parameter expressions for the bounds and set the pdt_array
3672 attribute. Notice that this attribute must be unconditionally set
3673 if this is an array of parameterized character length. */
3674 if (c1
->as
&& c1
->as
->type
== AS_EXPLICIT
)
3676 bool pdt_array
= false;
3678 /* Are the bounds of the array parameterized? */
3679 for (i
= 0; i
< c1
->as
->rank
; i
++)
3681 if (gfc_derived_parameter_expr (c1
->as
->lower
[i
]))
3683 if (gfc_derived_parameter_expr (c1
->as
->upper
[i
]))
3687 /* If they are, free the expressions for the bounds and
3688 replace them with the template expressions with substitute
3690 for (i
= 0; pdt_array
&& i
< c1
->as
->rank
; i
++)
3693 e
= gfc_copy_expr (c1
->as
->lower
[i
]);
3694 gfc_insert_kind_parameter_exprs (e
);
3695 gfc_simplify_expr (e
, 1);
3696 gfc_free_expr (c2
->as
->lower
[i
]);
3697 c2
->as
->lower
[i
] = e
;
3698 e
= gfc_copy_expr (c1
->as
->upper
[i
]);
3699 gfc_insert_kind_parameter_exprs (e
);
3700 gfc_simplify_expr (e
, 1);
3701 gfc_free_expr (c2
->as
->upper
[i
]);
3702 c2
->as
->upper
[i
] = e
;
3704 c2
->attr
.pdt_array
= pdt_array
? 1 : c2
->attr
.pdt_string
;
3705 if (c1
->initializer
)
3707 c2
->initializer
= gfc_copy_expr (c1
->initializer
);
3708 gfc_insert_kind_parameter_exprs (c2
->initializer
);
3709 gfc_simplify_expr (c2
->initializer
, 1);
3713 /* Recurse into this function for PDT components. */
3714 if ((c1
->ts
.type
== BT_DERIVED
|| c1
->ts
.type
== BT_CLASS
)
3715 && c1
->ts
.u
.derived
&& c1
->ts
.u
.derived
->attr
.pdt_template
)
3717 gfc_actual_arglist
*params
;
3718 /* The component in the template has a list of specification
3719 expressions derived from its declaration. */
3720 params
= gfc_copy_actual_arglist (c1
->param_list
);
3721 actual_param
= params
;
3722 /* Substitute the template parameters with the expressions
3723 from the specification list. */
3724 for (;actual_param
; actual_param
= actual_param
->next
)
3725 gfc_insert_parameter_exprs (actual_param
->expr
,
3726 type_param_spec_list
);
3728 /* Now obtain the PDT instance for the component. */
3729 old_param_spec_list
= type_param_spec_list
;
3730 m
= gfc_get_pdt_instance (params
, &c2
->ts
.u
.derived
, NULL
);
3731 type_param_spec_list
= old_param_spec_list
;
3733 c2
->param_list
= params
;
3734 if (!(c2
->attr
.pointer
|| c2
->attr
.allocatable
))
3735 c2
->initializer
= gfc_default_initializer (&c2
->ts
);
3737 if (c2
->attr
.allocatable
)
3738 instance
->attr
.alloc_comp
= 1;
3742 gfc_commit_symbol (instance
);
3744 *ext_param_list
= type_param_spec_list
;
3749 gfc_free_actual_arglist (type_param_spec_list
);
3754 /* Matches a declaration-type-spec (F03:R502). If successful, sets the ts
3755 structure to the matched specification. This is necessary for FUNCTION and
3756 IMPLICIT statements.
3758 If implicit_flag is nonzero, then we don't check for the optional
3759 kind specification. Not doing so is needed for matching an IMPLICIT
3760 statement correctly. */
3763 gfc_match_decl_type_spec (gfc_typespec
*ts
, int implicit_flag
)
3765 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3766 gfc_symbol
*sym
, *dt_sym
;
3769 bool seen_deferred_kind
, matched_type
;
3770 const char *dt_name
;
3772 decl_type_param_list
= NULL
;
3774 /* A belt and braces check that the typespec is correctly being treated
3775 as a deferred characteristic association. */
3776 seen_deferred_kind
= (gfc_current_state () == COMP_FUNCTION
)
3777 && (gfc_current_block ()->result
->ts
.kind
== -1)
3778 && (ts
->kind
== -1);
3780 if (seen_deferred_kind
)
3783 /* Clear the current binding label, in case one is given. */
3784 curr_binding_label
= NULL
;
3786 if (gfc_match (" byte") == MATCH_YES
)
3788 if (!gfc_notify_std (GFC_STD_GNU
, "BYTE type at %C"))
3791 if (gfc_validate_kind (BT_INTEGER
, 1, true) < 0)
3793 gfc_error ("BYTE type used at %C "
3794 "is not available on the target machine");
3798 ts
->type
= BT_INTEGER
;
3804 m
= gfc_match (" type (");
3805 matched_type
= (m
== MATCH_YES
);
3808 gfc_gobble_whitespace ();
3809 if (gfc_peek_ascii_char () == '*')
3811 if ((m
= gfc_match ("*)")) != MATCH_YES
)
3813 if (gfc_comp_struct (gfc_current_state ()))
3815 gfc_error ("Assumed type at %C is not allowed for components");
3818 if (!gfc_notify_std (GFC_STD_F2008_TS
, "Assumed type "
3821 ts
->type
= BT_ASSUMED
;
3825 m
= gfc_match ("%n", name
);
3826 matched_type
= (m
== MATCH_YES
);
3829 if ((matched_type
&& strcmp ("integer", name
) == 0)
3830 || (!matched_type
&& gfc_match (" integer") == MATCH_YES
))
3832 ts
->type
= BT_INTEGER
;
3833 ts
->kind
= gfc_default_integer_kind
;
3837 if ((matched_type
&& strcmp ("character", name
) == 0)
3838 || (!matched_type
&& gfc_match (" character") == MATCH_YES
))
3841 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
3842 "intrinsic-type-spec at %C"))
3845 ts
->type
= BT_CHARACTER
;
3846 if (implicit_flag
== 0)
3847 m
= gfc_match_char_spec (ts
);
3851 if (matched_type
&& m
== MATCH_YES
&& gfc_match_char (')') != MATCH_YES
)
3857 if ((matched_type
&& strcmp ("real", name
) == 0)
3858 || (!matched_type
&& gfc_match (" real") == MATCH_YES
))
3861 ts
->kind
= gfc_default_real_kind
;
3866 && (strcmp ("doubleprecision", name
) == 0
3867 || (strcmp ("double", name
) == 0
3868 && gfc_match (" precision") == MATCH_YES
)))
3869 || (!matched_type
&& gfc_match (" double precision") == MATCH_YES
))
3872 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
3873 "intrinsic-type-spec at %C"))
3875 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
3879 ts
->kind
= gfc_default_double_kind
;
3883 if ((matched_type
&& strcmp ("complex", name
) == 0)
3884 || (!matched_type
&& gfc_match (" complex") == MATCH_YES
))
3886 ts
->type
= BT_COMPLEX
;
3887 ts
->kind
= gfc_default_complex_kind
;
3892 && (strcmp ("doublecomplex", name
) == 0
3893 || (strcmp ("double", name
) == 0
3894 && gfc_match (" complex") == MATCH_YES
)))
3895 || (!matched_type
&& gfc_match (" double complex") == MATCH_YES
))
3897 if (!gfc_notify_std (GFC_STD_GNU
, "DOUBLE COMPLEX at %C"))
3901 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
3902 "intrinsic-type-spec at %C"))
3905 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
3908 ts
->type
= BT_COMPLEX
;
3909 ts
->kind
= gfc_default_double_kind
;
3913 if ((matched_type
&& strcmp ("logical", name
) == 0)
3914 || (!matched_type
&& gfc_match (" logical") == MATCH_YES
))
3916 ts
->type
= BT_LOGICAL
;
3917 ts
->kind
= gfc_default_logical_kind
;
3923 m
= gfc_match_actual_arglist (1, &decl_type_param_list
, true);
3924 if (m
== MATCH_ERROR
)
3927 m
= gfc_match_char (')');
3931 m
= match_record_decl (name
);
3933 if (matched_type
|| m
== MATCH_YES
)
3935 ts
->type
= BT_DERIVED
;
3936 /* We accept record/s/ or type(s) where s is a structure, but we
3937 * don't need all the extra derived-type stuff for structures. */
3938 if (gfc_find_symbol (gfc_dt_upper_string (name
), NULL
, 1, &sym
))
3940 gfc_error ("Type name %qs at %C is ambiguous", name
);
3944 if (sym
&& sym
->attr
.flavor
== FL_DERIVED
3945 && sym
->attr
.pdt_template
3946 && gfc_current_state () != COMP_DERIVED
)
3948 m
= gfc_get_pdt_instance (decl_type_param_list
, &sym
, NULL
);
3951 gcc_assert (!sym
->attr
.pdt_template
&& sym
->attr
.pdt_type
);
3952 ts
->u
.derived
= sym
;
3953 strcpy (name
, gfc_dt_lower_string (sym
->name
));
3956 if (sym
&& sym
->attr
.flavor
== FL_STRUCT
)
3958 ts
->u
.derived
= sym
;
3961 /* Actually a derived type. */
3966 /* Match nested STRUCTURE declarations; only valid within another
3967 structure declaration. */
3968 if (flag_dec_structure
3969 && (gfc_current_state () == COMP_STRUCTURE
3970 || gfc_current_state () == COMP_MAP
))
3972 m
= gfc_match (" structure");
3975 m
= gfc_match_structure_decl ();
3978 /* gfc_new_block is updated by match_structure_decl. */
3979 ts
->type
= BT_DERIVED
;
3980 ts
->u
.derived
= gfc_new_block
;
3984 if (m
== MATCH_ERROR
)
3988 /* Match CLASS declarations. */
3989 m
= gfc_match (" class ( * )");
3990 if (m
== MATCH_ERROR
)
3992 else if (m
== MATCH_YES
)
3996 ts
->type
= BT_CLASS
;
3997 gfc_find_symbol ("STAR", gfc_current_ns
, 1, &upe
);
4000 upe
= gfc_new_symbol ("STAR", gfc_current_ns
);
4001 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "STAR");
4003 gfc_set_sym_referenced (upe
);
4005 upe
->ts
.type
= BT_VOID
;
4006 upe
->attr
.unlimited_polymorphic
= 1;
4007 /* This is essential to force the construction of
4008 unlimited polymorphic component class containers. */
4009 upe
->attr
.zero_comp
= 1;
4010 if (!gfc_add_flavor (&upe
->attr
, FL_DERIVED
, NULL
,
4011 &gfc_current_locus
))
4016 st
= gfc_get_tbp_symtree (&gfc_current_ns
->sym_root
, "STAR");
4020 ts
->u
.derived
= upe
;
4024 m
= gfc_match (" class (");
4027 m
= gfc_match ("%n", name
);
4033 ts
->type
= BT_CLASS
;
4035 if (!gfc_notify_std (GFC_STD_F2003
, "CLASS statement at %C"))
4038 m
= gfc_match_actual_arglist (1, &decl_type_param_list
, true);
4039 if (m
== MATCH_ERROR
)
4042 m
= gfc_match_char (')');
4047 /* Defer association of the derived type until the end of the
4048 specification block. However, if the derived type can be
4049 found, add it to the typespec. */
4050 if (gfc_matching_function
)
4052 ts
->u
.derived
= NULL
;
4053 if (gfc_current_state () != COMP_INTERFACE
4054 && !gfc_find_symbol (name
, NULL
, 1, &sym
) && sym
)
4056 sym
= gfc_find_dt_in_generic (sym
);
4057 ts
->u
.derived
= sym
;
4062 /* Search for the name but allow the components to be defined later. If
4063 type = -1, this typespec has been seen in a function declaration but
4064 the type could not be accessed at that point. The actual derived type is
4065 stored in a symtree with the first letter of the name capitalized; the
4066 symtree with the all lower-case name contains the associated
4067 generic function. */
4068 dt_name
= gfc_dt_upper_string (name
);
4073 gfc_get_ha_symbol (name
, &sym
);
4074 if (sym
->generic
&& gfc_find_symbol (dt_name
, NULL
, 0, &dt_sym
))
4076 gfc_error ("Type name %qs at %C is ambiguous", name
);
4079 if (sym
->generic
&& !dt_sym
)
4080 dt_sym
= gfc_find_dt_in_generic (sym
);
4082 /* Host associated PDTs can get confused with their constructors
4083 because they ar instantiated in the template's namespace. */
4086 if (gfc_find_symbol (dt_name
, NULL
, 1, &dt_sym
))
4088 gfc_error ("Type name %qs at %C is ambiguous", name
);
4091 if (dt_sym
&& !dt_sym
->attr
.pdt_type
)
4095 else if (ts
->kind
== -1)
4097 int iface
= gfc_state_stack
->previous
->state
!= COMP_INTERFACE
4098 || gfc_current_ns
->has_import_set
;
4099 gfc_find_symbol (name
, NULL
, iface
, &sym
);
4100 if (sym
&& sym
->generic
&& gfc_find_symbol (dt_name
, NULL
, 1, &dt_sym
))
4102 gfc_error ("Type name %qs at %C is ambiguous", name
);
4105 if (sym
&& sym
->generic
&& !dt_sym
)
4106 dt_sym
= gfc_find_dt_in_generic (sym
);
4113 if ((sym
->attr
.flavor
!= FL_UNKNOWN
&& sym
->attr
.flavor
!= FL_STRUCT
4114 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.generic
))
4115 || sym
->attr
.subroutine
)
4117 gfc_error ("Type name %qs at %C conflicts with previously declared "
4118 "entity at %L, which has the same name", name
,
4123 if (sym
&& sym
->attr
.flavor
== FL_DERIVED
4124 && sym
->attr
.pdt_template
4125 && gfc_current_state () != COMP_DERIVED
)
4127 m
= gfc_get_pdt_instance (decl_type_param_list
, &sym
, NULL
);
4130 gcc_assert (!sym
->attr
.pdt_template
&& sym
->attr
.pdt_type
);
4131 ts
->u
.derived
= sym
;
4132 strcpy (name
, gfc_dt_lower_string (sym
->name
));
4135 gfc_save_symbol_data (sym
);
4136 gfc_set_sym_referenced (sym
);
4137 if (!sym
->attr
.generic
4138 && !gfc_add_generic (&sym
->attr
, sym
->name
, NULL
))
4141 if (!sym
->attr
.function
4142 && !gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
4145 if (dt_sym
&& dt_sym
->attr
.flavor
== FL_DERIVED
4146 && dt_sym
->attr
.pdt_template
4147 && gfc_current_state () != COMP_DERIVED
)
4149 m
= gfc_get_pdt_instance (decl_type_param_list
, &dt_sym
, NULL
);
4152 gcc_assert (!dt_sym
->attr
.pdt_template
&& dt_sym
->attr
.pdt_type
);
4157 gfc_interface
*intr
, *head
;
4159 /* Use upper case to save the actual derived-type symbol. */
4160 gfc_get_symbol (dt_name
, NULL
, &dt_sym
);
4161 dt_sym
->name
= gfc_get_string ("%s", sym
->name
);
4162 head
= sym
->generic
;
4163 intr
= gfc_get_interface ();
4165 intr
->where
= gfc_current_locus
;
4167 sym
->generic
= intr
;
4168 sym
->attr
.if_source
= IFSRC_DECL
;
4171 gfc_save_symbol_data (dt_sym
);
4173 gfc_set_sym_referenced (dt_sym
);
4175 if (dt_sym
->attr
.flavor
!= FL_DERIVED
&& dt_sym
->attr
.flavor
!= FL_STRUCT
4176 && !gfc_add_flavor (&dt_sym
->attr
, FL_DERIVED
, sym
->name
, NULL
))
4179 ts
->u
.derived
= dt_sym
;
4185 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
4186 "intrinsic-type-spec at %C"))
4189 /* For all types except double, derived and character, look for an
4190 optional kind specifier. MATCH_NO is actually OK at this point. */
4191 if (implicit_flag
== 1)
4193 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
4199 if (gfc_current_form
== FORM_FREE
)
4201 c
= gfc_peek_ascii_char ();
4202 if (!gfc_is_whitespace (c
) && c
!= '*' && c
!= '('
4203 && c
!= ':' && c
!= ',')
4205 if (matched_type
&& c
== ')')
4207 gfc_next_ascii_char ();
4214 m
= gfc_match_kind_spec (ts
, false);
4215 if (m
== MATCH_NO
&& ts
->type
!= BT_CHARACTER
)
4217 m
= gfc_match_old_kind_spec (ts
);
4218 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) == -1)
4222 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
4225 /* Defer association of the KIND expression of function results
4226 until after USE and IMPORT statements. */
4227 if ((gfc_current_state () == COMP_NONE
&& gfc_error_flag_test ())
4228 || gfc_matching_function
)
4232 m
= MATCH_YES
; /* No kind specifier found. */
4238 /* Match an IMPLICIT NONE statement. Actually, this statement is
4239 already matched in parse.c, or we would not end up here in the
4240 first place. So the only thing we need to check, is if there is
4241 trailing garbage. If not, the match is successful. */
4244 gfc_match_implicit_none (void)
4248 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4250 bool external
= false;
4251 locus cur_loc
= gfc_current_locus
;
4253 if (gfc_current_ns
->seen_implicit_none
4254 || gfc_current_ns
->has_implicit_none_export
)
4256 gfc_error ("Duplicate IMPLICIT NONE statement at %C");
4260 gfc_gobble_whitespace ();
4261 c
= gfc_peek_ascii_char ();
4264 (void) gfc_next_ascii_char ();
4265 if (!gfc_notify_std (GFC_STD_F2018
, "IMPORT NONE with spec list at %C"))
4268 gfc_gobble_whitespace ();
4269 if (gfc_peek_ascii_char () == ')')
4271 (void) gfc_next_ascii_char ();
4277 m
= gfc_match (" %n", name
);
4281 if (strcmp (name
, "type") == 0)
4283 else if (strcmp (name
, "external") == 0)
4288 gfc_gobble_whitespace ();
4289 c
= gfc_next_ascii_char ();
4300 if (gfc_match_eos () != MATCH_YES
)
4303 gfc_set_implicit_none (type
, external
, &cur_loc
);
4309 /* Match the letter range(s) of an IMPLICIT statement. */
4312 match_implicit_range (void)
4318 cur_loc
= gfc_current_locus
;
4320 gfc_gobble_whitespace ();
4321 c
= gfc_next_ascii_char ();
4324 gfc_error ("Missing character range in IMPLICIT at %C");
4331 gfc_gobble_whitespace ();
4332 c1
= gfc_next_ascii_char ();
4336 gfc_gobble_whitespace ();
4337 c
= gfc_next_ascii_char ();
4342 inner
= 0; /* Fall through. */
4349 gfc_gobble_whitespace ();
4350 c2
= gfc_next_ascii_char ();
4354 gfc_gobble_whitespace ();
4355 c
= gfc_next_ascii_char ();
4357 if ((c
!= ',') && (c
!= ')'))
4370 gfc_error ("Letters must be in alphabetic order in "
4371 "IMPLICIT statement at %C");
4375 /* See if we can add the newly matched range to the pending
4376 implicits from this IMPLICIT statement. We do not check for
4377 conflicts with whatever earlier IMPLICIT statements may have
4378 set. This is done when we've successfully finished matching
4380 if (!gfc_add_new_implicit_range (c1
, c2
))
4387 gfc_syntax_error (ST_IMPLICIT
);
4389 gfc_current_locus
= cur_loc
;
4394 /* Match an IMPLICIT statement, storing the types for
4395 gfc_set_implicit() if the statement is accepted by the parser.
4396 There is a strange looking, but legal syntactic construction
4397 possible. It looks like:
4399 IMPLICIT INTEGER (a-b) (c-d)
4401 This is legal if "a-b" is a constant expression that happens to
4402 equal one of the legal kinds for integers. The real problem
4403 happens with an implicit specification that looks like:
4405 IMPLICIT INTEGER (a-b)
4407 In this case, a typespec matcher that is "greedy" (as most of the
4408 matchers are) gobbles the character range as a kindspec, leaving
4409 nothing left. We therefore have to go a bit more slowly in the
4410 matching process by inhibiting the kindspec checking during
4411 typespec matching and checking for a kind later. */
4414 gfc_match_implicit (void)
4421 if (gfc_current_ns
->seen_implicit_none
)
4423 gfc_error ("IMPLICIT statement at %C following an IMPLICIT NONE (type) "
4430 /* We don't allow empty implicit statements. */
4431 if (gfc_match_eos () == MATCH_YES
)
4433 gfc_error ("Empty IMPLICIT statement at %C");
4439 /* First cleanup. */
4440 gfc_clear_new_implicit ();
4442 /* A basic type is mandatory here. */
4443 m
= gfc_match_decl_type_spec (&ts
, 1);
4444 if (m
== MATCH_ERROR
)
4449 cur_loc
= gfc_current_locus
;
4450 m
= match_implicit_range ();
4454 /* We may have <TYPE> (<RANGE>). */
4455 gfc_gobble_whitespace ();
4456 c
= gfc_peek_ascii_char ();
4457 if (c
== ',' || c
== '\n' || c
== ';' || c
== '!')
4459 /* Check for CHARACTER with no length parameter. */
4460 if (ts
.type
== BT_CHARACTER
&& !ts
.u
.cl
)
4462 ts
.kind
= gfc_default_character_kind
;
4463 ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4464 ts
.u
.cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
,
4468 /* Record the Successful match. */
4469 if (!gfc_merge_new_implicit (&ts
))
4472 c
= gfc_next_ascii_char ();
4473 else if (gfc_match_eos () == MATCH_ERROR
)
4478 gfc_current_locus
= cur_loc
;
4481 /* Discard the (incorrectly) matched range. */
4482 gfc_clear_new_implicit ();
4484 /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
4485 if (ts
.type
== BT_CHARACTER
)
4486 m
= gfc_match_char_spec (&ts
);
4489 m
= gfc_match_kind_spec (&ts
, false);
4492 m
= gfc_match_old_kind_spec (&ts
);
4493 if (m
== MATCH_ERROR
)
4499 if (m
== MATCH_ERROR
)
4502 m
= match_implicit_range ();
4503 if (m
== MATCH_ERROR
)
4508 gfc_gobble_whitespace ();
4509 c
= gfc_next_ascii_char ();
4510 if (c
!= ',' && gfc_match_eos () != MATCH_YES
)
4513 if (!gfc_merge_new_implicit (&ts
))
4521 gfc_syntax_error (ST_IMPLICIT
);
4529 gfc_match_import (void)
4531 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4536 if (gfc_current_ns
->proc_name
== NULL
4537 || gfc_current_ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
4539 gfc_error ("IMPORT statement at %C only permitted in "
4540 "an INTERFACE body");
4544 if (gfc_current_ns
->proc_name
->attr
.module_procedure
)
4546 gfc_error ("F2008: C1210 IMPORT statement at %C is not permitted "
4547 "in a module procedure interface body");
4551 if (!gfc_notify_std (GFC_STD_F2003
, "IMPORT statement at %C"))
4554 if (gfc_match_eos () == MATCH_YES
)
4556 /* All host variables should be imported. */
4557 gfc_current_ns
->has_import_set
= 1;
4561 if (gfc_match (" ::") == MATCH_YES
)
4563 if (gfc_match_eos () == MATCH_YES
)
4565 gfc_error ("Expecting list of named entities at %C");
4573 m
= gfc_match (" %n", name
);
4577 if (gfc_current_ns
->parent
!= NULL
4578 && gfc_find_symbol (name
, gfc_current_ns
->parent
, 1, &sym
))
4580 gfc_error ("Type name %qs at %C is ambiguous", name
);
4583 else if (!sym
&& gfc_current_ns
->proc_name
->ns
->parent
!= NULL
4584 && gfc_find_symbol (name
,
4585 gfc_current_ns
->proc_name
->ns
->parent
,
4588 gfc_error ("Type name %qs at %C is ambiguous", name
);
4594 gfc_error ("Cannot IMPORT %qs from host scoping unit "
4595 "at %C - does not exist.", name
);
4599 if (gfc_find_symtree (gfc_current_ns
->sym_root
, name
))
4601 gfc_warning (0, "%qs is already IMPORTed from host scoping unit "
4606 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, name
);
4609 sym
->attr
.imported
= 1;
4611 if (sym
->attr
.generic
&& (sym
= gfc_find_dt_in_generic (sym
)))
4613 /* The actual derived type is stored in a symtree with the first
4614 letter of the name capitalized; the symtree with the all
4615 lower-case name contains the associated generic function. */
4616 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
,
4617 gfc_dt_upper_string (name
));
4620 sym
->attr
.imported
= 1;
4633 if (gfc_match_eos () == MATCH_YES
)
4635 if (gfc_match_char (',') != MATCH_YES
)
4642 gfc_error ("Syntax error in IMPORT statement at %C");
4647 /* A minimal implementation of gfc_match without whitespace, escape
4648 characters or variable arguments. Returns true if the next
4649 characters match the TARGET template exactly. */
4652 match_string_p (const char *target
)
4656 for (p
= target
; *p
; p
++)
4657 if ((char) gfc_next_ascii_char () != *p
)
4662 /* Matches an attribute specification including array specs. If
4663 successful, leaves the variables current_attr and current_as
4664 holding the specification. Also sets the colon_seen variable for
4665 later use by matchers associated with initializations.
4667 This subroutine is a little tricky in the sense that we don't know
4668 if we really have an attr-spec until we hit the double colon.
4669 Until that time, we can only return MATCH_NO. This forces us to
4670 check for duplicate specification at this level. */
4673 match_attr_spec (void)
4675 /* Modifiers that can exist in a type statement. */
4677 { GFC_DECL_BEGIN
= 0,
4678 DECL_ALLOCATABLE
= GFC_DECL_BEGIN
, DECL_DIMENSION
, DECL_EXTERNAL
,
4679 DECL_IN
, DECL_OUT
, DECL_INOUT
, DECL_INTRINSIC
, DECL_OPTIONAL
,
4680 DECL_PARAMETER
, DECL_POINTER
, DECL_PROTECTED
, DECL_PRIVATE
,
4681 DECL_STATIC
, DECL_AUTOMATIC
,
4682 DECL_PUBLIC
, DECL_SAVE
, DECL_TARGET
, DECL_VALUE
, DECL_VOLATILE
,
4683 DECL_IS_BIND_C
, DECL_CODIMENSION
, DECL_ASYNCHRONOUS
, DECL_CONTIGUOUS
,
4684 DECL_LEN
, DECL_KIND
, DECL_NONE
, GFC_DECL_END
/* Sentinel */
4687 /* GFC_DECL_END is the sentinel, index starts at 0. */
4688 #define NUM_DECL GFC_DECL_END
4690 locus start
, seen_at
[NUM_DECL
];
4697 gfc_clear_attr (¤t_attr
);
4698 start
= gfc_current_locus
;
4704 /* See if we get all of the keywords up to the final double colon. */
4705 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
4713 gfc_gobble_whitespace ();
4715 ch
= gfc_next_ascii_char ();
4718 /* This is the successful exit condition for the loop. */
4719 if (gfc_next_ascii_char () == ':')
4724 gfc_gobble_whitespace ();
4725 switch (gfc_peek_ascii_char ())
4728 gfc_next_ascii_char ();
4729 switch (gfc_next_ascii_char ())
4732 if (match_string_p ("locatable"))
4734 /* Matched "allocatable". */
4735 d
= DECL_ALLOCATABLE
;
4740 if (match_string_p ("ynchronous"))
4742 /* Matched "asynchronous". */
4743 d
= DECL_ASYNCHRONOUS
;
4748 if (match_string_p ("tomatic"))
4750 /* Matched "automatic". */
4758 /* Try and match the bind(c). */
4759 m
= gfc_match_bind_c (NULL
, true);
4762 else if (m
== MATCH_ERROR
)
4767 gfc_next_ascii_char ();
4768 if ('o' != gfc_next_ascii_char ())
4770 switch (gfc_next_ascii_char ())
4773 if (match_string_p ("imension"))
4775 d
= DECL_CODIMENSION
;
4780 if (match_string_p ("tiguous"))
4782 d
= DECL_CONTIGUOUS
;
4789 if (match_string_p ("dimension"))
4794 if (match_string_p ("external"))
4799 if (match_string_p ("int"))
4801 ch
= gfc_next_ascii_char ();
4804 if (match_string_p ("nt"))
4806 /* Matched "intent". */
4807 /* TODO: Call match_intent_spec from here. */
4808 if (gfc_match (" ( in out )") == MATCH_YES
)
4810 else if (gfc_match (" ( in )") == MATCH_YES
)
4812 else if (gfc_match (" ( out )") == MATCH_YES
)
4818 if (match_string_p ("insic"))
4820 /* Matched "intrinsic". */
4828 if (match_string_p ("kind"))
4833 if (match_string_p ("len"))
4838 if (match_string_p ("optional"))
4843 gfc_next_ascii_char ();
4844 switch (gfc_next_ascii_char ())
4847 if (match_string_p ("rameter"))
4849 /* Matched "parameter". */
4855 if (match_string_p ("inter"))
4857 /* Matched "pointer". */
4863 ch
= gfc_next_ascii_char ();
4866 if (match_string_p ("vate"))
4868 /* Matched "private". */
4874 if (match_string_p ("tected"))
4876 /* Matched "protected". */
4883 if (match_string_p ("blic"))
4885 /* Matched "public". */
4893 gfc_next_ascii_char ();
4894 switch (gfc_next_ascii_char ())
4897 if (match_string_p ("ve"))
4899 /* Matched "save". */
4905 if (match_string_p ("atic"))
4907 /* Matched "static". */
4915 if (match_string_p ("target"))
4920 gfc_next_ascii_char ();
4921 ch
= gfc_next_ascii_char ();
4924 if (match_string_p ("lue"))
4926 /* Matched "value". */
4932 if (match_string_p ("latile"))
4934 /* Matched "volatile". */
4942 /* No double colon and no recognizable decl_type, so assume that
4943 we've been looking at something else the whole time. */
4950 /* Check to make sure any parens are paired up correctly. */
4951 if (gfc_match_parens () == MATCH_ERROR
)
4958 seen_at
[d
] = gfc_current_locus
;
4960 if (d
== DECL_DIMENSION
|| d
== DECL_CODIMENSION
)
4962 gfc_array_spec
*as
= NULL
;
4964 m
= gfc_match_array_spec (&as
, d
== DECL_DIMENSION
,
4965 d
== DECL_CODIMENSION
);
4967 if (current_as
== NULL
)
4969 else if (m
== MATCH_YES
)
4971 if (!merge_array_spec (as
, current_as
, false))
4978 if (d
== DECL_CODIMENSION
)
4979 gfc_error ("Missing codimension specification at %C");
4981 gfc_error ("Missing dimension specification at %C");
4985 if (m
== MATCH_ERROR
)
4990 /* Since we've seen a double colon, we have to be looking at an
4991 attr-spec. This means that we can now issue errors. */
4992 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
4997 case DECL_ALLOCATABLE
:
4998 attr
= "ALLOCATABLE";
5000 case DECL_ASYNCHRONOUS
:
5001 attr
= "ASYNCHRONOUS";
5003 case DECL_CODIMENSION
:
5004 attr
= "CODIMENSION";
5006 case DECL_CONTIGUOUS
:
5007 attr
= "CONTIGUOUS";
5009 case DECL_DIMENSION
:
5016 attr
= "INTENT (IN)";
5019 attr
= "INTENT (OUT)";
5022 attr
= "INTENT (IN OUT)";
5024 case DECL_INTRINSIC
:
5036 case DECL_PARAMETER
:
5042 case DECL_PROTECTED
:
5057 case DECL_AUTOMATIC
:
5063 case DECL_IS_BIND_C
:
5073 attr
= NULL
; /* This shouldn't happen. */
5076 gfc_error ("Duplicate %s attribute at %L", attr
, &seen_at
[d
]);
5081 /* Now that we've dealt with duplicate attributes, add the attributes
5082 to the current attribute. */
5083 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
5090 if ((d
== DECL_STATIC
|| d
== DECL_AUTOMATIC
)
5091 && !flag_dec_static
)
5093 gfc_error ("%s at %L is a DEC extension, enable with "
5095 d
== DECL_STATIC
? "STATIC" : "AUTOMATIC", &seen_at
[d
]);
5099 /* Allow SAVE with STATIC, but don't complain. */
5100 if (d
== DECL_STATIC
&& seen
[DECL_SAVE
])
5103 if (gfc_current_state () == COMP_DERIVED
5104 && d
!= DECL_DIMENSION
&& d
!= DECL_CODIMENSION
5105 && d
!= DECL_POINTER
&& d
!= DECL_PRIVATE
5106 && d
!= DECL_PUBLIC
&& d
!= DECL_CONTIGUOUS
&& d
!= DECL_NONE
)
5108 if (d
== DECL_ALLOCATABLE
)
5110 if (!gfc_notify_std (GFC_STD_F2003
, "ALLOCATABLE "
5111 "attribute at %C in a TYPE definition"))
5117 else if (d
== DECL_KIND
)
5119 if (!gfc_notify_std (GFC_STD_F2003
, "KIND "
5120 "attribute at %C in a TYPE definition"))
5125 if (current_ts
.type
!= BT_INTEGER
)
5127 gfc_error ("Component with KIND attribute at %C must be "
5132 if (current_ts
.kind
!= gfc_default_integer_kind
)
5134 gfc_error ("Component with KIND attribute at %C must be "
5135 "default integer kind (%d)",
5136 gfc_default_integer_kind
);
5141 else if (d
== DECL_LEN
)
5143 if (!gfc_notify_std (GFC_STD_F2003
, "LEN "
5144 "attribute at %C in a TYPE definition"))
5149 if (current_ts
.type
!= BT_INTEGER
)
5151 gfc_error ("Component with LEN attribute at %C must be "
5156 if (current_ts
.kind
!= gfc_default_integer_kind
)
5158 gfc_error ("Component with LEN attribute at %C must be "
5159 "default integer kind (%d)",
5160 gfc_default_integer_kind
);
5167 gfc_error ("Attribute at %L is not allowed in a TYPE definition",
5174 if ((d
== DECL_PRIVATE
|| d
== DECL_PUBLIC
)
5175 && gfc_current_state () != COMP_MODULE
)
5177 if (d
== DECL_PRIVATE
)
5181 if (gfc_current_state () == COMP_DERIVED
5182 && gfc_state_stack
->previous
5183 && gfc_state_stack
->previous
->state
== COMP_MODULE
)
5185 if (!gfc_notify_std (GFC_STD_F2003
, "Attribute %s "
5186 "at %L in a TYPE definition", attr
,
5195 gfc_error ("%s attribute at %L is not allowed outside of the "
5196 "specification part of a module", attr
, &seen_at
[d
]);
5202 if (gfc_current_state () != COMP_DERIVED
5203 && (d
== DECL_KIND
|| d
== DECL_LEN
))
5205 gfc_error ("Attribute at %L is not allowed outside a TYPE "
5206 "definition", &seen_at
[d
]);
5213 case DECL_ALLOCATABLE
:
5214 t
= gfc_add_allocatable (¤t_attr
, &seen_at
[d
]);
5217 case DECL_ASYNCHRONOUS
:
5218 if (!gfc_notify_std (GFC_STD_F2003
, "ASYNCHRONOUS attribute at %C"))
5221 t
= gfc_add_asynchronous (¤t_attr
, NULL
, &seen_at
[d
]);
5224 case DECL_CODIMENSION
:
5225 t
= gfc_add_codimension (¤t_attr
, NULL
, &seen_at
[d
]);
5228 case DECL_CONTIGUOUS
:
5229 if (!gfc_notify_std (GFC_STD_F2008
, "CONTIGUOUS attribute at %C"))
5232 t
= gfc_add_contiguous (¤t_attr
, NULL
, &seen_at
[d
]);
5235 case DECL_DIMENSION
:
5236 t
= gfc_add_dimension (¤t_attr
, NULL
, &seen_at
[d
]);
5240 t
= gfc_add_external (¤t_attr
, &seen_at
[d
]);
5244 t
= gfc_add_intent (¤t_attr
, INTENT_IN
, &seen_at
[d
]);
5248 t
= gfc_add_intent (¤t_attr
, INTENT_OUT
, &seen_at
[d
]);
5252 t
= gfc_add_intent (¤t_attr
, INTENT_INOUT
, &seen_at
[d
]);
5255 case DECL_INTRINSIC
:
5256 t
= gfc_add_intrinsic (¤t_attr
, &seen_at
[d
]);
5260 t
= gfc_add_optional (¤t_attr
, &seen_at
[d
]);
5264 t
= gfc_add_kind (¤t_attr
, &seen_at
[d
]);
5268 t
= gfc_add_len (¤t_attr
, &seen_at
[d
]);
5271 case DECL_PARAMETER
:
5272 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, &seen_at
[d
]);
5276 t
= gfc_add_pointer (¤t_attr
, &seen_at
[d
]);
5279 case DECL_PROTECTED
:
5280 if (gfc_current_state () != COMP_MODULE
5281 || (gfc_current_ns
->proc_name
5282 && gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
))
5284 gfc_error ("PROTECTED at %C only allowed in specification "
5285 "part of a module");
5290 if (!gfc_notify_std (GFC_STD_F2003
, "PROTECTED attribute at %C"))
5293 t
= gfc_add_protected (¤t_attr
, NULL
, &seen_at
[d
]);
5297 t
= gfc_add_access (¤t_attr
, ACCESS_PRIVATE
, NULL
,
5302 t
= gfc_add_access (¤t_attr
, ACCESS_PUBLIC
, NULL
,
5308 t
= gfc_add_save (¤t_attr
, SAVE_EXPLICIT
, NULL
, &seen_at
[d
]);
5311 case DECL_AUTOMATIC
:
5312 t
= gfc_add_automatic (¤t_attr
, NULL
, &seen_at
[d
]);
5316 t
= gfc_add_target (¤t_attr
, &seen_at
[d
]);
5319 case DECL_IS_BIND_C
:
5320 t
= gfc_add_is_bind_c(¤t_attr
, NULL
, &seen_at
[d
], 0);
5324 if (!gfc_notify_std (GFC_STD_F2003
, "VALUE attribute at %C"))
5327 t
= gfc_add_value (¤t_attr
, NULL
, &seen_at
[d
]);
5331 if (!gfc_notify_std (GFC_STD_F2003
, "VOLATILE attribute at %C"))
5334 t
= gfc_add_volatile (¤t_attr
, NULL
, &seen_at
[d
]);
5338 gfc_internal_error ("match_attr_spec(): Bad attribute");
5348 /* Since Fortran 2008 module variables implicitly have the SAVE attribute. */
5349 if ((gfc_current_state () == COMP_MODULE
5350 || gfc_current_state () == COMP_SUBMODULE
)
5351 && !current_attr
.save
5352 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
5353 current_attr
.save
= SAVE_IMPLICIT
;
5359 gfc_current_locus
= start
;
5360 gfc_free_array_spec (current_as
);
5367 /* Set the binding label, dest_label, either with the binding label
5368 stored in the given gfc_typespec, ts, or if none was provided, it
5369 will be the symbol name in all lower case, as required by the draft
5370 (J3/04-007, section 15.4.1). If a binding label was given and
5371 there is more than one argument (num_idents), it is an error. */
5374 set_binding_label (const char **dest_label
, const char *sym_name
,
5377 if (num_idents
> 1 && has_name_equals
)
5379 gfc_error ("Multiple identifiers provided with "
5380 "single NAME= specifier at %C");
5384 if (curr_binding_label
)
5385 /* Binding label given; store in temp holder till have sym. */
5386 *dest_label
= curr_binding_label
;
5389 /* No binding label given, and the NAME= specifier did not exist,
5390 which means there was no NAME="". */
5391 if (sym_name
!= NULL
&& has_name_equals
== 0)
5392 *dest_label
= IDENTIFIER_POINTER (get_identifier (sym_name
));
5399 /* Set the status of the given common block as being BIND(C) or not,
5400 depending on the given parameter, is_bind_c. */
5403 set_com_block_bind_c (gfc_common_head
*com_block
, int is_bind_c
)
5405 com_block
->is_bind_c
= is_bind_c
;
5410 /* Verify that the given gfc_typespec is for a C interoperable type. */
5413 gfc_verify_c_interop (gfc_typespec
*ts
)
5415 if (ts
->type
== BT_DERIVED
&& ts
->u
.derived
!= NULL
)
5416 return (ts
->u
.derived
->ts
.is_c_interop
|| ts
->u
.derived
->attr
.is_bind_c
)
5418 else if (ts
->type
== BT_CLASS
)
5420 else if (ts
->is_c_interop
!= 1 && ts
->type
!= BT_ASSUMED
)
5427 /* Verify that the variables of a given common block, which has been
5428 defined with the attribute specifier bind(c), to be of a C
5429 interoperable type. Errors will be reported here, if
5433 verify_com_block_vars_c_interop (gfc_common_head
*com_block
)
5435 gfc_symbol
*curr_sym
= NULL
;
5438 curr_sym
= com_block
->head
;
5440 /* Make sure we have at least one symbol. */
5441 if (curr_sym
== NULL
)
5444 /* Here we know we have a symbol, so we'll execute this loop
5448 /* The second to last param, 1, says this is in a common block. */
5449 retval
= verify_bind_c_sym (curr_sym
, &(curr_sym
->ts
), 1, com_block
);
5450 curr_sym
= curr_sym
->common_next
;
5451 } while (curr_sym
!= NULL
);
5457 /* Verify that a given BIND(C) symbol is C interoperable. If it is not,
5458 an appropriate error message is reported. */
5461 verify_bind_c_sym (gfc_symbol
*tmp_sym
, gfc_typespec
*ts
,
5462 int is_in_common
, gfc_common_head
*com_block
)
5464 bool bind_c_function
= false;
5467 if (tmp_sym
->attr
.function
&& tmp_sym
->attr
.is_bind_c
)
5468 bind_c_function
= true;
5470 if (tmp_sym
->attr
.function
&& tmp_sym
->result
!= NULL
)
5472 tmp_sym
= tmp_sym
->result
;
5473 /* Make sure it wasn't an implicitly typed result. */
5474 if (tmp_sym
->attr
.implicit_type
&& warn_c_binding_type
)
5476 gfc_warning (OPT_Wc_binding_type
,
5477 "Implicitly declared BIND(C) function %qs at "
5478 "%L may not be C interoperable", tmp_sym
->name
,
5479 &tmp_sym
->declared_at
);
5480 tmp_sym
->ts
.f90_type
= tmp_sym
->ts
.type
;
5481 /* Mark it as C interoperable to prevent duplicate warnings. */
5482 tmp_sym
->ts
.is_c_interop
= 1;
5483 tmp_sym
->attr
.is_c_interop
= 1;
5487 /* Here, we know we have the bind(c) attribute, so if we have
5488 enough type info, then verify that it's a C interop kind.
5489 The info could be in the symbol already, or possibly still in
5490 the given ts (current_ts), so look in both. */
5491 if (tmp_sym
->ts
.type
!= BT_UNKNOWN
|| ts
->type
!= BT_UNKNOWN
)
5493 if (!gfc_verify_c_interop (&(tmp_sym
->ts
)))
5495 /* See if we're dealing with a sym in a common block or not. */
5496 if (is_in_common
== 1 && warn_c_binding_type
)
5498 gfc_warning (OPT_Wc_binding_type
,
5499 "Variable %qs in common block %qs at %L "
5500 "may not be a C interoperable "
5501 "kind though common block %qs is BIND(C)",
5502 tmp_sym
->name
, com_block
->name
,
5503 &(tmp_sym
->declared_at
), com_block
->name
);
5507 if (tmp_sym
->ts
.type
== BT_DERIVED
|| ts
->type
== BT_DERIVED
)
5508 gfc_error ("Type declaration %qs at %L is not C "
5509 "interoperable but it is BIND(C)",
5510 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5511 else if (warn_c_binding_type
)
5512 gfc_warning (OPT_Wc_binding_type
, "Variable %qs at %L "
5513 "may not be a C interoperable "
5514 "kind but it is BIND(C)",
5515 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5519 /* Variables declared w/in a common block can't be bind(c)
5520 since there's no way for C to see these variables, so there's
5521 semantically no reason for the attribute. */
5522 if (is_in_common
== 1 && tmp_sym
->attr
.is_bind_c
== 1)
5524 gfc_error ("Variable %qs in common block %qs at "
5525 "%L cannot be declared with BIND(C) "
5526 "since it is not a global",
5527 tmp_sym
->name
, com_block
->name
,
5528 &(tmp_sym
->declared_at
));
5532 /* Scalar variables that are bind(c) can not have the pointer
5533 or allocatable attributes. */
5534 if (tmp_sym
->attr
.is_bind_c
== 1)
5536 if (tmp_sym
->attr
.pointer
== 1)
5538 gfc_error ("Variable %qs at %L cannot have both the "
5539 "POINTER and BIND(C) attributes",
5540 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5544 if (tmp_sym
->attr
.allocatable
== 1)
5546 gfc_error ("Variable %qs at %L cannot have both the "
5547 "ALLOCATABLE and BIND(C) attributes",
5548 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5554 /* If it is a BIND(C) function, make sure the return value is a
5555 scalar value. The previous tests in this function made sure
5556 the type is interoperable. */
5557 if (bind_c_function
&& tmp_sym
->as
!= NULL
)
5558 gfc_error ("Return type of BIND(C) function %qs at %L cannot "
5559 "be an array", tmp_sym
->name
, &(tmp_sym
->declared_at
));
5561 /* BIND(C) functions can not return a character string. */
5562 if (bind_c_function
&& tmp_sym
->ts
.type
== BT_CHARACTER
)
5563 if (tmp_sym
->ts
.u
.cl
== NULL
|| tmp_sym
->ts
.u
.cl
->length
== NULL
5564 || tmp_sym
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
5565 || mpz_cmp_si (tmp_sym
->ts
.u
.cl
->length
->value
.integer
, 1) != 0)
5566 gfc_error ("Return type of BIND(C) function %qs at %L cannot "
5567 "be a character string", tmp_sym
->name
,
5568 &(tmp_sym
->declared_at
));
5571 /* See if the symbol has been marked as private. If it has, make sure
5572 there is no binding label and warn the user if there is one. */
5573 if (tmp_sym
->attr
.access
== ACCESS_PRIVATE
5574 && tmp_sym
->binding_label
)
5575 /* Use gfc_warning_now because we won't say that the symbol fails
5576 just because of this. */
5577 gfc_warning_now (0, "Symbol %qs at %L is marked PRIVATE but has been "
5578 "given the binding label %qs", tmp_sym
->name
,
5579 &(tmp_sym
->declared_at
), tmp_sym
->binding_label
);
5585 /* Set the appropriate fields for a symbol that's been declared as
5586 BIND(C) (the is_bind_c flag and the binding label), and verify that
5587 the type is C interoperable. Errors are reported by the functions
5588 used to set/test these fields. */
5591 set_verify_bind_c_sym (gfc_symbol
*tmp_sym
, int num_idents
)
5595 /* TODO: Do we need to make sure the vars aren't marked private? */
5597 /* Set the is_bind_c bit in symbol_attribute. */
5598 gfc_add_is_bind_c (&(tmp_sym
->attr
), tmp_sym
->name
, &gfc_current_locus
, 0);
5600 if (!set_binding_label (&tmp_sym
->binding_label
, tmp_sym
->name
, num_idents
))
5607 /* Set the fields marking the given common block as BIND(C), including
5608 a binding label, and report any errors encountered. */
5611 set_verify_bind_c_com_block (gfc_common_head
*com_block
, int num_idents
)
5615 /* destLabel, common name, typespec (which may have binding label). */
5616 if (!set_binding_label (&com_block
->binding_label
, com_block
->name
,
5620 /* Set the given common block (com_block) to being bind(c) (1). */
5621 set_com_block_bind_c (com_block
, 1);
5627 /* Retrieve the list of one or more identifiers that the given bind(c)
5628 attribute applies to. */
5631 get_bind_c_idents (void)
5633 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5635 gfc_symbol
*tmp_sym
= NULL
;
5637 gfc_common_head
*com_block
= NULL
;
5639 if (gfc_match_name (name
) == MATCH_YES
)
5641 found_id
= MATCH_YES
;
5642 gfc_get_ha_symbol (name
, &tmp_sym
);
5644 else if (match_common_name (name
) == MATCH_YES
)
5646 found_id
= MATCH_YES
;
5647 com_block
= gfc_get_common (name
, 0);
5651 gfc_error ("Need either entity or common block name for "
5652 "attribute specification statement at %C");
5656 /* Save the current identifier and look for more. */
5659 /* Increment the number of identifiers found for this spec stmt. */
5662 /* Make sure we have a sym or com block, and verify that it can
5663 be bind(c). Set the appropriate field(s) and look for more
5665 if (tmp_sym
!= NULL
|| com_block
!= NULL
)
5667 if (tmp_sym
!= NULL
)
5669 if (!set_verify_bind_c_sym (tmp_sym
, num_idents
))
5674 if (!set_verify_bind_c_com_block (com_block
, num_idents
))
5678 /* Look to see if we have another identifier. */
5680 if (gfc_match_eos () == MATCH_YES
)
5681 found_id
= MATCH_NO
;
5682 else if (gfc_match_char (',') != MATCH_YES
)
5683 found_id
= MATCH_NO
;
5684 else if (gfc_match_name (name
) == MATCH_YES
)
5686 found_id
= MATCH_YES
;
5687 gfc_get_ha_symbol (name
, &tmp_sym
);
5689 else if (match_common_name (name
) == MATCH_YES
)
5691 found_id
= MATCH_YES
;
5692 com_block
= gfc_get_common (name
, 0);
5696 gfc_error ("Missing entity or common block name for "
5697 "attribute specification statement at %C");
5703 gfc_internal_error ("Missing symbol");
5705 } while (found_id
== MATCH_YES
);
5707 /* if we get here we were successful */
5712 /* Try and match a BIND(C) attribute specification statement. */
5715 gfc_match_bind_c_stmt (void)
5717 match found_match
= MATCH_NO
;
5722 /* This may not be necessary. */
5724 /* Clear the temporary binding label holder. */
5725 curr_binding_label
= NULL
;
5727 /* Look for the bind(c). */
5728 found_match
= gfc_match_bind_c (NULL
, true);
5730 if (found_match
== MATCH_YES
)
5732 if (!gfc_notify_std (GFC_STD_F2003
, "BIND(C) statement at %C"))
5735 /* Look for the :: now, but it is not required. */
5738 /* Get the identifier(s) that needs to be updated. This may need to
5739 change to hand the flag(s) for the attr specified so all identifiers
5740 found can have all appropriate parts updated (assuming that the same
5741 spec stmt can have multiple attrs, such as both bind(c) and
5743 if (!get_bind_c_idents ())
5744 /* Error message should have printed already. */
5752 /* Match a data declaration statement. */
5755 gfc_match_data_decl (void)
5761 type_param_spec_list
= NULL
;
5762 decl_type_param_list
= NULL
;
5764 num_idents_on_line
= 0;
5766 m
= gfc_match_decl_type_spec (¤t_ts
, 0);
5770 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
5771 && !gfc_comp_struct (gfc_current_state ()))
5773 sym
= gfc_use_derived (current_ts
.u
.derived
);
5781 current_ts
.u
.derived
= sym
;
5784 m
= match_attr_spec ();
5785 if (m
== MATCH_ERROR
)
5791 if (current_ts
.type
== BT_CLASS
5792 && current_ts
.u
.derived
->attr
.unlimited_polymorphic
)
5795 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
5796 && current_ts
.u
.derived
->components
== NULL
5797 && !current_ts
.u
.derived
->attr
.zero_comp
)
5800 if (current_attr
.pointer
&& gfc_comp_struct (gfc_current_state ()))
5803 if (current_attr
.allocatable
&& gfc_current_state () == COMP_DERIVED
5804 && current_ts
.u
.derived
== gfc_current_block ())
5807 gfc_find_symbol (current_ts
.u
.derived
->name
,
5808 current_ts
.u
.derived
->ns
, 1, &sym
);
5810 /* Any symbol that we find had better be a type definition
5811 which has its components defined, or be a structure definition
5812 actively being parsed. */
5813 if (sym
!= NULL
&& gfc_fl_struct (sym
->attr
.flavor
)
5814 && (current_ts
.u
.derived
->components
!= NULL
5815 || current_ts
.u
.derived
->attr
.zero_comp
5816 || current_ts
.u
.derived
== gfc_new_block
))
5819 gfc_error ("Derived type at %C has not been previously defined "
5820 "and so cannot appear in a derived type definition");
5826 /* If we have an old-style character declaration, and no new-style
5827 attribute specifications, then there a comma is optional between
5828 the type specification and the variable list. */
5829 if (m
== MATCH_NO
&& current_ts
.type
== BT_CHARACTER
&& old_char_selector
)
5830 gfc_match_char (',');
5832 /* Give the types/attributes to symbols that follow. Give the element
5833 a number so that repeat character length expressions can be copied. */
5837 num_idents_on_line
++;
5838 m
= variable_decl (elem
++);
5839 if (m
== MATCH_ERROR
)
5844 if (gfc_match_eos () == MATCH_YES
)
5846 if (gfc_match_char (',') != MATCH_YES
)
5850 if (!gfc_error_flag_test ())
5852 /* An anonymous structure declaration is unambiguous; if we matched one
5853 according to gfc_match_structure_decl, we need to return MATCH_YES
5854 here to avoid confusing the remaining matchers, even if there was an
5855 error during variable_decl. We must flush any such errors. Note this
5856 causes the parser to gracefully continue parsing the remaining input
5857 as a structure body, which likely follows. */
5858 if (current_ts
.type
== BT_DERIVED
&& current_ts
.u
.derived
5859 && gfc_fl_struct (current_ts
.u
.derived
->attr
.flavor
))
5861 gfc_error_now ("Syntax error in anonymous structure declaration"
5863 /* Skip the bad variable_decl and line up for the start of the
5865 gfc_error_recovery ();
5870 gfc_error ("Syntax error in data declaration at %C");
5875 gfc_free_data_all (gfc_current_ns
);
5878 if (saved_kind_expr
)
5879 gfc_free_expr (saved_kind_expr
);
5880 if (type_param_spec_list
)
5881 gfc_free_actual_arglist (type_param_spec_list
);
5882 if (decl_type_param_list
)
5883 gfc_free_actual_arglist (decl_type_param_list
);
5884 saved_kind_expr
= NULL
;
5885 gfc_free_array_spec (current_as
);
5891 /* Match a prefix associated with a function or subroutine
5892 declaration. If the typespec pointer is nonnull, then a typespec
5893 can be matched. Note that if nothing matches, MATCH_YES is
5894 returned (the null string was matched). */
5897 gfc_match_prefix (gfc_typespec
*ts
)
5903 gfc_clear_attr (¤t_attr
);
5905 seen_impure
= false;
5907 gcc_assert (!gfc_matching_prefix
);
5908 gfc_matching_prefix
= true;
5912 found_prefix
= false;
5914 /* MODULE is a prefix like PURE, ELEMENTAL, etc., having a
5915 corresponding attribute seems natural and distinguishes these
5916 procedures from procedure types of PROC_MODULE, which these are
5918 if (gfc_match ("module% ") == MATCH_YES
)
5920 if (!gfc_notify_std (GFC_STD_F2008
, "MODULE prefix at %C"))
5923 current_attr
.module_procedure
= 1;
5924 found_prefix
= true;
5927 if (!seen_type
&& ts
!= NULL
5928 && gfc_match_decl_type_spec (ts
, 0) == MATCH_YES
5929 && gfc_match_space () == MATCH_YES
)
5933 found_prefix
= true;
5936 if (gfc_match ("elemental% ") == MATCH_YES
)
5938 if (!gfc_add_elemental (¤t_attr
, NULL
))
5941 found_prefix
= true;
5944 if (gfc_match ("pure% ") == MATCH_YES
)
5946 if (!gfc_add_pure (¤t_attr
, NULL
))
5949 found_prefix
= true;
5952 if (gfc_match ("recursive% ") == MATCH_YES
)
5954 if (!gfc_add_recursive (¤t_attr
, NULL
))
5957 found_prefix
= true;
5960 /* IMPURE is a somewhat special case, as it needs not set an actual
5961 attribute but rather only prevents ELEMENTAL routines from being
5962 automatically PURE. */
5963 if (gfc_match ("impure% ") == MATCH_YES
)
5965 if (!gfc_notify_std (GFC_STD_F2008
, "IMPURE procedure at %C"))
5969 found_prefix
= true;
5972 while (found_prefix
);
5974 /* IMPURE and PURE must not both appear, of course. */
5975 if (seen_impure
&& current_attr
.pure
)
5977 gfc_error ("PURE and IMPURE must not appear both at %C");
5981 /* If IMPURE it not seen but the procedure is ELEMENTAL, mark it as PURE. */
5982 if (!seen_impure
&& current_attr
.elemental
&& !current_attr
.pure
)
5984 if (!gfc_add_pure (¤t_attr
, NULL
))
5988 /* At this point, the next item is not a prefix. */
5989 gcc_assert (gfc_matching_prefix
);
5991 gfc_matching_prefix
= false;
5995 gcc_assert (gfc_matching_prefix
);
5996 gfc_matching_prefix
= false;
6001 /* Copy attributes matched by gfc_match_prefix() to attributes on a symbol. */
6004 copy_prefix (symbol_attribute
*dest
, locus
*where
)
6006 if (dest
->module_procedure
)
6008 if (current_attr
.elemental
)
6009 dest
->elemental
= 1;
6011 if (current_attr
.pure
)
6014 if (current_attr
.recursive
)
6015 dest
->recursive
= 1;
6017 /* Module procedures are unusual in that the 'dest' is copied from
6018 the interface declaration. However, this is an oportunity to
6019 check that the submodule declaration is compliant with the
6021 if (dest
->elemental
&& !current_attr
.elemental
)
6023 gfc_error ("ELEMENTAL prefix in MODULE PROCEDURE interface is "
6024 "missing at %L", where
);
6028 if (dest
->pure
&& !current_attr
.pure
)
6030 gfc_error ("PURE prefix in MODULE PROCEDURE interface is "
6031 "missing at %L", where
);
6035 if (dest
->recursive
&& !current_attr
.recursive
)
6037 gfc_error ("RECURSIVE prefix in MODULE PROCEDURE interface is "
6038 "missing at %L", where
);
6045 if (current_attr
.elemental
&& !gfc_add_elemental (dest
, where
))
6048 if (current_attr
.pure
&& !gfc_add_pure (dest
, where
))
6051 if (current_attr
.recursive
&& !gfc_add_recursive (dest
, where
))
6058 /* Match a formal argument list or, if typeparam is true, a
6059 type_param_name_list. */
6062 gfc_match_formal_arglist (gfc_symbol
*progname
, int st_flag
,
6063 int null_flag
, bool typeparam
)
6065 gfc_formal_arglist
*head
, *tail
, *p
, *q
;
6066 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6069 gfc_formal_arglist
*formal
= NULL
;
6073 /* Keep the interface formal argument list and null it so that the
6074 matching for the new declaration can be done. The numbers and
6075 names of the arguments are checked here. The interface formal
6076 arguments are retained in formal_arglist and the characteristics
6077 are compared in resolve.c(resolve_fl_procedure). See the remark
6078 in get_proc_name about the eventual need to copy the formal_arglist
6079 and populate the formal namespace of the interface symbol. */
6080 if (progname
->attr
.module_procedure
6081 && progname
->attr
.host_assoc
)
6083 formal
= progname
->formal
;
6084 progname
->formal
= NULL
;
6087 if (gfc_match_char ('(') != MATCH_YES
)
6094 if (gfc_match_char (')') == MATCH_YES
)
6099 if (gfc_match_char ('*') == MATCH_YES
)
6102 if (!typeparam
&& !gfc_notify_std (GFC_STD_F95_OBS
,
6103 "Alternate-return argument at %C"))
6109 gfc_error_now ("A parameter name is required at %C");
6113 m
= gfc_match_name (name
);
6117 gfc_error_now ("A parameter name is required at %C");
6121 if (!typeparam
&& gfc_get_symbol (name
, NULL
, &sym
))
6124 && gfc_get_symbol (name
, progname
->f2k_derived
, &sym
))
6128 p
= gfc_get_formal_arglist ();
6140 /* We don't add the VARIABLE flavor because the name could be a
6141 dummy procedure. We don't apply these attributes to formal
6142 arguments of statement functions. */
6143 if (sym
!= NULL
&& !st_flag
6144 && (!gfc_add_dummy(&sym
->attr
, sym
->name
, NULL
)
6145 || !gfc_missing_attr (&sym
->attr
, NULL
)))
6151 /* The name of a program unit can be in a different namespace,
6152 so check for it explicitly. After the statement is accepted,
6153 the name is checked for especially in gfc_get_symbol(). */
6154 if (gfc_new_block
!= NULL
&& sym
!= NULL
&& !typeparam
6155 && strcmp (sym
->name
, gfc_new_block
->name
) == 0)
6157 gfc_error ("Name %qs at %C is the name of the procedure",
6163 if (gfc_match_char (')') == MATCH_YES
)
6166 m
= gfc_match_char (',');
6170 gfc_error_now ("Expected parameter list in type declaration "
6173 gfc_error ("Unexpected junk in formal argument list at %C");
6179 /* Check for duplicate symbols in the formal argument list. */
6182 for (p
= head
; p
->next
; p
= p
->next
)
6187 for (q
= p
->next
; q
; q
= q
->next
)
6188 if (p
->sym
== q
->sym
)
6191 gfc_error_now ("Duplicate name %qs in parameter "
6192 "list at %C", p
->sym
->name
);
6194 gfc_error ("Duplicate symbol %qs in formal argument "
6195 "list at %C", p
->sym
->name
);
6203 if (!gfc_add_explicit_interface (progname
, IFSRC_DECL
, head
, NULL
))
6209 /* gfc_error_now used in following and return with MATCH_YES because
6210 doing otherwise results in a cascade of extraneous errors and in
6211 some cases an ICE in symbol.c(gfc_release_symbol). */
6212 if (progname
->attr
.module_procedure
&& progname
->attr
.host_assoc
)
6214 bool arg_count_mismatch
= false;
6216 if (!formal
&& head
)
6217 arg_count_mismatch
= true;
6219 /* Abbreviated module procedure declaration is not meant to have any
6220 formal arguments! */
6221 if (!progname
->abr_modproc_decl
&& formal
&& !head
)
6222 arg_count_mismatch
= true;
6224 for (p
= formal
, q
= head
; p
&& q
; p
= p
->next
, q
= q
->next
)
6226 if ((p
->next
!= NULL
&& q
->next
== NULL
)
6227 || (p
->next
== NULL
&& q
->next
!= NULL
))
6228 arg_count_mismatch
= true;
6229 else if ((p
->sym
== NULL
&& q
->sym
== NULL
)
6230 || strcmp (p
->sym
->name
, q
->sym
->name
) == 0)
6233 gfc_error_now ("Mismatch in MODULE PROCEDURE formal "
6234 "argument names (%s/%s) at %C",
6235 p
->sym
->name
, q
->sym
->name
);
6238 if (arg_count_mismatch
)
6239 gfc_error_now ("Mismatch in number of MODULE PROCEDURE "
6240 "formal arguments at %C");
6246 gfc_free_formal_arglist (head
);
6251 /* Match a RESULT specification following a function declaration or
6252 ENTRY statement. Also matches the end-of-statement. */
6255 match_result (gfc_symbol
*function
, gfc_symbol
**result
)
6257 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6261 if (gfc_match (" result (") != MATCH_YES
)
6264 m
= gfc_match_name (name
);
6268 /* Get the right paren, and that's it because there could be the
6269 bind(c) attribute after the result clause. */
6270 if (gfc_match_char (')') != MATCH_YES
)
6272 /* TODO: should report the missing right paren here. */
6276 if (strcmp (function
->name
, name
) == 0)
6278 gfc_error ("RESULT variable at %C must be different than function name");
6282 if (gfc_get_symbol (name
, NULL
, &r
))
6285 if (!gfc_add_result (&r
->attr
, r
->name
, NULL
))
6294 /* Match a function suffix, which could be a combination of a result
6295 clause and BIND(C), either one, or neither. The draft does not
6296 require them to come in a specific order. */
6299 gfc_match_suffix (gfc_symbol
*sym
, gfc_symbol
**result
)
6301 match is_bind_c
; /* Found bind(c). */
6302 match is_result
; /* Found result clause. */
6303 match found_match
; /* Status of whether we've found a good match. */
6304 char peek_char
; /* Character we're going to peek at. */
6305 bool allow_binding_name
;
6307 /* Initialize to having found nothing. */
6308 found_match
= MATCH_NO
;
6309 is_bind_c
= MATCH_NO
;
6310 is_result
= MATCH_NO
;
6312 /* Get the next char to narrow between result and bind(c). */
6313 gfc_gobble_whitespace ();
6314 peek_char
= gfc_peek_ascii_char ();
6316 /* C binding names are not allowed for internal procedures. */
6317 if (gfc_current_state () == COMP_CONTAINS
6318 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
6319 allow_binding_name
= false;
6321 allow_binding_name
= true;
6326 /* Look for result clause. */
6327 is_result
= match_result (sym
, result
);
6328 if (is_result
== MATCH_YES
)
6330 /* Now see if there is a bind(c) after it. */
6331 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
6332 /* We've found the result clause and possibly bind(c). */
6333 found_match
= MATCH_YES
;
6336 /* This should only be MATCH_ERROR. */
6337 found_match
= is_result
;
6340 /* Look for bind(c) first. */
6341 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
6342 if (is_bind_c
== MATCH_YES
)
6344 /* Now see if a result clause followed it. */
6345 is_result
= match_result (sym
, result
);
6346 found_match
= MATCH_YES
;
6350 /* Should only be a MATCH_ERROR if we get here after seeing 'b'. */
6351 found_match
= MATCH_ERROR
;
6355 gfc_error ("Unexpected junk after function declaration at %C");
6356 found_match
= MATCH_ERROR
;
6360 if (is_bind_c
== MATCH_YES
)
6362 /* Fortran 2008 draft allows BIND(C) for internal procedures. */
6363 if (gfc_current_state () == COMP_CONTAINS
6364 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
6365 && !gfc_notify_std (GFC_STD_F2008
, "BIND(C) attribute "
6366 "at %L may not be specified for an internal "
6367 "procedure", &gfc_current_locus
))
6370 if (!gfc_add_is_bind_c (&(sym
->attr
), sym
->name
, &gfc_current_locus
, 1))
6378 /* Procedure pointer return value without RESULT statement:
6379 Add "hidden" result variable named "ppr@". */
6382 add_hidden_procptr_result (gfc_symbol
*sym
)
6386 if (gfc_notification_std (GFC_STD_F2003
) == ERROR
)
6389 /* First usage case: PROCEDURE and EXTERNAL statements. */
6390 case1
= gfc_current_state () == COMP_FUNCTION
&& gfc_current_block ()
6391 && strcmp (gfc_current_block ()->name
, sym
->name
) == 0
6392 && sym
->attr
.external
;
6393 /* Second usage case: INTERFACE statements. */
6394 case2
= gfc_current_state () == COMP_INTERFACE
&& gfc_state_stack
->previous
6395 && gfc_state_stack
->previous
->state
== COMP_FUNCTION
6396 && strcmp (gfc_state_stack
->previous
->sym
->name
, sym
->name
) == 0;
6402 gfc_get_sym_tree ("ppr@", gfc_current_ns
, &stree
, false);
6406 gfc_get_sym_tree ("ppr@", gfc_current_ns
->parent
, &stree
, false);
6407 st2
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "ppr@");
6408 st2
->n
.sym
= stree
->n
.sym
;
6409 stree
->n
.sym
->refs
++;
6411 sym
->result
= stree
->n
.sym
;
6413 sym
->result
->attr
.proc_pointer
= sym
->attr
.proc_pointer
;
6414 sym
->result
->attr
.pointer
= sym
->attr
.pointer
;
6415 sym
->result
->attr
.external
= sym
->attr
.external
;
6416 sym
->result
->attr
.referenced
= sym
->attr
.referenced
;
6417 sym
->result
->ts
= sym
->ts
;
6418 sym
->attr
.proc_pointer
= 0;
6419 sym
->attr
.pointer
= 0;
6420 sym
->attr
.external
= 0;
6421 if (sym
->result
->attr
.external
&& sym
->result
->attr
.pointer
)
6423 sym
->result
->attr
.pointer
= 0;
6424 sym
->result
->attr
.proc_pointer
= 1;
6427 return gfc_add_result (&sym
->result
->attr
, sym
->result
->name
, NULL
);
6429 /* POINTER after PROCEDURE/EXTERNAL/INTERFACE statement. */
6430 else if (sym
->attr
.function
&& !sym
->attr
.external
&& sym
->attr
.pointer
6431 && sym
->result
&& sym
->result
!= sym
&& sym
->result
->attr
.external
6432 && sym
== gfc_current_ns
->proc_name
6433 && sym
== sym
->result
->ns
->proc_name
6434 && strcmp ("ppr@", sym
->result
->name
) == 0)
6436 sym
->result
->attr
.proc_pointer
= 1;
6437 sym
->attr
.pointer
= 0;
6445 /* Match the interface for a PROCEDURE declaration,
6446 including brackets (R1212). */
6449 match_procedure_interface (gfc_symbol
**proc_if
)
6453 locus old_loc
, entry_loc
;
6454 gfc_namespace
*old_ns
= gfc_current_ns
;
6455 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6457 old_loc
= entry_loc
= gfc_current_locus
;
6458 gfc_clear_ts (¤t_ts
);
6460 if (gfc_match (" (") != MATCH_YES
)
6462 gfc_current_locus
= entry_loc
;
6466 /* Get the type spec. for the procedure interface. */
6467 old_loc
= gfc_current_locus
;
6468 m
= gfc_match_decl_type_spec (¤t_ts
, 0);
6469 gfc_gobble_whitespace ();
6470 if (m
== MATCH_YES
|| (m
== MATCH_NO
&& gfc_peek_ascii_char () == ')'))
6473 if (m
== MATCH_ERROR
)
6476 /* Procedure interface is itself a procedure. */
6477 gfc_current_locus
= old_loc
;
6478 m
= gfc_match_name (name
);
6480 /* First look to see if it is already accessible in the current
6481 namespace because it is use associated or contained. */
6483 if (gfc_find_sym_tree (name
, NULL
, 0, &st
))
6486 /* If it is still not found, then try the parent namespace, if it
6487 exists and create the symbol there if it is still not found. */
6488 if (gfc_current_ns
->parent
)
6489 gfc_current_ns
= gfc_current_ns
->parent
;
6490 if (st
== NULL
&& gfc_get_ha_sym_tree (name
, &st
))
6493 gfc_current_ns
= old_ns
;
6494 *proc_if
= st
->n
.sym
;
6499 /* Resolve interface if possible. That way, attr.procedure is only set
6500 if it is declared by a later procedure-declaration-stmt, which is
6501 invalid per F08:C1216 (cf. resolve_procedure_interface). */
6502 while ((*proc_if
)->ts
.interface
6503 && *proc_if
!= (*proc_if
)->ts
.interface
)
6504 *proc_if
= (*proc_if
)->ts
.interface
;
6506 if ((*proc_if
)->attr
.flavor
== FL_UNKNOWN
6507 && (*proc_if
)->ts
.type
== BT_UNKNOWN
6508 && !gfc_add_flavor (&(*proc_if
)->attr
, FL_PROCEDURE
,
6509 (*proc_if
)->name
, NULL
))
6514 if (gfc_match (" )") != MATCH_YES
)
6516 gfc_current_locus
= entry_loc
;
6524 /* Match a PROCEDURE declaration (R1211). */
6527 match_procedure_decl (void)
6530 gfc_symbol
*sym
, *proc_if
= NULL
;
6532 gfc_expr
*initializer
= NULL
;
6534 /* Parse interface (with brackets). */
6535 m
= match_procedure_interface (&proc_if
);
6539 /* Parse attributes (with colons). */
6540 m
= match_attr_spec();
6541 if (m
== MATCH_ERROR
)
6544 if (proc_if
&& proc_if
->attr
.is_bind_c
&& !current_attr
.is_bind_c
)
6546 current_attr
.is_bind_c
= 1;
6547 has_name_equals
= 0;
6548 curr_binding_label
= NULL
;
6551 /* Get procedure symbols. */
6554 m
= gfc_match_symbol (&sym
, 0);
6557 else if (m
== MATCH_ERROR
)
6560 /* Add current_attr to the symbol attributes. */
6561 if (!gfc_copy_attr (&sym
->attr
, ¤t_attr
, NULL
))
6564 if (sym
->attr
.is_bind_c
)
6566 /* Check for C1218. */
6567 if (!proc_if
|| !proc_if
->attr
.is_bind_c
)
6569 gfc_error ("BIND(C) attribute at %C requires "
6570 "an interface with BIND(C)");
6573 /* Check for C1217. */
6574 if (has_name_equals
&& sym
->attr
.pointer
)
6576 gfc_error ("BIND(C) procedure with NAME may not have "
6577 "POINTER attribute at %C");
6580 if (has_name_equals
&& sym
->attr
.dummy
)
6582 gfc_error ("Dummy procedure at %C may not have "
6583 "BIND(C) attribute with NAME");
6586 /* Set binding label for BIND(C). */
6587 if (!set_binding_label (&sym
->binding_label
, sym
->name
, num
))
6591 if (!gfc_add_external (&sym
->attr
, NULL
))
6594 if (add_hidden_procptr_result (sym
))
6597 if (!gfc_add_proc (&sym
->attr
, sym
->name
, NULL
))
6600 /* Set interface. */
6601 if (proc_if
!= NULL
)
6603 if (sym
->ts
.type
!= BT_UNKNOWN
)
6605 gfc_error ("Procedure %qs at %L already has basic type of %s",
6606 sym
->name
, &gfc_current_locus
,
6607 gfc_basic_typename (sym
->ts
.type
));
6610 sym
->ts
.interface
= proc_if
;
6611 sym
->attr
.untyped
= 1;
6612 sym
->attr
.if_source
= IFSRC_IFBODY
;
6614 else if (current_ts
.type
!= BT_UNKNOWN
)
6616 if (!gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
6618 sym
->ts
.interface
= gfc_new_symbol ("", gfc_current_ns
);
6619 sym
->ts
.interface
->ts
= current_ts
;
6620 sym
->ts
.interface
->attr
.flavor
= FL_PROCEDURE
;
6621 sym
->ts
.interface
->attr
.function
= 1;
6622 sym
->attr
.function
= 1;
6623 sym
->attr
.if_source
= IFSRC_UNKNOWN
;
6626 if (gfc_match (" =>") == MATCH_YES
)
6628 if (!current_attr
.pointer
)
6630 gfc_error ("Initialization at %C isn't for a pointer variable");
6635 m
= match_pointer_init (&initializer
, 1);
6639 if (!add_init_expr_to_sym (sym
->name
, &initializer
, &gfc_current_locus
))
6644 if (gfc_match_eos () == MATCH_YES
)
6646 if (gfc_match_char (',') != MATCH_YES
)
6651 gfc_error ("Syntax error in PROCEDURE statement at %C");
6655 /* Free stuff up and return. */
6656 gfc_free_expr (initializer
);
6662 match_binding_attributes (gfc_typebound_proc
* ba
, bool generic
, bool ppc
);
6665 /* Match a procedure pointer component declaration (R445). */
6668 match_ppc_decl (void)
6671 gfc_symbol
*proc_if
= NULL
;
6675 gfc_expr
*initializer
= NULL
;
6676 gfc_typebound_proc
* tb
;
6677 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6679 /* Parse interface (with brackets). */
6680 m
= match_procedure_interface (&proc_if
);
6684 /* Parse attributes. */
6685 tb
= XCNEW (gfc_typebound_proc
);
6686 tb
->where
= gfc_current_locus
;
6687 m
= match_binding_attributes (tb
, false, true);
6688 if (m
== MATCH_ERROR
)
6691 gfc_clear_attr (¤t_attr
);
6692 current_attr
.procedure
= 1;
6693 current_attr
.proc_pointer
= 1;
6694 current_attr
.access
= tb
->access
;
6695 current_attr
.flavor
= FL_PROCEDURE
;
6697 /* Match the colons (required). */
6698 if (gfc_match (" ::") != MATCH_YES
)
6700 gfc_error ("Expected %<::%> after binding-attributes at %C");
6704 /* Check for C450. */
6705 if (!tb
->nopass
&& proc_if
== NULL
)
6707 gfc_error("NOPASS or explicit interface required at %C");
6711 if (!gfc_notify_std (GFC_STD_F2003
, "Procedure pointer component at %C"))
6714 /* Match PPC names. */
6718 m
= gfc_match_name (name
);
6721 else if (m
== MATCH_ERROR
)
6724 if (!gfc_add_component (gfc_current_block(), name
, &c
))
6727 /* Add current_attr to the symbol attributes. */
6728 if (!gfc_copy_attr (&c
->attr
, ¤t_attr
, NULL
))
6731 if (!gfc_add_external (&c
->attr
, NULL
))
6734 if (!gfc_add_proc (&c
->attr
, name
, NULL
))
6741 c
->tb
= XCNEW (gfc_typebound_proc
);
6742 c
->tb
->where
= gfc_current_locus
;
6746 /* Set interface. */
6747 if (proc_if
!= NULL
)
6749 c
->ts
.interface
= proc_if
;
6750 c
->attr
.untyped
= 1;
6751 c
->attr
.if_source
= IFSRC_IFBODY
;
6753 else if (ts
.type
!= BT_UNKNOWN
)
6756 c
->ts
.interface
= gfc_new_symbol ("", gfc_current_ns
);
6757 c
->ts
.interface
->result
= c
->ts
.interface
;
6758 c
->ts
.interface
->ts
= ts
;
6759 c
->ts
.interface
->attr
.flavor
= FL_PROCEDURE
;
6760 c
->ts
.interface
->attr
.function
= 1;
6761 c
->attr
.function
= 1;
6762 c
->attr
.if_source
= IFSRC_UNKNOWN
;
6765 if (gfc_match (" =>") == MATCH_YES
)
6767 m
= match_pointer_init (&initializer
, 1);
6770 gfc_free_expr (initializer
);
6773 c
->initializer
= initializer
;
6776 if (gfc_match_eos () == MATCH_YES
)
6778 if (gfc_match_char (',') != MATCH_YES
)
6783 gfc_error ("Syntax error in procedure pointer component at %C");
6788 /* Match a PROCEDURE declaration inside an interface (R1206). */
6791 match_procedure_in_interface (void)
6795 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6798 if (current_interface
.type
== INTERFACE_NAMELESS
6799 || current_interface
.type
== INTERFACE_ABSTRACT
)
6801 gfc_error ("PROCEDURE at %C must be in a generic interface");
6805 /* Check if the F2008 optional double colon appears. */
6806 gfc_gobble_whitespace ();
6807 old_locus
= gfc_current_locus
;
6808 if (gfc_match ("::") == MATCH_YES
)
6810 if (!gfc_notify_std (GFC_STD_F2008
, "double colon in "
6811 "MODULE PROCEDURE statement at %L", &old_locus
))
6815 gfc_current_locus
= old_locus
;
6819 m
= gfc_match_name (name
);
6822 else if (m
== MATCH_ERROR
)
6824 if (gfc_get_symbol (name
, gfc_current_ns
->parent
, &sym
))
6827 if (!gfc_add_interface (sym
))
6830 if (gfc_match_eos () == MATCH_YES
)
6832 if (gfc_match_char (',') != MATCH_YES
)
6839 gfc_error ("Syntax error in PROCEDURE statement at %C");
6844 /* General matcher for PROCEDURE declarations. */
6846 static match
match_procedure_in_type (void);
6849 gfc_match_procedure (void)
6853 switch (gfc_current_state ())
6858 case COMP_SUBMODULE
:
6859 case COMP_SUBROUTINE
:
6862 m
= match_procedure_decl ();
6864 case COMP_INTERFACE
:
6865 m
= match_procedure_in_interface ();
6868 m
= match_ppc_decl ();
6870 case COMP_DERIVED_CONTAINS
:
6871 m
= match_procedure_in_type ();
6880 if (!gfc_notify_std (GFC_STD_F2003
, "PROCEDURE statement at %C"))
6887 /* Warn if a matched procedure has the same name as an intrinsic; this is
6888 simply a wrapper around gfc_warn_intrinsic_shadow that interprets the current
6889 parser-state-stack to find out whether we're in a module. */
6892 do_warn_intrinsic_shadow (const gfc_symbol
* sym
, bool func
)
6896 in_module
= (gfc_state_stack
->previous
6897 && (gfc_state_stack
->previous
->state
== COMP_MODULE
6898 || gfc_state_stack
->previous
->state
== COMP_SUBMODULE
));
6900 gfc_warn_intrinsic_shadow (sym
, in_module
, func
);
6904 /* Match a function declaration. */
6907 gfc_match_function_decl (void)
6909 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6910 gfc_symbol
*sym
, *result
;
6914 match found_match
; /* Status returned by match func. */
6916 if (gfc_current_state () != COMP_NONE
6917 && gfc_current_state () != COMP_INTERFACE
6918 && gfc_current_state () != COMP_CONTAINS
)
6921 gfc_clear_ts (¤t_ts
);
6923 old_loc
= gfc_current_locus
;
6925 m
= gfc_match_prefix (¤t_ts
);
6928 gfc_current_locus
= old_loc
;
6932 if (gfc_match ("function% %n", name
) != MATCH_YES
)
6934 gfc_current_locus
= old_loc
;
6938 if (get_proc_name (name
, &sym
, false))
6941 if (add_hidden_procptr_result (sym
))
6944 if (current_attr
.module_procedure
)
6945 sym
->attr
.module_procedure
= 1;
6947 gfc_new_block
= sym
;
6949 m
= gfc_match_formal_arglist (sym
, 0, 0);
6952 gfc_error ("Expected formal argument list in function "
6953 "definition at %C");
6957 else if (m
== MATCH_ERROR
)
6962 /* According to the draft, the bind(c) and result clause can
6963 come in either order after the formal_arg_list (i.e., either
6964 can be first, both can exist together or by themselves or neither
6965 one). Therefore, the match_result can't match the end of the
6966 string, and check for the bind(c) or result clause in either order. */
6967 found_match
= gfc_match_eos ();
6969 /* Make sure that it isn't already declared as BIND(C). If it is, it
6970 must have been marked BIND(C) with a BIND(C) attribute and that is
6971 not allowed for procedures. */
6972 if (sym
->attr
.is_bind_c
== 1)
6974 sym
->attr
.is_bind_c
= 0;
6975 if (sym
->old_symbol
!= NULL
)
6976 gfc_error_now ("BIND(C) attribute at %L can only be used for "
6977 "variables or common blocks",
6978 &(sym
->old_symbol
->declared_at
));
6980 gfc_error_now ("BIND(C) attribute at %L can only be used for "
6981 "variables or common blocks", &gfc_current_locus
);
6984 if (found_match
!= MATCH_YES
)
6986 /* If we haven't found the end-of-statement, look for a suffix. */
6987 suffix_match
= gfc_match_suffix (sym
, &result
);
6988 if (suffix_match
== MATCH_YES
)
6989 /* Need to get the eos now. */
6990 found_match
= gfc_match_eos ();
6992 found_match
= suffix_match
;
6995 if(found_match
!= MATCH_YES
)
6999 /* Make changes to the symbol. */
7002 if (!gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
7005 if (!gfc_missing_attr (&sym
->attr
, NULL
))
7008 if (!copy_prefix (&sym
->attr
, &sym
->declared_at
))
7010 if(!sym
->attr
.module_procedure
)
7016 /* Delay matching the function characteristics until after the
7017 specification block by signalling kind=-1. */
7018 sym
->declared_at
= old_loc
;
7019 if (current_ts
.type
!= BT_UNKNOWN
)
7020 current_ts
.kind
= -1;
7022 current_ts
.kind
= 0;
7026 if (current_ts
.type
!= BT_UNKNOWN
7027 && !gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
7033 if (current_ts
.type
!= BT_UNKNOWN
7034 && !gfc_add_type (result
, ¤t_ts
, &gfc_current_locus
))
7036 sym
->result
= result
;
7039 /* Warn if this procedure has the same name as an intrinsic. */
7040 do_warn_intrinsic_shadow (sym
, true);
7046 gfc_current_locus
= old_loc
;
7051 /* This is mostly a copy of parse.c(add_global_procedure) but modified to
7052 pass the name of the entry, rather than the gfc_current_block name, and
7053 to return false upon finding an existing global entry. */
7056 add_global_entry (const char *name
, const char *binding_label
, bool sub
,
7060 enum gfc_symbol_type type
;
7062 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
7064 /* Only in Fortran 2003: For procedures with a binding label also the Fortran
7065 name is a global identifier. */
7066 if (!binding_label
|| gfc_notification_std (GFC_STD_F2008
))
7068 s
= gfc_get_gsymbol (name
);
7070 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= type
))
7072 gfc_global_used (s
, where
);
7081 s
->ns
= gfc_current_ns
;
7085 /* Don't add the symbol multiple times. */
7087 && (!gfc_notification_std (GFC_STD_F2008
)
7088 || strcmp (name
, binding_label
) != 0))
7090 s
= gfc_get_gsymbol (binding_label
);
7092 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= type
))
7094 gfc_global_used (s
, where
);
7101 s
->binding_label
= binding_label
;
7104 s
->ns
= gfc_current_ns
;
7112 /* Match an ENTRY statement. */
7115 gfc_match_entry (void)
7120 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7121 gfc_compile_state state
;
7125 bool module_procedure
;
7129 m
= gfc_match_name (name
);
7133 if (!gfc_notify_std (GFC_STD_F2008_OBS
, "ENTRY statement at %C"))
7136 state
= gfc_current_state ();
7137 if (state
!= COMP_SUBROUTINE
&& state
!= COMP_FUNCTION
)
7142 gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
7145 gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
7147 case COMP_SUBMODULE
:
7148 gfc_error ("ENTRY statement at %C cannot appear within a SUBMODULE");
7150 case COMP_BLOCK_DATA
:
7151 gfc_error ("ENTRY statement at %C cannot appear within "
7154 case COMP_INTERFACE
:
7155 gfc_error ("ENTRY statement at %C cannot appear within "
7158 case COMP_STRUCTURE
:
7159 gfc_error ("ENTRY statement at %C cannot appear within "
7160 "a STRUCTURE block");
7163 gfc_error ("ENTRY statement at %C cannot appear within "
7164 "a DERIVED TYPE block");
7167 gfc_error ("ENTRY statement at %C cannot appear within "
7168 "an IF-THEN block");
7171 case COMP_DO_CONCURRENT
:
7172 gfc_error ("ENTRY statement at %C cannot appear within "
7176 gfc_error ("ENTRY statement at %C cannot appear within "
7180 gfc_error ("ENTRY statement at %C cannot appear within "
7184 gfc_error ("ENTRY statement at %C cannot appear within "
7188 gfc_error ("ENTRY statement at %C cannot appear within "
7189 "a contained subprogram");
7192 gfc_error ("Unexpected ENTRY statement at %C");
7197 if ((state
== COMP_SUBROUTINE
|| state
== COMP_FUNCTION
)
7198 && gfc_state_stack
->previous
->state
== COMP_INTERFACE
)
7200 gfc_error ("ENTRY statement at %C cannot appear within an INTERFACE");
7204 module_procedure
= gfc_current_ns
->parent
!= NULL
7205 && gfc_current_ns
->parent
->proc_name
7206 && gfc_current_ns
->parent
->proc_name
->attr
.flavor
7209 if (gfc_current_ns
->parent
!= NULL
7210 && gfc_current_ns
->parent
->proc_name
7211 && !module_procedure
)
7213 gfc_error("ENTRY statement at %C cannot appear in a "
7214 "contained procedure");
7218 /* Module function entries need special care in get_proc_name
7219 because previous references within the function will have
7220 created symbols attached to the current namespace. */
7221 if (get_proc_name (name
, &entry
,
7222 gfc_current_ns
->parent
!= NULL
7223 && module_procedure
))
7226 proc
= gfc_current_block ();
7228 /* Make sure that it isn't already declared as BIND(C). If it is, it
7229 must have been marked BIND(C) with a BIND(C) attribute and that is
7230 not allowed for procedures. */
7231 if (entry
->attr
.is_bind_c
== 1)
7233 entry
->attr
.is_bind_c
= 0;
7234 if (entry
->old_symbol
!= NULL
)
7235 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7236 "variables or common blocks",
7237 &(entry
->old_symbol
->declared_at
));
7239 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7240 "variables or common blocks", &gfc_current_locus
);
7243 /* Check what next non-whitespace character is so we can tell if there
7244 is the required parens if we have a BIND(C). */
7245 old_loc
= gfc_current_locus
;
7246 gfc_gobble_whitespace ();
7247 peek_char
= gfc_peek_ascii_char ();
7249 if (state
== COMP_SUBROUTINE
)
7251 m
= gfc_match_formal_arglist (entry
, 0, 1);
7255 /* Call gfc_match_bind_c with allow_binding_name = true as ENTRY can
7256 never be an internal procedure. */
7257 is_bind_c
= gfc_match_bind_c (entry
, true);
7258 if (is_bind_c
== MATCH_ERROR
)
7260 if (is_bind_c
== MATCH_YES
)
7262 if (peek_char
!= '(')
7264 gfc_error ("Missing required parentheses before BIND(C) at %C");
7267 if (!gfc_add_is_bind_c (&(entry
->attr
), entry
->name
,
7268 &(entry
->declared_at
), 1))
7272 if (!gfc_current_ns
->parent
7273 && !add_global_entry (name
, entry
->binding_label
, true,
7277 /* An entry in a subroutine. */
7278 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
7279 || !gfc_add_subroutine (&entry
->attr
, entry
->name
, NULL
))
7284 /* An entry in a function.
7285 We need to take special care because writing
7290 ENTRY f() RESULT (r)
7292 ENTRY f RESULT (r). */
7293 if (gfc_match_eos () == MATCH_YES
)
7295 gfc_current_locus
= old_loc
;
7296 /* Match the empty argument list, and add the interface to
7298 m
= gfc_match_formal_arglist (entry
, 0, 1);
7301 m
= gfc_match_formal_arglist (entry
, 0, 0);
7308 if (gfc_match_eos () == MATCH_YES
)
7310 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
7311 || !gfc_add_function (&entry
->attr
, entry
->name
, NULL
))
7314 entry
->result
= entry
;
7318 m
= gfc_match_suffix (entry
, &result
);
7320 gfc_syntax_error (ST_ENTRY
);
7326 if (!gfc_add_result (&result
->attr
, result
->name
, NULL
)
7327 || !gfc_add_entry (&entry
->attr
, result
->name
, NULL
)
7328 || !gfc_add_function (&entry
->attr
, result
->name
, NULL
))
7330 entry
->result
= result
;
7334 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
7335 || !gfc_add_function (&entry
->attr
, entry
->name
, NULL
))
7337 entry
->result
= entry
;
7341 if (!gfc_current_ns
->parent
7342 && !add_global_entry (name
, entry
->binding_label
, false,
7347 if (gfc_match_eos () != MATCH_YES
)
7349 gfc_syntax_error (ST_ENTRY
);
7353 entry
->attr
.recursive
= proc
->attr
.recursive
;
7354 entry
->attr
.elemental
= proc
->attr
.elemental
;
7355 entry
->attr
.pure
= proc
->attr
.pure
;
7357 el
= gfc_get_entry_list ();
7359 el
->next
= gfc_current_ns
->entries
;
7360 gfc_current_ns
->entries
= el
;
7362 el
->id
= el
->next
->id
+ 1;
7366 new_st
.op
= EXEC_ENTRY
;
7367 new_st
.ext
.entry
= el
;
7373 /* Match a subroutine statement, including optional prefixes. */
7376 gfc_match_subroutine (void)
7378 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7383 bool allow_binding_name
;
7385 if (gfc_current_state () != COMP_NONE
7386 && gfc_current_state () != COMP_INTERFACE
7387 && gfc_current_state () != COMP_CONTAINS
)
7390 m
= gfc_match_prefix (NULL
);
7394 m
= gfc_match ("subroutine% %n", name
);
7398 if (get_proc_name (name
, &sym
, false))
7401 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
7402 the symbol existed before. */
7403 sym
->declared_at
= gfc_current_locus
;
7405 if (current_attr
.module_procedure
)
7406 sym
->attr
.module_procedure
= 1;
7408 if (add_hidden_procptr_result (sym
))
7411 gfc_new_block
= sym
;
7413 /* Check what next non-whitespace character is so we can tell if there
7414 is the required parens if we have a BIND(C). */
7415 gfc_gobble_whitespace ();
7416 peek_char
= gfc_peek_ascii_char ();
7418 if (!gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
))
7421 if (gfc_match_formal_arglist (sym
, 0, 1) != MATCH_YES
)
7424 /* Make sure that it isn't already declared as BIND(C). If it is, it
7425 must have been marked BIND(C) with a BIND(C) attribute and that is
7426 not allowed for procedures. */
7427 if (sym
->attr
.is_bind_c
== 1)
7429 sym
->attr
.is_bind_c
= 0;
7430 if (sym
->old_symbol
!= NULL
)
7431 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7432 "variables or common blocks",
7433 &(sym
->old_symbol
->declared_at
));
7435 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7436 "variables or common blocks", &gfc_current_locus
);
7439 /* C binding names are not allowed for internal procedures. */
7440 if (gfc_current_state () == COMP_CONTAINS
7441 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
7442 allow_binding_name
= false;
7444 allow_binding_name
= true;
7446 /* Here, we are just checking if it has the bind(c) attribute, and if
7447 so, then we need to make sure it's all correct. If it doesn't,
7448 we still need to continue matching the rest of the subroutine line. */
7449 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
7450 if (is_bind_c
== MATCH_ERROR
)
7452 /* There was an attempt at the bind(c), but it was wrong. An
7453 error message should have been printed w/in the gfc_match_bind_c
7454 so here we'll just return the MATCH_ERROR. */
7458 if (is_bind_c
== MATCH_YES
)
7460 /* The following is allowed in the Fortran 2008 draft. */
7461 if (gfc_current_state () == COMP_CONTAINS
7462 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
7463 && !gfc_notify_std (GFC_STD_F2008
, "BIND(C) attribute "
7464 "at %L may not be specified for an internal "
7465 "procedure", &gfc_current_locus
))
7468 if (peek_char
!= '(')
7470 gfc_error ("Missing required parentheses before BIND(C) at %C");
7473 if (!gfc_add_is_bind_c (&(sym
->attr
), sym
->name
,
7474 &(sym
->declared_at
), 1))
7478 if (gfc_match_eos () != MATCH_YES
)
7480 gfc_syntax_error (ST_SUBROUTINE
);
7484 if (!copy_prefix (&sym
->attr
, &sym
->declared_at
))
7486 if(!sym
->attr
.module_procedure
)
7492 /* Warn if it has the same name as an intrinsic. */
7493 do_warn_intrinsic_shadow (sym
, false);
7499 /* Check that the NAME identifier in a BIND attribute or statement
7500 is conform to C identifier rules. */
7503 check_bind_name_identifier (char **name
)
7505 char *n
= *name
, *p
;
7507 /* Remove leading spaces. */
7511 /* On an empty string, free memory and set name to NULL. */
7519 /* Remove trailing spaces. */
7520 p
= n
+ strlen(n
) - 1;
7524 /* Insert the identifier into the symbol table. */
7529 /* Now check that identifier is valid under C rules. */
7532 gfc_error ("Invalid C identifier in NAME= specifier at %C");
7537 if (!(ISALNUM (*p
) || *p
== '_' || *p
== '$'))
7539 gfc_error ("Invalid C identifier in NAME= specifier at %C");
7547 /* Match a BIND(C) specifier, with the optional 'name=' specifier if
7548 given, and set the binding label in either the given symbol (if not
7549 NULL), or in the current_ts. The symbol may be NULL because we may
7550 encounter the BIND(C) before the declaration itself. Return
7551 MATCH_NO if what we're looking at isn't a BIND(C) specifier,
7552 MATCH_ERROR if it is a BIND(C) clause but an error was encountered,
7553 or MATCH_YES if the specifier was correct and the binding label and
7554 bind(c) fields were set correctly for the given symbol or the
7555 current_ts. If allow_binding_name is false, no binding name may be
7559 gfc_match_bind_c (gfc_symbol
*sym
, bool allow_binding_name
)
7561 char *binding_label
= NULL
;
7564 /* Initialize the flag that specifies whether we encountered a NAME=
7565 specifier or not. */
7566 has_name_equals
= 0;
7568 /* This much we have to be able to match, in this order, if
7569 there is a bind(c) label. */
7570 if (gfc_match (" bind ( c ") != MATCH_YES
)
7573 /* Now see if there is a binding label, or if we've reached the
7574 end of the bind(c) attribute without one. */
7575 if (gfc_match_char (',') == MATCH_YES
)
7577 if (gfc_match (" name = ") != MATCH_YES
)
7579 gfc_error ("Syntax error in NAME= specifier for binding label "
7581 /* should give an error message here */
7585 has_name_equals
= 1;
7587 if (gfc_match_init_expr (&e
) != MATCH_YES
)
7593 if (!gfc_simplify_expr(e
, 0))
7595 gfc_error ("NAME= specifier at %C should be a constant expression");
7600 if (e
->expr_type
!= EXPR_CONSTANT
|| e
->ts
.type
!= BT_CHARACTER
7601 || e
->ts
.kind
!= gfc_default_character_kind
|| e
->rank
!= 0)
7603 gfc_error ("NAME= specifier at %C should be a scalar of "
7604 "default character kind");
7609 // Get a C string from the Fortran string constant
7610 binding_label
= gfc_widechar_to_char (e
->value
.character
.string
,
7611 e
->value
.character
.length
);
7614 // Check that it is valid (old gfc_match_name_C)
7615 if (check_bind_name_identifier (&binding_label
) != MATCH_YES
)
7619 /* Get the required right paren. */
7620 if (gfc_match_char (')') != MATCH_YES
)
7622 gfc_error ("Missing closing paren for binding label at %C");
7626 if (has_name_equals
&& !allow_binding_name
)
7628 gfc_error ("No binding name is allowed in BIND(C) at %C");
7632 if (has_name_equals
&& sym
!= NULL
&& sym
->attr
.dummy
)
7634 gfc_error ("For dummy procedure %s, no binding name is "
7635 "allowed in BIND(C) at %C", sym
->name
);
7640 /* Save the binding label to the symbol. If sym is null, we're
7641 probably matching the typespec attributes of a declaration and
7642 haven't gotten the name yet, and therefore, no symbol yet. */
7646 sym
->binding_label
= binding_label
;
7648 curr_binding_label
= binding_label
;
7650 else if (allow_binding_name
)
7652 /* No binding label, but if symbol isn't null, we
7653 can set the label for it here.
7654 If name="" or allow_binding_name is false, no C binding name is
7656 if (sym
!= NULL
&& sym
->name
!= NULL
&& has_name_equals
== 0)
7657 sym
->binding_label
= IDENTIFIER_POINTER (get_identifier (sym
->name
));
7660 if (has_name_equals
&& gfc_current_state () == COMP_INTERFACE
7661 && current_interface
.type
== INTERFACE_ABSTRACT
)
7663 gfc_error ("NAME not allowed on BIND(C) for ABSTRACT INTERFACE at %C");
7671 /* Return nonzero if we're currently compiling a contained procedure. */
7674 contained_procedure (void)
7676 gfc_state_data
*s
= gfc_state_stack
;
7678 if ((s
->state
== COMP_SUBROUTINE
|| s
->state
== COMP_FUNCTION
)
7679 && s
->previous
!= NULL
&& s
->previous
->state
== COMP_CONTAINS
)
7685 /* Set the kind of each enumerator. The kind is selected such that it is
7686 interoperable with the corresponding C enumeration type, making
7687 sure that -fshort-enums is honored. */
7692 enumerator_history
*current_history
= NULL
;
7696 if (max_enum
== NULL
|| enum_history
== NULL
)
7699 if (!flag_short_enums
)
7705 kind
= gfc_integer_kinds
[i
++].kind
;
7707 while (kind
< gfc_c_int_kind
7708 && gfc_check_integer_range (max_enum
->initializer
->value
.integer
,
7711 current_history
= enum_history
;
7712 while (current_history
!= NULL
)
7714 current_history
->sym
->ts
.kind
= kind
;
7715 current_history
= current_history
->next
;
7720 /* Match any of the various end-block statements. Returns the type of
7721 END to the caller. The END INTERFACE, END IF, END DO, END SELECT
7722 and END BLOCK statements cannot be replaced by a single END statement. */
7725 gfc_match_end (gfc_statement
*st
)
7727 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7728 gfc_compile_state state
;
7730 const char *block_name
;
7734 gfc_namespace
*parent_ns
, *ns
, *prev_ns
;
7735 gfc_namespace
**nsp
;
7736 bool abreviated_modproc_decl
= false;
7737 bool got_matching_end
= false;
7739 old_loc
= gfc_current_locus
;
7740 if (gfc_match ("end") != MATCH_YES
)
7743 state
= gfc_current_state ();
7744 block_name
= gfc_current_block () == NULL
7745 ? NULL
: gfc_current_block ()->name
;
7749 case COMP_ASSOCIATE
:
7751 if (!strncmp (block_name
, "block@", strlen("block@")))
7756 case COMP_DERIVED_CONTAINS
:
7757 state
= gfc_state_stack
->previous
->state
;
7758 block_name
= gfc_state_stack
->previous
->sym
== NULL
7759 ? NULL
: gfc_state_stack
->previous
->sym
->name
;
7760 abreviated_modproc_decl
= gfc_state_stack
->previous
->sym
7761 && gfc_state_stack
->previous
->sym
->abr_modproc_decl
;
7768 if (!abreviated_modproc_decl
)
7769 abreviated_modproc_decl
= gfc_current_block ()
7770 && gfc_current_block ()->abr_modproc_decl
;
7776 *st
= ST_END_PROGRAM
;
7777 target
= " program";
7781 case COMP_SUBROUTINE
:
7782 *st
= ST_END_SUBROUTINE
;
7783 if (!abreviated_modproc_decl
)
7784 target
= " subroutine";
7786 target
= " procedure";
7787 eos_ok
= !contained_procedure ();
7791 *st
= ST_END_FUNCTION
;
7792 if (!abreviated_modproc_decl
)
7793 target
= " function";
7795 target
= " procedure";
7796 eos_ok
= !contained_procedure ();
7799 case COMP_BLOCK_DATA
:
7800 *st
= ST_END_BLOCK_DATA
;
7801 target
= " block data";
7806 *st
= ST_END_MODULE
;
7811 case COMP_SUBMODULE
:
7812 *st
= ST_END_SUBMODULE
;
7813 target
= " submodule";
7817 case COMP_INTERFACE
:
7818 *st
= ST_END_INTERFACE
;
7819 target
= " interface";
7835 case COMP_STRUCTURE
:
7836 *st
= ST_END_STRUCTURE
;
7837 target
= " structure";
7842 case COMP_DERIVED_CONTAINS
:
7848 case COMP_ASSOCIATE
:
7849 *st
= ST_END_ASSOCIATE
;
7850 target
= " associate";
7867 case COMP_DO_CONCURRENT
:
7874 *st
= ST_END_CRITICAL
;
7875 target
= " critical";
7880 case COMP_SELECT_TYPE
:
7881 *st
= ST_END_SELECT
;
7887 *st
= ST_END_FORALL
;
7902 last_initializer
= NULL
;
7904 gfc_free_enum_history ();
7908 gfc_error ("Unexpected END statement at %C");
7912 old_loc
= gfc_current_locus
;
7913 if (gfc_match_eos () == MATCH_YES
)
7915 if (!eos_ok
&& (*st
== ST_END_SUBROUTINE
|| *st
== ST_END_FUNCTION
))
7917 if (!gfc_notify_std (GFC_STD_F2008
, "END statement "
7918 "instead of %s statement at %L",
7919 abreviated_modproc_decl
? "END PROCEDURE"
7920 : gfc_ascii_statement(*st
), &old_loc
))
7925 /* We would have required END [something]. */
7926 gfc_error ("%s statement expected at %L",
7927 gfc_ascii_statement (*st
), &old_loc
);
7934 /* Verify that we've got the sort of end-block that we're expecting. */
7935 if (gfc_match (target
) != MATCH_YES
)
7937 gfc_error ("Expecting %s statement at %L", abreviated_modproc_decl
7938 ? "END PROCEDURE" : gfc_ascii_statement(*st
), &old_loc
);
7942 got_matching_end
= true;
7944 old_loc
= gfc_current_locus
;
7945 /* If we're at the end, make sure a block name wasn't required. */
7946 if (gfc_match_eos () == MATCH_YES
)
7949 if (*st
!= ST_ENDDO
&& *st
!= ST_ENDIF
&& *st
!= ST_END_SELECT
7950 && *st
!= ST_END_FORALL
&& *st
!= ST_END_WHERE
&& *st
!= ST_END_BLOCK
7951 && *st
!= ST_END_ASSOCIATE
&& *st
!= ST_END_CRITICAL
)
7957 gfc_error ("Expected block name of %qs in %s statement at %L",
7958 block_name
, gfc_ascii_statement (*st
), &old_loc
);
7963 /* END INTERFACE has a special handler for its several possible endings. */
7964 if (*st
== ST_END_INTERFACE
)
7965 return gfc_match_end_interface ();
7967 /* We haven't hit the end of statement, so what is left must be an
7969 m
= gfc_match_space ();
7971 m
= gfc_match_name (name
);
7974 gfc_error ("Expected terminating name at %C");
7978 if (block_name
== NULL
)
7981 /* We have to pick out the declared submodule name from the composite
7982 required by F2008:11.2.3 para 2, which ends in the declared name. */
7983 if (state
== COMP_SUBMODULE
)
7984 block_name
= strchr (block_name
, '.') + 1;
7986 if (strcmp (name
, block_name
) != 0 && strcmp (block_name
, "ppr@") != 0)
7988 gfc_error ("Expected label %qs for %s statement at %C", block_name
,
7989 gfc_ascii_statement (*st
));
7992 /* Procedure pointer as function result. */
7993 else if (strcmp (block_name
, "ppr@") == 0
7994 && strcmp (name
, gfc_current_block ()->ns
->proc_name
->name
) != 0)
7996 gfc_error ("Expected label %qs for %s statement at %C",
7997 gfc_current_block ()->ns
->proc_name
->name
,
7998 gfc_ascii_statement (*st
));
8002 if (gfc_match_eos () == MATCH_YES
)
8006 gfc_syntax_error (*st
);
8009 gfc_current_locus
= old_loc
;
8011 /* If we are missing an END BLOCK, we created a half-ready namespace.
8012 Remove it from the parent namespace's sibling list. */
8014 while (state
== COMP_BLOCK
&& !got_matching_end
)
8016 parent_ns
= gfc_current_ns
->parent
;
8018 nsp
= &(gfc_state_stack
->previous
->tail
->ext
.block
.ns
);
8024 if (ns
== gfc_current_ns
)
8026 if (prev_ns
== NULL
)
8029 prev_ns
->sibling
= ns
->sibling
;
8035 gfc_free_namespace (gfc_current_ns
);
8036 gfc_current_ns
= parent_ns
;
8037 gfc_state_stack
= gfc_state_stack
->previous
;
8038 state
= gfc_current_state ();
8046 /***************** Attribute declaration statements ****************/
8048 /* Set the attribute of a single variable. */
8053 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8056 /* Workaround -Wmaybe-uninitialized false positive during
8057 profiledbootstrap by initializing them. */
8058 gfc_symbol
*sym
= NULL
;
8064 m
= gfc_match_name (name
);
8068 if (find_special (name
, &sym
, false))
8071 if (!check_function_name (name
))
8077 var_locus
= gfc_current_locus
;
8079 /* Deal with possible array specification for certain attributes. */
8080 if (current_attr
.dimension
8081 || current_attr
.codimension
8082 || current_attr
.allocatable
8083 || current_attr
.pointer
8084 || current_attr
.target
)
8086 m
= gfc_match_array_spec (&as
, !current_attr
.codimension
,
8087 !current_attr
.dimension
8088 && !current_attr
.pointer
8089 && !current_attr
.target
);
8090 if (m
== MATCH_ERROR
)
8093 if (current_attr
.dimension
&& m
== MATCH_NO
)
8095 gfc_error ("Missing array specification at %L in DIMENSION "
8096 "statement", &var_locus
);
8101 if (current_attr
.dimension
&& sym
->value
)
8103 gfc_error ("Dimensions specified for %s at %L after its "
8104 "initialization", sym
->name
, &var_locus
);
8109 if (current_attr
.codimension
&& m
== MATCH_NO
)
8111 gfc_error ("Missing array specification at %L in CODIMENSION "
8112 "statement", &var_locus
);
8117 if ((current_attr
.allocatable
|| current_attr
.pointer
)
8118 && (m
== MATCH_YES
) && (as
->type
!= AS_DEFERRED
))
8120 gfc_error ("Array specification must be deferred at %L", &var_locus
);
8126 /* Update symbol table. DIMENSION attribute is set in
8127 gfc_set_array_spec(). For CLASS variables, this must be applied
8128 to the first component, or '_data' field. */
8129 if (sym
->ts
.type
== BT_CLASS
&& sym
->ts
.u
.derived
->attr
.is_class
)
8131 if (!gfc_copy_attr (&CLASS_DATA(sym
)->attr
, ¤t_attr
, &var_locus
))
8139 if (current_attr
.dimension
== 0 && current_attr
.codimension
== 0
8140 && !gfc_copy_attr (&sym
->attr
, ¤t_attr
, &var_locus
))
8147 if (sym
->ts
.type
== BT_CLASS
8148 && !gfc_build_class_symbol (&sym
->ts
, &sym
->attr
, &sym
->as
))
8154 if (!gfc_set_array_spec (sym
, as
, &var_locus
))
8160 if (sym
->attr
.cray_pointee
&& sym
->as
!= NULL
)
8162 /* Fix the array spec. */
8163 m
= gfc_mod_pointee_as (sym
->as
);
8164 if (m
== MATCH_ERROR
)
8168 if (!gfc_add_attribute (&sym
->attr
, &var_locus
))
8174 if ((current_attr
.external
|| current_attr
.intrinsic
)
8175 && sym
->attr
.flavor
!= FL_PROCEDURE
8176 && !gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, NULL
))
8182 add_hidden_procptr_result (sym
);
8187 gfc_free_array_spec (as
);
8192 /* Generic attribute declaration subroutine. Used for attributes that
8193 just have a list of names. */
8200 /* Gobble the optional double colon, by simply ignoring the result
8210 if (gfc_match_eos () == MATCH_YES
)
8216 if (gfc_match_char (',') != MATCH_YES
)
8218 gfc_error ("Unexpected character in variable list at %C");
8228 /* This routine matches Cray Pointer declarations of the form:
8229 pointer ( <pointer>, <pointee> )
8231 pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...
8232 The pointer, if already declared, should be an integer. Otherwise, we
8233 set it as BT_INTEGER with kind gfc_index_integer_kind. The pointee may
8234 be either a scalar, or an array declaration. No space is allocated for
8235 the pointee. For the statement
8236 pointer (ipt, ar(10))
8237 any subsequent uses of ar will be translated (in C-notation) as
8238 ar(i) => ((<type> *) ipt)(i)
8239 After gimplification, pointee variable will disappear in the code. */
8242 cray_pointer_decl (void)
8245 gfc_array_spec
*as
= NULL
;
8246 gfc_symbol
*cptr
; /* Pointer symbol. */
8247 gfc_symbol
*cpte
; /* Pointee symbol. */
8253 if (gfc_match_char ('(') != MATCH_YES
)
8255 gfc_error ("Expected %<(%> at %C");
8259 /* Match pointer. */
8260 var_locus
= gfc_current_locus
;
8261 gfc_clear_attr (¤t_attr
);
8262 gfc_add_cray_pointer (¤t_attr
, &var_locus
);
8263 current_ts
.type
= BT_INTEGER
;
8264 current_ts
.kind
= gfc_index_integer_kind
;
8266 m
= gfc_match_symbol (&cptr
, 0);
8269 gfc_error ("Expected variable name at %C");
8273 if (!gfc_add_cray_pointer (&cptr
->attr
, &var_locus
))
8276 gfc_set_sym_referenced (cptr
);
8278 if (cptr
->ts
.type
== BT_UNKNOWN
) /* Override the type, if necessary. */
8280 cptr
->ts
.type
= BT_INTEGER
;
8281 cptr
->ts
.kind
= gfc_index_integer_kind
;
8283 else if (cptr
->ts
.type
!= BT_INTEGER
)
8285 gfc_error ("Cray pointer at %C must be an integer");
8288 else if (cptr
->ts
.kind
< gfc_index_integer_kind
)
8289 gfc_warning (0, "Cray pointer at %C has %d bytes of precision;"
8290 " memory addresses require %d bytes",
8291 cptr
->ts
.kind
, gfc_index_integer_kind
);
8293 if (gfc_match_char (',') != MATCH_YES
)
8295 gfc_error ("Expected \",\" at %C");
8299 /* Match Pointee. */
8300 var_locus
= gfc_current_locus
;
8301 gfc_clear_attr (¤t_attr
);
8302 gfc_add_cray_pointee (¤t_attr
, &var_locus
);
8303 current_ts
.type
= BT_UNKNOWN
;
8304 current_ts
.kind
= 0;
8306 m
= gfc_match_symbol (&cpte
, 0);
8309 gfc_error ("Expected variable name at %C");
8313 /* Check for an optional array spec. */
8314 m
= gfc_match_array_spec (&as
, true, false);
8315 if (m
== MATCH_ERROR
)
8317 gfc_free_array_spec (as
);
8320 else if (m
== MATCH_NO
)
8322 gfc_free_array_spec (as
);
8326 if (!gfc_add_cray_pointee (&cpte
->attr
, &var_locus
))
8329 gfc_set_sym_referenced (cpte
);
8331 if (cpte
->as
== NULL
)
8333 if (!gfc_set_array_spec (cpte
, as
, &var_locus
))
8334 gfc_internal_error ("Couldn't set Cray pointee array spec.");
8336 else if (as
!= NULL
)
8338 gfc_error ("Duplicate array spec for Cray pointee at %C");
8339 gfc_free_array_spec (as
);
8345 if (cpte
->as
!= NULL
)
8347 /* Fix array spec. */
8348 m
= gfc_mod_pointee_as (cpte
->as
);
8349 if (m
== MATCH_ERROR
)
8353 /* Point the Pointee at the Pointer. */
8354 cpte
->cp_pointer
= cptr
;
8356 if (gfc_match_char (')') != MATCH_YES
)
8358 gfc_error ("Expected \")\" at %C");
8361 m
= gfc_match_char (',');
8363 done
= true; /* Stop searching for more declarations. */
8367 if (m
== MATCH_ERROR
/* Failed when trying to find ',' above. */
8368 || gfc_match_eos () != MATCH_YES
)
8370 gfc_error ("Expected %<,%> or end of statement at %C");
8378 gfc_match_external (void)
8381 gfc_clear_attr (¤t_attr
);
8382 current_attr
.external
= 1;
8384 return attr_decl ();
8389 gfc_match_intent (void)
8393 /* This is not allowed within a BLOCK construct! */
8394 if (gfc_current_state () == COMP_BLOCK
)
8396 gfc_error ("INTENT is not allowed inside of BLOCK at %C");
8400 intent
= match_intent_spec ();
8401 if (intent
== INTENT_UNKNOWN
)
8404 gfc_clear_attr (¤t_attr
);
8405 current_attr
.intent
= intent
;
8407 return attr_decl ();
8412 gfc_match_intrinsic (void)
8415 gfc_clear_attr (¤t_attr
);
8416 current_attr
.intrinsic
= 1;
8418 return attr_decl ();
8423 gfc_match_optional (void)
8425 /* This is not allowed within a BLOCK construct! */
8426 if (gfc_current_state () == COMP_BLOCK
)
8428 gfc_error ("OPTIONAL is not allowed inside of BLOCK at %C");
8432 gfc_clear_attr (¤t_attr
);
8433 current_attr
.optional
= 1;
8435 return attr_decl ();
8440 gfc_match_pointer (void)
8442 gfc_gobble_whitespace ();
8443 if (gfc_peek_ascii_char () == '(')
8445 if (!flag_cray_pointer
)
8447 gfc_error ("Cray pointer declaration at %C requires -fcray-pointer "
8451 return cray_pointer_decl ();
8455 gfc_clear_attr (¤t_attr
);
8456 current_attr
.pointer
= 1;
8458 return attr_decl ();
8464 gfc_match_allocatable (void)
8466 gfc_clear_attr (¤t_attr
);
8467 current_attr
.allocatable
= 1;
8469 return attr_decl ();
8474 gfc_match_codimension (void)
8476 gfc_clear_attr (¤t_attr
);
8477 current_attr
.codimension
= 1;
8479 return attr_decl ();
8484 gfc_match_contiguous (void)
8486 if (!gfc_notify_std (GFC_STD_F2008
, "CONTIGUOUS statement at %C"))
8489 gfc_clear_attr (¤t_attr
);
8490 current_attr
.contiguous
= 1;
8492 return attr_decl ();
8497 gfc_match_dimension (void)
8499 gfc_clear_attr (¤t_attr
);
8500 current_attr
.dimension
= 1;
8502 return attr_decl ();
8507 gfc_match_target (void)
8509 gfc_clear_attr (¤t_attr
);
8510 current_attr
.target
= 1;
8512 return attr_decl ();
8516 /* Match the list of entities being specified in a PUBLIC or PRIVATE
8520 access_attr_decl (gfc_statement st
)
8522 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8523 interface_type type
;
8525 gfc_symbol
*sym
, *dt_sym
;
8526 gfc_intrinsic_op op
;
8529 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
8534 m
= gfc_match_generic_spec (&type
, name
, &op
);
8537 if (m
== MATCH_ERROR
)
8542 case INTERFACE_NAMELESS
:
8543 case INTERFACE_ABSTRACT
:
8546 case INTERFACE_GENERIC
:
8547 case INTERFACE_DTIO
:
8549 if (gfc_get_symbol (name
, NULL
, &sym
))
8552 if (type
== INTERFACE_DTIO
8553 && gfc_current_ns
->proc_name
8554 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
8555 && sym
->attr
.flavor
== FL_UNKNOWN
)
8556 sym
->attr
.flavor
= FL_PROCEDURE
;
8558 if (!gfc_add_access (&sym
->attr
,
8560 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
,
8564 if (sym
->attr
.generic
&& (dt_sym
= gfc_find_dt_in_generic (sym
))
8565 && !gfc_add_access (&dt_sym
->attr
,
8567 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
,
8573 case INTERFACE_INTRINSIC_OP
:
8574 if (gfc_current_ns
->operator_access
[op
] == ACCESS_UNKNOWN
)
8576 gfc_intrinsic_op other_op
;
8578 gfc_current_ns
->operator_access
[op
] =
8579 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
8581 /* Handle the case if there is another op with the same
8582 function, for INTRINSIC_EQ vs. INTRINSIC_EQ_OS and so on. */
8583 other_op
= gfc_equivalent_op (op
);
8585 if (other_op
!= INTRINSIC_NONE
)
8586 gfc_current_ns
->operator_access
[other_op
] =
8587 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
8592 gfc_error ("Access specification of the %s operator at %C has "
8593 "already been specified", gfc_op2string (op
));
8599 case INTERFACE_USER_OP
:
8600 uop
= gfc_get_uop (name
);
8602 if (uop
->access
== ACCESS_UNKNOWN
)
8604 uop
->access
= (st
== ST_PUBLIC
)
8605 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
8609 gfc_error ("Access specification of the .%s. operator at %C "
8610 "has already been specified", sym
->name
);
8617 if (gfc_match_char (',') == MATCH_NO
)
8621 if (gfc_match_eos () != MATCH_YES
)
8626 gfc_syntax_error (st
);
8634 gfc_match_protected (void)
8639 if (!gfc_current_ns
->proc_name
8640 || gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
8642 gfc_error ("PROTECTED at %C only allowed in specification "
8643 "part of a module");
8648 if (!gfc_notify_std (GFC_STD_F2003
, "PROTECTED statement at %C"))
8651 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
8656 if (gfc_match_eos () == MATCH_YES
)
8661 m
= gfc_match_symbol (&sym
, 0);
8665 if (!gfc_add_protected (&sym
->attr
, sym
->name
, &gfc_current_locus
))
8677 if (gfc_match_eos () == MATCH_YES
)
8679 if (gfc_match_char (',') != MATCH_YES
)
8686 gfc_error ("Syntax error in PROTECTED statement at %C");
8691 /* The PRIVATE statement is a bit weird in that it can be an attribute
8692 declaration, but also works as a standalone statement inside of a
8693 type declaration or a module. */
8696 gfc_match_private (gfc_statement
*st
)
8699 if (gfc_match ("private") != MATCH_YES
)
8702 if (gfc_current_state () != COMP_MODULE
8703 && !(gfc_current_state () == COMP_DERIVED
8704 && gfc_state_stack
->previous
8705 && gfc_state_stack
->previous
->state
== COMP_MODULE
)
8706 && !(gfc_current_state () == COMP_DERIVED_CONTAINS
8707 && gfc_state_stack
->previous
&& gfc_state_stack
->previous
->previous
8708 && gfc_state_stack
->previous
->previous
->state
== COMP_MODULE
))
8710 gfc_error ("PRIVATE statement at %C is only allowed in the "
8711 "specification part of a module");
8715 if (gfc_current_state () == COMP_DERIVED
)
8717 if (gfc_match_eos () == MATCH_YES
)
8723 gfc_syntax_error (ST_PRIVATE
);
8727 if (gfc_match_eos () == MATCH_YES
)
8734 return access_attr_decl (ST_PRIVATE
);
8739 gfc_match_public (gfc_statement
*st
)
8742 if (gfc_match ("public") != MATCH_YES
)
8745 if (gfc_current_state () != COMP_MODULE
)
8747 gfc_error ("PUBLIC statement at %C is only allowed in the "
8748 "specification part of a module");
8752 if (gfc_match_eos () == MATCH_YES
)
8759 return access_attr_decl (ST_PUBLIC
);
8763 /* Workhorse for gfc_match_parameter. */
8773 m
= gfc_match_symbol (&sym
, 0);
8775 gfc_error ("Expected variable name at %C in PARAMETER statement");
8780 if (gfc_match_char ('=') == MATCH_NO
)
8782 gfc_error ("Expected = sign in PARAMETER statement at %C");
8786 m
= gfc_match_init_expr (&init
);
8788 gfc_error ("Expected expression at %C in PARAMETER statement");
8792 if (sym
->ts
.type
== BT_UNKNOWN
8793 && !gfc_set_default_type (sym
, 1, NULL
))
8799 if (!gfc_check_assign_symbol (sym
, NULL
, init
)
8800 || !gfc_add_flavor (&sym
->attr
, FL_PARAMETER
, sym
->name
, NULL
))
8808 gfc_error ("Initializing already initialized variable at %C");
8813 t
= add_init_expr_to_sym (sym
->name
, &init
, &gfc_current_locus
);
8814 return (t
) ? MATCH_YES
: MATCH_ERROR
;
8817 gfc_free_expr (init
);
8822 /* Match a parameter statement, with the weird syntax that these have. */
8825 gfc_match_parameter (void)
8827 const char *term
= " )%t";
8830 if (gfc_match_char ('(') == MATCH_NO
)
8832 /* With legacy PARAMETER statements, don't expect a terminating ')'. */
8833 if (!gfc_notify_std (GFC_STD_LEGACY
, "PARAMETER without '()' at %C"))
8844 if (gfc_match (term
) == MATCH_YES
)
8847 if (gfc_match_char (',') != MATCH_YES
)
8849 gfc_error ("Unexpected characters in PARAMETER statement at %C");
8860 gfc_match_automatic (void)
8864 bool seen_symbol
= false;
8866 if (!flag_dec_static
)
8868 gfc_error ("%s at %C is a DEC extension, enable with "
8879 m
= gfc_match_symbol (&sym
, 0);
8889 if (!gfc_add_automatic (&sym
->attr
, sym
->name
, &gfc_current_locus
))
8895 if (gfc_match_eos () == MATCH_YES
)
8897 if (gfc_match_char (',') != MATCH_YES
)
8903 gfc_error ("Expected entity-list in AUTOMATIC statement at %C");
8910 gfc_error ("Syntax error in AUTOMATIC statement at %C");
8916 gfc_match_static (void)
8920 bool seen_symbol
= false;
8922 if (!flag_dec_static
)
8924 gfc_error ("%s at %C is a DEC extension, enable with "
8934 m
= gfc_match_symbol (&sym
, 0);
8944 if (!gfc_add_save (&sym
->attr
, SAVE_EXPLICIT
, sym
->name
,
8945 &gfc_current_locus
))
8951 if (gfc_match_eos () == MATCH_YES
)
8953 if (gfc_match_char (',') != MATCH_YES
)
8959 gfc_error ("Expected entity-list in STATIC statement at %C");
8966 gfc_error ("Syntax error in STATIC statement at %C");
8971 /* Save statements have a special syntax. */
8974 gfc_match_save (void)
8976 char n
[GFC_MAX_SYMBOL_LEN
+1];
8981 if (gfc_match_eos () == MATCH_YES
)
8983 if (gfc_current_ns
->seen_save
)
8985 if (!gfc_notify_std (GFC_STD_LEGACY
, "Blanket SAVE statement at %C "
8986 "follows previous SAVE statement"))
8990 gfc_current_ns
->save_all
= gfc_current_ns
->seen_save
= 1;
8994 if (gfc_current_ns
->save_all
)
8996 if (!gfc_notify_std (GFC_STD_LEGACY
, "SAVE statement at %C follows "
8997 "blanket SAVE statement"))
9005 m
= gfc_match_symbol (&sym
, 0);
9009 if (!gfc_add_save (&sym
->attr
, SAVE_EXPLICIT
, sym
->name
,
9010 &gfc_current_locus
))
9021 m
= gfc_match (" / %n /", &n
);
9022 if (m
== MATCH_ERROR
)
9027 c
= gfc_get_common (n
, 0);
9030 gfc_current_ns
->seen_save
= 1;
9033 if (gfc_match_eos () == MATCH_YES
)
9035 if (gfc_match_char (',') != MATCH_YES
)
9042 gfc_error ("Syntax error in SAVE statement at %C");
9048 gfc_match_value (void)
9053 /* This is not allowed within a BLOCK construct! */
9054 if (gfc_current_state () == COMP_BLOCK
)
9056 gfc_error ("VALUE is not allowed inside of BLOCK at %C");
9060 if (!gfc_notify_std (GFC_STD_F2003
, "VALUE statement at %C"))
9063 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
9068 if (gfc_match_eos () == MATCH_YES
)
9073 m
= gfc_match_symbol (&sym
, 0);
9077 if (!gfc_add_value (&sym
->attr
, sym
->name
, &gfc_current_locus
))
9089 if (gfc_match_eos () == MATCH_YES
)
9091 if (gfc_match_char (',') != MATCH_YES
)
9098 gfc_error ("Syntax error in VALUE statement at %C");
9104 gfc_match_volatile (void)
9110 if (!gfc_notify_std (GFC_STD_F2003
, "VOLATILE statement at %C"))
9113 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
9118 if (gfc_match_eos () == MATCH_YES
)
9123 /* VOLATILE is special because it can be added to host-associated
9124 symbols locally. Except for coarrays. */
9125 m
= gfc_match_symbol (&sym
, 1);
9129 name
= XCNEWVAR (char, strlen (sym
->name
) + 1);
9130 strcpy (name
, sym
->name
);
9131 if (!check_function_name (name
))
9133 /* F2008, C560+C561. VOLATILE for host-/use-associated variable or
9134 for variable in a BLOCK which is defined outside of the BLOCK. */
9135 if (sym
->ns
!= gfc_current_ns
&& sym
->attr
.codimension
)
9137 gfc_error ("Specifying VOLATILE for coarray variable %qs at "
9138 "%C, which is use-/host-associated", sym
->name
);
9141 if (!gfc_add_volatile (&sym
->attr
, sym
->name
, &gfc_current_locus
))
9153 if (gfc_match_eos () == MATCH_YES
)
9155 if (gfc_match_char (',') != MATCH_YES
)
9162 gfc_error ("Syntax error in VOLATILE statement at %C");
9168 gfc_match_asynchronous (void)
9174 if (!gfc_notify_std (GFC_STD_F2003
, "ASYNCHRONOUS statement at %C"))
9177 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
9182 if (gfc_match_eos () == MATCH_YES
)
9187 /* ASYNCHRONOUS is special because it can be added to host-associated
9189 m
= gfc_match_symbol (&sym
, 1);
9193 name
= XCNEWVAR (char, strlen (sym
->name
) + 1);
9194 strcpy (name
, sym
->name
);
9195 if (!check_function_name (name
))
9197 if (!gfc_add_asynchronous (&sym
->attr
, sym
->name
, &gfc_current_locus
))
9209 if (gfc_match_eos () == MATCH_YES
)
9211 if (gfc_match_char (',') != MATCH_YES
)
9218 gfc_error ("Syntax error in ASYNCHRONOUS statement at %C");
9223 /* Match a module procedure statement in a submodule. */
9226 gfc_match_submod_proc (void)
9228 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9229 gfc_symbol
*sym
, *fsym
;
9231 gfc_formal_arglist
*formal
, *head
, *tail
;
9233 if (gfc_current_state () != COMP_CONTAINS
9234 || !(gfc_state_stack
->previous
9235 && (gfc_state_stack
->previous
->state
== COMP_SUBMODULE
9236 || gfc_state_stack
->previous
->state
== COMP_MODULE
)))
9239 m
= gfc_match (" module% procedure% %n", name
);
9243 if (!gfc_notify_std (GFC_STD_F2008
, "MODULE PROCEDURE declaration "
9247 if (get_proc_name (name
, &sym
, false))
9250 /* Make sure that the result field is appropriately filled, even though
9251 the result symbol will be replaced later on. */
9252 if (sym
->tlink
&& sym
->tlink
->attr
.function
)
9254 if (sym
->tlink
->result
9255 && sym
->tlink
->result
!= sym
->tlink
)
9256 sym
->result
= sym
->tlink
->result
;
9261 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
9262 the symbol existed before. */
9263 sym
->declared_at
= gfc_current_locus
;
9265 if (!sym
->attr
.module_procedure
)
9268 /* Signal match_end to expect "end procedure". */
9269 sym
->abr_modproc_decl
= 1;
9271 /* Change from IFSRC_IFBODY coming from the interface declaration. */
9272 sym
->attr
.if_source
= IFSRC_DECL
;
9274 gfc_new_block
= sym
;
9276 /* Make a new formal arglist with the symbols in the procedure
9279 for (formal
= sym
->formal
; formal
&& formal
->sym
; formal
= formal
->next
)
9281 if (formal
== sym
->formal
)
9282 head
= tail
= gfc_get_formal_arglist ();
9285 tail
->next
= gfc_get_formal_arglist ();
9289 if (gfc_copy_dummy_sym (&fsym
, formal
->sym
, 0))
9293 gfc_set_sym_referenced (fsym
);
9296 /* The dummy symbols get cleaned up, when the formal_namespace of the
9297 interface declaration is cleared. This allows us to add the
9298 explicit interface as is done for other type of procedure. */
9299 if (!gfc_add_explicit_interface (sym
, IFSRC_DECL
, head
,
9300 &gfc_current_locus
))
9303 if (gfc_match_eos () != MATCH_YES
)
9305 gfc_syntax_error (ST_MODULE_PROC
);
9312 gfc_free_formal_arglist (head
);
9317 /* Match a module procedure statement. Note that we have to modify
9318 symbols in the parent's namespace because the current one was there
9319 to receive symbols that are in an interface's formal argument list. */
9322 gfc_match_modproc (void)
9324 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9328 gfc_namespace
*module_ns
;
9329 gfc_interface
*old_interface_head
, *interface
;
9331 if (gfc_state_stack
->state
!= COMP_INTERFACE
9332 || gfc_state_stack
->previous
== NULL
9333 || current_interface
.type
== INTERFACE_NAMELESS
9334 || current_interface
.type
== INTERFACE_ABSTRACT
)
9336 gfc_error ("MODULE PROCEDURE at %C must be in a generic module "
9341 module_ns
= gfc_current_ns
->parent
;
9342 for (; module_ns
; module_ns
= module_ns
->parent
)
9343 if (module_ns
->proc_name
->attr
.flavor
== FL_MODULE
9344 || module_ns
->proc_name
->attr
.flavor
== FL_PROGRAM
9345 || (module_ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
9346 && !module_ns
->proc_name
->attr
.contained
))
9349 if (module_ns
== NULL
)
9352 /* Store the current state of the interface. We will need it if we
9353 end up with a syntax error and need to recover. */
9354 old_interface_head
= gfc_current_interface_head ();
9356 /* Check if the F2008 optional double colon appears. */
9357 gfc_gobble_whitespace ();
9358 old_locus
= gfc_current_locus
;
9359 if (gfc_match ("::") == MATCH_YES
)
9361 if (!gfc_notify_std (GFC_STD_F2008
, "double colon in "
9362 "MODULE PROCEDURE statement at %L", &old_locus
))
9366 gfc_current_locus
= old_locus
;
9371 old_locus
= gfc_current_locus
;
9373 m
= gfc_match_name (name
);
9379 /* Check for syntax error before starting to add symbols to the
9380 current namespace. */
9381 if (gfc_match_eos () == MATCH_YES
)
9384 if (!last
&& gfc_match_char (',') != MATCH_YES
)
9387 /* Now we're sure the syntax is valid, we process this item
9389 if (gfc_get_symbol (name
, module_ns
, &sym
))
9392 if (sym
->attr
.intrinsic
)
9394 gfc_error ("Intrinsic procedure at %L cannot be a MODULE "
9395 "PROCEDURE", &old_locus
);
9399 if (sym
->attr
.proc
!= PROC_MODULE
9400 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
9403 if (!gfc_add_interface (sym
))
9406 sym
->attr
.mod_proc
= 1;
9407 sym
->declared_at
= old_locus
;
9416 /* Restore the previous state of the interface. */
9417 interface
= gfc_current_interface_head ();
9418 gfc_set_current_interface_head (old_interface_head
);
9420 /* Free the new interfaces. */
9421 while (interface
!= old_interface_head
)
9423 gfc_interface
*i
= interface
->next
;
9428 /* And issue a syntax error. */
9429 gfc_syntax_error (ST_MODULE_PROC
);
9434 /* Check a derived type that is being extended. */
9437 check_extended_derived_type (char *name
)
9439 gfc_symbol
*extended
;
9441 if (gfc_find_symbol (name
, gfc_current_ns
, 1, &extended
))
9443 gfc_error ("Ambiguous symbol in TYPE definition at %C");
9447 extended
= gfc_find_dt_in_generic (extended
);
9452 gfc_error ("Symbol %qs at %C has not been previously defined", name
);
9456 if (extended
->attr
.flavor
!= FL_DERIVED
)
9458 gfc_error ("%qs in EXTENDS expression at %C is not a "
9459 "derived type", name
);
9463 if (extended
->attr
.is_bind_c
)
9465 gfc_error ("%qs cannot be extended at %C because it "
9466 "is BIND(C)", extended
->name
);
9470 if (extended
->attr
.sequence
)
9472 gfc_error ("%qs cannot be extended at %C because it "
9473 "is a SEQUENCE type", extended
->name
);
9481 /* Match the optional attribute specifiers for a type declaration.
9482 Return MATCH_ERROR if an error is encountered in one of the handled
9483 attributes (public, private, bind(c)), MATCH_NO if what's found is
9484 not a handled attribute, and MATCH_YES otherwise. TODO: More error
9485 checking on attribute conflicts needs to be done. */
9488 gfc_get_type_attr_spec (symbol_attribute
*attr
, char *name
)
9490 /* See if the derived type is marked as private. */
9491 if (gfc_match (" , private") == MATCH_YES
)
9493 if (gfc_current_state () != COMP_MODULE
)
9495 gfc_error ("Derived type at %C can only be PRIVATE in the "
9496 "specification part of a module");
9500 if (!gfc_add_access (attr
, ACCESS_PRIVATE
, NULL
, NULL
))
9503 else if (gfc_match (" , public") == MATCH_YES
)
9505 if (gfc_current_state () != COMP_MODULE
)
9507 gfc_error ("Derived type at %C can only be PUBLIC in the "
9508 "specification part of a module");
9512 if (!gfc_add_access (attr
, ACCESS_PUBLIC
, NULL
, NULL
))
9515 else if (gfc_match (" , bind ( c )") == MATCH_YES
)
9517 /* If the type is defined to be bind(c) it then needs to make
9518 sure that all fields are interoperable. This will
9519 need to be a semantic check on the finished derived type.
9520 See 15.2.3 (lines 9-12) of F2003 draft. */
9521 if (!gfc_add_is_bind_c (attr
, NULL
, &gfc_current_locus
, 0))
9524 /* TODO: attr conflicts need to be checked, probably in symbol.c. */
9526 else if (gfc_match (" , abstract") == MATCH_YES
)
9528 if (!gfc_notify_std (GFC_STD_F2003
, "ABSTRACT type at %C"))
9531 if (!gfc_add_abstract (attr
, &gfc_current_locus
))
9534 else if (name
&& gfc_match (" , extends ( %n )", name
) == MATCH_YES
)
9536 if (!gfc_add_extension (attr
, &gfc_current_locus
))
9542 /* If we get here, something matched. */
9547 /* Common function for type declaration blocks similar to derived types, such
9548 as STRUCTURES and MAPs. Unlike derived types, a structure type
9549 does NOT have a generic symbol matching the name given by the user.
9550 STRUCTUREs can share names with variables and PARAMETERs so we must allow
9551 for the creation of an independent symbol.
9552 Other parameters are a message to prefix errors with, the name of the new
9553 type to be created, and the flavor to add to the resulting symbol. */
9556 get_struct_decl (const char *name
, sym_flavor fl
, locus
*decl
,
9557 gfc_symbol
**result
)
9562 gcc_assert (name
[0] == (char) TOUPPER (name
[0]));
9567 where
= gfc_current_locus
;
9569 if (gfc_get_symbol (name
, NULL
, &sym
))
9574 gfc_internal_error ("Failed to create structure type '%s' at %C", name
);
9578 if (sym
->components
!= NULL
|| sym
->attr
.zero_comp
)
9580 gfc_error ("Type definition of %qs at %C was already defined at %L",
9581 sym
->name
, &sym
->declared_at
);
9585 sym
->declared_at
= where
;
9587 if (sym
->attr
.flavor
!= fl
9588 && !gfc_add_flavor (&sym
->attr
, fl
, sym
->name
, NULL
))
9591 if (!sym
->hash_value
)
9592 /* Set the hash for the compound name for this type. */
9593 sym
->hash_value
= gfc_hash_value (sym
);
9595 /* Normally the type is expected to have been completely parsed by the time
9596 a field declaration with this type is seen. For unions, maps, and nested
9597 structure declarations, we need to indicate that it is okay that we
9598 haven't seen any components yet. This will be updated after the structure
9600 sym
->attr
.zero_comp
= 0;
9602 /* Structures always act like derived-types with the SEQUENCE attribute */
9603 gfc_add_sequence (&sym
->attr
, sym
->name
, NULL
);
9605 if (result
) *result
= sym
;
9611 /* Match the opening of a MAP block. Like a struct within a union in C;
9612 behaves identical to STRUCTURE blocks. */
9615 gfc_match_map (void)
9617 /* Counter used to give unique internal names to map structures. */
9618 static unsigned int gfc_map_id
= 0;
9619 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9623 old_loc
= gfc_current_locus
;
9625 if (gfc_match_eos () != MATCH_YES
)
9627 gfc_error ("Junk after MAP statement at %C");
9628 gfc_current_locus
= old_loc
;
9632 /* Map blocks are anonymous so we make up unique names for the symbol table
9633 which are invalid Fortran identifiers. */
9634 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "MM$%u", gfc_map_id
++);
9636 if (!get_struct_decl (name
, FL_STRUCT
, &old_loc
, &sym
))
9639 gfc_new_block
= sym
;
9645 /* Match the opening of a UNION block. */
9648 gfc_match_union (void)
9650 /* Counter used to give unique internal names to union types. */
9651 static unsigned int gfc_union_id
= 0;
9652 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9656 old_loc
= gfc_current_locus
;
9658 if (gfc_match_eos () != MATCH_YES
)
9660 gfc_error ("Junk after UNION statement at %C");
9661 gfc_current_locus
= old_loc
;
9665 /* Unions are anonymous so we make up unique names for the symbol table
9666 which are invalid Fortran identifiers. */
9667 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "UU$%u", gfc_union_id
++);
9669 if (!get_struct_decl (name
, FL_UNION
, &old_loc
, &sym
))
9672 gfc_new_block
= sym
;
9678 /* Match the beginning of a STRUCTURE declaration. This is similar to
9679 matching the beginning of a derived type declaration with a few
9680 twists. The resulting type symbol has no access control or other
9681 interesting attributes. */
9684 gfc_match_structure_decl (void)
9686 /* Counter used to give unique internal names to anonymous structures. */
9687 static unsigned int gfc_structure_id
= 0;
9688 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9693 if (!flag_dec_structure
)
9695 gfc_error ("%s at %C is a DEC extension, enable with "
9696 "%<-fdec-structure%>",
9703 m
= gfc_match (" /%n/", name
);
9706 /* Non-nested structure declarations require a structure name. */
9707 if (!gfc_comp_struct (gfc_current_state ()))
9709 gfc_error ("Structure name expected in non-nested structure "
9710 "declaration at %C");
9713 /* This is an anonymous structure; make up a unique name for it
9714 (upper-case letters never make it to symbol names from the source).
9715 The important thing is initializing the type variable
9716 and setting gfc_new_symbol, which is immediately used by
9717 parse_structure () and variable_decl () to add components of
9719 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "SS$%u", gfc_structure_id
++);
9722 where
= gfc_current_locus
;
9723 /* No field list allowed after non-nested structure declaration. */
9724 if (!gfc_comp_struct (gfc_current_state ())
9725 && gfc_match_eos () != MATCH_YES
)
9727 gfc_error ("Junk after non-nested STRUCTURE statement at %C");
9731 /* Make sure the name is not the name of an intrinsic type. */
9732 if (gfc_is_intrinsic_typename (name
))
9734 gfc_error ("Structure name %qs at %C cannot be the same as an"
9735 " intrinsic type", name
);
9739 /* Store the actual type symbol for the structure with an upper-case first
9740 letter (an invalid Fortran identifier). */
9742 if (!get_struct_decl (gfc_dt_upper_string (name
), FL_STRUCT
, &where
, &sym
))
9745 gfc_new_block
= sym
;
9750 /* This function does some work to determine which matcher should be used to
9751 * match a statement beginning with "TYPE". This is used to disambiguate TYPE
9752 * as an alias for PRINT from derived type declarations, TYPE IS statements,
9753 * and derived type data declarations. */
9756 gfc_match_type (gfc_statement
*st
)
9758 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9762 /* Requires -fdec. */
9766 m
= gfc_match ("type");
9769 /* If we already have an error in the buffer, it is probably from failing to
9770 * match a derived type data declaration. Let it happen. */
9771 else if (gfc_error_flag_test ())
9774 old_loc
= gfc_current_locus
;
9777 /* If we see an attribute list before anything else it's definitely a derived
9778 * type declaration. */
9779 if (gfc_match (" ,") == MATCH_YES
|| gfc_match (" ::") == MATCH_YES
)
9781 gfc_current_locus
= old_loc
;
9782 *st
= ST_DERIVED_DECL
;
9783 return gfc_match_derived_decl ();
9786 /* By now "TYPE" has already been matched. If we do not see a name, this may
9787 * be something like "TYPE *" or "TYPE <fmt>". */
9788 m
= gfc_match_name (name
);
9791 /* Let print match if it can, otherwise throw an error from
9792 * gfc_match_derived_decl. */
9793 gfc_current_locus
= old_loc
;
9794 if (gfc_match_print () == MATCH_YES
)
9799 gfc_current_locus
= old_loc
;
9800 *st
= ST_DERIVED_DECL
;
9801 return gfc_match_derived_decl ();
9804 /* A derived type declaration requires an EOS. Without it, assume print. */
9805 m
= gfc_match_eos ();
9808 /* Check manually for TYPE IS (... - this is invalid print syntax. */
9809 if (strncmp ("is", name
, 3) == 0
9810 && gfc_match (" (", name
) == MATCH_YES
)
9812 gfc_current_locus
= old_loc
;
9813 gcc_assert (gfc_match (" is") == MATCH_YES
);
9815 return gfc_match_type_is ();
9817 gfc_current_locus
= old_loc
;
9819 return gfc_match_print ();
9823 /* By now we have "TYPE <name> <EOS>". Check first if the name is an
9824 * intrinsic typename - if so let gfc_match_derived_decl dump an error.
9825 * Otherwise if gfc_match_derived_decl fails it's probably an existing
9826 * symbol which can be printed. */
9827 gfc_current_locus
= old_loc
;
9828 m
= gfc_match_derived_decl ();
9829 if (gfc_is_intrinsic_typename (name
) || m
== MATCH_YES
)
9831 *st
= ST_DERIVED_DECL
;
9834 gfc_current_locus
= old_loc
;
9836 return gfc_match_print ();
9843 /* Match the beginning of a derived type declaration. If a type name
9844 was the result of a function, then it is possible to have a symbol
9845 already to be known as a derived type yet have no components. */
9848 gfc_match_derived_decl (void)
9850 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9851 char parent
[GFC_MAX_SYMBOL_LEN
+ 1];
9852 symbol_attribute attr
;
9853 gfc_symbol
*sym
, *gensym
;
9854 gfc_symbol
*extended
;
9856 match is_type_attr_spec
= MATCH_NO
;
9857 bool seen_attr
= false;
9858 gfc_interface
*intr
= NULL
, *head
;
9859 bool parameterized_type
= false;
9860 bool seen_colons
= false;
9862 if (gfc_comp_struct (gfc_current_state ()))
9867 gfc_clear_attr (&attr
);
9872 is_type_attr_spec
= gfc_get_type_attr_spec (&attr
, parent
);
9873 if (is_type_attr_spec
== MATCH_ERROR
)
9875 if (is_type_attr_spec
== MATCH_YES
)
9877 } while (is_type_attr_spec
== MATCH_YES
);
9879 /* Deal with derived type extensions. The extension attribute has
9880 been added to 'attr' but now the parent type must be found and
9883 extended
= check_extended_derived_type (parent
);
9885 if (parent
[0] && !extended
)
9888 m
= gfc_match (" ::");
9895 gfc_error ("Expected :: in TYPE definition at %C");
9899 m
= gfc_match (" %n ", name
);
9903 /* Make sure that we don't identify TYPE IS (...) as a parameterized
9904 derived type named 'is'.
9905 TODO Expand the check, when 'name' = "is" by matching " (tname) "
9906 and checking if this is a(n intrinsic) typename. his picks up
9907 misplaced TYPE IS statements such as in select_type_1.f03. */
9908 if (gfc_peek_ascii_char () == '(')
9910 if (gfc_current_state () == COMP_SELECT_TYPE
9911 || (!seen_colons
&& !strcmp (name
, "is")))
9913 parameterized_type
= true;
9916 m
= gfc_match_eos ();
9917 if (m
!= MATCH_YES
&& !parameterized_type
)
9920 /* Make sure the name is not the name of an intrinsic type. */
9921 if (gfc_is_intrinsic_typename (name
))
9923 gfc_error ("Type name %qs at %C cannot be the same as an intrinsic "
9928 if (gfc_get_symbol (name
, NULL
, &gensym
))
9931 if (!gensym
->attr
.generic
&& gensym
->ts
.type
!= BT_UNKNOWN
)
9933 gfc_error ("Derived type name %qs at %C already has a basic type "
9934 "of %s", gensym
->name
, gfc_typename (&gensym
->ts
));
9938 if (!gensym
->attr
.generic
9939 && !gfc_add_generic (&gensym
->attr
, gensym
->name
, NULL
))
9942 if (!gensym
->attr
.function
9943 && !gfc_add_function (&gensym
->attr
, gensym
->name
, NULL
))
9946 sym
= gfc_find_dt_in_generic (gensym
);
9948 if (sym
&& (sym
->components
!= NULL
|| sym
->attr
.zero_comp
))
9950 gfc_error ("Derived type definition of %qs at %C has already been "
9951 "defined", sym
->name
);
9957 /* Use upper case to save the actual derived-type symbol. */
9958 gfc_get_symbol (gfc_dt_upper_string (gensym
->name
), NULL
, &sym
);
9959 sym
->name
= gfc_get_string ("%s", gensym
->name
);
9960 head
= gensym
->generic
;
9961 intr
= gfc_get_interface ();
9963 intr
->where
= gfc_current_locus
;
9964 intr
->sym
->declared_at
= gfc_current_locus
;
9966 gensym
->generic
= intr
;
9967 gensym
->attr
.if_source
= IFSRC_DECL
;
9970 /* The symbol may already have the derived attribute without the
9971 components. The ways this can happen is via a function
9972 definition, an INTRINSIC statement or a subtype in another
9973 derived type that is a pointer. The first part of the AND clause
9974 is true if the symbol is not the return value of a function. */
9975 if (sym
->attr
.flavor
!= FL_DERIVED
9976 && !gfc_add_flavor (&sym
->attr
, FL_DERIVED
, sym
->name
, NULL
))
9979 if (attr
.access
!= ACCESS_UNKNOWN
9980 && !gfc_add_access (&sym
->attr
, attr
.access
, sym
->name
, NULL
))
9982 else if (sym
->attr
.access
== ACCESS_UNKNOWN
9983 && gensym
->attr
.access
!= ACCESS_UNKNOWN
9984 && !gfc_add_access (&sym
->attr
, gensym
->attr
.access
,
9988 if (sym
->attr
.access
!= ACCESS_UNKNOWN
9989 && gensym
->attr
.access
== ACCESS_UNKNOWN
)
9990 gensym
->attr
.access
= sym
->attr
.access
;
9992 /* See if the derived type was labeled as bind(c). */
9993 if (attr
.is_bind_c
!= 0)
9994 sym
->attr
.is_bind_c
= attr
.is_bind_c
;
9996 /* Construct the f2k_derived namespace if it is not yet there. */
9997 if (!sym
->f2k_derived
)
9998 sym
->f2k_derived
= gfc_get_namespace (NULL
, 0);
10000 if (parameterized_type
)
10002 /* Ignore error or mismatches by going to the end of the statement
10003 in order to avoid the component declarations causing problems. */
10004 m
= gfc_match_formal_arglist (sym
, 0, 0, true);
10005 if (m
!= MATCH_YES
)
10006 gfc_error_recovery ();
10007 m
= gfc_match_eos ();
10008 if (m
!= MATCH_YES
)
10010 gfc_error_recovery ();
10011 gfc_error_now ("Garbage after PARAMETERIZED TYPE declaration at %C");
10013 sym
->attr
.pdt_template
= 1;
10016 if (extended
&& !sym
->components
)
10019 gfc_formal_arglist
*f
, *g
, *h
;
10021 /* Add the extended derived type as the first component. */
10022 gfc_add_component (sym
, parent
, &p
);
10024 gfc_set_sym_referenced (extended
);
10026 p
->ts
.type
= BT_DERIVED
;
10027 p
->ts
.u
.derived
= extended
;
10028 p
->initializer
= gfc_default_initializer (&p
->ts
);
10030 /* Set extension level. */
10031 if (extended
->attr
.extension
== 255)
10033 /* Since the extension field is 8 bit wide, we can only have
10034 up to 255 extension levels. */
10035 gfc_error ("Maximum extension level reached with type %qs at %L",
10036 extended
->name
, &extended
->declared_at
);
10037 return MATCH_ERROR
;
10039 sym
->attr
.extension
= extended
->attr
.extension
+ 1;
10041 /* Provide the links between the extended type and its extension. */
10042 if (!extended
->f2k_derived
)
10043 extended
->f2k_derived
= gfc_get_namespace (NULL
, 0);
10045 /* Copy the extended type-param-name-list from the extended type,
10046 append those of the extension and add the whole lot to the
10048 if (extended
->attr
.pdt_template
)
10051 sym
->attr
.pdt_template
= 1;
10052 for (f
= extended
->formal
; f
; f
= f
->next
)
10054 if (f
== extended
->formal
)
10056 g
= gfc_get_formal_arglist ();
10061 g
->next
= gfc_get_formal_arglist ();
10066 g
->next
= sym
->formal
;
10071 if (!sym
->hash_value
)
10072 /* Set the hash for the compound name for this type. */
10073 sym
->hash_value
= gfc_hash_value (sym
);
10075 /* Take over the ABSTRACT attribute. */
10076 sym
->attr
.abstract
= attr
.abstract
;
10078 gfc_new_block
= sym
;
10084 /* Cray Pointees can be declared as:
10085 pointer (ipt, a (n,m,...,*)) */
10088 gfc_mod_pointee_as (gfc_array_spec
*as
)
10090 as
->cray_pointee
= true; /* This will be useful to know later. */
10091 if (as
->type
== AS_ASSUMED_SIZE
)
10092 as
->cp_was_assumed
= true;
10093 else if (as
->type
== AS_ASSUMED_SHAPE
)
10095 gfc_error ("Cray Pointee at %C cannot be assumed shape array");
10096 return MATCH_ERROR
;
10102 /* Match the enum definition statement, here we are trying to match
10103 the first line of enum definition statement.
10104 Returns MATCH_YES if match is found. */
10107 gfc_match_enum (void)
10111 m
= gfc_match_eos ();
10112 if (m
!= MATCH_YES
)
10115 if (!gfc_notify_std (GFC_STD_F2003
, "ENUM and ENUMERATOR at %C"))
10116 return MATCH_ERROR
;
10122 /* Returns an initializer whose value is one higher than the value of the
10123 LAST_INITIALIZER argument. If the argument is NULL, the
10124 initializers value will be set to zero. The initializer's kind
10125 will be set to gfc_c_int_kind.
10127 If -fshort-enums is given, the appropriate kind will be selected
10128 later after all enumerators have been parsed. A warning is issued
10129 here if an initializer exceeds gfc_c_int_kind. */
10132 enum_initializer (gfc_expr
*last_initializer
, locus where
)
10135 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_c_int_kind
, &where
);
10137 mpz_init (result
->value
.integer
);
10139 if (last_initializer
!= NULL
)
10141 mpz_add_ui (result
->value
.integer
, last_initializer
->value
.integer
, 1);
10142 result
->where
= last_initializer
->where
;
10144 if (gfc_check_integer_range (result
->value
.integer
,
10145 gfc_c_int_kind
) != ARITH_OK
)
10147 gfc_error ("Enumerator exceeds the C integer type at %C");
10153 /* Control comes here, if it's the very first enumerator and no
10154 initializer has been given. It will be initialized to zero. */
10155 mpz_set_si (result
->value
.integer
, 0);
10162 /* Match a variable name with an optional initializer. When this
10163 subroutine is called, a variable is expected to be parsed next.
10164 Depending on what is happening at the moment, updates either the
10165 symbol table or the current interface. */
10168 enumerator_decl (void)
10170 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10171 gfc_expr
*initializer
;
10172 gfc_array_spec
*as
= NULL
;
10179 initializer
= NULL
;
10180 old_locus
= gfc_current_locus
;
10182 /* When we get here, we've just matched a list of attributes and
10183 maybe a type and a double colon. The next thing we expect to see
10184 is the name of the symbol. */
10185 m
= gfc_match_name (name
);
10186 if (m
!= MATCH_YES
)
10189 var_locus
= gfc_current_locus
;
10191 /* OK, we've successfully matched the declaration. Now put the
10192 symbol in the current namespace. If we fail to create the symbol,
10194 if (!build_sym (name
, NULL
, false, &as
, &var_locus
))
10200 /* The double colon must be present in order to have initializers.
10201 Otherwise the statement is ambiguous with an assignment statement. */
10204 if (gfc_match_char ('=') == MATCH_YES
)
10206 m
= gfc_match_init_expr (&initializer
);
10209 gfc_error ("Expected an initialization expression at %C");
10213 if (m
!= MATCH_YES
)
10218 /* If we do not have an initializer, the initialization value of the
10219 previous enumerator (stored in last_initializer) is incremented
10220 by 1 and is used to initialize the current enumerator. */
10221 if (initializer
== NULL
)
10222 initializer
= enum_initializer (last_initializer
, old_locus
);
10224 if (initializer
== NULL
|| initializer
->ts
.type
!= BT_INTEGER
)
10226 gfc_error ("ENUMERATOR %L not initialized with integer expression",
10232 /* Store this current initializer, for the next enumerator variable
10233 to be parsed. add_init_expr_to_sym() zeros initializer, so we
10234 use last_initializer below. */
10235 last_initializer
= initializer
;
10236 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
10238 /* Maintain enumerator history. */
10239 gfc_find_symbol (name
, NULL
, 0, &sym
);
10240 create_enum_history (sym
, last_initializer
);
10242 return (t
) ? MATCH_YES
: MATCH_ERROR
;
10245 /* Free stuff up and return. */
10246 gfc_free_expr (initializer
);
10252 /* Match the enumerator definition statement. */
10255 gfc_match_enumerator_def (void)
10260 gfc_clear_ts (¤t_ts
);
10262 m
= gfc_match (" enumerator");
10263 if (m
!= MATCH_YES
)
10266 m
= gfc_match (" :: ");
10267 if (m
== MATCH_ERROR
)
10270 colon_seen
= (m
== MATCH_YES
);
10272 if (gfc_current_state () != COMP_ENUM
)
10274 gfc_error ("ENUM definition statement expected before %C");
10275 gfc_free_enum_history ();
10276 return MATCH_ERROR
;
10279 (¤t_ts
)->type
= BT_INTEGER
;
10280 (¤t_ts
)->kind
= gfc_c_int_kind
;
10282 gfc_clear_attr (¤t_attr
);
10283 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, NULL
);
10292 m
= enumerator_decl ();
10293 if (m
== MATCH_ERROR
)
10295 gfc_free_enum_history ();
10301 if (gfc_match_eos () == MATCH_YES
)
10303 if (gfc_match_char (',') != MATCH_YES
)
10307 if (gfc_current_state () == COMP_ENUM
)
10309 gfc_free_enum_history ();
10310 gfc_error ("Syntax error in ENUMERATOR definition at %C");
10315 gfc_free_array_spec (current_as
);
10322 /* Match binding attributes. */
10325 match_binding_attributes (gfc_typebound_proc
* ba
, bool generic
, bool ppc
)
10327 bool found_passing
= false;
10328 bool seen_ptr
= false;
10329 match m
= MATCH_YES
;
10331 /* Initialize to defaults. Do so even before the MATCH_NO check so that in
10332 this case the defaults are in there. */
10333 ba
->access
= ACCESS_UNKNOWN
;
10334 ba
->pass_arg
= NULL
;
10335 ba
->pass_arg_num
= 0;
10337 ba
->non_overridable
= 0;
10341 /* If we find a comma, we believe there are binding attributes. */
10342 m
= gfc_match_char (',');
10348 /* Access specifier. */
10350 m
= gfc_match (" public");
10351 if (m
== MATCH_ERROR
)
10353 if (m
== MATCH_YES
)
10355 if (ba
->access
!= ACCESS_UNKNOWN
)
10357 gfc_error ("Duplicate access-specifier at %C");
10361 ba
->access
= ACCESS_PUBLIC
;
10365 m
= gfc_match (" private");
10366 if (m
== MATCH_ERROR
)
10368 if (m
== MATCH_YES
)
10370 if (ba
->access
!= ACCESS_UNKNOWN
)
10372 gfc_error ("Duplicate access-specifier at %C");
10376 ba
->access
= ACCESS_PRIVATE
;
10380 /* If inside GENERIC, the following is not allowed. */
10385 m
= gfc_match (" nopass");
10386 if (m
== MATCH_ERROR
)
10388 if (m
== MATCH_YES
)
10392 gfc_error ("Binding attributes already specify passing,"
10393 " illegal NOPASS at %C");
10397 found_passing
= true;
10402 /* PASS possibly including argument. */
10403 m
= gfc_match (" pass");
10404 if (m
== MATCH_ERROR
)
10406 if (m
== MATCH_YES
)
10408 char arg
[GFC_MAX_SYMBOL_LEN
+ 1];
10412 gfc_error ("Binding attributes already specify passing,"
10413 " illegal PASS at %C");
10417 m
= gfc_match (" ( %n )", arg
);
10418 if (m
== MATCH_ERROR
)
10420 if (m
== MATCH_YES
)
10421 ba
->pass_arg
= gfc_get_string ("%s", arg
);
10422 gcc_assert ((m
== MATCH_YES
) == (ba
->pass_arg
!= NULL
));
10424 found_passing
= true;
10431 /* POINTER flag. */
10432 m
= gfc_match (" pointer");
10433 if (m
== MATCH_ERROR
)
10435 if (m
== MATCH_YES
)
10439 gfc_error ("Duplicate POINTER attribute at %C");
10449 /* NON_OVERRIDABLE flag. */
10450 m
= gfc_match (" non_overridable");
10451 if (m
== MATCH_ERROR
)
10453 if (m
== MATCH_YES
)
10455 if (ba
->non_overridable
)
10457 gfc_error ("Duplicate NON_OVERRIDABLE at %C");
10461 ba
->non_overridable
= 1;
10465 /* DEFERRED flag. */
10466 m
= gfc_match (" deferred");
10467 if (m
== MATCH_ERROR
)
10469 if (m
== MATCH_YES
)
10473 gfc_error ("Duplicate DEFERRED at %C");
10484 /* Nothing matching found. */
10486 gfc_error ("Expected access-specifier at %C");
10488 gfc_error ("Expected binding attribute at %C");
10491 while (gfc_match_char (',') == MATCH_YES
);
10493 /* NON_OVERRIDABLE and DEFERRED exclude themselves. */
10494 if (ba
->non_overridable
&& ba
->deferred
)
10496 gfc_error ("NON_OVERRIDABLE and DEFERRED can't both appear at %C");
10503 if (ba
->access
== ACCESS_UNKNOWN
)
10504 ba
->access
= gfc_typebound_default_access
;
10506 if (ppc
&& !seen_ptr
)
10508 gfc_error ("POINTER attribute is required for procedure pointer component"
10516 return MATCH_ERROR
;
10520 /* Match a PROCEDURE specific binding inside a derived type. */
10523 match_procedure_in_type (void)
10525 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10526 char target_buf
[GFC_MAX_SYMBOL_LEN
+ 1];
10527 char* target
= NULL
, *ifc
= NULL
;
10528 gfc_typebound_proc tb
;
10532 gfc_symtree
* stree
;
10537 /* Check current state. */
10538 gcc_assert (gfc_state_stack
->state
== COMP_DERIVED_CONTAINS
);
10539 block
= gfc_state_stack
->previous
->sym
;
10540 gcc_assert (block
);
10542 /* Try to match PROCEDURE(interface). */
10543 if (gfc_match (" (") == MATCH_YES
)
10545 m
= gfc_match_name (target_buf
);
10546 if (m
== MATCH_ERROR
)
10548 if (m
!= MATCH_YES
)
10550 gfc_error ("Interface-name expected after %<(%> at %C");
10551 return MATCH_ERROR
;
10554 if (gfc_match (" )") != MATCH_YES
)
10556 gfc_error ("%<)%> expected at %C");
10557 return MATCH_ERROR
;
10563 /* Construct the data structure. */
10564 memset (&tb
, 0, sizeof (tb
));
10565 tb
.where
= gfc_current_locus
;
10567 /* Match binding attributes. */
10568 m
= match_binding_attributes (&tb
, false, false);
10569 if (m
== MATCH_ERROR
)
10571 seen_attrs
= (m
== MATCH_YES
);
10573 /* Check that attribute DEFERRED is given if an interface is specified. */
10574 if (tb
.deferred
&& !ifc
)
10576 gfc_error ("Interface must be specified for DEFERRED binding at %C");
10577 return MATCH_ERROR
;
10579 if (ifc
&& !tb
.deferred
)
10581 gfc_error ("PROCEDURE(interface) at %C should be declared DEFERRED");
10582 return MATCH_ERROR
;
10585 /* Match the colons. */
10586 m
= gfc_match (" ::");
10587 if (m
== MATCH_ERROR
)
10589 seen_colons
= (m
== MATCH_YES
);
10590 if (seen_attrs
&& !seen_colons
)
10592 gfc_error ("Expected %<::%> after binding-attributes at %C");
10593 return MATCH_ERROR
;
10596 /* Match the binding names. */
10599 m
= gfc_match_name (name
);
10600 if (m
== MATCH_ERROR
)
10604 gfc_error ("Expected binding name at %C");
10605 return MATCH_ERROR
;
10608 if (num
>1 && !gfc_notify_std (GFC_STD_F2008
, "PROCEDURE list at %C"))
10609 return MATCH_ERROR
;
10611 /* Try to match the '=> target', if it's there. */
10613 m
= gfc_match (" =>");
10614 if (m
== MATCH_ERROR
)
10616 if (m
== MATCH_YES
)
10620 gfc_error ("%<=> target%> is invalid for DEFERRED binding at %C");
10621 return MATCH_ERROR
;
10626 gfc_error ("%<::%> needed in PROCEDURE binding with explicit target"
10628 return MATCH_ERROR
;
10631 m
= gfc_match_name (target_buf
);
10632 if (m
== MATCH_ERROR
)
10636 gfc_error ("Expected binding target after %<=>%> at %C");
10637 return MATCH_ERROR
;
10639 target
= target_buf
;
10642 /* If no target was found, it has the same name as the binding. */
10646 /* Get the namespace to insert the symbols into. */
10647 ns
= block
->f2k_derived
;
10650 /* If the binding is DEFERRED, check that the containing type is ABSTRACT. */
10651 if (tb
.deferred
&& !block
->attr
.abstract
)
10653 gfc_error ("Type %qs containing DEFERRED binding at %C "
10654 "is not ABSTRACT", block
->name
);
10655 return MATCH_ERROR
;
10658 /* See if we already have a binding with this name in the symtree which
10659 would be an error. If a GENERIC already targeted this binding, it may
10660 be already there but then typebound is still NULL. */
10661 stree
= gfc_find_symtree (ns
->tb_sym_root
, name
);
10662 if (stree
&& stree
->n
.tb
)
10664 gfc_error ("There is already a procedure with binding name %qs for "
10665 "the derived type %qs at %C", name
, block
->name
);
10666 return MATCH_ERROR
;
10669 /* Insert it and set attributes. */
10673 stree
= gfc_new_symtree (&ns
->tb_sym_root
, name
);
10674 gcc_assert (stree
);
10676 stree
->n
.tb
= gfc_get_typebound_proc (&tb
);
10678 if (gfc_get_sym_tree (target
, gfc_current_ns
, &stree
->n
.tb
->u
.specific
,
10680 return MATCH_ERROR
;
10681 gfc_set_sym_referenced (stree
->n
.tb
->u
.specific
->n
.sym
);
10682 gfc_add_flavor(&stree
->n
.tb
->u
.specific
->n
.sym
->attr
, FL_PROCEDURE
,
10683 target
, &stree
->n
.tb
->u
.specific
->n
.sym
->declared_at
);
10685 if (gfc_match_eos () == MATCH_YES
)
10687 if (gfc_match_char (',') != MATCH_YES
)
10692 gfc_error ("Syntax error in PROCEDURE statement at %C");
10693 return MATCH_ERROR
;
10697 /* Match a GENERIC procedure binding inside a derived type. */
10700 gfc_match_generic (void)
10702 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10703 char bind_name
[GFC_MAX_SYMBOL_LEN
+ 16]; /* Allow space for OPERATOR(...). */
10705 gfc_typebound_proc tbattr
; /* Used for match_binding_attributes. */
10706 gfc_typebound_proc
* tb
;
10708 interface_type op_type
;
10709 gfc_intrinsic_op op
;
10712 /* Check current state. */
10713 if (gfc_current_state () == COMP_DERIVED
)
10715 gfc_error ("GENERIC at %C must be inside a derived-type CONTAINS");
10716 return MATCH_ERROR
;
10718 if (gfc_current_state () != COMP_DERIVED_CONTAINS
)
10720 block
= gfc_state_stack
->previous
->sym
;
10721 ns
= block
->f2k_derived
;
10722 gcc_assert (block
&& ns
);
10724 memset (&tbattr
, 0, sizeof (tbattr
));
10725 tbattr
.where
= gfc_current_locus
;
10727 /* See if we get an access-specifier. */
10728 m
= match_binding_attributes (&tbattr
, true, false);
10729 if (m
== MATCH_ERROR
)
10732 /* Now the colons, those are required. */
10733 if (gfc_match (" ::") != MATCH_YES
)
10735 gfc_error ("Expected %<::%> at %C");
10739 /* Match the binding name; depending on type (operator / generic) format
10740 it for future error messages into bind_name. */
10742 m
= gfc_match_generic_spec (&op_type
, name
, &op
);
10743 if (m
== MATCH_ERROR
)
10744 return MATCH_ERROR
;
10747 gfc_error ("Expected generic name or operator descriptor at %C");
10753 case INTERFACE_GENERIC
:
10754 case INTERFACE_DTIO
:
10755 snprintf (bind_name
, sizeof (bind_name
), "%s", name
);
10758 case INTERFACE_USER_OP
:
10759 snprintf (bind_name
, sizeof (bind_name
), "OPERATOR(.%s.)", name
);
10762 case INTERFACE_INTRINSIC_OP
:
10763 snprintf (bind_name
, sizeof (bind_name
), "OPERATOR(%s)",
10764 gfc_op2string (op
));
10767 case INTERFACE_NAMELESS
:
10768 gfc_error ("Malformed GENERIC statement at %C");
10773 gcc_unreachable ();
10776 /* Match the required =>. */
10777 if (gfc_match (" =>") != MATCH_YES
)
10779 gfc_error ("Expected %<=>%> at %C");
10783 /* Try to find existing GENERIC binding with this name / for this operator;
10784 if there is something, check that it is another GENERIC and then extend
10785 it rather than building a new node. Otherwise, create it and put it
10786 at the right position. */
10790 case INTERFACE_DTIO
:
10791 case INTERFACE_USER_OP
:
10792 case INTERFACE_GENERIC
:
10794 const bool is_op
= (op_type
== INTERFACE_USER_OP
);
10797 st
= gfc_find_symtree (is_op
? ns
->tb_uop_root
: ns
->tb_sym_root
, name
);
10798 tb
= st
? st
->n
.tb
: NULL
;
10802 case INTERFACE_INTRINSIC_OP
:
10803 tb
= ns
->tb_op
[op
];
10807 gcc_unreachable ();
10812 if (!tb
->is_generic
)
10814 gcc_assert (op_type
== INTERFACE_GENERIC
);
10815 gfc_error ("There's already a non-generic procedure with binding name"
10816 " %qs for the derived type %qs at %C",
10817 bind_name
, block
->name
);
10821 if (tb
->access
!= tbattr
.access
)
10823 gfc_error ("Binding at %C must have the same access as already"
10824 " defined binding %qs", bind_name
);
10830 tb
= gfc_get_typebound_proc (NULL
);
10831 tb
->where
= gfc_current_locus
;
10832 tb
->access
= tbattr
.access
;
10833 tb
->is_generic
= 1;
10834 tb
->u
.generic
= NULL
;
10838 case INTERFACE_DTIO
:
10839 case INTERFACE_GENERIC
:
10840 case INTERFACE_USER_OP
:
10842 const bool is_op
= (op_type
== INTERFACE_USER_OP
);
10843 gfc_symtree
* st
= gfc_get_tbp_symtree (is_op
? &ns
->tb_uop_root
:
10844 &ns
->tb_sym_root
, name
);
10851 case INTERFACE_INTRINSIC_OP
:
10852 ns
->tb_op
[op
] = tb
;
10856 gcc_unreachable ();
10860 /* Now, match all following names as specific targets. */
10863 gfc_symtree
* target_st
;
10864 gfc_tbp_generic
* target
;
10866 m
= gfc_match_name (name
);
10867 if (m
== MATCH_ERROR
)
10871 gfc_error ("Expected specific binding name at %C");
10875 target_st
= gfc_get_tbp_symtree (&ns
->tb_sym_root
, name
);
10877 /* See if this is a duplicate specification. */
10878 for (target
= tb
->u
.generic
; target
; target
= target
->next
)
10879 if (target_st
== target
->specific_st
)
10881 gfc_error ("%qs already defined as specific binding for the"
10882 " generic %qs at %C", name
, bind_name
);
10886 target
= gfc_get_tbp_generic ();
10887 target
->specific_st
= target_st
;
10888 target
->specific
= NULL
;
10889 target
->next
= tb
->u
.generic
;
10890 target
->is_operator
= ((op_type
== INTERFACE_USER_OP
)
10891 || (op_type
== INTERFACE_INTRINSIC_OP
));
10892 tb
->u
.generic
= target
;
10894 while (gfc_match (" ,") == MATCH_YES
);
10896 /* Here should be the end. */
10897 if (gfc_match_eos () != MATCH_YES
)
10899 gfc_error ("Junk after GENERIC binding at %C");
10906 return MATCH_ERROR
;
10910 /* Match a FINAL declaration inside a derived type. */
10913 gfc_match_final_decl (void)
10915 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10918 gfc_namespace
* module_ns
;
10922 if (gfc_current_form
== FORM_FREE
)
10924 char c
= gfc_peek_ascii_char ();
10925 if (!gfc_is_whitespace (c
) && c
!= ':')
10929 if (gfc_state_stack
->state
!= COMP_DERIVED_CONTAINS
)
10931 if (gfc_current_form
== FORM_FIXED
)
10934 gfc_error ("FINAL declaration at %C must be inside a derived type "
10935 "CONTAINS section");
10936 return MATCH_ERROR
;
10939 block
= gfc_state_stack
->previous
->sym
;
10940 gcc_assert (block
);
10942 if (!gfc_state_stack
->previous
|| !gfc_state_stack
->previous
->previous
10943 || gfc_state_stack
->previous
->previous
->state
!= COMP_MODULE
)
10945 gfc_error ("Derived type declaration with FINAL at %C must be in the"
10946 " specification part of a MODULE");
10947 return MATCH_ERROR
;
10950 module_ns
= gfc_current_ns
;
10951 gcc_assert (module_ns
);
10952 gcc_assert (module_ns
->proc_name
->attr
.flavor
== FL_MODULE
);
10954 /* Match optional ::, don't care about MATCH_YES or MATCH_NO. */
10955 if (gfc_match (" ::") == MATCH_ERROR
)
10956 return MATCH_ERROR
;
10958 /* Match the sequence of procedure names. */
10965 if (first
&& gfc_match_eos () == MATCH_YES
)
10967 gfc_error ("Empty FINAL at %C");
10968 return MATCH_ERROR
;
10971 m
= gfc_match_name (name
);
10974 gfc_error ("Expected module procedure name at %C");
10975 return MATCH_ERROR
;
10977 else if (m
!= MATCH_YES
)
10978 return MATCH_ERROR
;
10980 if (gfc_match_eos () == MATCH_YES
)
10982 if (!last
&& gfc_match_char (',') != MATCH_YES
)
10984 gfc_error ("Expected %<,%> at %C");
10985 return MATCH_ERROR
;
10988 if (gfc_get_symbol (name
, module_ns
, &sym
))
10990 gfc_error ("Unknown procedure name %qs at %C", name
);
10991 return MATCH_ERROR
;
10994 /* Mark the symbol as module procedure. */
10995 if (sym
->attr
.proc
!= PROC_MODULE
10996 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
10997 return MATCH_ERROR
;
10999 /* Check if we already have this symbol in the list, this is an error. */
11000 for (f
= block
->f2k_derived
->finalizers
; f
; f
= f
->next
)
11001 if (f
->proc_sym
== sym
)
11003 gfc_error ("%qs at %C is already defined as FINAL procedure",
11005 return MATCH_ERROR
;
11008 /* Add this symbol to the list of finalizers. */
11009 gcc_assert (block
->f2k_derived
);
11011 f
= XCNEW (gfc_finalizer
);
11013 f
->proc_tree
= NULL
;
11014 f
->where
= gfc_current_locus
;
11015 f
->next
= block
->f2k_derived
->finalizers
;
11016 block
->f2k_derived
->finalizers
= f
;
11026 const ext_attr_t ext_attr_list
[] = {
11027 { "dllimport", EXT_ATTR_DLLIMPORT
, "dllimport" },
11028 { "dllexport", EXT_ATTR_DLLEXPORT
, "dllexport" },
11029 { "cdecl", EXT_ATTR_CDECL
, "cdecl" },
11030 { "stdcall", EXT_ATTR_STDCALL
, "stdcall" },
11031 { "fastcall", EXT_ATTR_FASTCALL
, "fastcall" },
11032 { "no_arg_check", EXT_ATTR_NO_ARG_CHECK
, NULL
},
11033 { NULL
, EXT_ATTR_LAST
, NULL
}
11036 /* Match a !GCC$ ATTRIBUTES statement of the form:
11037 !GCC$ ATTRIBUTES attribute-list :: var-name [, var-name] ...
11038 When we come here, we have already matched the !GCC$ ATTRIBUTES string.
11040 TODO: We should support all GCC attributes using the same syntax for
11041 the attribute list, i.e. the list in C
11042 __attributes(( attribute-list ))
11044 !GCC$ ATTRIBUTES attribute-list ::
11045 Cf. c-parser.c's c_parser_attributes; the data can then directly be
11048 As there is absolutely no risk of confusion, we should never return
11051 gfc_match_gcc_attributes (void)
11053 symbol_attribute attr
;
11054 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
11059 gfc_clear_attr (&attr
);
11064 if (gfc_match_name (name
) != MATCH_YES
)
11065 return MATCH_ERROR
;
11067 for (id
= 0; id
< EXT_ATTR_LAST
; id
++)
11068 if (strcmp (name
, ext_attr_list
[id
].name
) == 0)
11071 if (id
== EXT_ATTR_LAST
)
11073 gfc_error ("Unknown attribute in !GCC$ ATTRIBUTES statement at %C");
11074 return MATCH_ERROR
;
11077 if (!gfc_add_ext_attribute (&attr
, (ext_attr_id_t
)id
, &gfc_current_locus
))
11078 return MATCH_ERROR
;
11080 gfc_gobble_whitespace ();
11081 ch
= gfc_next_ascii_char ();
11084 /* This is the successful exit condition for the loop. */
11085 if (gfc_next_ascii_char () == ':')
11095 if (gfc_match_eos () == MATCH_YES
)
11100 m
= gfc_match_name (name
);
11101 if (m
!= MATCH_YES
)
11104 if (find_special (name
, &sym
, true))
11105 return MATCH_ERROR
;
11107 sym
->attr
.ext_attr
|= attr
.ext_attr
;
11109 if (gfc_match_eos () == MATCH_YES
)
11112 if (gfc_match_char (',') != MATCH_YES
)
11119 gfc_error ("Syntax error in !GCC$ ATTRIBUTES statement at %C");
11120 return MATCH_ERROR
;
11124 /* Match a !GCC$ UNROLL statement of the form:
11127 The parameter n is the number of times we are supposed to unroll.
11129 When we come here, we have already matched the !GCC$ UNROLL string. */
11131 gfc_match_gcc_unroll (void)
11135 if (gfc_match_small_int (&value
) == MATCH_YES
)
11137 if (value
< 0 || value
> USHRT_MAX
)
11139 gfc_error ("%<GCC unroll%> directive requires a"
11140 " non-negative integral constant"
11141 " less than or equal to %u at %C",
11144 return MATCH_ERROR
;
11146 if (gfc_match_eos () == MATCH_YES
)
11148 directive_unroll
= value
== 0 ? 1 : value
;
11153 gfc_error ("Syntax error in !GCC$ UNROLL directive at %C");
11154 return MATCH_ERROR
;