1 /* Declaration statement matcher
2 Copyright (C) 2002-2018 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
23 #include "coretypes.h"
27 #include "stringpool.h"
30 #include "constructor.h"
32 /* Macros to access allocate memory for gfc_data_variable,
33 gfc_data_value and gfc_data. */
34 #define gfc_get_data_variable() XCNEW (gfc_data_variable)
35 #define gfc_get_data_value() XCNEW (gfc_data_value)
36 #define gfc_get_data() XCNEW (gfc_data)
39 static bool set_binding_label (const char **, const char *, int);
42 /* This flag is set if an old-style length selector is matched
43 during a type-declaration statement. */
45 static int old_char_selector
;
47 /* When variables acquire types and attributes from a declaration
48 statement, they get them from the following static variables. The
49 first part of a declaration sets these variables and the second
50 part copies these into symbol structures. */
52 static gfc_typespec current_ts
;
54 static symbol_attribute current_attr
;
55 static gfc_array_spec
*current_as
;
56 static int colon_seen
;
59 /* The current binding label (if any). */
60 static const char* curr_binding_label
;
61 /* Need to know how many identifiers are on the current data declaration
62 line in case we're given the BIND(C) attribute with a NAME= specifier. */
63 static int num_idents_on_line
;
64 /* Need to know if a NAME= specifier was found during gfc_match_bind_c so we
65 can supply a name if the curr_binding_label is nil and NAME= was not. */
66 static int has_name_equals
= 0;
68 /* Initializer of the previous enumerator. */
70 static gfc_expr
*last_initializer
;
72 /* History of all the enumerators is maintained, so that
73 kind values of all the enumerators could be updated depending
74 upon the maximum initialized value. */
76 typedef struct enumerator_history
79 gfc_expr
*initializer
;
80 struct enumerator_history
*next
;
84 /* Header of enum history chain. */
86 static enumerator_history
*enum_history
= NULL
;
88 /* Pointer of enum history node containing largest initializer. */
90 static enumerator_history
*max_enum
= NULL
;
92 /* gfc_new_block points to the symbol of a newly matched block. */
94 gfc_symbol
*gfc_new_block
;
96 bool gfc_matching_function
;
98 /* Set upon parsing a !GCC$ unroll n directive for use in the next loop. */
99 int directive_unroll
= -1;
101 /* If a kind expression of a component of a parameterized derived type is
102 parameterized, temporarily store the expression here. */
103 static gfc_expr
*saved_kind_expr
= NULL
;
105 /* Used to store the parameter list arising in a PDT declaration and
106 in the typespec of a PDT variable or component. */
107 static gfc_actual_arglist
*decl_type_param_list
;
108 static gfc_actual_arglist
*type_param_spec_list
;
110 /********************* DATA statement subroutines *********************/
112 static bool in_match_data
= false;
115 gfc_in_match_data (void)
117 return in_match_data
;
121 set_in_match_data (bool set_value
)
123 in_match_data
= set_value
;
126 /* Free a gfc_data_variable structure and everything beneath it. */
129 free_variable (gfc_data_variable
*p
)
131 gfc_data_variable
*q
;
136 gfc_free_expr (p
->expr
);
137 gfc_free_iterator (&p
->iter
, 0);
138 free_variable (p
->list
);
144 /* Free a gfc_data_value structure and everything beneath it. */
147 free_value (gfc_data_value
*p
)
154 mpz_clear (p
->repeat
);
155 gfc_free_expr (p
->expr
);
161 /* Free a list of gfc_data structures. */
164 gfc_free_data (gfc_data
*p
)
171 free_variable (p
->var
);
172 free_value (p
->value
);
178 /* Free all data in a namespace. */
181 gfc_free_data_all (gfc_namespace
*ns
)
193 /* Reject data parsed since the last restore point was marked. */
196 gfc_reject_data (gfc_namespace
*ns
)
200 while (ns
->data
&& ns
->data
!= ns
->old_data
)
208 static match
var_element (gfc_data_variable
*);
210 /* Match a list of variables terminated by an iterator and a right
214 var_list (gfc_data_variable
*parent
)
216 gfc_data_variable
*tail
, var
;
219 m
= var_element (&var
);
220 if (m
== MATCH_ERROR
)
225 tail
= gfc_get_data_variable ();
232 if (gfc_match_char (',') != MATCH_YES
)
235 m
= gfc_match_iterator (&parent
->iter
, 1);
238 if (m
== MATCH_ERROR
)
241 m
= var_element (&var
);
242 if (m
== MATCH_ERROR
)
247 tail
->next
= gfc_get_data_variable ();
253 if (gfc_match_char (')') != MATCH_YES
)
258 gfc_syntax_error (ST_DATA
);
263 /* Match a single element in a data variable list, which can be a
264 variable-iterator list. */
267 var_element (gfc_data_variable
*new_var
)
272 memset (new_var
, 0, sizeof (gfc_data_variable
));
274 if (gfc_match_char ('(') == MATCH_YES
)
275 return var_list (new_var
);
277 m
= gfc_match_variable (&new_var
->expr
, 0);
281 sym
= new_var
->expr
->symtree
->n
.sym
;
283 /* Symbol should already have an associated type. */
284 if (!gfc_check_symbol_typed (sym
, gfc_current_ns
, false, gfc_current_locus
))
287 if (!sym
->attr
.function
&& gfc_current_ns
->parent
288 && gfc_current_ns
->parent
== sym
->ns
)
290 gfc_error ("Host associated variable %qs may not be in the DATA "
291 "statement at %C", sym
->name
);
295 if (gfc_current_state () != COMP_BLOCK_DATA
296 && sym
->attr
.in_common
297 && !gfc_notify_std (GFC_STD_GNU
, "initialization of "
298 "common block variable %qs in DATA statement at %C",
302 if (!gfc_add_data (&sym
->attr
, sym
->name
, &new_var
->expr
->where
))
309 /* Match the top-level list of data variables. */
312 top_var_list (gfc_data
*d
)
314 gfc_data_variable var
, *tail
, *new_var
;
321 m
= var_element (&var
);
324 if (m
== MATCH_ERROR
)
327 new_var
= gfc_get_data_variable ();
333 tail
->next
= new_var
;
337 if (gfc_match_char ('/') == MATCH_YES
)
339 if (gfc_match_char (',') != MATCH_YES
)
346 gfc_syntax_error (ST_DATA
);
347 gfc_free_data_all (gfc_current_ns
);
353 match_data_constant (gfc_expr
**result
)
355 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
356 gfc_symbol
*sym
, *dt_sym
= NULL
;
361 m
= gfc_match_literal_constant (&expr
, 1);
368 if (m
== MATCH_ERROR
)
371 m
= gfc_match_null (result
);
375 old_loc
= gfc_current_locus
;
377 /* Should this be a structure component, try to match it
378 before matching a name. */
379 m
= gfc_match_rvalue (result
);
380 if (m
== MATCH_ERROR
)
383 if (m
== MATCH_YES
&& (*result
)->expr_type
== EXPR_STRUCTURE
)
385 if (!gfc_simplify_expr (*result
, 0))
389 else if (m
== MATCH_YES
)
390 gfc_free_expr (*result
);
392 gfc_current_locus
= old_loc
;
394 m
= gfc_match_name (name
);
398 if (gfc_find_symbol (name
, NULL
, 1, &sym
))
401 if (sym
&& sym
->attr
.generic
)
402 dt_sym
= gfc_find_dt_in_generic (sym
);
405 || (sym
->attr
.flavor
!= FL_PARAMETER
406 && (!dt_sym
|| !gfc_fl_struct (dt_sym
->attr
.flavor
))))
408 gfc_error ("Symbol %qs must be a PARAMETER in DATA statement at %C",
413 else if (dt_sym
&& gfc_fl_struct (dt_sym
->attr
.flavor
))
414 return gfc_match_structure_constructor (dt_sym
, result
);
416 /* Check to see if the value is an initialization array expression. */
417 if (sym
->value
->expr_type
== EXPR_ARRAY
)
419 gfc_current_locus
= old_loc
;
421 m
= gfc_match_init_expr (result
);
422 if (m
== MATCH_ERROR
)
427 if (!gfc_simplify_expr (*result
, 0))
430 if ((*result
)->expr_type
== EXPR_CONSTANT
)
434 gfc_error ("Invalid initializer %s in Data statement at %C", name
);
440 *result
= gfc_copy_expr (sym
->value
);
445 /* Match a list of values in a DATA statement. The leading '/' has
446 already been seen at this point. */
449 top_val_list (gfc_data
*data
)
451 gfc_data_value
*new_val
, *tail
;
459 m
= match_data_constant (&expr
);
462 if (m
== MATCH_ERROR
)
465 new_val
= gfc_get_data_value ();
466 mpz_init (new_val
->repeat
);
469 data
->value
= new_val
;
471 tail
->next
= new_val
;
475 if (expr
->ts
.type
!= BT_INTEGER
|| gfc_match_char ('*') != MATCH_YES
)
478 mpz_set_ui (tail
->repeat
, 1);
482 mpz_set (tail
->repeat
, expr
->value
.integer
);
483 gfc_free_expr (expr
);
485 m
= match_data_constant (&tail
->expr
);
488 if (m
== MATCH_ERROR
)
492 if (gfc_match_char ('/') == MATCH_YES
)
494 if (gfc_match_char (',') == MATCH_NO
)
501 gfc_syntax_error (ST_DATA
);
502 gfc_free_data_all (gfc_current_ns
);
507 /* Matches an old style initialization. */
510 match_old_style_init (const char *name
)
517 /* Set up data structure to hold initializers. */
518 gfc_find_sym_tree (name
, NULL
, 0, &st
);
521 newdata
= gfc_get_data ();
522 newdata
->var
= gfc_get_data_variable ();
523 newdata
->var
->expr
= gfc_get_variable_expr (st
);
524 newdata
->where
= gfc_current_locus
;
526 /* Match initial value list. This also eats the terminal '/'. */
527 m
= top_val_list (newdata
);
536 gfc_error ("Initialization at %C is not allowed in a PURE procedure");
540 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
542 /* Mark the variable as having appeared in a data statement. */
543 if (!gfc_add_data (&sym
->attr
, sym
->name
, &sym
->declared_at
))
549 /* Chain in namespace list of DATA initializers. */
550 newdata
->next
= gfc_current_ns
->data
;
551 gfc_current_ns
->data
= newdata
;
557 /* Match the stuff following a DATA statement. If ERROR_FLAG is set,
558 we are matching a DATA statement and are therefore issuing an error
559 if we encounter something unexpected, if not, we're trying to match
560 an old-style initialization expression of the form INTEGER I /2/. */
563 gfc_match_data (void)
568 /* Before parsing the rest of a DATA statement, check F2008:c1206. */
569 if ((gfc_current_state () == COMP_FUNCTION
570 || gfc_current_state () == COMP_SUBROUTINE
)
571 && gfc_state_stack
->previous
->state
== COMP_INTERFACE
)
573 gfc_error ("DATA statement at %C cannot appear within an INTERFACE");
577 set_in_match_data (true);
581 new_data
= gfc_get_data ();
582 new_data
->where
= gfc_current_locus
;
584 m
= top_var_list (new_data
);
588 if (new_data
->var
->iter
.var
589 && new_data
->var
->iter
.var
->ts
.type
== BT_INTEGER
590 && new_data
->var
->iter
.var
->symtree
->n
.sym
->attr
.implied_index
== 1
591 && new_data
->var
->list
592 && new_data
->var
->list
->expr
593 && new_data
->var
->list
->expr
->ts
.type
== BT_CHARACTER
594 && new_data
->var
->list
->expr
->ref
595 && new_data
->var
->list
->expr
->ref
->type
== REF_SUBSTRING
)
597 gfc_error ("Invalid substring in data-implied-do at %L in DATA "
598 "statement", &new_data
->var
->list
->expr
->where
);
602 m
= top_val_list (new_data
);
606 new_data
->next
= gfc_current_ns
->data
;
607 gfc_current_ns
->data
= new_data
;
609 if (gfc_match_eos () == MATCH_YES
)
612 gfc_match_char (','); /* Optional comma */
615 set_in_match_data (false);
619 gfc_error ("DATA statement at %C is not allowed in a PURE procedure");
622 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
627 set_in_match_data (false);
628 gfc_free_data (new_data
);
633 /************************ Declaration statements *********************/
636 /* Like gfc_match_init_expr, but matches a 'clist' (old-style initialization
637 list). The difference here is the expression is a list of constants
638 and is surrounded by '/'.
639 The typespec ts must match the typespec of the variable which the
640 clist is initializing.
641 The arrayspec tells whether this should match a list of constants
642 corresponding to array elements or a scalar (as == NULL). */
645 match_clist_expr (gfc_expr
**result
, gfc_typespec
*ts
, gfc_array_spec
*as
)
647 gfc_constructor_base array_head
= NULL
;
648 gfc_expr
*expr
= NULL
;
651 mpz_t repeat
, cons_size
, as_size
;
657 mpz_init_set_ui (repeat
, 0);
658 scalar
= !as
|| !as
->rank
;
660 /* We have already matched '/' - now look for a constant list, as with
661 top_val_list from decl.c, but append the result to an array. */
662 if (gfc_match ("/") == MATCH_YES
)
664 gfc_error ("Empty old style initializer list at %C");
668 where
= gfc_current_locus
;
671 m
= match_data_constant (&expr
);
673 expr
= NULL
; /* match_data_constant may set expr to garbage */
676 if (m
== MATCH_ERROR
)
679 /* Found r in repeat spec r*c; look for the constant to repeat. */
680 if ( gfc_match_char ('*') == MATCH_YES
)
684 gfc_error ("Repeat spec invalid in scalar initializer at %C");
687 if (expr
->ts
.type
!= BT_INTEGER
)
689 gfc_error ("Repeat spec must be an integer at %C");
692 mpz_set (repeat
, expr
->value
.integer
);
693 gfc_free_expr (expr
);
696 m
= match_data_constant (&expr
);
698 gfc_error ("Expected data constant after repeat spec at %C");
702 /* No repeat spec, we matched the data constant itself. */
704 mpz_set_ui (repeat
, 1);
708 /* Add the constant initializer as many times as repeated. */
709 for (; mpz_cmp_ui (repeat
, 0) > 0; mpz_sub_ui (repeat
, repeat
, 1))
711 /* Make sure types of elements match */
712 if(ts
&& !gfc_compare_types (&expr
->ts
, ts
)
713 && !gfc_convert_type (expr
, ts
, 1))
716 gfc_constructor_append_expr (&array_head
,
717 gfc_copy_expr (expr
), &gfc_current_locus
);
720 gfc_free_expr (expr
);
724 /* For scalar initializers quit after one element. */
727 if(gfc_match_char ('/') != MATCH_YES
)
729 gfc_error ("End of scalar initializer expected at %C");
735 if (gfc_match_char ('/') == MATCH_YES
)
737 if (gfc_match_char (',') == MATCH_NO
)
741 /* Set up expr as an array constructor. */
744 expr
= gfc_get_array_expr (ts
->type
, ts
->kind
, &where
);
746 expr
->value
.constructor
= array_head
;
748 expr
->rank
= as
->rank
;
749 expr
->shape
= gfc_get_shape (expr
->rank
);
751 /* Validate sizes. We built expr ourselves, so cons_size will be
752 constant (we fail above for non-constant expressions).
753 We still need to verify that the array-spec has constant size. */
755 gcc_assert (gfc_array_size (expr
, &cons_size
));
756 if (!spec_size (as
, &as_size
))
758 gfc_error ("Expected constant array-spec in initializer list at %L",
759 as
->type
== AS_EXPLICIT
? &as
->upper
[0]->where
: &where
);
764 /* Make sure the specs are of the same size. */
765 cmp
= mpz_cmp (cons_size
, as_size
);
767 gfc_error ("Not enough elements in array initializer at %C");
769 gfc_error ("Too many elements in array initializer at %C");
772 mpz_clear (cons_size
);
777 /* Make sure scalar types match. */
778 else if (!gfc_compare_types (&expr
->ts
, ts
)
779 && !gfc_convert_type (expr
, ts
, 1))
783 expr
->ts
.u
.cl
->length_from_typespec
= 1;
790 gfc_error ("Syntax error in old style initializer list at %C");
794 expr
->value
.constructor
= NULL
;
795 gfc_free_expr (expr
);
796 gfc_constructor_free (array_head
);
802 /* Auxiliary function to merge DIMENSION and CODIMENSION array specs. */
805 merge_array_spec (gfc_array_spec
*from
, gfc_array_spec
*to
, bool copy
)
809 if ((from
->type
== AS_ASSUMED_RANK
&& to
->corank
)
810 || (to
->type
== AS_ASSUMED_RANK
&& from
->corank
))
812 gfc_error ("The assumed-rank array at %C shall not have a codimension");
816 if (to
->rank
== 0 && from
->rank
> 0)
818 to
->rank
= from
->rank
;
819 to
->type
= from
->type
;
820 to
->cray_pointee
= from
->cray_pointee
;
821 to
->cp_was_assumed
= from
->cp_was_assumed
;
823 for (i
= 0; i
< to
->corank
; i
++)
825 /* Do not exceed the limits on lower[] and upper[]. gfortran
826 cleans up elsewhere. */
828 if (j
>= GFC_MAX_DIMENSIONS
)
831 to
->lower
[j
] = to
->lower
[i
];
832 to
->upper
[j
] = to
->upper
[i
];
834 for (i
= 0; i
< from
->rank
; i
++)
838 to
->lower
[i
] = gfc_copy_expr (from
->lower
[i
]);
839 to
->upper
[i
] = gfc_copy_expr (from
->upper
[i
]);
843 to
->lower
[i
] = from
->lower
[i
];
844 to
->upper
[i
] = from
->upper
[i
];
848 else if (to
->corank
== 0 && from
->corank
> 0)
850 to
->corank
= from
->corank
;
851 to
->cotype
= from
->cotype
;
853 for (i
= 0; i
< from
->corank
; i
++)
855 /* Do not exceed the limits on lower[] and upper[]. gfortran
856 cleans up elsewhere. */
858 if (j
>= GFC_MAX_DIMENSIONS
)
863 to
->lower
[j
] = gfc_copy_expr (from
->lower
[i
]);
864 to
->upper
[j
] = gfc_copy_expr (from
->upper
[i
]);
868 to
->lower
[j
] = from
->lower
[i
];
869 to
->upper
[j
] = from
->upper
[i
];
874 if (to
->rank
+ to
->corank
> GFC_MAX_DIMENSIONS
)
876 gfc_error ("Sum of array rank %d and corank %d at %C exceeds maximum "
877 "allowed dimensions of %d",
878 to
->rank
, to
->corank
, GFC_MAX_DIMENSIONS
);
879 to
->corank
= GFC_MAX_DIMENSIONS
- to
->rank
;
886 /* Match an intent specification. Since this can only happen after an
887 INTENT word, a legal intent-spec must follow. */
890 match_intent_spec (void)
893 if (gfc_match (" ( in out )") == MATCH_YES
)
895 if (gfc_match (" ( in )") == MATCH_YES
)
897 if (gfc_match (" ( out )") == MATCH_YES
)
900 gfc_error ("Bad INTENT specification at %C");
901 return INTENT_UNKNOWN
;
905 /* Matches a character length specification, which is either a
906 specification expression, '*', or ':'. */
909 char_len_param_value (gfc_expr
**expr
, bool *deferred
)
916 if (gfc_match_char ('*') == MATCH_YES
)
919 if (gfc_match_char (':') == MATCH_YES
)
921 if (!gfc_notify_std (GFC_STD_F2003
, "deferred type parameter at %C"))
929 m
= gfc_match_expr (expr
);
931 if (m
== MATCH_NO
|| m
== MATCH_ERROR
)
934 if (!gfc_expr_check_typed (*expr
, gfc_current_ns
, false))
937 if ((*expr
)->expr_type
== EXPR_FUNCTION
)
939 if ((*expr
)->ts
.type
== BT_INTEGER
940 || ((*expr
)->ts
.type
== BT_UNKNOWN
941 && strcmp((*expr
)->symtree
->name
, "null") != 0))
946 else if ((*expr
)->expr_type
== EXPR_CONSTANT
)
948 /* F2008, 4.4.3.1: The length is a type parameter; its kind is
949 processor dependent and its value is greater than or equal to zero.
950 F2008, 4.4.3.2: If the character length parameter value evaluates
951 to a negative value, the length of character entities declared
954 if ((*expr
)->ts
.type
== BT_INTEGER
)
956 if (mpz_cmp_si ((*expr
)->value
.integer
, 0) < 0)
957 mpz_set_si ((*expr
)->value
.integer
, 0);
962 else if ((*expr
)->expr_type
== EXPR_ARRAY
)
964 else if ((*expr
)->expr_type
== EXPR_VARIABLE
)
969 e
= gfc_copy_expr (*expr
);
971 /* This catches the invalid code "[character(m(2:3)) :: 'x', 'y']",
972 which causes an ICE if gfc_reduce_init_expr() is called. */
973 if (e
->ref
&& e
->ref
->type
== REF_ARRAY
974 && e
->ref
->u
.ar
.type
== AR_UNKNOWN
975 && e
->ref
->u
.ar
.dimen_type
[0] == DIMEN_RANGE
)
978 t
= gfc_reduce_init_expr (e
);
980 if (!t
&& e
->ts
.type
== BT_UNKNOWN
981 && e
->symtree
->n
.sym
->attr
.untyped
== 1
982 && (flag_implicit_none
983 || e
->symtree
->n
.sym
->ns
->seen_implicit_none
== 1
984 || e
->symtree
->n
.sym
->ns
->parent
->seen_implicit_none
== 1))
990 if ((e
->ref
&& e
->ref
->type
== REF_ARRAY
991 && e
->ref
->u
.ar
.type
!= AR_ELEMENT
)
992 || (!e
->ref
&& e
->expr_type
== EXPR_ARRAY
))
1004 gfc_error ("Scalar INTEGER expression expected at %L", &(*expr
)->where
);
1009 /* A character length is a '*' followed by a literal integer or a
1010 char_len_param_value in parenthesis. */
1013 match_char_length (gfc_expr
**expr
, bool *deferred
, bool obsolescent_check
)
1019 m
= gfc_match_char ('*');
1023 m
= gfc_match_small_literal_int (&length
, NULL
);
1024 if (m
== MATCH_ERROR
)
1029 if (obsolescent_check
1030 && !gfc_notify_std (GFC_STD_F95_OBS
, "Old-style character length at %C"))
1032 *expr
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
, length
);
1036 if (gfc_match_char ('(') == MATCH_NO
)
1039 m
= char_len_param_value (expr
, deferred
);
1040 if (m
!= MATCH_YES
&& gfc_matching_function
)
1042 gfc_undo_symbols ();
1046 if (m
== MATCH_ERROR
)
1051 if (gfc_match_char (')') == MATCH_NO
)
1053 gfc_free_expr (*expr
);
1061 gfc_error ("Syntax error in character length specification at %C");
1066 /* Special subroutine for finding a symbol. Check if the name is found
1067 in the current name space. If not, and we're compiling a function or
1068 subroutine and the parent compilation unit is an interface, then check
1069 to see if the name we've been given is the name of the interface
1070 (located in another namespace). */
1073 find_special (const char *name
, gfc_symbol
**result
, bool allow_subroutine
)
1079 i
= gfc_get_sym_tree (name
, NULL
, &st
, allow_subroutine
);
1082 *result
= st
? st
->n
.sym
: NULL
;
1086 if (gfc_current_state () != COMP_SUBROUTINE
1087 && gfc_current_state () != COMP_FUNCTION
)
1090 s
= gfc_state_stack
->previous
;
1094 if (s
->state
!= COMP_INTERFACE
)
1097 goto end
; /* Nameless interface. */
1099 if (strcmp (name
, s
->sym
->name
) == 0)
1110 /* Special subroutine for getting a symbol node associated with a
1111 procedure name, used in SUBROUTINE and FUNCTION statements. The
1112 symbol is created in the parent using with symtree node in the
1113 child unit pointing to the symbol. If the current namespace has no
1114 parent, then the symbol is just created in the current unit. */
1117 get_proc_name (const char *name
, gfc_symbol
**result
, bool module_fcn_entry
)
1123 /* Module functions have to be left in their own namespace because
1124 they have potentially (almost certainly!) already been referenced.
1125 In this sense, they are rather like external functions. This is
1126 fixed up in resolve.c(resolve_entries), where the symbol name-
1127 space is set to point to the master function, so that the fake
1128 result mechanism can work. */
1129 if (module_fcn_entry
)
1131 /* Present if entry is declared to be a module procedure. */
1132 rc
= gfc_find_symbol (name
, gfc_current_ns
->parent
, 0, result
);
1134 if (*result
== NULL
)
1135 rc
= gfc_get_symbol (name
, NULL
, result
);
1136 else if (!gfc_get_symbol (name
, NULL
, &sym
) && sym
1137 && (*result
)->ts
.type
== BT_UNKNOWN
1138 && sym
->attr
.flavor
== FL_UNKNOWN
)
1139 /* Pick up the typespec for the entry, if declared in the function
1140 body. Note that this symbol is FL_UNKNOWN because it will
1141 only have appeared in a type declaration. The local symtree
1142 is set to point to the module symbol and a unique symtree
1143 to the local version. This latter ensures a correct clearing
1146 /* If the ENTRY proceeds its specification, we need to ensure
1147 that this does not raise a "has no IMPLICIT type" error. */
1148 if (sym
->ts
.type
== BT_UNKNOWN
)
1149 sym
->attr
.untyped
= 1;
1151 (*result
)->ts
= sym
->ts
;
1153 /* Put the symbol in the procedure namespace so that, should
1154 the ENTRY precede its specification, the specification
1156 (*result
)->ns
= gfc_current_ns
;
1158 gfc_find_sym_tree (name
, gfc_current_ns
, 0, &st
);
1159 st
->n
.sym
= *result
;
1160 st
= gfc_get_unique_symtree (gfc_current_ns
);
1166 rc
= gfc_get_symbol (name
, gfc_current_ns
->parent
, result
);
1172 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
1175 if (sym
->attr
.module_procedure
1176 && sym
->attr
.if_source
== IFSRC_IFBODY
)
1178 /* Create a partially populated interface symbol to carry the
1179 characteristics of the procedure and the result. */
1180 sym
->tlink
= gfc_new_symbol (name
, sym
->ns
);
1181 gfc_add_type (sym
->tlink
, &(sym
->ts
),
1182 &gfc_current_locus
);
1183 gfc_copy_attr (&sym
->tlink
->attr
, &sym
->attr
, NULL
);
1184 if (sym
->attr
.dimension
)
1185 sym
->tlink
->as
= gfc_copy_array_spec (sym
->as
);
1187 /* Ideally, at this point, a copy would be made of the formal
1188 arguments and their namespace. However, this does not appear
1189 to be necessary, albeit at the expense of not being able to
1190 use gfc_compare_interfaces directly. */
1192 if (sym
->result
&& sym
->result
!= sym
)
1194 sym
->tlink
->result
= sym
->result
;
1197 else if (sym
->result
)
1199 sym
->tlink
->result
= sym
->tlink
;
1202 else if (sym
&& !sym
->gfc_new
1203 && gfc_current_state () != COMP_INTERFACE
)
1205 /* Trap another encompassed procedure with the same name. All
1206 these conditions are necessary to avoid picking up an entry
1207 whose name clashes with that of the encompassing procedure;
1208 this is handled using gsymbols to register unique, globally
1209 accessible names. */
1210 if (sym
->attr
.flavor
!= 0
1211 && sym
->attr
.proc
!= 0
1212 && (sym
->attr
.subroutine
|| sym
->attr
.function
|| sym
->attr
.entry
)
1213 && sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
1214 gfc_error_now ("Procedure %qs at %C is already defined at %L",
1215 name
, &sym
->declared_at
);
1217 if (sym
->attr
.flavor
!= 0
1218 && sym
->attr
.entry
&& sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
1219 gfc_error_now ("Procedure %qs at %C is already defined at %L",
1220 name
, &sym
->declared_at
);
1222 if (sym
->attr
.external
&& sym
->attr
.procedure
1223 && gfc_current_state () == COMP_CONTAINS
)
1224 gfc_error_now ("Contained procedure %qs at %C clashes with "
1225 "procedure defined at %L",
1226 name
, &sym
->declared_at
);
1228 /* Trap a procedure with a name the same as interface in the
1229 encompassing scope. */
1230 if (sym
->attr
.generic
!= 0
1231 && (sym
->attr
.subroutine
|| sym
->attr
.function
)
1232 && !sym
->attr
.mod_proc
)
1233 gfc_error_now ("Name %qs at %C is already defined"
1234 " as a generic interface at %L",
1235 name
, &sym
->declared_at
);
1237 /* Trap declarations of attributes in encompassing scope. The
1238 signature for this is that ts.kind is set. Legitimate
1239 references only set ts.type. */
1240 if (sym
->ts
.kind
!= 0
1241 && !sym
->attr
.implicit_type
1242 && sym
->attr
.proc
== 0
1243 && gfc_current_ns
->parent
!= NULL
1244 && sym
->attr
.access
== 0
1245 && !module_fcn_entry
)
1246 gfc_error_now ("Procedure %qs at %C has an explicit interface "
1247 "and must not have attributes declared at %L",
1248 name
, &sym
->declared_at
);
1251 if (gfc_current_ns
->parent
== NULL
|| *result
== NULL
)
1254 /* Module function entries will already have a symtree in
1255 the current namespace but will need one at module level. */
1256 if (module_fcn_entry
)
1258 /* Present if entry is declared to be a module procedure. */
1259 rc
= gfc_find_sym_tree (name
, gfc_current_ns
->parent
, 0, &st
);
1261 st
= gfc_new_symtree (&gfc_current_ns
->parent
->sym_root
, name
);
1264 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, name
);
1269 /* See if the procedure should be a module procedure. */
1271 if (((sym
->ns
->proc_name
!= NULL
1272 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
1273 && sym
->attr
.proc
!= PROC_MODULE
)
1274 || (module_fcn_entry
&& sym
->attr
.proc
!= PROC_MODULE
))
1275 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
1282 /* Verify that the given symbol representing a parameter is C
1283 interoperable, by checking to see if it was marked as such after
1284 its declaration. If the given symbol is not interoperable, a
1285 warning is reported, thus removing the need to return the status to
1286 the calling function. The standard does not require the user use
1287 one of the iso_c_binding named constants to declare an
1288 interoperable parameter, but we can't be sure if the param is C
1289 interop or not if the user doesn't. For example, integer(4) may be
1290 legal Fortran, but doesn't have meaning in C. It may interop with
1291 a number of the C types, which causes a problem because the
1292 compiler can't know which one. This code is almost certainly not
1293 portable, and the user will get what they deserve if the C type
1294 across platforms isn't always interoperable with integer(4). If
1295 the user had used something like integer(c_int) or integer(c_long),
1296 the compiler could have automatically handled the varying sizes
1297 across platforms. */
1300 gfc_verify_c_interop_param (gfc_symbol
*sym
)
1302 int is_c_interop
= 0;
1305 /* We check implicitly typed variables in symbol.c:gfc_set_default_type().
1306 Don't repeat the checks here. */
1307 if (sym
->attr
.implicit_type
)
1310 /* For subroutines or functions that are passed to a BIND(C) procedure,
1311 they're interoperable if they're BIND(C) and their params are all
1313 if (sym
->attr
.flavor
== FL_PROCEDURE
)
1315 if (sym
->attr
.is_bind_c
== 0)
1317 gfc_error_now ("Procedure %qs at %L must have the BIND(C) "
1318 "attribute to be C interoperable", sym
->name
,
1319 &(sym
->declared_at
));
1324 if (sym
->attr
.is_c_interop
== 1)
1325 /* We've already checked this procedure; don't check it again. */
1328 return verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
1333 /* See if we've stored a reference to a procedure that owns sym. */
1334 if (sym
->ns
!= NULL
&& sym
->ns
->proc_name
!= NULL
)
1336 if (sym
->ns
->proc_name
->attr
.is_bind_c
== 1)
1338 is_c_interop
= (gfc_verify_c_interop(&(sym
->ts
)) ? 1 : 0);
1340 if (is_c_interop
!= 1)
1342 /* Make personalized messages to give better feedback. */
1343 if (sym
->ts
.type
== BT_DERIVED
)
1344 gfc_error ("Variable %qs at %L is a dummy argument to the "
1345 "BIND(C) procedure %qs but is not C interoperable "
1346 "because derived type %qs is not C interoperable",
1347 sym
->name
, &(sym
->declared_at
),
1348 sym
->ns
->proc_name
->name
,
1349 sym
->ts
.u
.derived
->name
);
1350 else if (sym
->ts
.type
== BT_CLASS
)
1351 gfc_error ("Variable %qs at %L is a dummy argument to the "
1352 "BIND(C) procedure %qs but is not C interoperable "
1353 "because it is polymorphic",
1354 sym
->name
, &(sym
->declared_at
),
1355 sym
->ns
->proc_name
->name
);
1356 else if (warn_c_binding_type
)
1357 gfc_warning (OPT_Wc_binding_type
,
1358 "Variable %qs at %L is a dummy argument of the "
1359 "BIND(C) procedure %qs but may not be C "
1361 sym
->name
, &(sym
->declared_at
),
1362 sym
->ns
->proc_name
->name
);
1365 /* Character strings are only C interoperable if they have a
1367 if (sym
->ts
.type
== BT_CHARACTER
)
1369 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
1370 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
1371 || mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
1373 gfc_error ("Character argument %qs at %L "
1374 "must be length 1 because "
1375 "procedure %qs is BIND(C)",
1376 sym
->name
, &sym
->declared_at
,
1377 sym
->ns
->proc_name
->name
);
1382 /* We have to make sure that any param to a bind(c) routine does
1383 not have the allocatable, pointer, or optional attributes,
1384 according to J3/04-007, section 5.1. */
1385 if (sym
->attr
.allocatable
== 1
1386 && !gfc_notify_std (GFC_STD_F2008_TS
, "Variable %qs at %L with "
1387 "ALLOCATABLE attribute in procedure %qs "
1388 "with BIND(C)", sym
->name
,
1389 &(sym
->declared_at
),
1390 sym
->ns
->proc_name
->name
))
1393 if (sym
->attr
.pointer
== 1
1394 && !gfc_notify_std (GFC_STD_F2008_TS
, "Variable %qs at %L with "
1395 "POINTER attribute in procedure %qs "
1396 "with BIND(C)", sym
->name
,
1397 &(sym
->declared_at
),
1398 sym
->ns
->proc_name
->name
))
1401 if ((sym
->attr
.allocatable
|| sym
->attr
.pointer
) && !sym
->as
)
1403 gfc_error ("Scalar variable %qs at %L with POINTER or "
1404 "ALLOCATABLE in procedure %qs with BIND(C) is not yet"
1405 " supported", sym
->name
, &(sym
->declared_at
),
1406 sym
->ns
->proc_name
->name
);
1410 if (sym
->attr
.optional
== 1 && sym
->attr
.value
)
1412 gfc_error ("Variable %qs at %L cannot have both the OPTIONAL "
1413 "and the VALUE attribute because procedure %qs "
1414 "is BIND(C)", sym
->name
, &(sym
->declared_at
),
1415 sym
->ns
->proc_name
->name
);
1418 else if (sym
->attr
.optional
== 1
1419 && !gfc_notify_std (GFC_STD_F2008_TS
, "Variable %qs "
1420 "at %L with OPTIONAL attribute in "
1421 "procedure %qs which is BIND(C)",
1422 sym
->name
, &(sym
->declared_at
),
1423 sym
->ns
->proc_name
->name
))
1426 /* Make sure that if it has the dimension attribute, that it is
1427 either assumed size or explicit shape. Deferred shape is already
1428 covered by the pointer/allocatable attribute. */
1429 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SHAPE
1430 && !gfc_notify_std (GFC_STD_F2008_TS
, "Assumed-shape array %qs "
1431 "at %L as dummy argument to the BIND(C) "
1432 "procedure %qs at %L", sym
->name
,
1433 &(sym
->declared_at
),
1434 sym
->ns
->proc_name
->name
,
1435 &(sym
->ns
->proc_name
->declared_at
)))
1445 /* Function called by variable_decl() that adds a name to the symbol table. */
1448 build_sym (const char *name
, gfc_charlen
*cl
, bool cl_deferred
,
1449 gfc_array_spec
**as
, locus
*var_locus
)
1451 symbol_attribute attr
;
1456 /* Symbols in a submodule are host associated from the parent module or
1457 submodules. Therefore, they can be overridden by declarations in the
1458 submodule scope. Deal with this by attaching the existing symbol to
1459 a new symtree and recycling the old symtree with a new symbol... */
1460 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
1461 if (st
!= NULL
&& gfc_state_stack
->state
== COMP_SUBMODULE
1462 && st
->n
.sym
!= NULL
1463 && st
->n
.sym
->attr
.host_assoc
&& st
->n
.sym
->attr
.used_in_submodule
)
1465 gfc_symtree
*s
= gfc_get_unique_symtree (gfc_current_ns
);
1466 s
->n
.sym
= st
->n
.sym
;
1467 sym
= gfc_new_symbol (name
, gfc_current_ns
);
1472 gfc_set_sym_referenced (sym
);
1474 /* ...Otherwise generate a new symtree and new symbol. */
1475 else if (gfc_get_symbol (name
, NULL
, &sym
))
1478 /* Check if the name has already been defined as a type. The
1479 first letter of the symtree will be in upper case then. Of
1480 course, this is only necessary if the upper case letter is
1481 actually different. */
1483 upper
= TOUPPER(name
[0]);
1484 if (upper
!= name
[0])
1486 char u_name
[GFC_MAX_SYMBOL_LEN
+ 1];
1489 gcc_assert (strlen(name
) <= GFC_MAX_SYMBOL_LEN
);
1490 strcpy (u_name
, name
);
1493 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, u_name
);
1495 /* STRUCTURE types can alias symbol names */
1496 if (st
!= 0 && st
->n
.sym
->attr
.flavor
!= FL_STRUCT
)
1498 gfc_error ("Symbol %qs at %C also declared as a type at %L", name
,
1499 &st
->n
.sym
->declared_at
);
1504 /* Start updating the symbol table. Add basic type attribute if present. */
1505 if (current_ts
.type
!= BT_UNKNOWN
1506 && (sym
->attr
.implicit_type
== 0
1507 || !gfc_compare_types (&sym
->ts
, ¤t_ts
))
1508 && !gfc_add_type (sym
, ¤t_ts
, var_locus
))
1511 if (sym
->ts
.type
== BT_CHARACTER
)
1514 sym
->ts
.deferred
= cl_deferred
;
1517 /* Add dimension attribute if present. */
1518 if (!gfc_set_array_spec (sym
, *as
, var_locus
))
1522 /* Add attribute to symbol. The copy is so that we can reset the
1523 dimension attribute. */
1524 attr
= current_attr
;
1526 attr
.codimension
= 0;
1528 if (!gfc_copy_attr (&sym
->attr
, &attr
, var_locus
))
1531 /* Finish any work that may need to be done for the binding label,
1532 if it's a bind(c). The bind(c) attr is found before the symbol
1533 is made, and before the symbol name (for data decls), so the
1534 current_ts is holding the binding label, or nothing if the
1535 name= attr wasn't given. Therefore, test here if we're dealing
1536 with a bind(c) and make sure the binding label is set correctly. */
1537 if (sym
->attr
.is_bind_c
== 1)
1539 if (!sym
->binding_label
)
1541 /* Set the binding label and verify that if a NAME= was specified
1542 then only one identifier was in the entity-decl-list. */
1543 if (!set_binding_label (&sym
->binding_label
, sym
->name
,
1544 num_idents_on_line
))
1549 /* See if we know we're in a common block, and if it's a bind(c)
1550 common then we need to make sure we're an interoperable type. */
1551 if (sym
->attr
.in_common
== 1)
1553 /* Test the common block object. */
1554 if (sym
->common_block
!= NULL
&& sym
->common_block
->is_bind_c
== 1
1555 && sym
->ts
.is_c_interop
!= 1)
1557 gfc_error_now ("Variable %qs in common block %qs at %C "
1558 "must be declared with a C interoperable "
1559 "kind since common block %qs is BIND(C)",
1560 sym
->name
, sym
->common_block
->name
,
1561 sym
->common_block
->name
);
1566 sym
->attr
.implied_index
= 0;
1568 /* Use the parameter expressions for a parameterized derived type. */
1569 if ((sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
1570 && sym
->ts
.u
.derived
->attr
.pdt_type
&& type_param_spec_list
)
1571 sym
->param_list
= gfc_copy_actual_arglist (type_param_spec_list
);
1573 if (sym
->ts
.type
== BT_CLASS
)
1574 return gfc_build_class_symbol (&sym
->ts
, &sym
->attr
, &sym
->as
);
1580 /* Set character constant to the given length. The constant will be padded or
1581 truncated. If we're inside an array constructor without a typespec, we
1582 additionally check that all elements have the same length; check_len -1
1583 means no checking. */
1586 gfc_set_constant_character_len (gfc_charlen_t len
, gfc_expr
*expr
,
1587 gfc_charlen_t check_len
)
1592 if (expr
->ts
.type
!= BT_CHARACTER
)
1595 if (expr
->expr_type
!= EXPR_CONSTANT
)
1597 gfc_error_now ("CHARACTER length must be a constant at %L", &expr
->where
);
1601 slen
= expr
->value
.character
.length
;
1604 s
= gfc_get_wide_string (len
+ 1);
1605 memcpy (s
, expr
->value
.character
.string
,
1606 MIN (len
, slen
) * sizeof (gfc_char_t
));
1608 gfc_wide_memset (&s
[slen
], ' ', len
- slen
);
1610 if (warn_character_truncation
&& slen
> len
)
1611 gfc_warning_now (OPT_Wcharacter_truncation
,
1612 "CHARACTER expression at %L is being truncated "
1613 "(%ld/%ld)", &expr
->where
,
1614 (long) slen
, (long) len
);
1616 /* Apply the standard by 'hand' otherwise it gets cleared for
1618 if (check_len
!= -1 && slen
!= check_len
1619 && !(gfc_option
.allow_std
& GFC_STD_GNU
))
1620 gfc_error_now ("The CHARACTER elements of the array constructor "
1621 "at %L must have the same length (%ld/%ld)",
1622 &expr
->where
, (long) slen
,
1626 free (expr
->value
.character
.string
);
1627 expr
->value
.character
.string
= s
;
1628 expr
->value
.character
.length
= len
;
1633 /* Function to create and update the enumerator history
1634 using the information passed as arguments.
1635 Pointer "max_enum" is also updated, to point to
1636 enum history node containing largest initializer.
1638 SYM points to the symbol node of enumerator.
1639 INIT points to its enumerator value. */
1642 create_enum_history (gfc_symbol
*sym
, gfc_expr
*init
)
1644 enumerator_history
*new_enum_history
;
1645 gcc_assert (sym
!= NULL
&& init
!= NULL
);
1647 new_enum_history
= XCNEW (enumerator_history
);
1649 new_enum_history
->sym
= sym
;
1650 new_enum_history
->initializer
= init
;
1651 new_enum_history
->next
= NULL
;
1653 if (enum_history
== NULL
)
1655 enum_history
= new_enum_history
;
1656 max_enum
= enum_history
;
1660 new_enum_history
->next
= enum_history
;
1661 enum_history
= new_enum_history
;
1663 if (mpz_cmp (max_enum
->initializer
->value
.integer
,
1664 new_enum_history
->initializer
->value
.integer
) < 0)
1665 max_enum
= new_enum_history
;
1670 /* Function to free enum kind history. */
1673 gfc_free_enum_history (void)
1675 enumerator_history
*current
= enum_history
;
1676 enumerator_history
*next
;
1678 while (current
!= NULL
)
1680 next
= current
->next
;
1685 enum_history
= NULL
;
1689 /* Function called by variable_decl() that adds an initialization
1690 expression to a symbol. */
1693 add_init_expr_to_sym (const char *name
, gfc_expr
**initp
, locus
*var_locus
)
1695 symbol_attribute attr
;
1700 if (find_special (name
, &sym
, false))
1705 /* If this symbol is confirming an implicit parameter type,
1706 then an initialization expression is not allowed. */
1707 if (attr
.flavor
== FL_PARAMETER
1708 && sym
->value
!= NULL
1711 gfc_error ("Initializer not allowed for PARAMETER %qs at %C",
1718 /* An initializer is required for PARAMETER declarations. */
1719 if (attr
.flavor
== FL_PARAMETER
)
1721 gfc_error ("PARAMETER at %L is missing an initializer", var_locus
);
1727 /* If a variable appears in a DATA block, it cannot have an
1731 gfc_error ("Variable %qs at %C with an initializer already "
1732 "appears in a DATA statement", sym
->name
);
1736 /* Check if the assignment can happen. This has to be put off
1737 until later for derived type variables and procedure pointers. */
1738 if (!gfc_bt_struct (sym
->ts
.type
) && !gfc_bt_struct (init
->ts
.type
)
1739 && sym
->ts
.type
!= BT_CLASS
&& init
->ts
.type
!= BT_CLASS
1740 && !sym
->attr
.proc_pointer
1741 && !gfc_check_assign_symbol (sym
, NULL
, init
))
1744 if (sym
->ts
.type
== BT_CHARACTER
&& sym
->ts
.u
.cl
1745 && init
->ts
.type
== BT_CHARACTER
)
1747 /* Update symbol character length according initializer. */
1748 if (!gfc_check_assign_symbol (sym
, NULL
, init
))
1751 if (sym
->ts
.u
.cl
->length
== NULL
)
1754 /* If there are multiple CHARACTER variables declared on the
1755 same line, we don't want them to share the same length. */
1756 sym
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1758 if (sym
->attr
.flavor
== FL_PARAMETER
)
1760 if (init
->expr_type
== EXPR_CONSTANT
)
1762 clen
= init
->value
.character
.length
;
1763 sym
->ts
.u
.cl
->length
1764 = gfc_get_int_expr (gfc_charlen_int_kind
,
1767 else if (init
->expr_type
== EXPR_ARRAY
)
1769 if (init
->ts
.u
.cl
&& init
->ts
.u
.cl
->length
)
1771 const gfc_expr
*length
= init
->ts
.u
.cl
->length
;
1772 if (length
->expr_type
!= EXPR_CONSTANT
)
1774 gfc_error ("Cannot initialize parameter array "
1776 "with variable length elements",
1780 clen
= mpz_get_si (length
->value
.integer
);
1782 else if (init
->value
.constructor
)
1785 c
= gfc_constructor_first (init
->value
.constructor
);
1786 clen
= c
->expr
->value
.character
.length
;
1790 sym
->ts
.u
.cl
->length
1791 = gfc_get_int_expr (gfc_charlen_int_kind
,
1794 else if (init
->ts
.u
.cl
&& init
->ts
.u
.cl
->length
)
1795 sym
->ts
.u
.cl
->length
=
1796 gfc_copy_expr (sym
->value
->ts
.u
.cl
->length
);
1799 /* Update initializer character length according symbol. */
1800 else if (sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1802 if (!gfc_specification_expr (sym
->ts
.u
.cl
->length
))
1805 int k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
,
1807 /* resolve_charlen will complain later on if the length
1808 is too large. Just skeep the initialization in that case. */
1809 if (mpz_cmp (sym
->ts
.u
.cl
->length
->value
.integer
,
1810 gfc_integer_kinds
[k
].huge
) <= 0)
1813 = gfc_mpz_get_hwi (sym
->ts
.u
.cl
->length
->value
.integer
);
1815 if (init
->expr_type
== EXPR_CONSTANT
)
1816 gfc_set_constant_character_len (len
, init
, -1);
1817 else if (init
->expr_type
== EXPR_ARRAY
)
1821 /* Build a new charlen to prevent simplification from
1822 deleting the length before it is resolved. */
1823 init
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1824 init
->ts
.u
.cl
->length
1825 = gfc_copy_expr (sym
->ts
.u
.cl
->length
);
1827 for (c
= gfc_constructor_first (init
->value
.constructor
);
1828 c
; c
= gfc_constructor_next (c
))
1829 gfc_set_constant_character_len (len
, c
->expr
, -1);
1835 /* If sym is implied-shape, set its upper bounds from init. */
1836 if (sym
->attr
.flavor
== FL_PARAMETER
&& sym
->attr
.dimension
1837 && sym
->as
->type
== AS_IMPLIED_SHAPE
)
1841 if (init
->rank
== 0)
1843 gfc_error ("Can't initialize implied-shape array at %L"
1844 " with scalar", &sym
->declared_at
);
1848 /* Shape should be present, we get an initialization expression. */
1849 gcc_assert (init
->shape
);
1851 for (dim
= 0; dim
< sym
->as
->rank
; ++dim
)
1854 gfc_expr
*e
, *lower
;
1856 lower
= sym
->as
->lower
[dim
];
1858 /* If the lower bound is an array element from another
1859 parameterized array, then it is marked with EXPR_VARIABLE and
1860 is an initialization expression. Try to reduce it. */
1861 if (lower
->expr_type
== EXPR_VARIABLE
)
1862 gfc_reduce_init_expr (lower
);
1864 if (lower
->expr_type
== EXPR_CONSTANT
)
1866 /* All dimensions must be without upper bound. */
1867 gcc_assert (!sym
->as
->upper
[dim
]);
1870 e
= gfc_get_constant_expr (BT_INTEGER
, k
, &sym
->declared_at
);
1871 mpz_add (e
->value
.integer
, lower
->value
.integer
,
1873 mpz_sub_ui (e
->value
.integer
, e
->value
.integer
, 1);
1874 sym
->as
->upper
[dim
] = e
;
1878 gfc_error ("Non-constant lower bound in implied-shape"
1879 " declaration at %L", &lower
->where
);
1884 sym
->as
->type
= AS_EXPLICIT
;
1887 /* Need to check if the expression we initialized this
1888 to was one of the iso_c_binding named constants. If so,
1889 and we're a parameter (constant), let it be iso_c.
1891 integer(c_int), parameter :: my_int = c_int
1892 integer(my_int) :: my_int_2
1893 If we mark my_int as iso_c (since we can see it's value
1894 is equal to one of the named constants), then my_int_2
1895 will be considered C interoperable. */
1896 if (sym
->ts
.type
!= BT_CHARACTER
&& !gfc_bt_struct (sym
->ts
.type
))
1898 sym
->ts
.is_iso_c
|= init
->ts
.is_iso_c
;
1899 sym
->ts
.is_c_interop
|= init
->ts
.is_c_interop
;
1900 /* attr bits needed for module files. */
1901 sym
->attr
.is_iso_c
|= init
->ts
.is_iso_c
;
1902 sym
->attr
.is_c_interop
|= init
->ts
.is_c_interop
;
1903 if (init
->ts
.is_iso_c
)
1904 sym
->ts
.f90_type
= init
->ts
.f90_type
;
1907 /* Add initializer. Make sure we keep the ranks sane. */
1908 if (sym
->attr
.dimension
&& init
->rank
== 0)
1913 if (sym
->attr
.flavor
== FL_PARAMETER
1914 && init
->expr_type
== EXPR_CONSTANT
1915 && spec_size (sym
->as
, &size
)
1916 && mpz_cmp_si (size
, 0) > 0)
1918 array
= gfc_get_array_expr (init
->ts
.type
, init
->ts
.kind
,
1920 for (n
= 0; n
< (int)mpz_get_si (size
); n
++)
1921 gfc_constructor_append_expr (&array
->value
.constructor
,
1924 : gfc_copy_expr (init
),
1927 array
->shape
= gfc_get_shape (sym
->as
->rank
);
1928 for (n
= 0; n
< sym
->as
->rank
; n
++)
1929 spec_dimen_size (sym
->as
, n
, &array
->shape
[n
]);
1934 init
->rank
= sym
->as
->rank
;
1938 if (sym
->attr
.save
== SAVE_NONE
)
1939 sym
->attr
.save
= SAVE_IMPLICIT
;
1947 /* Function called by variable_decl() that adds a name to a structure
1951 build_struct (const char *name
, gfc_charlen
*cl
, gfc_expr
**init
,
1952 gfc_array_spec
**as
)
1957 /* F03:C438/C439. If the current symbol is of the same derived type that we're
1958 constructing, it must have the pointer attribute. */
1959 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
1960 && current_ts
.u
.derived
== gfc_current_block ()
1961 && current_attr
.pointer
== 0)
1963 if (current_attr
.allocatable
1964 && !gfc_notify_std(GFC_STD_F2008
, "Component at %C "
1965 "must have the POINTER attribute"))
1969 else if (current_attr
.allocatable
== 0)
1971 gfc_error ("Component at %C must have the POINTER attribute");
1977 if (current_ts
.type
== BT_CLASS
1978 && !(current_attr
.pointer
|| current_attr
.allocatable
))
1980 gfc_error ("Component %qs with CLASS at %C must be allocatable "
1981 "or pointer", name
);
1985 if (gfc_current_block ()->attr
.pointer
&& (*as
)->rank
!= 0)
1987 if ((*as
)->type
!= AS_DEFERRED
&& (*as
)->type
!= AS_EXPLICIT
)
1989 gfc_error ("Array component of structure at %C must have explicit "
1990 "or deferred shape");
1995 /* If we are in a nested union/map definition, gfc_add_component will not
1996 properly find repeated components because:
1997 (i) gfc_add_component does a flat search, where components of unions
1998 and maps are implicity chained so nested components may conflict.
1999 (ii) Unions and maps are not linked as components of their parent
2000 structures until after they are parsed.
2001 For (i) we use gfc_find_component which searches recursively, and for (ii)
2002 we search each block directly from the parse stack until we find the top
2005 s
= gfc_state_stack
;
2006 if (s
->state
== COMP_UNION
|| s
->state
== COMP_MAP
)
2008 while (s
->state
== COMP_UNION
|| gfc_comp_struct (s
->state
))
2010 c
= gfc_find_component (s
->sym
, name
, true, true, NULL
);
2013 gfc_error_now ("Component %qs at %C already declared at %L",
2017 /* Break after we've searched the entire chain. */
2018 if (s
->state
== COMP_DERIVED
|| s
->state
== COMP_STRUCTURE
)
2024 if (!gfc_add_component (gfc_current_block(), name
, &c
))
2028 if (c
->ts
.type
== BT_CHARACTER
)
2031 if (c
->ts
.type
!= BT_CLASS
&& c
->ts
.type
!= BT_DERIVED
2032 && (c
->ts
.kind
== 0 || c
->ts
.type
== BT_CHARACTER
)
2033 && saved_kind_expr
!= NULL
)
2034 c
->kind_expr
= gfc_copy_expr (saved_kind_expr
);
2036 c
->attr
= current_attr
;
2038 c
->initializer
= *init
;
2045 c
->attr
.codimension
= 1;
2047 c
->attr
.dimension
= 1;
2051 gfc_apply_init (&c
->ts
, &c
->attr
, c
->initializer
);
2053 /* Check array components. */
2054 if (!c
->attr
.dimension
)
2057 if (c
->attr
.pointer
)
2059 if (c
->as
->type
!= AS_DEFERRED
)
2061 gfc_error ("Pointer array component of structure at %C must have a "
2066 else if (c
->attr
.allocatable
)
2068 if (c
->as
->type
!= AS_DEFERRED
)
2070 gfc_error ("Allocatable component of structure at %C must have a "
2077 if (c
->as
->type
!= AS_EXPLICIT
)
2079 gfc_error ("Array component of structure at %C must have an "
2086 if (c
->ts
.type
== BT_CLASS
)
2087 return gfc_build_class_symbol (&c
->ts
, &c
->attr
, &c
->as
);
2089 if (c
->attr
.pdt_kind
|| c
->attr
.pdt_len
)
2092 gfc_find_symbol (c
->name
, gfc_current_block ()->f2k_derived
,
2096 gfc_error ("Type parameter %qs at %C has no corresponding entry "
2097 "in the type parameter name list at %L",
2098 c
->name
, &gfc_current_block ()->declared_at
);
2102 sym
->attr
.pdt_kind
= c
->attr
.pdt_kind
;
2103 sym
->attr
.pdt_len
= c
->attr
.pdt_len
;
2105 sym
->value
= gfc_copy_expr (c
->initializer
);
2106 sym
->attr
.flavor
= FL_VARIABLE
;
2109 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
2110 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_template
2111 && decl_type_param_list
)
2112 c
->param_list
= gfc_copy_actual_arglist (decl_type_param_list
);
2118 /* Match a 'NULL()', and possibly take care of some side effects. */
2121 gfc_match_null (gfc_expr
**result
)
2124 match m
, m2
= MATCH_NO
;
2126 if ((m
= gfc_match (" null ( )")) == MATCH_ERROR
)
2132 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2134 if ((m2
= gfc_match (" null (")) != MATCH_YES
)
2137 old_loc
= gfc_current_locus
;
2138 if ((m2
= gfc_match (" %n ) ", name
)) == MATCH_ERROR
)
2141 && ((m2
= gfc_match (" mold = %n )", name
)) == MATCH_ERROR
))
2145 gfc_current_locus
= old_loc
;
2150 /* The NULL symbol now has to be/become an intrinsic function. */
2151 if (gfc_get_symbol ("null", NULL
, &sym
))
2153 gfc_error ("NULL() initialization at %C is ambiguous");
2157 gfc_intrinsic_symbol (sym
);
2159 if (sym
->attr
.proc
!= PROC_INTRINSIC
2160 && !(sym
->attr
.use_assoc
&& sym
->attr
.intrinsic
)
2161 && (!gfc_add_procedure(&sym
->attr
, PROC_INTRINSIC
, sym
->name
, NULL
)
2162 || !gfc_add_function (&sym
->attr
, sym
->name
, NULL
)))
2165 *result
= gfc_get_null_expr (&gfc_current_locus
);
2167 /* Invalid per F2008, C512. */
2168 if (m2
== MATCH_YES
)
2170 gfc_error ("NULL() initialization at %C may not have MOLD");
2178 /* Match the initialization expr for a data pointer or procedure pointer. */
2181 match_pointer_init (gfc_expr
**init
, int procptr
)
2185 if (gfc_pure (NULL
) && !gfc_comp_struct (gfc_state_stack
->state
))
2187 gfc_error ("Initialization of pointer at %C is not allowed in "
2188 "a PURE procedure");
2191 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
2193 /* Match NULL() initialization. */
2194 m
= gfc_match_null (init
);
2198 /* Match non-NULL initialization. */
2199 gfc_matching_ptr_assignment
= !procptr
;
2200 gfc_matching_procptr_assignment
= procptr
;
2201 m
= gfc_match_rvalue (init
);
2202 gfc_matching_ptr_assignment
= 0;
2203 gfc_matching_procptr_assignment
= 0;
2204 if (m
== MATCH_ERROR
)
2206 else if (m
== MATCH_NO
)
2208 gfc_error ("Error in pointer initialization at %C");
2212 if (!procptr
&& !gfc_resolve_expr (*init
))
2215 if (!gfc_notify_std (GFC_STD_F2008
, "non-NULL pointer "
2216 "initialization at %C"))
2224 check_function_name (char *name
)
2226 /* In functions that have a RESULT variable defined, the function name always
2227 refers to function calls. Therefore, the name is not allowed to appear in
2228 specification statements. When checking this, be careful about
2229 'hidden' procedure pointer results ('ppr@'). */
2231 if (gfc_current_state () == COMP_FUNCTION
)
2233 gfc_symbol
*block
= gfc_current_block ();
2234 if (block
&& block
->result
&& block
->result
!= block
2235 && strcmp (block
->result
->name
, "ppr@") != 0
2236 && strcmp (block
->name
, name
) == 0)
2238 gfc_error ("Function name %qs not allowed at %C", name
);
2247 /* Match a variable name with an optional initializer. When this
2248 subroutine is called, a variable is expected to be parsed next.
2249 Depending on what is happening at the moment, updates either the
2250 symbol table or the current interface. */
2253 variable_decl (int elem
)
2255 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2256 static unsigned int fill_id
= 0;
2257 gfc_expr
*initializer
, *char_len
;
2259 gfc_array_spec
*cp_as
; /* Extra copy for Cray Pointees. */
2271 /* When we get here, we've just matched a list of attributes and
2272 maybe a type and a double colon. The next thing we expect to see
2273 is the name of the symbol. */
2275 /* If we are parsing a structure with legacy support, we allow the symbol
2276 name to be '%FILL' which gives it an anonymous (inaccessible) name. */
2278 gfc_gobble_whitespace ();
2279 if (gfc_peek_ascii_char () == '%')
2281 gfc_next_ascii_char ();
2282 m
= gfc_match ("fill");
2287 m
= gfc_match_name (name
);
2295 if (gfc_current_state () != COMP_STRUCTURE
)
2297 if (flag_dec_structure
)
2298 gfc_error ("%qs not allowed outside STRUCTURE at %C", "%FILL");
2300 gfc_error ("%qs at %C is a DEC extension, enable with "
2301 "%<-fdec-structure%>", "%FILL");
2307 gfc_error ("%qs entity cannot have attributes at %C", "%FILL");
2311 /* %FILL components are given invalid fortran names. */
2312 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "%%FILL%u", fill_id
++);
2316 var_locus
= gfc_current_locus
;
2318 /* Now we could see the optional array spec. or character length. */
2319 m
= gfc_match_array_spec (&as
, true, true);
2320 if (m
== MATCH_ERROR
)
2324 as
= gfc_copy_array_spec (current_as
);
2326 && !merge_array_spec (current_as
, as
, true))
2332 if (flag_cray_pointer
)
2333 cp_as
= gfc_copy_array_spec (as
);
2335 /* At this point, we know for sure if the symbol is PARAMETER and can thus
2336 determine (and check) whether it can be implied-shape. If it
2337 was parsed as assumed-size, change it because PARAMETERs can not
2340 An explicit-shape-array cannot appear under several conditions.
2341 That check is done here as well. */
2344 if (as
->type
== AS_IMPLIED_SHAPE
&& current_attr
.flavor
!= FL_PARAMETER
)
2347 gfc_error ("Non-PARAMETER symbol %qs at %L can't be implied-shape",
2352 if (as
->type
== AS_ASSUMED_SIZE
&& as
->rank
== 1
2353 && current_attr
.flavor
== FL_PARAMETER
)
2354 as
->type
= AS_IMPLIED_SHAPE
;
2356 if (as
->type
== AS_IMPLIED_SHAPE
2357 && !gfc_notify_std (GFC_STD_F2008
, "Implied-shape array at %L",
2364 /* F2018:C830 (R816) An explicit-shape-spec whose bounds are not
2365 constant expressions shall appear only in a subprogram, derived
2366 type definition, BLOCK construct, or interface body. */
2367 if (as
->type
== AS_EXPLICIT
2368 && gfc_current_state () != COMP_BLOCK
2369 && gfc_current_state () != COMP_DERIVED
2370 && gfc_current_state () != COMP_FUNCTION
2371 && gfc_current_state () != COMP_INTERFACE
2372 && gfc_current_state () != COMP_SUBROUTINE
)
2375 bool not_constant
= false;
2377 for (int i
= 0; i
< as
->rank
; i
++)
2379 e
= gfc_copy_expr (as
->lower
[i
]);
2380 gfc_resolve_expr (e
);
2381 gfc_simplify_expr (e
, 0);
2382 if (e
&& (e
->expr_type
!= EXPR_CONSTANT
))
2384 not_constant
= true;
2389 e
= gfc_copy_expr (as
->upper
[i
]);
2390 gfc_resolve_expr (e
);
2391 gfc_simplify_expr (e
, 0);
2392 if (e
&& (e
->expr_type
!= EXPR_CONSTANT
))
2394 not_constant
= true;
2402 gfc_error ("Explicit shaped array with nonconstant bounds at %C");
2411 cl_deferred
= false;
2413 if (current_ts
.type
== BT_CHARACTER
)
2415 switch (match_char_length (&char_len
, &cl_deferred
, false))
2418 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2420 cl
->length
= char_len
;
2423 /* Non-constant lengths need to be copied after the first
2424 element. Also copy assumed lengths. */
2427 && (current_ts
.u
.cl
->length
== NULL
2428 || current_ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
2430 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2431 cl
->length
= gfc_copy_expr (current_ts
.u
.cl
->length
);
2434 cl
= current_ts
.u
.cl
;
2436 cl_deferred
= current_ts
.deferred
;
2445 /* The dummy arguments and result of the abreviated form of MODULE
2446 PROCEDUREs, used in SUBMODULES should not be redefined. */
2447 if (gfc_current_ns
->proc_name
2448 && gfc_current_ns
->proc_name
->abr_modproc_decl
)
2450 gfc_find_symbol (name
, gfc_current_ns
, 1, &sym
);
2451 if (sym
!= NULL
&& (sym
->attr
.dummy
|| sym
->attr
.result
))
2454 gfc_error ("%qs at %C is a redefinition of the declaration "
2455 "in the corresponding interface for MODULE "
2456 "PROCEDURE %qs", sym
->name
,
2457 gfc_current_ns
->proc_name
->name
);
2462 /* %FILL components may not have initializers. */
2463 if (strncmp (name
, "%FILL", 5) == 0 && gfc_match_eos () != MATCH_YES
)
2465 gfc_error ("%qs entity cannot have an initializer at %C", "%FILL");
2470 /* If this symbol has already shown up in a Cray Pointer declaration,
2471 and this is not a component declaration,
2472 then we want to set the type & bail out. */
2473 if (flag_cray_pointer
&& !gfc_comp_struct (gfc_current_state ()))
2475 gfc_find_symbol (name
, gfc_current_ns
, 1, &sym
);
2476 if (sym
!= NULL
&& sym
->attr
.cray_pointee
)
2478 sym
->ts
.type
= current_ts
.type
;
2479 sym
->ts
.kind
= current_ts
.kind
;
2481 sym
->ts
.u
.derived
= current_ts
.u
.derived
;
2482 sym
->ts
.is_c_interop
= current_ts
.is_c_interop
;
2483 sym
->ts
.is_iso_c
= current_ts
.is_iso_c
;
2486 /* Check to see if we have an array specification. */
2489 if (sym
->as
!= NULL
)
2491 gfc_error ("Duplicate array spec for Cray pointee at %C");
2492 gfc_free_array_spec (cp_as
);
2498 if (!gfc_set_array_spec (sym
, cp_as
, &var_locus
))
2499 gfc_internal_error ("Couldn't set pointee array spec.");
2501 /* Fix the array spec. */
2502 m
= gfc_mod_pointee_as (sym
->as
);
2503 if (m
== MATCH_ERROR
)
2511 gfc_free_array_spec (cp_as
);
2515 /* Procedure pointer as function result. */
2516 if (gfc_current_state () == COMP_FUNCTION
2517 && strcmp ("ppr@", gfc_current_block ()->name
) == 0
2518 && strcmp (name
, gfc_current_block ()->ns
->proc_name
->name
) == 0)
2519 strcpy (name
, "ppr@");
2521 if (gfc_current_state () == COMP_FUNCTION
2522 && strcmp (name
, gfc_current_block ()->name
) == 0
2523 && gfc_current_block ()->result
2524 && strcmp ("ppr@", gfc_current_block ()->result
->name
) == 0)
2525 strcpy (name
, "ppr@");
2527 /* OK, we've successfully matched the declaration. Now put the
2528 symbol in the current namespace, because it might be used in the
2529 optional initialization expression for this symbol, e.g. this is
2532 integer, parameter :: i = huge(i)
2534 This is only true for parameters or variables of a basic type.
2535 For components of derived types, it is not true, so we don't
2536 create a symbol for those yet. If we fail to create the symbol,
2538 if (!gfc_comp_struct (gfc_current_state ())
2539 && !build_sym (name
, cl
, cl_deferred
, &as
, &var_locus
))
2545 if (!check_function_name (name
))
2551 /* We allow old-style initializations of the form
2552 integer i /2/, j(4) /3*3, 1/
2553 (if no colon has been seen). These are different from data
2554 statements in that initializers are only allowed to apply to the
2555 variable immediately preceding, i.e.
2557 is not allowed. Therefore we have to do some work manually, that
2558 could otherwise be left to the matchers for DATA statements. */
2560 if (!colon_seen
&& gfc_match (" /") == MATCH_YES
)
2562 if (!gfc_notify_std (GFC_STD_GNU
, "Old-style "
2563 "initialization at %C"))
2566 /* Allow old style initializations for components of STRUCTUREs and MAPs
2567 but not components of derived types. */
2568 else if (gfc_current_state () == COMP_DERIVED
)
2570 gfc_error ("Invalid old style initialization for derived type "
2576 /* For structure components, read the initializer as a special
2577 expression and let the rest of this function apply the initializer
2579 else if (gfc_comp_struct (gfc_current_state ()))
2581 m
= match_clist_expr (&initializer
, ¤t_ts
, as
);
2583 gfc_error ("Syntax error in old style initialization of %s at %C",
2589 /* Otherwise we treat the old style initialization just like a
2590 DATA declaration for the current variable. */
2592 return match_old_style_init (name
);
2595 /* The double colon must be present in order to have initializers.
2596 Otherwise the statement is ambiguous with an assignment statement. */
2599 if (gfc_match (" =>") == MATCH_YES
)
2601 if (!current_attr
.pointer
)
2603 gfc_error ("Initialization at %C isn't for a pointer variable");
2608 m
= match_pointer_init (&initializer
, 0);
2612 else if (gfc_match_char ('=') == MATCH_YES
)
2614 if (current_attr
.pointer
)
2616 gfc_error ("Pointer initialization at %C requires %<=>%>, "
2622 m
= gfc_match_init_expr (&initializer
);
2625 gfc_error ("Expected an initialization expression at %C");
2629 if (current_attr
.flavor
!= FL_PARAMETER
&& gfc_pure (NULL
)
2630 && !gfc_comp_struct (gfc_state_stack
->state
))
2632 gfc_error ("Initialization of variable at %C is not allowed in "
2633 "a PURE procedure");
2637 if (current_attr
.flavor
!= FL_PARAMETER
2638 && !gfc_comp_struct (gfc_state_stack
->state
))
2639 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
2646 if (initializer
!= NULL
&& current_attr
.allocatable
2647 && gfc_comp_struct (gfc_current_state ()))
2649 gfc_error ("Initialization of allocatable component at %C is not "
2655 if (gfc_current_state () == COMP_DERIVED
2656 && gfc_current_block ()->attr
.pdt_template
)
2659 gfc_find_symbol (name
, gfc_current_block ()->f2k_derived
,
2661 if (!param
&& (current_attr
.pdt_kind
|| current_attr
.pdt_len
))
2663 gfc_error ("The component with KIND or LEN attribute at %C does not "
2664 "not appear in the type parameter list at %L",
2665 &gfc_current_block ()->declared_at
);
2669 else if (param
&& !(current_attr
.pdt_kind
|| current_attr
.pdt_len
))
2671 gfc_error ("The component at %C that appears in the type parameter "
2672 "list at %L has neither the KIND nor LEN attribute",
2673 &gfc_current_block ()->declared_at
);
2677 else if (as
&& (current_attr
.pdt_kind
|| current_attr
.pdt_len
))
2679 gfc_error ("The component at %C which is a type parameter must be "
2684 else if (param
&& initializer
)
2685 param
->value
= gfc_copy_expr (initializer
);
2688 /* Add the initializer. Note that it is fine if initializer is
2689 NULL here, because we sometimes also need to check if a
2690 declaration *must* have an initialization expression. */
2691 if (!gfc_comp_struct (gfc_current_state ()))
2692 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
2695 if (current_ts
.type
== BT_DERIVED
2696 && !current_attr
.pointer
&& !initializer
)
2697 initializer
= gfc_default_initializer (¤t_ts
);
2698 t
= build_struct (name
, cl
, &initializer
, &as
);
2700 /* If we match a nested structure definition we expect to see the
2701 * body even if the variable declarations blow up, so we need to keep
2702 * the structure declaration around. */
2703 if (gfc_new_block
&& gfc_new_block
->attr
.flavor
== FL_STRUCT
)
2704 gfc_commit_symbol (gfc_new_block
);
2707 m
= (t
) ? MATCH_YES
: MATCH_ERROR
;
2710 /* Free stuff up and return. */
2711 gfc_free_expr (initializer
);
2712 gfc_free_array_spec (as
);
2718 /* Match an extended-f77 "TYPESPEC*bytesize"-style kind specification.
2719 This assumes that the byte size is equal to the kind number for
2720 non-COMPLEX types, and equal to twice the kind number for COMPLEX. */
2723 gfc_match_old_kind_spec (gfc_typespec
*ts
)
2728 if (gfc_match_char ('*') != MATCH_YES
)
2731 m
= gfc_match_small_literal_int (&ts
->kind
, NULL
);
2735 original_kind
= ts
->kind
;
2737 /* Massage the kind numbers for complex types. */
2738 if (ts
->type
== BT_COMPLEX
)
2742 gfc_error ("Old-style type declaration %s*%d not supported at %C",
2743 gfc_basic_typename (ts
->type
), original_kind
);
2750 if (ts
->type
== BT_INTEGER
&& ts
->kind
== 4 && flag_integer4_kind
== 8)
2753 if (ts
->type
== BT_REAL
|| ts
->type
== BT_COMPLEX
)
2757 if (flag_real4_kind
== 8)
2759 if (flag_real4_kind
== 10)
2761 if (flag_real4_kind
== 16)
2767 if (flag_real8_kind
== 4)
2769 if (flag_real8_kind
== 10)
2771 if (flag_real8_kind
== 16)
2776 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
2778 gfc_error ("Old-style type declaration %s*%d not supported at %C",
2779 gfc_basic_typename (ts
->type
), original_kind
);
2783 if (!gfc_notify_std (GFC_STD_GNU
,
2784 "Nonstandard type declaration %s*%d at %C",
2785 gfc_basic_typename(ts
->type
), original_kind
))
2792 /* Match a kind specification. Since kinds are generally optional, we
2793 usually return MATCH_NO if something goes wrong. If a "kind="
2794 string is found, then we know we have an error. */
2797 gfc_match_kind_spec (gfc_typespec
*ts
, bool kind_expr_only
)
2807 saved_kind_expr
= NULL
;
2809 where
= loc
= gfc_current_locus
;
2814 if (gfc_match_char ('(') == MATCH_NO
)
2817 /* Also gobbles optional text. */
2818 if (gfc_match (" kind = ") == MATCH_YES
)
2821 loc
= gfc_current_locus
;
2825 n
= gfc_match_init_expr (&e
);
2827 if (gfc_derived_parameter_expr (e
))
2830 saved_kind_expr
= gfc_copy_expr (e
);
2831 goto close_brackets
;
2836 if (gfc_matching_function
)
2838 /* The function kind expression might include use associated or
2839 imported parameters and try again after the specification
2841 if (gfc_match_char (')') != MATCH_YES
)
2843 gfc_error ("Missing right parenthesis at %C");
2849 gfc_undo_symbols ();
2854 /* ....or else, the match is real. */
2856 gfc_error ("Expected initialization expression at %C");
2864 gfc_error ("Expected scalar initialization expression at %C");
2869 if (gfc_extract_int (e
, &ts
->kind
, 1))
2875 /* Before throwing away the expression, let's see if we had a
2876 C interoperable kind (and store the fact). */
2877 if (e
->ts
.is_c_interop
== 1)
2879 /* Mark this as C interoperable if being declared with one
2880 of the named constants from iso_c_binding. */
2881 ts
->is_c_interop
= e
->ts
.is_iso_c
;
2882 ts
->f90_type
= e
->ts
.f90_type
;
2884 ts
->interop_kind
= e
->symtree
->n
.sym
;
2890 /* Ignore errors to this point, if we've gotten here. This means
2891 we ignore the m=MATCH_ERROR from above. */
2892 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
2894 gfc_error ("Kind %d not supported for type %s at %C", ts
->kind
,
2895 gfc_basic_typename (ts
->type
));
2896 gfc_current_locus
= where
;
2900 /* Warn if, e.g., c_int is used for a REAL variable, but not
2901 if, e.g., c_double is used for COMPLEX as the standard
2902 explicitly says that the kind type parameter for complex and real
2903 variable is the same, i.e. c_float == c_float_complex. */
2904 if (ts
->f90_type
!= BT_UNKNOWN
&& ts
->f90_type
!= ts
->type
2905 && !((ts
->f90_type
== BT_REAL
&& ts
->type
== BT_COMPLEX
)
2906 || (ts
->f90_type
== BT_COMPLEX
&& ts
->type
== BT_REAL
)))
2907 gfc_warning_now (0, "C kind type parameter is for type %s but type at %L "
2908 "is %s", gfc_basic_typename (ts
->f90_type
), &where
,
2909 gfc_basic_typename (ts
->type
));
2913 gfc_gobble_whitespace ();
2914 if ((c
= gfc_next_ascii_char ()) != ')'
2915 && (ts
->type
!= BT_CHARACTER
|| c
!= ','))
2917 if (ts
->type
== BT_CHARACTER
)
2918 gfc_error ("Missing right parenthesis or comma at %C");
2920 gfc_error ("Missing right parenthesis at %C");
2924 /* All tests passed. */
2927 if(m
== MATCH_ERROR
)
2928 gfc_current_locus
= where
;
2930 if (ts
->type
== BT_INTEGER
&& ts
->kind
== 4 && flag_integer4_kind
== 8)
2933 if (ts
->type
== BT_REAL
|| ts
->type
== BT_COMPLEX
)
2937 if (flag_real4_kind
== 8)
2939 if (flag_real4_kind
== 10)
2941 if (flag_real4_kind
== 16)
2947 if (flag_real8_kind
== 4)
2949 if (flag_real8_kind
== 10)
2951 if (flag_real8_kind
== 16)
2956 /* Return what we know from the test(s). */
2961 gfc_current_locus
= where
;
2967 match_char_kind (int * kind
, int * is_iso_c
)
2976 where
= gfc_current_locus
;
2978 n
= gfc_match_init_expr (&e
);
2980 if (n
!= MATCH_YES
&& gfc_matching_function
)
2982 /* The expression might include use-associated or imported
2983 parameters and try again after the specification
2986 gfc_undo_symbols ();
2991 gfc_error ("Expected initialization expression at %C");
2997 gfc_error ("Expected scalar initialization expression at %C");
3002 if (gfc_derived_parameter_expr (e
))
3004 saved_kind_expr
= e
;
3009 fail
= gfc_extract_int (e
, kind
, 1);
3010 *is_iso_c
= e
->ts
.is_iso_c
;
3019 /* Ignore errors to this point, if we've gotten here. This means
3020 we ignore the m=MATCH_ERROR from above. */
3021 if (gfc_validate_kind (BT_CHARACTER
, *kind
, true) < 0)
3023 gfc_error ("Kind %d is not supported for CHARACTER at %C", *kind
);
3027 /* All tests passed. */
3030 if (m
== MATCH_ERROR
)
3031 gfc_current_locus
= where
;
3033 /* Return what we know from the test(s). */
3038 gfc_current_locus
= where
;
3043 /* Match the various kind/length specifications in a CHARACTER
3044 declaration. We don't return MATCH_NO. */
3047 gfc_match_char_spec (gfc_typespec
*ts
)
3049 int kind
, seen_length
, is_iso_c
;
3061 /* Try the old-style specification first. */
3062 old_char_selector
= 0;
3064 m
= match_char_length (&len
, &deferred
, true);
3068 old_char_selector
= 1;
3073 m
= gfc_match_char ('(');
3076 m
= MATCH_YES
; /* Character without length is a single char. */
3080 /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ). */
3081 if (gfc_match (" kind =") == MATCH_YES
)
3083 m
= match_char_kind (&kind
, &is_iso_c
);
3085 if (m
== MATCH_ERROR
)
3090 if (gfc_match (" , len =") == MATCH_NO
)
3093 m
= char_len_param_value (&len
, &deferred
);
3096 if (m
== MATCH_ERROR
)
3103 /* Try to match "LEN = <len-param>" or "LEN = <len-param>, KIND = <int>". */
3104 if (gfc_match (" len =") == MATCH_YES
)
3106 m
= char_len_param_value (&len
, &deferred
);
3109 if (m
== MATCH_ERROR
)
3113 if (gfc_match_char (')') == MATCH_YES
)
3116 if (gfc_match (" , kind =") != MATCH_YES
)
3119 if (match_char_kind (&kind
, &is_iso_c
) == MATCH_ERROR
)
3125 /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ). */
3126 m
= char_len_param_value (&len
, &deferred
);
3129 if (m
== MATCH_ERROR
)
3133 m
= gfc_match_char (')');
3137 if (gfc_match_char (',') != MATCH_YES
)
3140 gfc_match (" kind ="); /* Gobble optional text. */
3142 m
= match_char_kind (&kind
, &is_iso_c
);
3143 if (m
== MATCH_ERROR
)
3149 /* Require a right-paren at this point. */
3150 m
= gfc_match_char (')');
3155 gfc_error ("Syntax error in CHARACTER declaration at %C");
3157 gfc_free_expr (len
);
3161 /* Deal with character functions after USE and IMPORT statements. */
3162 if (gfc_matching_function
)
3164 gfc_free_expr (len
);
3165 gfc_undo_symbols ();
3171 gfc_free_expr (len
);
3175 /* Do some final massaging of the length values. */
3176 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
3178 if (seen_length
== 0)
3179 cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
, 1);
3182 /* If gfortran ends up here, then the len may be reducible to a
3183 constant. Try to do that here. If it does not reduce, simply
3184 assign len to the charlen. */
3185 if (len
&& len
->expr_type
!= EXPR_CONSTANT
)
3188 e
= gfc_copy_expr (len
);
3189 gfc_reduce_init_expr (e
);
3190 if (e
->expr_type
== EXPR_CONSTANT
)
3191 gfc_replace_expr (len
, e
);
3201 ts
->kind
= kind
== 0 ? gfc_default_character_kind
: kind
;
3202 ts
->deferred
= deferred
;
3204 /* We have to know if it was a C interoperable kind so we can
3205 do accurate type checking of bind(c) procs, etc. */
3207 /* Mark this as C interoperable if being declared with one
3208 of the named constants from iso_c_binding. */
3209 ts
->is_c_interop
= is_iso_c
;
3210 else if (len
!= NULL
)
3211 /* Here, we might have parsed something such as: character(c_char)
3212 In this case, the parsing code above grabs the c_char when
3213 looking for the length (line 1690, roughly). it's the last
3214 testcase for parsing the kind params of a character variable.
3215 However, it's not actually the length. this seems like it
3217 To see if the user used a C interop kind, test the expr
3218 of the so called length, and see if it's C interoperable. */
3219 ts
->is_c_interop
= len
->ts
.is_iso_c
;
3225 /* Matches a RECORD declaration. */
3228 match_record_decl (char *name
)
3231 old_loc
= gfc_current_locus
;
3234 m
= gfc_match (" record /");
3237 if (!flag_dec_structure
)
3239 gfc_current_locus
= old_loc
;
3240 gfc_error ("RECORD at %C is an extension, enable it with "
3244 m
= gfc_match (" %n/", name
);
3249 gfc_current_locus
= old_loc
;
3250 if (flag_dec_structure
3251 && (gfc_match (" record% ") == MATCH_YES
3252 || gfc_match (" record%t") == MATCH_YES
))
3253 gfc_error ("Structure name expected after RECORD at %C");
3261 /* This function uses the gfc_actual_arglist 'type_param_spec_list' as a source
3262 of expressions to substitute into the possibly parameterized expression
3263 'e'. Using a list is inefficient but should not be too bad since the
3264 number of type parameters is not likely to be large. */
3266 insert_parameter_exprs (gfc_expr
* e
, gfc_symbol
* sym ATTRIBUTE_UNUSED
,
3269 gfc_actual_arglist
*param
;
3272 if (e
->expr_type
!= EXPR_VARIABLE
)
3275 gcc_assert (e
->symtree
);
3276 if (e
->symtree
->n
.sym
->attr
.pdt_kind
3277 || (*f
!= 0 && e
->symtree
->n
.sym
->attr
.pdt_len
))
3279 for (param
= type_param_spec_list
; param
; param
= param
->next
)
3280 if (strcmp (e
->symtree
->n
.sym
->name
, param
->name
) == 0)
3285 copy
= gfc_copy_expr (param
->expr
);
3296 gfc_insert_kind_parameter_exprs (gfc_expr
*e
)
3298 return gfc_traverse_expr (e
, NULL
, &insert_parameter_exprs
, 0);
3303 gfc_insert_parameter_exprs (gfc_expr
*e
, gfc_actual_arglist
*param_list
)
3305 gfc_actual_arglist
*old_param_spec_list
= type_param_spec_list
;
3306 type_param_spec_list
= param_list
;
3307 return gfc_traverse_expr (e
, NULL
, &insert_parameter_exprs
, 1);
3308 type_param_spec_list
= NULL
;
3309 type_param_spec_list
= old_param_spec_list
;
3312 /* Determines the instance of a parameterized derived type to be used by
3313 matching determining the values of the kind parameters and using them
3314 in the name of the instance. If the instance exists, it is used, otherwise
3315 a new derived type is created. */
3317 gfc_get_pdt_instance (gfc_actual_arglist
*param_list
, gfc_symbol
**sym
,
3318 gfc_actual_arglist
**ext_param_list
)
3320 /* The PDT template symbol. */
3321 gfc_symbol
*pdt
= *sym
;
3322 /* The symbol for the parameter in the template f2k_namespace. */
3324 /* The hoped for instance of the PDT. */
3325 gfc_symbol
*instance
;
3326 /* The list of parameters appearing in the PDT declaration. */
3327 gfc_formal_arglist
*type_param_name_list
;
3328 /* Used to store the parameter specification list during recursive calls. */
3329 gfc_actual_arglist
*old_param_spec_list
;
3330 /* Pointers to the parameter specification being used. */
3331 gfc_actual_arglist
*actual_param
;
3332 gfc_actual_arglist
*tail
= NULL
;
3333 /* Used to build up the name of the PDT instance. The prefix uses 4
3334 characters and each KIND parameter 2 more. Allow 8 of the latter. */
3335 char name
[GFC_MAX_SYMBOL_LEN
+ 21];
3337 bool name_seen
= (param_list
== NULL
);
3338 bool assumed_seen
= false;
3339 bool deferred_seen
= false;
3340 bool spec_error
= false;
3342 gfc_expr
*kind_expr
;
3343 gfc_component
*c1
, *c2
;
3346 type_param_spec_list
= NULL
;
3348 type_param_name_list
= pdt
->formal
;
3349 actual_param
= param_list
;
3350 sprintf (name
, "Pdt%s", pdt
->name
);
3352 /* Run through the parameter name list and pick up the actual
3353 parameter values or use the default values in the PDT declaration. */
3354 for (; type_param_name_list
;
3355 type_param_name_list
= type_param_name_list
->next
)
3357 if (actual_param
&& actual_param
->spec_type
!= SPEC_EXPLICIT
)
3359 if (actual_param
->spec_type
== SPEC_ASSUMED
)
3360 spec_error
= deferred_seen
;
3362 spec_error
= assumed_seen
;
3366 gfc_error ("The type parameter spec list at %C cannot contain "
3367 "both ASSUMED and DEFERRED parameters");
3372 if (actual_param
&& actual_param
->name
)
3374 param
= type_param_name_list
->sym
;
3376 if (!param
|| !param
->name
)
3379 c1
= gfc_find_component (pdt
, param
->name
, false, true, NULL
);
3380 /* An error should already have been thrown in resolve.c
3381 (resolve_fl_derived0). */
3382 if (!pdt
->attr
.use_assoc
&& !c1
)
3388 if (!actual_param
&& !(c1
&& c1
->initializer
))
3390 gfc_error ("The type parameter spec list at %C does not contain "
3391 "enough parameter expressions");
3394 else if (!actual_param
&& c1
&& c1
->initializer
)
3395 kind_expr
= gfc_copy_expr (c1
->initializer
);
3396 else if (actual_param
&& actual_param
->spec_type
== SPEC_EXPLICIT
)
3397 kind_expr
= gfc_copy_expr (actual_param
->expr
);
3401 actual_param
= param_list
;
3402 for (;actual_param
; actual_param
= actual_param
->next
)
3403 if (actual_param
->name
3404 && strcmp (actual_param
->name
, param
->name
) == 0)
3406 if (actual_param
&& actual_param
->spec_type
== SPEC_EXPLICIT
)
3407 kind_expr
= gfc_copy_expr (actual_param
->expr
);
3410 if (c1
->initializer
)
3411 kind_expr
= gfc_copy_expr (c1
->initializer
);
3412 else if (!(actual_param
&& param
->attr
.pdt_len
))
3414 gfc_error ("The derived parameter %qs at %C does not "
3415 "have a default value", param
->name
);
3421 /* Store the current parameter expressions in a temporary actual
3422 arglist 'list' so that they can be substituted in the corresponding
3423 expressions in the PDT instance. */
3424 if (type_param_spec_list
== NULL
)
3426 type_param_spec_list
= gfc_get_actual_arglist ();
3427 tail
= type_param_spec_list
;
3431 tail
->next
= gfc_get_actual_arglist ();
3434 tail
->name
= param
->name
;
3438 /* Try simplification even for LEN expressions. */
3439 gfc_resolve_expr (kind_expr
);
3440 gfc_simplify_expr (kind_expr
, 1);
3441 /* Variable expressions seem to default to BT_PROCEDURE.
3442 TODO find out why this is and fix it. */
3443 if (kind_expr
->ts
.type
!= BT_INTEGER
3444 && kind_expr
->ts
.type
!= BT_PROCEDURE
)
3446 gfc_error ("The parameter expression at %C must be of "
3447 "INTEGER type and not %s type",
3448 gfc_basic_typename (kind_expr
->ts
.type
));
3452 tail
->expr
= gfc_copy_expr (kind_expr
);
3456 tail
->spec_type
= actual_param
->spec_type
;
3458 if (!param
->attr
.pdt_kind
)
3460 if (!name_seen
&& actual_param
)
3461 actual_param
= actual_param
->next
;
3464 gfc_free_expr (kind_expr
);
3471 && (actual_param
->spec_type
== SPEC_ASSUMED
3472 || actual_param
->spec_type
== SPEC_DEFERRED
))
3474 gfc_error ("The KIND parameter %qs at %C cannot either be "
3475 "ASSUMED or DEFERRED", param
->name
);
3479 if (!kind_expr
|| !gfc_is_constant_expr (kind_expr
))
3481 gfc_error ("The value for the KIND parameter %qs at %C does not "
3482 "reduce to a constant expression", param
->name
);
3486 gfc_extract_int (kind_expr
, &kind_value
);
3487 sprintf (name
+ strlen (name
), "_%d", kind_value
);
3489 if (!name_seen
&& actual_param
)
3490 actual_param
= actual_param
->next
;
3491 gfc_free_expr (kind_expr
);
3494 if (!name_seen
&& actual_param
)
3496 gfc_error ("The type parameter spec list at %C contains too many "
3497 "parameter expressions");
3501 /* Now we search for the PDT instance 'name'. If it doesn't exist, we
3502 build it, using 'pdt' as a template. */
3503 if (gfc_get_symbol (name
, pdt
->ns
, &instance
))
3505 gfc_error ("Parameterized derived type at %C is ambiguous");
3511 if (instance
->attr
.flavor
== FL_DERIVED
3512 && instance
->attr
.pdt_type
)
3516 *ext_param_list
= type_param_spec_list
;
3518 gfc_commit_symbols ();
3522 /* Start building the new instance of the parameterized type. */
3523 gfc_copy_attr (&instance
->attr
, &pdt
->attr
, &pdt
->declared_at
);
3524 instance
->attr
.pdt_template
= 0;
3525 instance
->attr
.pdt_type
= 1;
3526 instance
->declared_at
= gfc_current_locus
;
3528 /* Add the components, replacing the parameters in all expressions
3529 with the expressions for their values in 'type_param_spec_list'. */
3530 c1
= pdt
->components
;
3531 tail
= type_param_spec_list
;
3532 for (; c1
; c1
= c1
->next
)
3534 gfc_add_component (instance
, c1
->name
, &c2
);
3537 c2
->attr
= c1
->attr
;
3539 /* The order of declaration of the type_specs might not be the
3540 same as that of the components. */
3541 if (c1
->attr
.pdt_kind
|| c1
->attr
.pdt_len
)
3543 for (tail
= type_param_spec_list
; tail
; tail
= tail
->next
)
3544 if (strcmp (c1
->name
, tail
->name
) == 0)
3548 /* Deal with type extension by recursively calling this function
3549 to obtain the instance of the extended type. */
3550 if (gfc_current_state () != COMP_DERIVED
3551 && c1
== pdt
->components
3552 && (c1
->ts
.type
== BT_DERIVED
|| c1
->ts
.type
== BT_CLASS
)
3553 && c1
->ts
.u
.derived
&& c1
->ts
.u
.derived
->attr
.pdt_template
3554 && gfc_get_derived_super_type (*sym
) == c2
->ts
.u
.derived
)
3556 gfc_formal_arglist
*f
;
3558 old_param_spec_list
= type_param_spec_list
;
3560 /* Obtain a spec list appropriate to the extended type..*/
3561 actual_param
= gfc_copy_actual_arglist (type_param_spec_list
);
3562 type_param_spec_list
= actual_param
;
3563 for (f
= c1
->ts
.u
.derived
->formal
; f
&& f
->next
; f
= f
->next
)
3564 actual_param
= actual_param
->next
;
3567 gfc_free_actual_arglist (actual_param
->next
);
3568 actual_param
->next
= NULL
;
3571 /* Now obtain the PDT instance for the extended type. */
3572 c2
->param_list
= type_param_spec_list
;
3573 m
= gfc_get_pdt_instance (type_param_spec_list
, &c2
->ts
.u
.derived
,
3575 type_param_spec_list
= old_param_spec_list
;
3577 c2
->ts
.u
.derived
->refs
++;
3578 gfc_set_sym_referenced (c2
->ts
.u
.derived
);
3580 /* Set extension level. */
3581 if (c2
->ts
.u
.derived
->attr
.extension
== 255)
3583 /* Since the extension field is 8 bit wide, we can only have
3584 up to 255 extension levels. */
3585 gfc_error ("Maximum extension level reached with type %qs at %L",
3586 c2
->ts
.u
.derived
->name
,
3587 &c2
->ts
.u
.derived
->declared_at
);
3590 instance
->attr
.extension
= c2
->ts
.u
.derived
->attr
.extension
+ 1;
3595 /* Set the component kind using the parameterized expression. */
3596 if ((c1
->ts
.kind
== 0 || c1
->ts
.type
== BT_CHARACTER
)
3597 && c1
->kind_expr
!= NULL
)
3599 gfc_expr
*e
= gfc_copy_expr (c1
->kind_expr
);
3600 gfc_insert_kind_parameter_exprs (e
);
3601 gfc_simplify_expr (e
, 1);
3602 gfc_extract_int (e
, &c2
->ts
.kind
);
3604 if (gfc_validate_kind (c2
->ts
.type
, c2
->ts
.kind
, true) < 0)
3606 gfc_error ("Kind %d not supported for type %s at %C",
3607 c2
->ts
.kind
, gfc_basic_typename (c2
->ts
.type
));
3612 /* Similarly, set the string length if parameterized. */
3613 if (c1
->ts
.type
== BT_CHARACTER
3614 && c1
->ts
.u
.cl
->length
3615 && gfc_derived_parameter_expr (c1
->ts
.u
.cl
->length
))
3618 e
= gfc_copy_expr (c1
->ts
.u
.cl
->length
);
3619 gfc_insert_kind_parameter_exprs (e
);
3620 gfc_simplify_expr (e
, 1);
3621 c2
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
3622 c2
->ts
.u
.cl
->length
= e
;
3623 c2
->attr
.pdt_string
= 1;
3626 /* Set up either the KIND/LEN initializer, if constant,
3627 or the parameterized expression. Use the template
3628 initializer if one is not already set in this instance. */
3629 if (c2
->attr
.pdt_kind
|| c2
->attr
.pdt_len
)
3631 if (tail
&& tail
->expr
&& gfc_is_constant_expr (tail
->expr
))
3632 c2
->initializer
= gfc_copy_expr (tail
->expr
);
3633 else if (tail
&& tail
->expr
)
3635 c2
->param_list
= gfc_get_actual_arglist ();
3636 c2
->param_list
->name
= tail
->name
;
3637 c2
->param_list
->expr
= gfc_copy_expr (tail
->expr
);
3638 c2
->param_list
->next
= NULL
;
3641 if (!c2
->initializer
&& c1
->initializer
)
3642 c2
->initializer
= gfc_copy_expr (c1
->initializer
);
3645 /* Copy the array spec. */
3646 c2
->as
= gfc_copy_array_spec (c1
->as
);
3647 if (c1
->ts
.type
== BT_CLASS
)
3648 CLASS_DATA (c2
)->as
= gfc_copy_array_spec (CLASS_DATA (c1
)->as
);
3650 /* Determine if an array spec is parameterized. If so, substitute
3651 in the parameter expressions for the bounds and set the pdt_array
3652 attribute. Notice that this attribute must be unconditionally set
3653 if this is an array of parameterized character length. */
3654 if (c1
->as
&& c1
->as
->type
== AS_EXPLICIT
)
3656 bool pdt_array
= false;
3658 /* Are the bounds of the array parameterized? */
3659 for (i
= 0; i
< c1
->as
->rank
; i
++)
3661 if (gfc_derived_parameter_expr (c1
->as
->lower
[i
]))
3663 if (gfc_derived_parameter_expr (c1
->as
->upper
[i
]))
3667 /* If they are, free the expressions for the bounds and
3668 replace them with the template expressions with substitute
3670 for (i
= 0; pdt_array
&& i
< c1
->as
->rank
; i
++)
3673 e
= gfc_copy_expr (c1
->as
->lower
[i
]);
3674 gfc_insert_kind_parameter_exprs (e
);
3675 gfc_simplify_expr (e
, 1);
3676 gfc_free_expr (c2
->as
->lower
[i
]);
3677 c2
->as
->lower
[i
] = e
;
3678 e
= gfc_copy_expr (c1
->as
->upper
[i
]);
3679 gfc_insert_kind_parameter_exprs (e
);
3680 gfc_simplify_expr (e
, 1);
3681 gfc_free_expr (c2
->as
->upper
[i
]);
3682 c2
->as
->upper
[i
] = e
;
3684 c2
->attr
.pdt_array
= pdt_array
? 1 : c2
->attr
.pdt_string
;
3685 if (c1
->initializer
)
3687 c2
->initializer
= gfc_copy_expr (c1
->initializer
);
3688 gfc_insert_kind_parameter_exprs (c2
->initializer
);
3689 gfc_simplify_expr (c2
->initializer
, 1);
3693 /* Recurse into this function for PDT components. */
3694 if ((c1
->ts
.type
== BT_DERIVED
|| c1
->ts
.type
== BT_CLASS
)
3695 && c1
->ts
.u
.derived
&& c1
->ts
.u
.derived
->attr
.pdt_template
)
3697 gfc_actual_arglist
*params
;
3698 /* The component in the template has a list of specification
3699 expressions derived from its declaration. */
3700 params
= gfc_copy_actual_arglist (c1
->param_list
);
3701 actual_param
= params
;
3702 /* Substitute the template parameters with the expressions
3703 from the specification list. */
3704 for (;actual_param
; actual_param
= actual_param
->next
)
3705 gfc_insert_parameter_exprs (actual_param
->expr
,
3706 type_param_spec_list
);
3708 /* Now obtain the PDT instance for the component. */
3709 old_param_spec_list
= type_param_spec_list
;
3710 m
= gfc_get_pdt_instance (params
, &c2
->ts
.u
.derived
, NULL
);
3711 type_param_spec_list
= old_param_spec_list
;
3713 c2
->param_list
= params
;
3714 if (!(c2
->attr
.pointer
|| c2
->attr
.allocatable
))
3715 c2
->initializer
= gfc_default_initializer (&c2
->ts
);
3717 if (c2
->attr
.allocatable
)
3718 instance
->attr
.alloc_comp
= 1;
3722 gfc_commit_symbol (instance
);
3724 *ext_param_list
= type_param_spec_list
;
3729 gfc_free_actual_arglist (type_param_spec_list
);
3734 /* Matches a declaration-type-spec (F03:R502). If successful, sets the ts
3735 structure to the matched specification. This is necessary for FUNCTION and
3736 IMPLICIT statements.
3738 If implicit_flag is nonzero, then we don't check for the optional
3739 kind specification. Not doing so is needed for matching an IMPLICIT
3740 statement correctly. */
3743 gfc_match_decl_type_spec (gfc_typespec
*ts
, int implicit_flag
)
3745 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3746 gfc_symbol
*sym
, *dt_sym
;
3749 bool seen_deferred_kind
, matched_type
;
3750 const char *dt_name
;
3752 decl_type_param_list
= NULL
;
3754 /* A belt and braces check that the typespec is correctly being treated
3755 as a deferred characteristic association. */
3756 seen_deferred_kind
= (gfc_current_state () == COMP_FUNCTION
)
3757 && (gfc_current_block ()->result
->ts
.kind
== -1)
3758 && (ts
->kind
== -1);
3760 if (seen_deferred_kind
)
3763 /* Clear the current binding label, in case one is given. */
3764 curr_binding_label
= NULL
;
3766 if (gfc_match (" byte") == MATCH_YES
)
3768 if (!gfc_notify_std (GFC_STD_GNU
, "BYTE type at %C"))
3771 if (gfc_validate_kind (BT_INTEGER
, 1, true) < 0)
3773 gfc_error ("BYTE type used at %C "
3774 "is not available on the target machine");
3778 ts
->type
= BT_INTEGER
;
3784 m
= gfc_match (" type (");
3785 matched_type
= (m
== MATCH_YES
);
3788 gfc_gobble_whitespace ();
3789 if (gfc_peek_ascii_char () == '*')
3791 if ((m
= gfc_match ("*)")) != MATCH_YES
)
3793 if (gfc_comp_struct (gfc_current_state ()))
3795 gfc_error ("Assumed type at %C is not allowed for components");
3798 if (!gfc_notify_std (GFC_STD_F2008_TS
, "Assumed type "
3801 ts
->type
= BT_ASSUMED
;
3805 m
= gfc_match ("%n", name
);
3806 matched_type
= (m
== MATCH_YES
);
3809 if ((matched_type
&& strcmp ("integer", name
) == 0)
3810 || (!matched_type
&& gfc_match (" integer") == MATCH_YES
))
3812 ts
->type
= BT_INTEGER
;
3813 ts
->kind
= gfc_default_integer_kind
;
3817 if ((matched_type
&& strcmp ("character", name
) == 0)
3818 || (!matched_type
&& gfc_match (" character") == MATCH_YES
))
3821 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
3822 "intrinsic-type-spec at %C"))
3825 ts
->type
= BT_CHARACTER
;
3826 if (implicit_flag
== 0)
3827 m
= gfc_match_char_spec (ts
);
3831 if (matched_type
&& m
== MATCH_YES
&& gfc_match_char (')') != MATCH_YES
)
3837 if ((matched_type
&& strcmp ("real", name
) == 0)
3838 || (!matched_type
&& gfc_match (" real") == MATCH_YES
))
3841 ts
->kind
= gfc_default_real_kind
;
3846 && (strcmp ("doubleprecision", name
) == 0
3847 || (strcmp ("double", name
) == 0
3848 && gfc_match (" precision") == MATCH_YES
)))
3849 || (!matched_type
&& gfc_match (" double precision") == MATCH_YES
))
3852 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
3853 "intrinsic-type-spec at %C"))
3855 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
3859 ts
->kind
= gfc_default_double_kind
;
3863 if ((matched_type
&& strcmp ("complex", name
) == 0)
3864 || (!matched_type
&& gfc_match (" complex") == MATCH_YES
))
3866 ts
->type
= BT_COMPLEX
;
3867 ts
->kind
= gfc_default_complex_kind
;
3872 && (strcmp ("doublecomplex", name
) == 0
3873 || (strcmp ("double", name
) == 0
3874 && gfc_match (" complex") == MATCH_YES
)))
3875 || (!matched_type
&& gfc_match (" double complex") == MATCH_YES
))
3877 if (!gfc_notify_std (GFC_STD_GNU
, "DOUBLE COMPLEX at %C"))
3881 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
3882 "intrinsic-type-spec at %C"))
3885 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
3888 ts
->type
= BT_COMPLEX
;
3889 ts
->kind
= gfc_default_double_kind
;
3893 if ((matched_type
&& strcmp ("logical", name
) == 0)
3894 || (!matched_type
&& gfc_match (" logical") == MATCH_YES
))
3896 ts
->type
= BT_LOGICAL
;
3897 ts
->kind
= gfc_default_logical_kind
;
3903 m
= gfc_match_actual_arglist (1, &decl_type_param_list
, true);
3904 if (m
== MATCH_ERROR
)
3907 m
= gfc_match_char (')');
3911 m
= match_record_decl (name
);
3913 if (matched_type
|| m
== MATCH_YES
)
3915 ts
->type
= BT_DERIVED
;
3916 /* We accept record/s/ or type(s) where s is a structure, but we
3917 * don't need all the extra derived-type stuff for structures. */
3918 if (gfc_find_symbol (gfc_dt_upper_string (name
), NULL
, 1, &sym
))
3920 gfc_error ("Type name %qs at %C is ambiguous", name
);
3924 if (sym
&& sym
->attr
.flavor
== FL_DERIVED
3925 && sym
->attr
.pdt_template
3926 && gfc_current_state () != COMP_DERIVED
)
3928 m
= gfc_get_pdt_instance (decl_type_param_list
, &sym
, NULL
);
3931 gcc_assert (!sym
->attr
.pdt_template
&& sym
->attr
.pdt_type
);
3932 ts
->u
.derived
= sym
;
3933 strcpy (name
, gfc_dt_lower_string (sym
->name
));
3936 if (sym
&& sym
->attr
.flavor
== FL_STRUCT
)
3938 ts
->u
.derived
= sym
;
3941 /* Actually a derived type. */
3946 /* Match nested STRUCTURE declarations; only valid within another
3947 structure declaration. */
3948 if (flag_dec_structure
3949 && (gfc_current_state () == COMP_STRUCTURE
3950 || gfc_current_state () == COMP_MAP
))
3952 m
= gfc_match (" structure");
3955 m
= gfc_match_structure_decl ();
3958 /* gfc_new_block is updated by match_structure_decl. */
3959 ts
->type
= BT_DERIVED
;
3960 ts
->u
.derived
= gfc_new_block
;
3964 if (m
== MATCH_ERROR
)
3968 /* Match CLASS declarations. */
3969 m
= gfc_match (" class ( * )");
3970 if (m
== MATCH_ERROR
)
3972 else if (m
== MATCH_YES
)
3976 ts
->type
= BT_CLASS
;
3977 gfc_find_symbol ("STAR", gfc_current_ns
, 1, &upe
);
3980 upe
= gfc_new_symbol ("STAR", gfc_current_ns
);
3981 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "STAR");
3983 gfc_set_sym_referenced (upe
);
3985 upe
->ts
.type
= BT_VOID
;
3986 upe
->attr
.unlimited_polymorphic
= 1;
3987 /* This is essential to force the construction of
3988 unlimited polymorphic component class containers. */
3989 upe
->attr
.zero_comp
= 1;
3990 if (!gfc_add_flavor (&upe
->attr
, FL_DERIVED
, NULL
,
3991 &gfc_current_locus
))
3996 st
= gfc_get_tbp_symtree (&gfc_current_ns
->sym_root
, "STAR");
4000 ts
->u
.derived
= upe
;
4004 m
= gfc_match (" class (");
4007 m
= gfc_match ("%n", name
);
4013 ts
->type
= BT_CLASS
;
4015 if (!gfc_notify_std (GFC_STD_F2003
, "CLASS statement at %C"))
4018 m
= gfc_match_actual_arglist (1, &decl_type_param_list
, true);
4019 if (m
== MATCH_ERROR
)
4022 m
= gfc_match_char (')');
4027 /* Defer association of the derived type until the end of the
4028 specification block. However, if the derived type can be
4029 found, add it to the typespec. */
4030 if (gfc_matching_function
)
4032 ts
->u
.derived
= NULL
;
4033 if (gfc_current_state () != COMP_INTERFACE
4034 && !gfc_find_symbol (name
, NULL
, 1, &sym
) && sym
)
4036 sym
= gfc_find_dt_in_generic (sym
);
4037 ts
->u
.derived
= sym
;
4042 /* Search for the name but allow the components to be defined later. If
4043 type = -1, this typespec has been seen in a function declaration but
4044 the type could not be accessed at that point. The actual derived type is
4045 stored in a symtree with the first letter of the name capitalized; the
4046 symtree with the all lower-case name contains the associated
4047 generic function. */
4048 dt_name
= gfc_dt_upper_string (name
);
4053 gfc_get_ha_symbol (name
, &sym
);
4054 if (sym
->generic
&& gfc_find_symbol (dt_name
, NULL
, 0, &dt_sym
))
4056 gfc_error ("Type name %qs at %C is ambiguous", name
);
4059 if (sym
->generic
&& !dt_sym
)
4060 dt_sym
= gfc_find_dt_in_generic (sym
);
4062 /* Host associated PDTs can get confused with their constructors
4063 because they ar instantiated in the template's namespace. */
4066 if (gfc_find_symbol (dt_name
, NULL
, 1, &dt_sym
))
4068 gfc_error ("Type name %qs at %C is ambiguous", name
);
4071 if (dt_sym
&& !dt_sym
->attr
.pdt_type
)
4075 else if (ts
->kind
== -1)
4077 int iface
= gfc_state_stack
->previous
->state
!= COMP_INTERFACE
4078 || gfc_current_ns
->has_import_set
;
4079 gfc_find_symbol (name
, NULL
, iface
, &sym
);
4080 if (sym
&& sym
->generic
&& gfc_find_symbol (dt_name
, NULL
, 1, &dt_sym
))
4082 gfc_error ("Type name %qs at %C is ambiguous", name
);
4085 if (sym
&& sym
->generic
&& !dt_sym
)
4086 dt_sym
= gfc_find_dt_in_generic (sym
);
4093 if ((sym
->attr
.flavor
!= FL_UNKNOWN
&& sym
->attr
.flavor
!= FL_STRUCT
4094 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.generic
))
4095 || sym
->attr
.subroutine
)
4097 gfc_error ("Type name %qs at %C conflicts with previously declared "
4098 "entity at %L, which has the same name", name
,
4103 if (sym
&& sym
->attr
.flavor
== FL_DERIVED
4104 && sym
->attr
.pdt_template
4105 && gfc_current_state () != COMP_DERIVED
)
4107 m
= gfc_get_pdt_instance (decl_type_param_list
, &sym
, NULL
);
4110 gcc_assert (!sym
->attr
.pdt_template
&& sym
->attr
.pdt_type
);
4111 ts
->u
.derived
= sym
;
4112 strcpy (name
, gfc_dt_lower_string (sym
->name
));
4115 gfc_save_symbol_data (sym
);
4116 gfc_set_sym_referenced (sym
);
4117 if (!sym
->attr
.generic
4118 && !gfc_add_generic (&sym
->attr
, sym
->name
, NULL
))
4121 if (!sym
->attr
.function
4122 && !gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
4125 if (dt_sym
&& dt_sym
->attr
.flavor
== FL_DERIVED
4126 && dt_sym
->attr
.pdt_template
4127 && gfc_current_state () != COMP_DERIVED
)
4129 m
= gfc_get_pdt_instance (decl_type_param_list
, &dt_sym
, NULL
);
4132 gcc_assert (!dt_sym
->attr
.pdt_template
&& dt_sym
->attr
.pdt_type
);
4137 gfc_interface
*intr
, *head
;
4139 /* Use upper case to save the actual derived-type symbol. */
4140 gfc_get_symbol (dt_name
, NULL
, &dt_sym
);
4141 dt_sym
->name
= gfc_get_string ("%s", sym
->name
);
4142 head
= sym
->generic
;
4143 intr
= gfc_get_interface ();
4145 intr
->where
= gfc_current_locus
;
4147 sym
->generic
= intr
;
4148 sym
->attr
.if_source
= IFSRC_DECL
;
4151 gfc_save_symbol_data (dt_sym
);
4153 gfc_set_sym_referenced (dt_sym
);
4155 if (dt_sym
->attr
.flavor
!= FL_DERIVED
&& dt_sym
->attr
.flavor
!= FL_STRUCT
4156 && !gfc_add_flavor (&dt_sym
->attr
, FL_DERIVED
, sym
->name
, NULL
))
4159 ts
->u
.derived
= dt_sym
;
4165 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
4166 "intrinsic-type-spec at %C"))
4169 /* For all types except double, derived and character, look for an
4170 optional kind specifier. MATCH_NO is actually OK at this point. */
4171 if (implicit_flag
== 1)
4173 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
4179 if (gfc_current_form
== FORM_FREE
)
4181 c
= gfc_peek_ascii_char ();
4182 if (!gfc_is_whitespace (c
) && c
!= '*' && c
!= '('
4183 && c
!= ':' && c
!= ',')
4185 if (matched_type
&& c
== ')')
4187 gfc_next_ascii_char ();
4194 m
= gfc_match_kind_spec (ts
, false);
4195 if (m
== MATCH_NO
&& ts
->type
!= BT_CHARACTER
)
4197 m
= gfc_match_old_kind_spec (ts
);
4198 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) == -1)
4202 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
4205 /* Defer association of the KIND expression of function results
4206 until after USE and IMPORT statements. */
4207 if ((gfc_current_state () == COMP_NONE
&& gfc_error_flag_test ())
4208 || gfc_matching_function
)
4212 m
= MATCH_YES
; /* No kind specifier found. */
4218 /* Match an IMPLICIT NONE statement. Actually, this statement is
4219 already matched in parse.c, or we would not end up here in the
4220 first place. So the only thing we need to check, is if there is
4221 trailing garbage. If not, the match is successful. */
4224 gfc_match_implicit_none (void)
4228 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4230 bool external
= false;
4231 locus cur_loc
= gfc_current_locus
;
4233 if (gfc_current_ns
->seen_implicit_none
4234 || gfc_current_ns
->has_implicit_none_export
)
4236 gfc_error ("Duplicate IMPLICIT NONE statement at %C");
4240 gfc_gobble_whitespace ();
4241 c
= gfc_peek_ascii_char ();
4244 (void) gfc_next_ascii_char ();
4245 if (!gfc_notify_std (GFC_STD_F2018
, "IMPORT NONE with spec list at %C"))
4248 gfc_gobble_whitespace ();
4249 if (gfc_peek_ascii_char () == ')')
4251 (void) gfc_next_ascii_char ();
4257 m
= gfc_match (" %n", name
);
4261 if (strcmp (name
, "type") == 0)
4263 else if (strcmp (name
, "external") == 0)
4268 gfc_gobble_whitespace ();
4269 c
= gfc_next_ascii_char ();
4280 if (gfc_match_eos () != MATCH_YES
)
4283 gfc_set_implicit_none (type
, external
, &cur_loc
);
4289 /* Match the letter range(s) of an IMPLICIT statement. */
4292 match_implicit_range (void)
4298 cur_loc
= gfc_current_locus
;
4300 gfc_gobble_whitespace ();
4301 c
= gfc_next_ascii_char ();
4304 gfc_error ("Missing character range in IMPLICIT at %C");
4311 gfc_gobble_whitespace ();
4312 c1
= gfc_next_ascii_char ();
4316 gfc_gobble_whitespace ();
4317 c
= gfc_next_ascii_char ();
4322 inner
= 0; /* Fall through. */
4329 gfc_gobble_whitespace ();
4330 c2
= gfc_next_ascii_char ();
4334 gfc_gobble_whitespace ();
4335 c
= gfc_next_ascii_char ();
4337 if ((c
!= ',') && (c
!= ')'))
4350 gfc_error ("Letters must be in alphabetic order in "
4351 "IMPLICIT statement at %C");
4355 /* See if we can add the newly matched range to the pending
4356 implicits from this IMPLICIT statement. We do not check for
4357 conflicts with whatever earlier IMPLICIT statements may have
4358 set. This is done when we've successfully finished matching
4360 if (!gfc_add_new_implicit_range (c1
, c2
))
4367 gfc_syntax_error (ST_IMPLICIT
);
4369 gfc_current_locus
= cur_loc
;
4374 /* Match an IMPLICIT statement, storing the types for
4375 gfc_set_implicit() if the statement is accepted by the parser.
4376 There is a strange looking, but legal syntactic construction
4377 possible. It looks like:
4379 IMPLICIT INTEGER (a-b) (c-d)
4381 This is legal if "a-b" is a constant expression that happens to
4382 equal one of the legal kinds for integers. The real problem
4383 happens with an implicit specification that looks like:
4385 IMPLICIT INTEGER (a-b)
4387 In this case, a typespec matcher that is "greedy" (as most of the
4388 matchers are) gobbles the character range as a kindspec, leaving
4389 nothing left. We therefore have to go a bit more slowly in the
4390 matching process by inhibiting the kindspec checking during
4391 typespec matching and checking for a kind later. */
4394 gfc_match_implicit (void)
4401 if (gfc_current_ns
->seen_implicit_none
)
4403 gfc_error ("IMPLICIT statement at %C following an IMPLICIT NONE (type) "
4410 /* We don't allow empty implicit statements. */
4411 if (gfc_match_eos () == MATCH_YES
)
4413 gfc_error ("Empty IMPLICIT statement at %C");
4419 /* First cleanup. */
4420 gfc_clear_new_implicit ();
4422 /* A basic type is mandatory here. */
4423 m
= gfc_match_decl_type_spec (&ts
, 1);
4424 if (m
== MATCH_ERROR
)
4429 cur_loc
= gfc_current_locus
;
4430 m
= match_implicit_range ();
4434 /* We may have <TYPE> (<RANGE>). */
4435 gfc_gobble_whitespace ();
4436 c
= gfc_peek_ascii_char ();
4437 if (c
== ',' || c
== '\n' || c
== ';' || c
== '!')
4439 /* Check for CHARACTER with no length parameter. */
4440 if (ts
.type
== BT_CHARACTER
&& !ts
.u
.cl
)
4442 ts
.kind
= gfc_default_character_kind
;
4443 ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4444 ts
.u
.cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
,
4448 /* Record the Successful match. */
4449 if (!gfc_merge_new_implicit (&ts
))
4452 c
= gfc_next_ascii_char ();
4453 else if (gfc_match_eos () == MATCH_ERROR
)
4458 gfc_current_locus
= cur_loc
;
4461 /* Discard the (incorrectly) matched range. */
4462 gfc_clear_new_implicit ();
4464 /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
4465 if (ts
.type
== BT_CHARACTER
)
4466 m
= gfc_match_char_spec (&ts
);
4469 m
= gfc_match_kind_spec (&ts
, false);
4472 m
= gfc_match_old_kind_spec (&ts
);
4473 if (m
== MATCH_ERROR
)
4479 if (m
== MATCH_ERROR
)
4482 m
= match_implicit_range ();
4483 if (m
== MATCH_ERROR
)
4488 gfc_gobble_whitespace ();
4489 c
= gfc_next_ascii_char ();
4490 if (c
!= ',' && gfc_match_eos () != MATCH_YES
)
4493 if (!gfc_merge_new_implicit (&ts
))
4501 gfc_syntax_error (ST_IMPLICIT
);
4509 gfc_match_import (void)
4511 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4516 if (gfc_current_ns
->proc_name
== NULL
4517 || gfc_current_ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
4519 gfc_error ("IMPORT statement at %C only permitted in "
4520 "an INTERFACE body");
4524 if (gfc_current_ns
->proc_name
->attr
.module_procedure
)
4526 gfc_error ("F2008: C1210 IMPORT statement at %C is not permitted "
4527 "in a module procedure interface body");
4531 if (!gfc_notify_std (GFC_STD_F2003
, "IMPORT statement at %C"))
4534 if (gfc_match_eos () == MATCH_YES
)
4536 /* All host variables should be imported. */
4537 gfc_current_ns
->has_import_set
= 1;
4541 if (gfc_match (" ::") == MATCH_YES
)
4543 if (gfc_match_eos () == MATCH_YES
)
4545 gfc_error ("Expecting list of named entities at %C");
4553 m
= gfc_match (" %n", name
);
4557 if (gfc_current_ns
->parent
!= NULL
4558 && gfc_find_symbol (name
, gfc_current_ns
->parent
, 1, &sym
))
4560 gfc_error ("Type name %qs at %C is ambiguous", name
);
4563 else if (!sym
&& gfc_current_ns
->proc_name
->ns
->parent
!= NULL
4564 && gfc_find_symbol (name
,
4565 gfc_current_ns
->proc_name
->ns
->parent
,
4568 gfc_error ("Type name %qs at %C is ambiguous", name
);
4574 gfc_error ("Cannot IMPORT %qs from host scoping unit "
4575 "at %C - does not exist.", name
);
4579 if (gfc_find_symtree (gfc_current_ns
->sym_root
, name
))
4581 gfc_warning (0, "%qs is already IMPORTed from host scoping unit "
4586 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, name
);
4589 sym
->attr
.imported
= 1;
4591 if (sym
->attr
.generic
&& (sym
= gfc_find_dt_in_generic (sym
)))
4593 /* The actual derived type is stored in a symtree with the first
4594 letter of the name capitalized; the symtree with the all
4595 lower-case name contains the associated generic function. */
4596 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
,
4597 gfc_dt_upper_string (name
));
4600 sym
->attr
.imported
= 1;
4613 if (gfc_match_eos () == MATCH_YES
)
4615 if (gfc_match_char (',') != MATCH_YES
)
4622 gfc_error ("Syntax error in IMPORT statement at %C");
4627 /* A minimal implementation of gfc_match without whitespace, escape
4628 characters or variable arguments. Returns true if the next
4629 characters match the TARGET template exactly. */
4632 match_string_p (const char *target
)
4636 for (p
= target
; *p
; p
++)
4637 if ((char) gfc_next_ascii_char () != *p
)
4642 /* Matches an attribute specification including array specs. If
4643 successful, leaves the variables current_attr and current_as
4644 holding the specification. Also sets the colon_seen variable for
4645 later use by matchers associated with initializations.
4647 This subroutine is a little tricky in the sense that we don't know
4648 if we really have an attr-spec until we hit the double colon.
4649 Until that time, we can only return MATCH_NO. This forces us to
4650 check for duplicate specification at this level. */
4653 match_attr_spec (void)
4655 /* Modifiers that can exist in a type statement. */
4657 { GFC_DECL_BEGIN
= 0,
4658 DECL_ALLOCATABLE
= GFC_DECL_BEGIN
, DECL_DIMENSION
, DECL_EXTERNAL
,
4659 DECL_IN
, DECL_OUT
, DECL_INOUT
, DECL_INTRINSIC
, DECL_OPTIONAL
,
4660 DECL_PARAMETER
, DECL_POINTER
, DECL_PROTECTED
, DECL_PRIVATE
,
4661 DECL_STATIC
, DECL_AUTOMATIC
,
4662 DECL_PUBLIC
, DECL_SAVE
, DECL_TARGET
, DECL_VALUE
, DECL_VOLATILE
,
4663 DECL_IS_BIND_C
, DECL_CODIMENSION
, DECL_ASYNCHRONOUS
, DECL_CONTIGUOUS
,
4664 DECL_LEN
, DECL_KIND
, DECL_NONE
, GFC_DECL_END
/* Sentinel */
4667 /* GFC_DECL_END is the sentinel, index starts at 0. */
4668 #define NUM_DECL GFC_DECL_END
4670 locus start
, seen_at
[NUM_DECL
];
4677 gfc_clear_attr (¤t_attr
);
4678 start
= gfc_current_locus
;
4684 /* See if we get all of the keywords up to the final double colon. */
4685 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
4693 gfc_gobble_whitespace ();
4695 ch
= gfc_next_ascii_char ();
4698 /* This is the successful exit condition for the loop. */
4699 if (gfc_next_ascii_char () == ':')
4704 gfc_gobble_whitespace ();
4705 switch (gfc_peek_ascii_char ())
4708 gfc_next_ascii_char ();
4709 switch (gfc_next_ascii_char ())
4712 if (match_string_p ("locatable"))
4714 /* Matched "allocatable". */
4715 d
= DECL_ALLOCATABLE
;
4720 if (match_string_p ("ynchronous"))
4722 /* Matched "asynchronous". */
4723 d
= DECL_ASYNCHRONOUS
;
4728 if (match_string_p ("tomatic"))
4730 /* Matched "automatic". */
4738 /* Try and match the bind(c). */
4739 m
= gfc_match_bind_c (NULL
, true);
4742 else if (m
== MATCH_ERROR
)
4747 gfc_next_ascii_char ();
4748 if ('o' != gfc_next_ascii_char ())
4750 switch (gfc_next_ascii_char ())
4753 if (match_string_p ("imension"))
4755 d
= DECL_CODIMENSION
;
4760 if (match_string_p ("tiguous"))
4762 d
= DECL_CONTIGUOUS
;
4769 if (match_string_p ("dimension"))
4774 if (match_string_p ("external"))
4779 if (match_string_p ("int"))
4781 ch
= gfc_next_ascii_char ();
4784 if (match_string_p ("nt"))
4786 /* Matched "intent". */
4787 /* TODO: Call match_intent_spec from here. */
4788 if (gfc_match (" ( in out )") == MATCH_YES
)
4790 else if (gfc_match (" ( in )") == MATCH_YES
)
4792 else if (gfc_match (" ( out )") == MATCH_YES
)
4798 if (match_string_p ("insic"))
4800 /* Matched "intrinsic". */
4808 if (match_string_p ("kind"))
4813 if (match_string_p ("len"))
4818 if (match_string_p ("optional"))
4823 gfc_next_ascii_char ();
4824 switch (gfc_next_ascii_char ())
4827 if (match_string_p ("rameter"))
4829 /* Matched "parameter". */
4835 if (match_string_p ("inter"))
4837 /* Matched "pointer". */
4843 ch
= gfc_next_ascii_char ();
4846 if (match_string_p ("vate"))
4848 /* Matched "private". */
4854 if (match_string_p ("tected"))
4856 /* Matched "protected". */
4863 if (match_string_p ("blic"))
4865 /* Matched "public". */
4873 gfc_next_ascii_char ();
4874 switch (gfc_next_ascii_char ())
4877 if (match_string_p ("ve"))
4879 /* Matched "save". */
4885 if (match_string_p ("atic"))
4887 /* Matched "static". */
4895 if (match_string_p ("target"))
4900 gfc_next_ascii_char ();
4901 ch
= gfc_next_ascii_char ();
4904 if (match_string_p ("lue"))
4906 /* Matched "value". */
4912 if (match_string_p ("latile"))
4914 /* Matched "volatile". */
4922 /* No double colon and no recognizable decl_type, so assume that
4923 we've been looking at something else the whole time. */
4930 /* Check to make sure any parens are paired up correctly. */
4931 if (gfc_match_parens () == MATCH_ERROR
)
4938 seen_at
[d
] = gfc_current_locus
;
4940 if (d
== DECL_DIMENSION
|| d
== DECL_CODIMENSION
)
4942 gfc_array_spec
*as
= NULL
;
4944 m
= gfc_match_array_spec (&as
, d
== DECL_DIMENSION
,
4945 d
== DECL_CODIMENSION
);
4947 if (current_as
== NULL
)
4949 else if (m
== MATCH_YES
)
4951 if (!merge_array_spec (as
, current_as
, false))
4958 if (d
== DECL_CODIMENSION
)
4959 gfc_error ("Missing codimension specification at %C");
4961 gfc_error ("Missing dimension specification at %C");
4965 if (m
== MATCH_ERROR
)
4970 /* Since we've seen a double colon, we have to be looking at an
4971 attr-spec. This means that we can now issue errors. */
4972 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
4977 case DECL_ALLOCATABLE
:
4978 attr
= "ALLOCATABLE";
4980 case DECL_ASYNCHRONOUS
:
4981 attr
= "ASYNCHRONOUS";
4983 case DECL_CODIMENSION
:
4984 attr
= "CODIMENSION";
4986 case DECL_CONTIGUOUS
:
4987 attr
= "CONTIGUOUS";
4989 case DECL_DIMENSION
:
4996 attr
= "INTENT (IN)";
4999 attr
= "INTENT (OUT)";
5002 attr
= "INTENT (IN OUT)";
5004 case DECL_INTRINSIC
:
5016 case DECL_PARAMETER
:
5022 case DECL_PROTECTED
:
5037 case DECL_AUTOMATIC
:
5043 case DECL_IS_BIND_C
:
5053 attr
= NULL
; /* This shouldn't happen. */
5056 gfc_error ("Duplicate %s attribute at %L", attr
, &seen_at
[d
]);
5061 /* Now that we've dealt with duplicate attributes, add the attributes
5062 to the current attribute. */
5063 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
5070 if ((d
== DECL_STATIC
|| d
== DECL_AUTOMATIC
)
5071 && !flag_dec_static
)
5073 gfc_error ("%s at %L is a DEC extension, enable with "
5075 d
== DECL_STATIC
? "STATIC" : "AUTOMATIC", &seen_at
[d
]);
5079 /* Allow SAVE with STATIC, but don't complain. */
5080 if (d
== DECL_STATIC
&& seen
[DECL_SAVE
])
5083 if (gfc_current_state () == COMP_DERIVED
5084 && d
!= DECL_DIMENSION
&& d
!= DECL_CODIMENSION
5085 && d
!= DECL_POINTER
&& d
!= DECL_PRIVATE
5086 && d
!= DECL_PUBLIC
&& d
!= DECL_CONTIGUOUS
&& d
!= DECL_NONE
)
5088 if (d
== DECL_ALLOCATABLE
)
5090 if (!gfc_notify_std (GFC_STD_F2003
, "ALLOCATABLE "
5091 "attribute at %C in a TYPE definition"))
5097 else if (d
== DECL_KIND
)
5099 if (!gfc_notify_std (GFC_STD_F2003
, "KIND "
5100 "attribute at %C in a TYPE definition"))
5105 if (current_ts
.type
!= BT_INTEGER
)
5107 gfc_error ("Component with KIND attribute at %C must be "
5112 if (current_ts
.kind
!= gfc_default_integer_kind
)
5114 gfc_error ("Component with KIND attribute at %C must be "
5115 "default integer kind (%d)",
5116 gfc_default_integer_kind
);
5121 else if (d
== DECL_LEN
)
5123 if (!gfc_notify_std (GFC_STD_F2003
, "LEN "
5124 "attribute at %C in a TYPE definition"))
5129 if (current_ts
.type
!= BT_INTEGER
)
5131 gfc_error ("Component with LEN attribute at %C must be "
5136 if (current_ts
.kind
!= gfc_default_integer_kind
)
5138 gfc_error ("Component with LEN attribute at %C must be "
5139 "default integer kind (%d)",
5140 gfc_default_integer_kind
);
5147 gfc_error ("Attribute at %L is not allowed in a TYPE definition",
5154 if ((d
== DECL_PRIVATE
|| d
== DECL_PUBLIC
)
5155 && gfc_current_state () != COMP_MODULE
)
5157 if (d
== DECL_PRIVATE
)
5161 if (gfc_current_state () == COMP_DERIVED
5162 && gfc_state_stack
->previous
5163 && gfc_state_stack
->previous
->state
== COMP_MODULE
)
5165 if (!gfc_notify_std (GFC_STD_F2003
, "Attribute %s "
5166 "at %L in a TYPE definition", attr
,
5175 gfc_error ("%s attribute at %L is not allowed outside of the "
5176 "specification part of a module", attr
, &seen_at
[d
]);
5182 if (gfc_current_state () != COMP_DERIVED
5183 && (d
== DECL_KIND
|| d
== DECL_LEN
))
5185 gfc_error ("Attribute at %L is not allowed outside a TYPE "
5186 "definition", &seen_at
[d
]);
5193 case DECL_ALLOCATABLE
:
5194 t
= gfc_add_allocatable (¤t_attr
, &seen_at
[d
]);
5197 case DECL_ASYNCHRONOUS
:
5198 if (!gfc_notify_std (GFC_STD_F2003
, "ASYNCHRONOUS attribute at %C"))
5201 t
= gfc_add_asynchronous (¤t_attr
, NULL
, &seen_at
[d
]);
5204 case DECL_CODIMENSION
:
5205 t
= gfc_add_codimension (¤t_attr
, NULL
, &seen_at
[d
]);
5208 case DECL_CONTIGUOUS
:
5209 if (!gfc_notify_std (GFC_STD_F2008
, "CONTIGUOUS attribute at %C"))
5212 t
= gfc_add_contiguous (¤t_attr
, NULL
, &seen_at
[d
]);
5215 case DECL_DIMENSION
:
5216 t
= gfc_add_dimension (¤t_attr
, NULL
, &seen_at
[d
]);
5220 t
= gfc_add_external (¤t_attr
, &seen_at
[d
]);
5224 t
= gfc_add_intent (¤t_attr
, INTENT_IN
, &seen_at
[d
]);
5228 t
= gfc_add_intent (¤t_attr
, INTENT_OUT
, &seen_at
[d
]);
5232 t
= gfc_add_intent (¤t_attr
, INTENT_INOUT
, &seen_at
[d
]);
5235 case DECL_INTRINSIC
:
5236 t
= gfc_add_intrinsic (¤t_attr
, &seen_at
[d
]);
5240 t
= gfc_add_optional (¤t_attr
, &seen_at
[d
]);
5244 t
= gfc_add_kind (¤t_attr
, &seen_at
[d
]);
5248 t
= gfc_add_len (¤t_attr
, &seen_at
[d
]);
5251 case DECL_PARAMETER
:
5252 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, &seen_at
[d
]);
5256 t
= gfc_add_pointer (¤t_attr
, &seen_at
[d
]);
5259 case DECL_PROTECTED
:
5260 if (gfc_current_state () != COMP_MODULE
5261 || (gfc_current_ns
->proc_name
5262 && gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
))
5264 gfc_error ("PROTECTED at %C only allowed in specification "
5265 "part of a module");
5270 if (!gfc_notify_std (GFC_STD_F2003
, "PROTECTED attribute at %C"))
5273 t
= gfc_add_protected (¤t_attr
, NULL
, &seen_at
[d
]);
5277 t
= gfc_add_access (¤t_attr
, ACCESS_PRIVATE
, NULL
,
5282 t
= gfc_add_access (¤t_attr
, ACCESS_PUBLIC
, NULL
,
5288 t
= gfc_add_save (¤t_attr
, SAVE_EXPLICIT
, NULL
, &seen_at
[d
]);
5291 case DECL_AUTOMATIC
:
5292 t
= gfc_add_automatic (¤t_attr
, NULL
, &seen_at
[d
]);
5296 t
= gfc_add_target (¤t_attr
, &seen_at
[d
]);
5299 case DECL_IS_BIND_C
:
5300 t
= gfc_add_is_bind_c(¤t_attr
, NULL
, &seen_at
[d
], 0);
5304 if (!gfc_notify_std (GFC_STD_F2003
, "VALUE attribute at %C"))
5307 t
= gfc_add_value (¤t_attr
, NULL
, &seen_at
[d
]);
5311 if (!gfc_notify_std (GFC_STD_F2003
, "VOLATILE attribute at %C"))
5314 t
= gfc_add_volatile (¤t_attr
, NULL
, &seen_at
[d
]);
5318 gfc_internal_error ("match_attr_spec(): Bad attribute");
5328 /* Since Fortran 2008 module variables implicitly have the SAVE attribute. */
5329 if ((gfc_current_state () == COMP_MODULE
5330 || gfc_current_state () == COMP_SUBMODULE
)
5331 && !current_attr
.save
5332 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
5333 current_attr
.save
= SAVE_IMPLICIT
;
5339 gfc_current_locus
= start
;
5340 gfc_free_array_spec (current_as
);
5347 /* Set the binding label, dest_label, either with the binding label
5348 stored in the given gfc_typespec, ts, or if none was provided, it
5349 will be the symbol name in all lower case, as required by the draft
5350 (J3/04-007, section 15.4.1). If a binding label was given and
5351 there is more than one argument (num_idents), it is an error. */
5354 set_binding_label (const char **dest_label
, const char *sym_name
,
5357 if (num_idents
> 1 && has_name_equals
)
5359 gfc_error ("Multiple identifiers provided with "
5360 "single NAME= specifier at %C");
5364 if (curr_binding_label
)
5365 /* Binding label given; store in temp holder till have sym. */
5366 *dest_label
= curr_binding_label
;
5369 /* No binding label given, and the NAME= specifier did not exist,
5370 which means there was no NAME="". */
5371 if (sym_name
!= NULL
&& has_name_equals
== 0)
5372 *dest_label
= IDENTIFIER_POINTER (get_identifier (sym_name
));
5379 /* Set the status of the given common block as being BIND(C) or not,
5380 depending on the given parameter, is_bind_c. */
5383 set_com_block_bind_c (gfc_common_head
*com_block
, int is_bind_c
)
5385 com_block
->is_bind_c
= is_bind_c
;
5390 /* Verify that the given gfc_typespec is for a C interoperable type. */
5393 gfc_verify_c_interop (gfc_typespec
*ts
)
5395 if (ts
->type
== BT_DERIVED
&& ts
->u
.derived
!= NULL
)
5396 return (ts
->u
.derived
->ts
.is_c_interop
|| ts
->u
.derived
->attr
.is_bind_c
)
5398 else if (ts
->type
== BT_CLASS
)
5400 else if (ts
->is_c_interop
!= 1 && ts
->type
!= BT_ASSUMED
)
5407 /* Verify that the variables of a given common block, which has been
5408 defined with the attribute specifier bind(c), to be of a C
5409 interoperable type. Errors will be reported here, if
5413 verify_com_block_vars_c_interop (gfc_common_head
*com_block
)
5415 gfc_symbol
*curr_sym
= NULL
;
5418 curr_sym
= com_block
->head
;
5420 /* Make sure we have at least one symbol. */
5421 if (curr_sym
== NULL
)
5424 /* Here we know we have a symbol, so we'll execute this loop
5428 /* The second to last param, 1, says this is in a common block. */
5429 retval
= verify_bind_c_sym (curr_sym
, &(curr_sym
->ts
), 1, com_block
);
5430 curr_sym
= curr_sym
->common_next
;
5431 } while (curr_sym
!= NULL
);
5437 /* Verify that a given BIND(C) symbol is C interoperable. If it is not,
5438 an appropriate error message is reported. */
5441 verify_bind_c_sym (gfc_symbol
*tmp_sym
, gfc_typespec
*ts
,
5442 int is_in_common
, gfc_common_head
*com_block
)
5444 bool bind_c_function
= false;
5447 if (tmp_sym
->attr
.function
&& tmp_sym
->attr
.is_bind_c
)
5448 bind_c_function
= true;
5450 if (tmp_sym
->attr
.function
&& tmp_sym
->result
!= NULL
)
5452 tmp_sym
= tmp_sym
->result
;
5453 /* Make sure it wasn't an implicitly typed result. */
5454 if (tmp_sym
->attr
.implicit_type
&& warn_c_binding_type
)
5456 gfc_warning (OPT_Wc_binding_type
,
5457 "Implicitly declared BIND(C) function %qs at "
5458 "%L may not be C interoperable", tmp_sym
->name
,
5459 &tmp_sym
->declared_at
);
5460 tmp_sym
->ts
.f90_type
= tmp_sym
->ts
.type
;
5461 /* Mark it as C interoperable to prevent duplicate warnings. */
5462 tmp_sym
->ts
.is_c_interop
= 1;
5463 tmp_sym
->attr
.is_c_interop
= 1;
5467 /* Here, we know we have the bind(c) attribute, so if we have
5468 enough type info, then verify that it's a C interop kind.
5469 The info could be in the symbol already, or possibly still in
5470 the given ts (current_ts), so look in both. */
5471 if (tmp_sym
->ts
.type
!= BT_UNKNOWN
|| ts
->type
!= BT_UNKNOWN
)
5473 if (!gfc_verify_c_interop (&(tmp_sym
->ts
)))
5475 /* See if we're dealing with a sym in a common block or not. */
5476 if (is_in_common
== 1 && warn_c_binding_type
)
5478 gfc_warning (OPT_Wc_binding_type
,
5479 "Variable %qs in common block %qs at %L "
5480 "may not be a C interoperable "
5481 "kind though common block %qs is BIND(C)",
5482 tmp_sym
->name
, com_block
->name
,
5483 &(tmp_sym
->declared_at
), com_block
->name
);
5487 if (tmp_sym
->ts
.type
== BT_DERIVED
|| ts
->type
== BT_DERIVED
)
5488 gfc_error ("Type declaration %qs at %L is not C "
5489 "interoperable but it is BIND(C)",
5490 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5491 else if (warn_c_binding_type
)
5492 gfc_warning (OPT_Wc_binding_type
, "Variable %qs at %L "
5493 "may not be a C interoperable "
5494 "kind but it is BIND(C)",
5495 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5499 /* Variables declared w/in a common block can't be bind(c)
5500 since there's no way for C to see these variables, so there's
5501 semantically no reason for the attribute. */
5502 if (is_in_common
== 1 && tmp_sym
->attr
.is_bind_c
== 1)
5504 gfc_error ("Variable %qs in common block %qs at "
5505 "%L cannot be declared with BIND(C) "
5506 "since it is not a global",
5507 tmp_sym
->name
, com_block
->name
,
5508 &(tmp_sym
->declared_at
));
5512 /* Scalar variables that are bind(c) can not have the pointer
5513 or allocatable attributes. */
5514 if (tmp_sym
->attr
.is_bind_c
== 1)
5516 if (tmp_sym
->attr
.pointer
== 1)
5518 gfc_error ("Variable %qs at %L cannot have both the "
5519 "POINTER and BIND(C) attributes",
5520 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5524 if (tmp_sym
->attr
.allocatable
== 1)
5526 gfc_error ("Variable %qs at %L cannot have both the "
5527 "ALLOCATABLE and BIND(C) attributes",
5528 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5534 /* If it is a BIND(C) function, make sure the return value is a
5535 scalar value. The previous tests in this function made sure
5536 the type is interoperable. */
5537 if (bind_c_function
&& tmp_sym
->as
!= NULL
)
5538 gfc_error ("Return type of BIND(C) function %qs at %L cannot "
5539 "be an array", tmp_sym
->name
, &(tmp_sym
->declared_at
));
5541 /* BIND(C) functions can not return a character string. */
5542 if (bind_c_function
&& tmp_sym
->ts
.type
== BT_CHARACTER
)
5543 if (tmp_sym
->ts
.u
.cl
== NULL
|| tmp_sym
->ts
.u
.cl
->length
== NULL
5544 || tmp_sym
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
5545 || mpz_cmp_si (tmp_sym
->ts
.u
.cl
->length
->value
.integer
, 1) != 0)
5546 gfc_error ("Return type of BIND(C) function %qs at %L cannot "
5547 "be a character string", tmp_sym
->name
,
5548 &(tmp_sym
->declared_at
));
5551 /* See if the symbol has been marked as private. If it has, make sure
5552 there is no binding label and warn the user if there is one. */
5553 if (tmp_sym
->attr
.access
== ACCESS_PRIVATE
5554 && tmp_sym
->binding_label
)
5555 /* Use gfc_warning_now because we won't say that the symbol fails
5556 just because of this. */
5557 gfc_warning_now (0, "Symbol %qs at %L is marked PRIVATE but has been "
5558 "given the binding label %qs", tmp_sym
->name
,
5559 &(tmp_sym
->declared_at
), tmp_sym
->binding_label
);
5565 /* Set the appropriate fields for a symbol that's been declared as
5566 BIND(C) (the is_bind_c flag and the binding label), and verify that
5567 the type is C interoperable. Errors are reported by the functions
5568 used to set/test these fields. */
5571 set_verify_bind_c_sym (gfc_symbol
*tmp_sym
, int num_idents
)
5575 /* TODO: Do we need to make sure the vars aren't marked private? */
5577 /* Set the is_bind_c bit in symbol_attribute. */
5578 gfc_add_is_bind_c (&(tmp_sym
->attr
), tmp_sym
->name
, &gfc_current_locus
, 0);
5580 if (!set_binding_label (&tmp_sym
->binding_label
, tmp_sym
->name
, num_idents
))
5587 /* Set the fields marking the given common block as BIND(C), including
5588 a binding label, and report any errors encountered. */
5591 set_verify_bind_c_com_block (gfc_common_head
*com_block
, int num_idents
)
5595 /* destLabel, common name, typespec (which may have binding label). */
5596 if (!set_binding_label (&com_block
->binding_label
, com_block
->name
,
5600 /* Set the given common block (com_block) to being bind(c) (1). */
5601 set_com_block_bind_c (com_block
, 1);
5607 /* Retrieve the list of one or more identifiers that the given bind(c)
5608 attribute applies to. */
5611 get_bind_c_idents (void)
5613 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5615 gfc_symbol
*tmp_sym
= NULL
;
5617 gfc_common_head
*com_block
= NULL
;
5619 if (gfc_match_name (name
) == MATCH_YES
)
5621 found_id
= MATCH_YES
;
5622 gfc_get_ha_symbol (name
, &tmp_sym
);
5624 else if (match_common_name (name
) == MATCH_YES
)
5626 found_id
= MATCH_YES
;
5627 com_block
= gfc_get_common (name
, 0);
5631 gfc_error ("Need either entity or common block name for "
5632 "attribute specification statement at %C");
5636 /* Save the current identifier and look for more. */
5639 /* Increment the number of identifiers found for this spec stmt. */
5642 /* Make sure we have a sym or com block, and verify that it can
5643 be bind(c). Set the appropriate field(s) and look for more
5645 if (tmp_sym
!= NULL
|| com_block
!= NULL
)
5647 if (tmp_sym
!= NULL
)
5649 if (!set_verify_bind_c_sym (tmp_sym
, num_idents
))
5654 if (!set_verify_bind_c_com_block (com_block
, num_idents
))
5658 /* Look to see if we have another identifier. */
5660 if (gfc_match_eos () == MATCH_YES
)
5661 found_id
= MATCH_NO
;
5662 else if (gfc_match_char (',') != MATCH_YES
)
5663 found_id
= MATCH_NO
;
5664 else if (gfc_match_name (name
) == MATCH_YES
)
5666 found_id
= MATCH_YES
;
5667 gfc_get_ha_symbol (name
, &tmp_sym
);
5669 else if (match_common_name (name
) == MATCH_YES
)
5671 found_id
= MATCH_YES
;
5672 com_block
= gfc_get_common (name
, 0);
5676 gfc_error ("Missing entity or common block name for "
5677 "attribute specification statement at %C");
5683 gfc_internal_error ("Missing symbol");
5685 } while (found_id
== MATCH_YES
);
5687 /* if we get here we were successful */
5692 /* Try and match a BIND(C) attribute specification statement. */
5695 gfc_match_bind_c_stmt (void)
5697 match found_match
= MATCH_NO
;
5702 /* This may not be necessary. */
5704 /* Clear the temporary binding label holder. */
5705 curr_binding_label
= NULL
;
5707 /* Look for the bind(c). */
5708 found_match
= gfc_match_bind_c (NULL
, true);
5710 if (found_match
== MATCH_YES
)
5712 if (!gfc_notify_std (GFC_STD_F2003
, "BIND(C) statement at %C"))
5715 /* Look for the :: now, but it is not required. */
5718 /* Get the identifier(s) that needs to be updated. This may need to
5719 change to hand the flag(s) for the attr specified so all identifiers
5720 found can have all appropriate parts updated (assuming that the same
5721 spec stmt can have multiple attrs, such as both bind(c) and
5723 if (!get_bind_c_idents ())
5724 /* Error message should have printed already. */
5732 /* Match a data declaration statement. */
5735 gfc_match_data_decl (void)
5741 type_param_spec_list
= NULL
;
5742 decl_type_param_list
= NULL
;
5744 num_idents_on_line
= 0;
5746 m
= gfc_match_decl_type_spec (¤t_ts
, 0);
5750 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
5751 && !gfc_comp_struct (gfc_current_state ()))
5753 sym
= gfc_use_derived (current_ts
.u
.derived
);
5761 current_ts
.u
.derived
= sym
;
5764 m
= match_attr_spec ();
5765 if (m
== MATCH_ERROR
)
5771 if (current_ts
.type
== BT_CLASS
5772 && current_ts
.u
.derived
->attr
.unlimited_polymorphic
)
5775 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
5776 && current_ts
.u
.derived
->components
== NULL
5777 && !current_ts
.u
.derived
->attr
.zero_comp
)
5780 if (current_attr
.pointer
&& gfc_comp_struct (gfc_current_state ()))
5783 if (current_attr
.allocatable
&& gfc_current_state () == COMP_DERIVED
5784 && current_ts
.u
.derived
== gfc_current_block ())
5787 gfc_find_symbol (current_ts
.u
.derived
->name
,
5788 current_ts
.u
.derived
->ns
, 1, &sym
);
5790 /* Any symbol that we find had better be a type definition
5791 which has its components defined, or be a structure definition
5792 actively being parsed. */
5793 if (sym
!= NULL
&& gfc_fl_struct (sym
->attr
.flavor
)
5794 && (current_ts
.u
.derived
->components
!= NULL
5795 || current_ts
.u
.derived
->attr
.zero_comp
5796 || current_ts
.u
.derived
== gfc_new_block
))
5799 gfc_error ("Derived type at %C has not been previously defined "
5800 "and so cannot appear in a derived type definition");
5806 /* If we have an old-style character declaration, and no new-style
5807 attribute specifications, then there a comma is optional between
5808 the type specification and the variable list. */
5809 if (m
== MATCH_NO
&& current_ts
.type
== BT_CHARACTER
&& old_char_selector
)
5810 gfc_match_char (',');
5812 /* Give the types/attributes to symbols that follow. Give the element
5813 a number so that repeat character length expressions can be copied. */
5817 num_idents_on_line
++;
5818 m
= variable_decl (elem
++);
5819 if (m
== MATCH_ERROR
)
5824 if (gfc_match_eos () == MATCH_YES
)
5826 if (gfc_match_char (',') != MATCH_YES
)
5830 if (!gfc_error_flag_test ())
5832 /* An anonymous structure declaration is unambiguous; if we matched one
5833 according to gfc_match_structure_decl, we need to return MATCH_YES
5834 here to avoid confusing the remaining matchers, even if there was an
5835 error during variable_decl. We must flush any such errors. Note this
5836 causes the parser to gracefully continue parsing the remaining input
5837 as a structure body, which likely follows. */
5838 if (current_ts
.type
== BT_DERIVED
&& current_ts
.u
.derived
5839 && gfc_fl_struct (current_ts
.u
.derived
->attr
.flavor
))
5841 gfc_error_now ("Syntax error in anonymous structure declaration"
5843 /* Skip the bad variable_decl and line up for the start of the
5845 gfc_error_recovery ();
5850 gfc_error ("Syntax error in data declaration at %C");
5855 gfc_free_data_all (gfc_current_ns
);
5858 if (saved_kind_expr
)
5859 gfc_free_expr (saved_kind_expr
);
5860 if (type_param_spec_list
)
5861 gfc_free_actual_arglist (type_param_spec_list
);
5862 if (decl_type_param_list
)
5863 gfc_free_actual_arglist (decl_type_param_list
);
5864 saved_kind_expr
= NULL
;
5865 gfc_free_array_spec (current_as
);
5871 /* Match a prefix associated with a function or subroutine
5872 declaration. If the typespec pointer is nonnull, then a typespec
5873 can be matched. Note that if nothing matches, MATCH_YES is
5874 returned (the null string was matched). */
5877 gfc_match_prefix (gfc_typespec
*ts
)
5883 gfc_clear_attr (¤t_attr
);
5885 seen_impure
= false;
5887 gcc_assert (!gfc_matching_prefix
);
5888 gfc_matching_prefix
= true;
5892 found_prefix
= false;
5894 /* MODULE is a prefix like PURE, ELEMENTAL, etc., having a
5895 corresponding attribute seems natural and distinguishes these
5896 procedures from procedure types of PROC_MODULE, which these are
5898 if (gfc_match ("module% ") == MATCH_YES
)
5900 if (!gfc_notify_std (GFC_STD_F2008
, "MODULE prefix at %C"))
5903 current_attr
.module_procedure
= 1;
5904 found_prefix
= true;
5907 if (!seen_type
&& ts
!= NULL
5908 && gfc_match_decl_type_spec (ts
, 0) == MATCH_YES
5909 && gfc_match_space () == MATCH_YES
)
5913 found_prefix
= true;
5916 if (gfc_match ("elemental% ") == MATCH_YES
)
5918 if (!gfc_add_elemental (¤t_attr
, NULL
))
5921 found_prefix
= true;
5924 if (gfc_match ("pure% ") == MATCH_YES
)
5926 if (!gfc_add_pure (¤t_attr
, NULL
))
5929 found_prefix
= true;
5932 if (gfc_match ("recursive% ") == MATCH_YES
)
5934 if (!gfc_add_recursive (¤t_attr
, NULL
))
5937 found_prefix
= true;
5940 /* IMPURE is a somewhat special case, as it needs not set an actual
5941 attribute but rather only prevents ELEMENTAL routines from being
5942 automatically PURE. */
5943 if (gfc_match ("impure% ") == MATCH_YES
)
5945 if (!gfc_notify_std (GFC_STD_F2008
, "IMPURE procedure at %C"))
5949 found_prefix
= true;
5952 while (found_prefix
);
5954 /* IMPURE and PURE must not both appear, of course. */
5955 if (seen_impure
&& current_attr
.pure
)
5957 gfc_error ("PURE and IMPURE must not appear both at %C");
5961 /* If IMPURE it not seen but the procedure is ELEMENTAL, mark it as PURE. */
5962 if (!seen_impure
&& current_attr
.elemental
&& !current_attr
.pure
)
5964 if (!gfc_add_pure (¤t_attr
, NULL
))
5968 /* At this point, the next item is not a prefix. */
5969 gcc_assert (gfc_matching_prefix
);
5971 gfc_matching_prefix
= false;
5975 gcc_assert (gfc_matching_prefix
);
5976 gfc_matching_prefix
= false;
5981 /* Copy attributes matched by gfc_match_prefix() to attributes on a symbol. */
5984 copy_prefix (symbol_attribute
*dest
, locus
*where
)
5986 if (dest
->module_procedure
)
5988 if (current_attr
.elemental
)
5989 dest
->elemental
= 1;
5991 if (current_attr
.pure
)
5994 if (current_attr
.recursive
)
5995 dest
->recursive
= 1;
5997 /* Module procedures are unusual in that the 'dest' is copied from
5998 the interface declaration. However, this is an oportunity to
5999 check that the submodule declaration is compliant with the
6001 if (dest
->elemental
&& !current_attr
.elemental
)
6003 gfc_error ("ELEMENTAL prefix in MODULE PROCEDURE interface is "
6004 "missing at %L", where
);
6008 if (dest
->pure
&& !current_attr
.pure
)
6010 gfc_error ("PURE prefix in MODULE PROCEDURE interface is "
6011 "missing at %L", where
);
6015 if (dest
->recursive
&& !current_attr
.recursive
)
6017 gfc_error ("RECURSIVE prefix in MODULE PROCEDURE interface is "
6018 "missing at %L", where
);
6025 if (current_attr
.elemental
&& !gfc_add_elemental (dest
, where
))
6028 if (current_attr
.pure
&& !gfc_add_pure (dest
, where
))
6031 if (current_attr
.recursive
&& !gfc_add_recursive (dest
, where
))
6038 /* Match a formal argument list or, if typeparam is true, a
6039 type_param_name_list. */
6042 gfc_match_formal_arglist (gfc_symbol
*progname
, int st_flag
,
6043 int null_flag
, bool typeparam
)
6045 gfc_formal_arglist
*head
, *tail
, *p
, *q
;
6046 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6049 gfc_formal_arglist
*formal
= NULL
;
6053 /* Keep the interface formal argument list and null it so that the
6054 matching for the new declaration can be done. The numbers and
6055 names of the arguments are checked here. The interface formal
6056 arguments are retained in formal_arglist and the characteristics
6057 are compared in resolve.c(resolve_fl_procedure). See the remark
6058 in get_proc_name about the eventual need to copy the formal_arglist
6059 and populate the formal namespace of the interface symbol. */
6060 if (progname
->attr
.module_procedure
6061 && progname
->attr
.host_assoc
)
6063 formal
= progname
->formal
;
6064 progname
->formal
= NULL
;
6067 if (gfc_match_char ('(') != MATCH_YES
)
6074 if (gfc_match_char (')') == MATCH_YES
)
6079 if (gfc_match_char ('*') == MATCH_YES
)
6082 if (!typeparam
&& !gfc_notify_std (GFC_STD_F95_OBS
,
6083 "Alternate-return argument at %C"))
6089 gfc_error_now ("A parameter name is required at %C");
6093 m
= gfc_match_name (name
);
6097 gfc_error_now ("A parameter name is required at %C");
6101 if (!typeparam
&& gfc_get_symbol (name
, NULL
, &sym
))
6104 && gfc_get_symbol (name
, progname
->f2k_derived
, &sym
))
6108 p
= gfc_get_formal_arglist ();
6120 /* We don't add the VARIABLE flavor because the name could be a
6121 dummy procedure. We don't apply these attributes to formal
6122 arguments of statement functions. */
6123 if (sym
!= NULL
&& !st_flag
6124 && (!gfc_add_dummy(&sym
->attr
, sym
->name
, NULL
)
6125 || !gfc_missing_attr (&sym
->attr
, NULL
)))
6131 /* The name of a program unit can be in a different namespace,
6132 so check for it explicitly. After the statement is accepted,
6133 the name is checked for especially in gfc_get_symbol(). */
6134 if (gfc_new_block
!= NULL
&& sym
!= NULL
&& !typeparam
6135 && strcmp (sym
->name
, gfc_new_block
->name
) == 0)
6137 gfc_error ("Name %qs at %C is the name of the procedure",
6143 if (gfc_match_char (')') == MATCH_YES
)
6146 m
= gfc_match_char (',');
6150 gfc_error_now ("Expected parameter list in type declaration "
6153 gfc_error ("Unexpected junk in formal argument list at %C");
6159 /* Check for duplicate symbols in the formal argument list. */
6162 for (p
= head
; p
->next
; p
= p
->next
)
6167 for (q
= p
->next
; q
; q
= q
->next
)
6168 if (p
->sym
== q
->sym
)
6171 gfc_error_now ("Duplicate name %qs in parameter "
6172 "list at %C", p
->sym
->name
);
6174 gfc_error ("Duplicate symbol %qs in formal argument "
6175 "list at %C", p
->sym
->name
);
6183 if (!gfc_add_explicit_interface (progname
, IFSRC_DECL
, head
, NULL
))
6189 /* gfc_error_now used in following and return with MATCH_YES because
6190 doing otherwise results in a cascade of extraneous errors and in
6191 some cases an ICE in symbol.c(gfc_release_symbol). */
6192 if (progname
->attr
.module_procedure
&& progname
->attr
.host_assoc
)
6194 bool arg_count_mismatch
= false;
6196 if (!formal
&& head
)
6197 arg_count_mismatch
= true;
6199 /* Abbreviated module procedure declaration is not meant to have any
6200 formal arguments! */
6201 if (!progname
->abr_modproc_decl
&& formal
&& !head
)
6202 arg_count_mismatch
= true;
6204 for (p
= formal
, q
= head
; p
&& q
; p
= p
->next
, q
= q
->next
)
6206 if ((p
->next
!= NULL
&& q
->next
== NULL
)
6207 || (p
->next
== NULL
&& q
->next
!= NULL
))
6208 arg_count_mismatch
= true;
6209 else if ((p
->sym
== NULL
&& q
->sym
== NULL
)
6210 || strcmp (p
->sym
->name
, q
->sym
->name
) == 0)
6213 gfc_error_now ("Mismatch in MODULE PROCEDURE formal "
6214 "argument names (%s/%s) at %C",
6215 p
->sym
->name
, q
->sym
->name
);
6218 if (arg_count_mismatch
)
6219 gfc_error_now ("Mismatch in number of MODULE PROCEDURE "
6220 "formal arguments at %C");
6226 gfc_free_formal_arglist (head
);
6231 /* Match a RESULT specification following a function declaration or
6232 ENTRY statement. Also matches the end-of-statement. */
6235 match_result (gfc_symbol
*function
, gfc_symbol
**result
)
6237 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6241 if (gfc_match (" result (") != MATCH_YES
)
6244 m
= gfc_match_name (name
);
6248 /* Get the right paren, and that's it because there could be the
6249 bind(c) attribute after the result clause. */
6250 if (gfc_match_char (')') != MATCH_YES
)
6252 /* TODO: should report the missing right paren here. */
6256 if (strcmp (function
->name
, name
) == 0)
6258 gfc_error ("RESULT variable at %C must be different than function name");
6262 if (gfc_get_symbol (name
, NULL
, &r
))
6265 if (!gfc_add_result (&r
->attr
, r
->name
, NULL
))
6274 /* Match a function suffix, which could be a combination of a result
6275 clause and BIND(C), either one, or neither. The draft does not
6276 require them to come in a specific order. */
6279 gfc_match_suffix (gfc_symbol
*sym
, gfc_symbol
**result
)
6281 match is_bind_c
; /* Found bind(c). */
6282 match is_result
; /* Found result clause. */
6283 match found_match
; /* Status of whether we've found a good match. */
6284 char peek_char
; /* Character we're going to peek at. */
6285 bool allow_binding_name
;
6287 /* Initialize to having found nothing. */
6288 found_match
= MATCH_NO
;
6289 is_bind_c
= MATCH_NO
;
6290 is_result
= MATCH_NO
;
6292 /* Get the next char to narrow between result and bind(c). */
6293 gfc_gobble_whitespace ();
6294 peek_char
= gfc_peek_ascii_char ();
6296 /* C binding names are not allowed for internal procedures. */
6297 if (gfc_current_state () == COMP_CONTAINS
6298 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
6299 allow_binding_name
= false;
6301 allow_binding_name
= true;
6306 /* Look for result clause. */
6307 is_result
= match_result (sym
, result
);
6308 if (is_result
== MATCH_YES
)
6310 /* Now see if there is a bind(c) after it. */
6311 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
6312 /* We've found the result clause and possibly bind(c). */
6313 found_match
= MATCH_YES
;
6316 /* This should only be MATCH_ERROR. */
6317 found_match
= is_result
;
6320 /* Look for bind(c) first. */
6321 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
6322 if (is_bind_c
== MATCH_YES
)
6324 /* Now see if a result clause followed it. */
6325 is_result
= match_result (sym
, result
);
6326 found_match
= MATCH_YES
;
6330 /* Should only be a MATCH_ERROR if we get here after seeing 'b'. */
6331 found_match
= MATCH_ERROR
;
6335 gfc_error ("Unexpected junk after function declaration at %C");
6336 found_match
= MATCH_ERROR
;
6340 if (is_bind_c
== MATCH_YES
)
6342 /* Fortran 2008 draft allows BIND(C) for internal procedures. */
6343 if (gfc_current_state () == COMP_CONTAINS
6344 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
6345 && !gfc_notify_std (GFC_STD_F2008
, "BIND(C) attribute "
6346 "at %L may not be specified for an internal "
6347 "procedure", &gfc_current_locus
))
6350 if (!gfc_add_is_bind_c (&(sym
->attr
), sym
->name
, &gfc_current_locus
, 1))
6358 /* Procedure pointer return value without RESULT statement:
6359 Add "hidden" result variable named "ppr@". */
6362 add_hidden_procptr_result (gfc_symbol
*sym
)
6366 if (gfc_notification_std (GFC_STD_F2003
) == ERROR
)
6369 /* First usage case: PROCEDURE and EXTERNAL statements. */
6370 case1
= gfc_current_state () == COMP_FUNCTION
&& gfc_current_block ()
6371 && strcmp (gfc_current_block ()->name
, sym
->name
) == 0
6372 && sym
->attr
.external
;
6373 /* Second usage case: INTERFACE statements. */
6374 case2
= gfc_current_state () == COMP_INTERFACE
&& gfc_state_stack
->previous
6375 && gfc_state_stack
->previous
->state
== COMP_FUNCTION
6376 && strcmp (gfc_state_stack
->previous
->sym
->name
, sym
->name
) == 0;
6382 gfc_get_sym_tree ("ppr@", gfc_current_ns
, &stree
, false);
6386 gfc_get_sym_tree ("ppr@", gfc_current_ns
->parent
, &stree
, false);
6387 st2
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "ppr@");
6388 st2
->n
.sym
= stree
->n
.sym
;
6389 stree
->n
.sym
->refs
++;
6391 sym
->result
= stree
->n
.sym
;
6393 sym
->result
->attr
.proc_pointer
= sym
->attr
.proc_pointer
;
6394 sym
->result
->attr
.pointer
= sym
->attr
.pointer
;
6395 sym
->result
->attr
.external
= sym
->attr
.external
;
6396 sym
->result
->attr
.referenced
= sym
->attr
.referenced
;
6397 sym
->result
->ts
= sym
->ts
;
6398 sym
->attr
.proc_pointer
= 0;
6399 sym
->attr
.pointer
= 0;
6400 sym
->attr
.external
= 0;
6401 if (sym
->result
->attr
.external
&& sym
->result
->attr
.pointer
)
6403 sym
->result
->attr
.pointer
= 0;
6404 sym
->result
->attr
.proc_pointer
= 1;
6407 return gfc_add_result (&sym
->result
->attr
, sym
->result
->name
, NULL
);
6409 /* POINTER after PROCEDURE/EXTERNAL/INTERFACE statement. */
6410 else if (sym
->attr
.function
&& !sym
->attr
.external
&& sym
->attr
.pointer
6411 && sym
->result
&& sym
->result
!= sym
&& sym
->result
->attr
.external
6412 && sym
== gfc_current_ns
->proc_name
6413 && sym
== sym
->result
->ns
->proc_name
6414 && strcmp ("ppr@", sym
->result
->name
) == 0)
6416 sym
->result
->attr
.proc_pointer
= 1;
6417 sym
->attr
.pointer
= 0;
6425 /* Match the interface for a PROCEDURE declaration,
6426 including brackets (R1212). */
6429 match_procedure_interface (gfc_symbol
**proc_if
)
6433 locus old_loc
, entry_loc
;
6434 gfc_namespace
*old_ns
= gfc_current_ns
;
6435 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6437 old_loc
= entry_loc
= gfc_current_locus
;
6438 gfc_clear_ts (¤t_ts
);
6440 if (gfc_match (" (") != MATCH_YES
)
6442 gfc_current_locus
= entry_loc
;
6446 /* Get the type spec. for the procedure interface. */
6447 old_loc
= gfc_current_locus
;
6448 m
= gfc_match_decl_type_spec (¤t_ts
, 0);
6449 gfc_gobble_whitespace ();
6450 if (m
== MATCH_YES
|| (m
== MATCH_NO
&& gfc_peek_ascii_char () == ')'))
6453 if (m
== MATCH_ERROR
)
6456 /* Procedure interface is itself a procedure. */
6457 gfc_current_locus
= old_loc
;
6458 m
= gfc_match_name (name
);
6460 /* First look to see if it is already accessible in the current
6461 namespace because it is use associated or contained. */
6463 if (gfc_find_sym_tree (name
, NULL
, 0, &st
))
6466 /* If it is still not found, then try the parent namespace, if it
6467 exists and create the symbol there if it is still not found. */
6468 if (gfc_current_ns
->parent
)
6469 gfc_current_ns
= gfc_current_ns
->parent
;
6470 if (st
== NULL
&& gfc_get_ha_sym_tree (name
, &st
))
6473 gfc_current_ns
= old_ns
;
6474 *proc_if
= st
->n
.sym
;
6479 /* Resolve interface if possible. That way, attr.procedure is only set
6480 if it is declared by a later procedure-declaration-stmt, which is
6481 invalid per F08:C1216 (cf. resolve_procedure_interface). */
6482 while ((*proc_if
)->ts
.interface
6483 && *proc_if
!= (*proc_if
)->ts
.interface
)
6484 *proc_if
= (*proc_if
)->ts
.interface
;
6486 if ((*proc_if
)->attr
.flavor
== FL_UNKNOWN
6487 && (*proc_if
)->ts
.type
== BT_UNKNOWN
6488 && !gfc_add_flavor (&(*proc_if
)->attr
, FL_PROCEDURE
,
6489 (*proc_if
)->name
, NULL
))
6494 if (gfc_match (" )") != MATCH_YES
)
6496 gfc_current_locus
= entry_loc
;
6504 /* Match a PROCEDURE declaration (R1211). */
6507 match_procedure_decl (void)
6510 gfc_symbol
*sym
, *proc_if
= NULL
;
6512 gfc_expr
*initializer
= NULL
;
6514 /* Parse interface (with brackets). */
6515 m
= match_procedure_interface (&proc_if
);
6519 /* Parse attributes (with colons). */
6520 m
= match_attr_spec();
6521 if (m
== MATCH_ERROR
)
6524 if (proc_if
&& proc_if
->attr
.is_bind_c
&& !current_attr
.is_bind_c
)
6526 current_attr
.is_bind_c
= 1;
6527 has_name_equals
= 0;
6528 curr_binding_label
= NULL
;
6531 /* Get procedure symbols. */
6534 m
= gfc_match_symbol (&sym
, 0);
6537 else if (m
== MATCH_ERROR
)
6540 /* Add current_attr to the symbol attributes. */
6541 if (!gfc_copy_attr (&sym
->attr
, ¤t_attr
, NULL
))
6544 if (sym
->attr
.is_bind_c
)
6546 /* Check for C1218. */
6547 if (!proc_if
|| !proc_if
->attr
.is_bind_c
)
6549 gfc_error ("BIND(C) attribute at %C requires "
6550 "an interface with BIND(C)");
6553 /* Check for C1217. */
6554 if (has_name_equals
&& sym
->attr
.pointer
)
6556 gfc_error ("BIND(C) procedure with NAME may not have "
6557 "POINTER attribute at %C");
6560 if (has_name_equals
&& sym
->attr
.dummy
)
6562 gfc_error ("Dummy procedure at %C may not have "
6563 "BIND(C) attribute with NAME");
6566 /* Set binding label for BIND(C). */
6567 if (!set_binding_label (&sym
->binding_label
, sym
->name
, num
))
6571 if (!gfc_add_external (&sym
->attr
, NULL
))
6574 if (add_hidden_procptr_result (sym
))
6577 if (!gfc_add_proc (&sym
->attr
, sym
->name
, NULL
))
6580 /* Set interface. */
6581 if (proc_if
!= NULL
)
6583 if (sym
->ts
.type
!= BT_UNKNOWN
)
6585 gfc_error ("Procedure %qs at %L already has basic type of %s",
6586 sym
->name
, &gfc_current_locus
,
6587 gfc_basic_typename (sym
->ts
.type
));
6590 sym
->ts
.interface
= proc_if
;
6591 sym
->attr
.untyped
= 1;
6592 sym
->attr
.if_source
= IFSRC_IFBODY
;
6594 else if (current_ts
.type
!= BT_UNKNOWN
)
6596 if (!gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
6598 sym
->ts
.interface
= gfc_new_symbol ("", gfc_current_ns
);
6599 sym
->ts
.interface
->ts
= current_ts
;
6600 sym
->ts
.interface
->attr
.flavor
= FL_PROCEDURE
;
6601 sym
->ts
.interface
->attr
.function
= 1;
6602 sym
->attr
.function
= 1;
6603 sym
->attr
.if_source
= IFSRC_UNKNOWN
;
6606 if (gfc_match (" =>") == MATCH_YES
)
6608 if (!current_attr
.pointer
)
6610 gfc_error ("Initialization at %C isn't for a pointer variable");
6615 m
= match_pointer_init (&initializer
, 1);
6619 if (!add_init_expr_to_sym (sym
->name
, &initializer
, &gfc_current_locus
))
6624 if (gfc_match_eos () == MATCH_YES
)
6626 if (gfc_match_char (',') != MATCH_YES
)
6631 gfc_error ("Syntax error in PROCEDURE statement at %C");
6635 /* Free stuff up and return. */
6636 gfc_free_expr (initializer
);
6642 match_binding_attributes (gfc_typebound_proc
* ba
, bool generic
, bool ppc
);
6645 /* Match a procedure pointer component declaration (R445). */
6648 match_ppc_decl (void)
6651 gfc_symbol
*proc_if
= NULL
;
6655 gfc_expr
*initializer
= NULL
;
6656 gfc_typebound_proc
* tb
;
6657 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6659 /* Parse interface (with brackets). */
6660 m
= match_procedure_interface (&proc_if
);
6664 /* Parse attributes. */
6665 tb
= XCNEW (gfc_typebound_proc
);
6666 tb
->where
= gfc_current_locus
;
6667 m
= match_binding_attributes (tb
, false, true);
6668 if (m
== MATCH_ERROR
)
6671 gfc_clear_attr (¤t_attr
);
6672 current_attr
.procedure
= 1;
6673 current_attr
.proc_pointer
= 1;
6674 current_attr
.access
= tb
->access
;
6675 current_attr
.flavor
= FL_PROCEDURE
;
6677 /* Match the colons (required). */
6678 if (gfc_match (" ::") != MATCH_YES
)
6680 gfc_error ("Expected %<::%> after binding-attributes at %C");
6684 /* Check for C450. */
6685 if (!tb
->nopass
&& proc_if
== NULL
)
6687 gfc_error("NOPASS or explicit interface required at %C");
6691 if (!gfc_notify_std (GFC_STD_F2003
, "Procedure pointer component at %C"))
6694 /* Match PPC names. */
6698 m
= gfc_match_name (name
);
6701 else if (m
== MATCH_ERROR
)
6704 if (!gfc_add_component (gfc_current_block(), name
, &c
))
6707 /* Add current_attr to the symbol attributes. */
6708 if (!gfc_copy_attr (&c
->attr
, ¤t_attr
, NULL
))
6711 if (!gfc_add_external (&c
->attr
, NULL
))
6714 if (!gfc_add_proc (&c
->attr
, name
, NULL
))
6721 c
->tb
= XCNEW (gfc_typebound_proc
);
6722 c
->tb
->where
= gfc_current_locus
;
6726 /* Set interface. */
6727 if (proc_if
!= NULL
)
6729 c
->ts
.interface
= proc_if
;
6730 c
->attr
.untyped
= 1;
6731 c
->attr
.if_source
= IFSRC_IFBODY
;
6733 else if (ts
.type
!= BT_UNKNOWN
)
6736 c
->ts
.interface
= gfc_new_symbol ("", gfc_current_ns
);
6737 c
->ts
.interface
->result
= c
->ts
.interface
;
6738 c
->ts
.interface
->ts
= ts
;
6739 c
->ts
.interface
->attr
.flavor
= FL_PROCEDURE
;
6740 c
->ts
.interface
->attr
.function
= 1;
6741 c
->attr
.function
= 1;
6742 c
->attr
.if_source
= IFSRC_UNKNOWN
;
6745 if (gfc_match (" =>") == MATCH_YES
)
6747 m
= match_pointer_init (&initializer
, 1);
6750 gfc_free_expr (initializer
);
6753 c
->initializer
= initializer
;
6756 if (gfc_match_eos () == MATCH_YES
)
6758 if (gfc_match_char (',') != MATCH_YES
)
6763 gfc_error ("Syntax error in procedure pointer component at %C");
6768 /* Match a PROCEDURE declaration inside an interface (R1206). */
6771 match_procedure_in_interface (void)
6775 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6778 if (current_interface
.type
== INTERFACE_NAMELESS
6779 || current_interface
.type
== INTERFACE_ABSTRACT
)
6781 gfc_error ("PROCEDURE at %C must be in a generic interface");
6785 /* Check if the F2008 optional double colon appears. */
6786 gfc_gobble_whitespace ();
6787 old_locus
= gfc_current_locus
;
6788 if (gfc_match ("::") == MATCH_YES
)
6790 if (!gfc_notify_std (GFC_STD_F2008
, "double colon in "
6791 "MODULE PROCEDURE statement at %L", &old_locus
))
6795 gfc_current_locus
= old_locus
;
6799 m
= gfc_match_name (name
);
6802 else if (m
== MATCH_ERROR
)
6804 if (gfc_get_symbol (name
, gfc_current_ns
->parent
, &sym
))
6807 if (!gfc_add_interface (sym
))
6810 if (gfc_match_eos () == MATCH_YES
)
6812 if (gfc_match_char (',') != MATCH_YES
)
6819 gfc_error ("Syntax error in PROCEDURE statement at %C");
6824 /* General matcher for PROCEDURE declarations. */
6826 static match
match_procedure_in_type (void);
6829 gfc_match_procedure (void)
6833 switch (gfc_current_state ())
6838 case COMP_SUBMODULE
:
6839 case COMP_SUBROUTINE
:
6842 m
= match_procedure_decl ();
6844 case COMP_INTERFACE
:
6845 m
= match_procedure_in_interface ();
6848 m
= match_ppc_decl ();
6850 case COMP_DERIVED_CONTAINS
:
6851 m
= match_procedure_in_type ();
6860 if (!gfc_notify_std (GFC_STD_F2003
, "PROCEDURE statement at %C"))
6867 /* Warn if a matched procedure has the same name as an intrinsic; this is
6868 simply a wrapper around gfc_warn_intrinsic_shadow that interprets the current
6869 parser-state-stack to find out whether we're in a module. */
6872 do_warn_intrinsic_shadow (const gfc_symbol
* sym
, bool func
)
6876 in_module
= (gfc_state_stack
->previous
6877 && (gfc_state_stack
->previous
->state
== COMP_MODULE
6878 || gfc_state_stack
->previous
->state
== COMP_SUBMODULE
));
6880 gfc_warn_intrinsic_shadow (sym
, in_module
, func
);
6884 /* Match a function declaration. */
6887 gfc_match_function_decl (void)
6889 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6890 gfc_symbol
*sym
, *result
;
6894 match found_match
; /* Status returned by match func. */
6896 if (gfc_current_state () != COMP_NONE
6897 && gfc_current_state () != COMP_INTERFACE
6898 && gfc_current_state () != COMP_CONTAINS
)
6901 gfc_clear_ts (¤t_ts
);
6903 old_loc
= gfc_current_locus
;
6905 m
= gfc_match_prefix (¤t_ts
);
6908 gfc_current_locus
= old_loc
;
6912 if (gfc_match ("function% %n", name
) != MATCH_YES
)
6914 gfc_current_locus
= old_loc
;
6918 if (get_proc_name (name
, &sym
, false))
6921 if (add_hidden_procptr_result (sym
))
6924 if (current_attr
.module_procedure
)
6925 sym
->attr
.module_procedure
= 1;
6927 gfc_new_block
= sym
;
6929 m
= gfc_match_formal_arglist (sym
, 0, 0);
6932 gfc_error ("Expected formal argument list in function "
6933 "definition at %C");
6937 else if (m
== MATCH_ERROR
)
6942 /* According to the draft, the bind(c) and result clause can
6943 come in either order after the formal_arg_list (i.e., either
6944 can be first, both can exist together or by themselves or neither
6945 one). Therefore, the match_result can't match the end of the
6946 string, and check for the bind(c) or result clause in either order. */
6947 found_match
= gfc_match_eos ();
6949 /* Make sure that it isn't already declared as BIND(C). If it is, it
6950 must have been marked BIND(C) with a BIND(C) attribute and that is
6951 not allowed for procedures. */
6952 if (sym
->attr
.is_bind_c
== 1)
6954 sym
->attr
.is_bind_c
= 0;
6955 if (sym
->old_symbol
!= NULL
)
6956 gfc_error_now ("BIND(C) attribute at %L can only be used for "
6957 "variables or common blocks",
6958 &(sym
->old_symbol
->declared_at
));
6960 gfc_error_now ("BIND(C) attribute at %L can only be used for "
6961 "variables or common blocks", &gfc_current_locus
);
6964 if (found_match
!= MATCH_YES
)
6966 /* If we haven't found the end-of-statement, look for a suffix. */
6967 suffix_match
= gfc_match_suffix (sym
, &result
);
6968 if (suffix_match
== MATCH_YES
)
6969 /* Need to get the eos now. */
6970 found_match
= gfc_match_eos ();
6972 found_match
= suffix_match
;
6975 if(found_match
!= MATCH_YES
)
6979 /* Make changes to the symbol. */
6982 if (!gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
6985 if (!gfc_missing_attr (&sym
->attr
, NULL
))
6988 if (!copy_prefix (&sym
->attr
, &sym
->declared_at
))
6990 if(!sym
->attr
.module_procedure
)
6996 /* Delay matching the function characteristics until after the
6997 specification block by signalling kind=-1. */
6998 sym
->declared_at
= old_loc
;
6999 if (current_ts
.type
!= BT_UNKNOWN
)
7000 current_ts
.kind
= -1;
7002 current_ts
.kind
= 0;
7006 if (current_ts
.type
!= BT_UNKNOWN
7007 && !gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
7013 if (current_ts
.type
!= BT_UNKNOWN
7014 && !gfc_add_type (result
, ¤t_ts
, &gfc_current_locus
))
7016 sym
->result
= result
;
7019 /* Warn if this procedure has the same name as an intrinsic. */
7020 do_warn_intrinsic_shadow (sym
, true);
7026 gfc_current_locus
= old_loc
;
7031 /* This is mostly a copy of parse.c(add_global_procedure) but modified to
7032 pass the name of the entry, rather than the gfc_current_block name, and
7033 to return false upon finding an existing global entry. */
7036 add_global_entry (const char *name
, const char *binding_label
, bool sub
,
7040 enum gfc_symbol_type type
;
7042 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
7044 /* Only in Fortran 2003: For procedures with a binding label also the Fortran
7045 name is a global identifier. */
7046 if (!binding_label
|| gfc_notification_std (GFC_STD_F2008
))
7048 s
= gfc_get_gsymbol (name
);
7050 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= type
))
7052 gfc_global_used (s
, where
);
7061 s
->ns
= gfc_current_ns
;
7065 /* Don't add the symbol multiple times. */
7067 && (!gfc_notification_std (GFC_STD_F2008
)
7068 || strcmp (name
, binding_label
) != 0))
7070 s
= gfc_get_gsymbol (binding_label
);
7072 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= type
))
7074 gfc_global_used (s
, where
);
7081 s
->binding_label
= binding_label
;
7084 s
->ns
= gfc_current_ns
;
7092 /* Match an ENTRY statement. */
7095 gfc_match_entry (void)
7100 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7101 gfc_compile_state state
;
7105 bool module_procedure
;
7109 m
= gfc_match_name (name
);
7113 if (!gfc_notify_std (GFC_STD_F2008_OBS
, "ENTRY statement at %C"))
7116 state
= gfc_current_state ();
7117 if (state
!= COMP_SUBROUTINE
&& state
!= COMP_FUNCTION
)
7122 gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
7125 gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
7127 case COMP_SUBMODULE
:
7128 gfc_error ("ENTRY statement at %C cannot appear within a SUBMODULE");
7130 case COMP_BLOCK_DATA
:
7131 gfc_error ("ENTRY statement at %C cannot appear within "
7134 case COMP_INTERFACE
:
7135 gfc_error ("ENTRY statement at %C cannot appear within "
7138 case COMP_STRUCTURE
:
7139 gfc_error ("ENTRY statement at %C cannot appear within "
7140 "a STRUCTURE block");
7143 gfc_error ("ENTRY statement at %C cannot appear within "
7144 "a DERIVED TYPE block");
7147 gfc_error ("ENTRY statement at %C cannot appear within "
7148 "an IF-THEN block");
7151 case COMP_DO_CONCURRENT
:
7152 gfc_error ("ENTRY statement at %C cannot appear within "
7156 gfc_error ("ENTRY statement at %C cannot appear within "
7160 gfc_error ("ENTRY statement at %C cannot appear within "
7164 gfc_error ("ENTRY statement at %C cannot appear within "
7168 gfc_error ("ENTRY statement at %C cannot appear within "
7169 "a contained subprogram");
7172 gfc_error ("Unexpected ENTRY statement at %C");
7177 if ((state
== COMP_SUBROUTINE
|| state
== COMP_FUNCTION
)
7178 && gfc_state_stack
->previous
->state
== COMP_INTERFACE
)
7180 gfc_error ("ENTRY statement at %C cannot appear within an INTERFACE");
7184 module_procedure
= gfc_current_ns
->parent
!= NULL
7185 && gfc_current_ns
->parent
->proc_name
7186 && gfc_current_ns
->parent
->proc_name
->attr
.flavor
7189 if (gfc_current_ns
->parent
!= NULL
7190 && gfc_current_ns
->parent
->proc_name
7191 && !module_procedure
)
7193 gfc_error("ENTRY statement at %C cannot appear in a "
7194 "contained procedure");
7198 /* Module function entries need special care in get_proc_name
7199 because previous references within the function will have
7200 created symbols attached to the current namespace. */
7201 if (get_proc_name (name
, &entry
,
7202 gfc_current_ns
->parent
!= NULL
7203 && module_procedure
))
7206 proc
= gfc_current_block ();
7208 /* Make sure that it isn't already declared as BIND(C). If it is, it
7209 must have been marked BIND(C) with a BIND(C) attribute and that is
7210 not allowed for procedures. */
7211 if (entry
->attr
.is_bind_c
== 1)
7213 entry
->attr
.is_bind_c
= 0;
7214 if (entry
->old_symbol
!= NULL
)
7215 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7216 "variables or common blocks",
7217 &(entry
->old_symbol
->declared_at
));
7219 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7220 "variables or common blocks", &gfc_current_locus
);
7223 /* Check what next non-whitespace character is so we can tell if there
7224 is the required parens if we have a BIND(C). */
7225 old_loc
= gfc_current_locus
;
7226 gfc_gobble_whitespace ();
7227 peek_char
= gfc_peek_ascii_char ();
7229 if (state
== COMP_SUBROUTINE
)
7231 m
= gfc_match_formal_arglist (entry
, 0, 1);
7235 /* Call gfc_match_bind_c with allow_binding_name = true as ENTRY can
7236 never be an internal procedure. */
7237 is_bind_c
= gfc_match_bind_c (entry
, true);
7238 if (is_bind_c
== MATCH_ERROR
)
7240 if (is_bind_c
== MATCH_YES
)
7242 if (peek_char
!= '(')
7244 gfc_error ("Missing required parentheses before BIND(C) at %C");
7247 if (!gfc_add_is_bind_c (&(entry
->attr
), entry
->name
,
7248 &(entry
->declared_at
), 1))
7252 if (!gfc_current_ns
->parent
7253 && !add_global_entry (name
, entry
->binding_label
, true,
7257 /* An entry in a subroutine. */
7258 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
7259 || !gfc_add_subroutine (&entry
->attr
, entry
->name
, NULL
))
7264 /* An entry in a function.
7265 We need to take special care because writing
7270 ENTRY f() RESULT (r)
7272 ENTRY f RESULT (r). */
7273 if (gfc_match_eos () == MATCH_YES
)
7275 gfc_current_locus
= old_loc
;
7276 /* Match the empty argument list, and add the interface to
7278 m
= gfc_match_formal_arglist (entry
, 0, 1);
7281 m
= gfc_match_formal_arglist (entry
, 0, 0);
7288 if (gfc_match_eos () == MATCH_YES
)
7290 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
7291 || !gfc_add_function (&entry
->attr
, entry
->name
, NULL
))
7294 entry
->result
= entry
;
7298 m
= gfc_match_suffix (entry
, &result
);
7300 gfc_syntax_error (ST_ENTRY
);
7306 if (!gfc_add_result (&result
->attr
, result
->name
, NULL
)
7307 || !gfc_add_entry (&entry
->attr
, result
->name
, NULL
)
7308 || !gfc_add_function (&entry
->attr
, result
->name
, NULL
))
7310 entry
->result
= result
;
7314 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
7315 || !gfc_add_function (&entry
->attr
, entry
->name
, NULL
))
7317 entry
->result
= entry
;
7321 if (!gfc_current_ns
->parent
7322 && !add_global_entry (name
, entry
->binding_label
, false,
7327 if (gfc_match_eos () != MATCH_YES
)
7329 gfc_syntax_error (ST_ENTRY
);
7333 entry
->attr
.recursive
= proc
->attr
.recursive
;
7334 entry
->attr
.elemental
= proc
->attr
.elemental
;
7335 entry
->attr
.pure
= proc
->attr
.pure
;
7337 el
= gfc_get_entry_list ();
7339 el
->next
= gfc_current_ns
->entries
;
7340 gfc_current_ns
->entries
= el
;
7342 el
->id
= el
->next
->id
+ 1;
7346 new_st
.op
= EXEC_ENTRY
;
7347 new_st
.ext
.entry
= el
;
7353 /* Match a subroutine statement, including optional prefixes. */
7356 gfc_match_subroutine (void)
7358 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7363 bool allow_binding_name
;
7365 if (gfc_current_state () != COMP_NONE
7366 && gfc_current_state () != COMP_INTERFACE
7367 && gfc_current_state () != COMP_CONTAINS
)
7370 m
= gfc_match_prefix (NULL
);
7374 m
= gfc_match ("subroutine% %n", name
);
7378 if (get_proc_name (name
, &sym
, false))
7381 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
7382 the symbol existed before. */
7383 sym
->declared_at
= gfc_current_locus
;
7385 if (current_attr
.module_procedure
)
7386 sym
->attr
.module_procedure
= 1;
7388 if (add_hidden_procptr_result (sym
))
7391 gfc_new_block
= sym
;
7393 /* Check what next non-whitespace character is so we can tell if there
7394 is the required parens if we have a BIND(C). */
7395 gfc_gobble_whitespace ();
7396 peek_char
= gfc_peek_ascii_char ();
7398 if (!gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
))
7401 if (gfc_match_formal_arglist (sym
, 0, 1) != MATCH_YES
)
7404 /* Make sure that it isn't already declared as BIND(C). If it is, it
7405 must have been marked BIND(C) with a BIND(C) attribute and that is
7406 not allowed for procedures. */
7407 if (sym
->attr
.is_bind_c
== 1)
7409 sym
->attr
.is_bind_c
= 0;
7410 if (sym
->old_symbol
!= NULL
)
7411 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7412 "variables or common blocks",
7413 &(sym
->old_symbol
->declared_at
));
7415 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7416 "variables or common blocks", &gfc_current_locus
);
7419 /* C binding names are not allowed for internal procedures. */
7420 if (gfc_current_state () == COMP_CONTAINS
7421 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
7422 allow_binding_name
= false;
7424 allow_binding_name
= true;
7426 /* Here, we are just checking if it has the bind(c) attribute, and if
7427 so, then we need to make sure it's all correct. If it doesn't,
7428 we still need to continue matching the rest of the subroutine line. */
7429 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
7430 if (is_bind_c
== MATCH_ERROR
)
7432 /* There was an attempt at the bind(c), but it was wrong. An
7433 error message should have been printed w/in the gfc_match_bind_c
7434 so here we'll just return the MATCH_ERROR. */
7438 if (is_bind_c
== MATCH_YES
)
7440 /* The following is allowed in the Fortran 2008 draft. */
7441 if (gfc_current_state () == COMP_CONTAINS
7442 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
7443 && !gfc_notify_std (GFC_STD_F2008
, "BIND(C) attribute "
7444 "at %L may not be specified for an internal "
7445 "procedure", &gfc_current_locus
))
7448 if (peek_char
!= '(')
7450 gfc_error ("Missing required parentheses before BIND(C) at %C");
7453 if (!gfc_add_is_bind_c (&(sym
->attr
), sym
->name
,
7454 &(sym
->declared_at
), 1))
7458 if (gfc_match_eos () != MATCH_YES
)
7460 gfc_syntax_error (ST_SUBROUTINE
);
7464 if (!copy_prefix (&sym
->attr
, &sym
->declared_at
))
7466 if(!sym
->attr
.module_procedure
)
7472 /* Warn if it has the same name as an intrinsic. */
7473 do_warn_intrinsic_shadow (sym
, false);
7479 /* Check that the NAME identifier in a BIND attribute or statement
7480 is conform to C identifier rules. */
7483 check_bind_name_identifier (char **name
)
7485 char *n
= *name
, *p
;
7487 /* Remove leading spaces. */
7491 /* On an empty string, free memory and set name to NULL. */
7499 /* Remove trailing spaces. */
7500 p
= n
+ strlen(n
) - 1;
7504 /* Insert the identifier into the symbol table. */
7509 /* Now check that identifier is valid under C rules. */
7512 gfc_error ("Invalid C identifier in NAME= specifier at %C");
7517 if (!(ISALNUM (*p
) || *p
== '_' || *p
== '$'))
7519 gfc_error ("Invalid C identifier in NAME= specifier at %C");
7527 /* Match a BIND(C) specifier, with the optional 'name=' specifier if
7528 given, and set the binding label in either the given symbol (if not
7529 NULL), or in the current_ts. The symbol may be NULL because we may
7530 encounter the BIND(C) before the declaration itself. Return
7531 MATCH_NO if what we're looking at isn't a BIND(C) specifier,
7532 MATCH_ERROR if it is a BIND(C) clause but an error was encountered,
7533 or MATCH_YES if the specifier was correct and the binding label and
7534 bind(c) fields were set correctly for the given symbol or the
7535 current_ts. If allow_binding_name is false, no binding name may be
7539 gfc_match_bind_c (gfc_symbol
*sym
, bool allow_binding_name
)
7541 char *binding_label
= NULL
;
7544 /* Initialize the flag that specifies whether we encountered a NAME=
7545 specifier or not. */
7546 has_name_equals
= 0;
7548 /* This much we have to be able to match, in this order, if
7549 there is a bind(c) label. */
7550 if (gfc_match (" bind ( c ") != MATCH_YES
)
7553 /* Now see if there is a binding label, or if we've reached the
7554 end of the bind(c) attribute without one. */
7555 if (gfc_match_char (',') == MATCH_YES
)
7557 if (gfc_match (" name = ") != MATCH_YES
)
7559 gfc_error ("Syntax error in NAME= specifier for binding label "
7561 /* should give an error message here */
7565 has_name_equals
= 1;
7567 if (gfc_match_init_expr (&e
) != MATCH_YES
)
7573 if (!gfc_simplify_expr(e
, 0))
7575 gfc_error ("NAME= specifier at %C should be a constant expression");
7580 if (e
->expr_type
!= EXPR_CONSTANT
|| e
->ts
.type
!= BT_CHARACTER
7581 || e
->ts
.kind
!= gfc_default_character_kind
|| e
->rank
!= 0)
7583 gfc_error ("NAME= specifier at %C should be a scalar of "
7584 "default character kind");
7589 // Get a C string from the Fortran string constant
7590 binding_label
= gfc_widechar_to_char (e
->value
.character
.string
,
7591 e
->value
.character
.length
);
7594 // Check that it is valid (old gfc_match_name_C)
7595 if (check_bind_name_identifier (&binding_label
) != MATCH_YES
)
7599 /* Get the required right paren. */
7600 if (gfc_match_char (')') != MATCH_YES
)
7602 gfc_error ("Missing closing paren for binding label at %C");
7606 if (has_name_equals
&& !allow_binding_name
)
7608 gfc_error ("No binding name is allowed in BIND(C) at %C");
7612 if (has_name_equals
&& sym
!= NULL
&& sym
->attr
.dummy
)
7614 gfc_error ("For dummy procedure %s, no binding name is "
7615 "allowed in BIND(C) at %C", sym
->name
);
7620 /* Save the binding label to the symbol. If sym is null, we're
7621 probably matching the typespec attributes of a declaration and
7622 haven't gotten the name yet, and therefore, no symbol yet. */
7626 sym
->binding_label
= binding_label
;
7628 curr_binding_label
= binding_label
;
7630 else if (allow_binding_name
)
7632 /* No binding label, but if symbol isn't null, we
7633 can set the label for it here.
7634 If name="" or allow_binding_name is false, no C binding name is
7636 if (sym
!= NULL
&& sym
->name
!= NULL
&& has_name_equals
== 0)
7637 sym
->binding_label
= IDENTIFIER_POINTER (get_identifier (sym
->name
));
7640 if (has_name_equals
&& gfc_current_state () == COMP_INTERFACE
7641 && current_interface
.type
== INTERFACE_ABSTRACT
)
7643 gfc_error ("NAME not allowed on BIND(C) for ABSTRACT INTERFACE at %C");
7651 /* Return nonzero if we're currently compiling a contained procedure. */
7654 contained_procedure (void)
7656 gfc_state_data
*s
= gfc_state_stack
;
7658 if ((s
->state
== COMP_SUBROUTINE
|| s
->state
== COMP_FUNCTION
)
7659 && s
->previous
!= NULL
&& s
->previous
->state
== COMP_CONTAINS
)
7665 /* Set the kind of each enumerator. The kind is selected such that it is
7666 interoperable with the corresponding C enumeration type, making
7667 sure that -fshort-enums is honored. */
7672 enumerator_history
*current_history
= NULL
;
7676 if (max_enum
== NULL
|| enum_history
== NULL
)
7679 if (!flag_short_enums
)
7685 kind
= gfc_integer_kinds
[i
++].kind
;
7687 while (kind
< gfc_c_int_kind
7688 && gfc_check_integer_range (max_enum
->initializer
->value
.integer
,
7691 current_history
= enum_history
;
7692 while (current_history
!= NULL
)
7694 current_history
->sym
->ts
.kind
= kind
;
7695 current_history
= current_history
->next
;
7700 /* Match any of the various end-block statements. Returns the type of
7701 END to the caller. The END INTERFACE, END IF, END DO, END SELECT
7702 and END BLOCK statements cannot be replaced by a single END statement. */
7705 gfc_match_end (gfc_statement
*st
)
7707 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7708 gfc_compile_state state
;
7710 const char *block_name
;
7714 gfc_namespace
*parent_ns
, *ns
, *prev_ns
;
7715 gfc_namespace
**nsp
;
7716 bool abreviated_modproc_decl
= false;
7717 bool got_matching_end
= false;
7719 old_loc
= gfc_current_locus
;
7720 if (gfc_match ("end") != MATCH_YES
)
7723 state
= gfc_current_state ();
7724 block_name
= gfc_current_block () == NULL
7725 ? NULL
: gfc_current_block ()->name
;
7729 case COMP_ASSOCIATE
:
7731 if (!strncmp (block_name
, "block@", strlen("block@")))
7736 case COMP_DERIVED_CONTAINS
:
7737 state
= gfc_state_stack
->previous
->state
;
7738 block_name
= gfc_state_stack
->previous
->sym
== NULL
7739 ? NULL
: gfc_state_stack
->previous
->sym
->name
;
7740 abreviated_modproc_decl
= gfc_state_stack
->previous
->sym
7741 && gfc_state_stack
->previous
->sym
->abr_modproc_decl
;
7748 if (!abreviated_modproc_decl
)
7749 abreviated_modproc_decl
= gfc_current_block ()
7750 && gfc_current_block ()->abr_modproc_decl
;
7756 *st
= ST_END_PROGRAM
;
7757 target
= " program";
7761 case COMP_SUBROUTINE
:
7762 *st
= ST_END_SUBROUTINE
;
7763 if (!abreviated_modproc_decl
)
7764 target
= " subroutine";
7766 target
= " procedure";
7767 eos_ok
= !contained_procedure ();
7771 *st
= ST_END_FUNCTION
;
7772 if (!abreviated_modproc_decl
)
7773 target
= " function";
7775 target
= " procedure";
7776 eos_ok
= !contained_procedure ();
7779 case COMP_BLOCK_DATA
:
7780 *st
= ST_END_BLOCK_DATA
;
7781 target
= " block data";
7786 *st
= ST_END_MODULE
;
7791 case COMP_SUBMODULE
:
7792 *st
= ST_END_SUBMODULE
;
7793 target
= " submodule";
7797 case COMP_INTERFACE
:
7798 *st
= ST_END_INTERFACE
;
7799 target
= " interface";
7815 case COMP_STRUCTURE
:
7816 *st
= ST_END_STRUCTURE
;
7817 target
= " structure";
7822 case COMP_DERIVED_CONTAINS
:
7828 case COMP_ASSOCIATE
:
7829 *st
= ST_END_ASSOCIATE
;
7830 target
= " associate";
7847 case COMP_DO_CONCURRENT
:
7854 *st
= ST_END_CRITICAL
;
7855 target
= " critical";
7860 case COMP_SELECT_TYPE
:
7861 *st
= ST_END_SELECT
;
7867 *st
= ST_END_FORALL
;
7882 last_initializer
= NULL
;
7884 gfc_free_enum_history ();
7888 gfc_error ("Unexpected END statement at %C");
7892 old_loc
= gfc_current_locus
;
7893 if (gfc_match_eos () == MATCH_YES
)
7895 if (!eos_ok
&& (*st
== ST_END_SUBROUTINE
|| *st
== ST_END_FUNCTION
))
7897 if (!gfc_notify_std (GFC_STD_F2008
, "END statement "
7898 "instead of %s statement at %L",
7899 abreviated_modproc_decl
? "END PROCEDURE"
7900 : gfc_ascii_statement(*st
), &old_loc
))
7905 /* We would have required END [something]. */
7906 gfc_error ("%s statement expected at %L",
7907 gfc_ascii_statement (*st
), &old_loc
);
7914 /* Verify that we've got the sort of end-block that we're expecting. */
7915 if (gfc_match (target
) != MATCH_YES
)
7917 gfc_error ("Expecting %s statement at %L", abreviated_modproc_decl
7918 ? "END PROCEDURE" : gfc_ascii_statement(*st
), &old_loc
);
7922 got_matching_end
= true;
7924 old_loc
= gfc_current_locus
;
7925 /* If we're at the end, make sure a block name wasn't required. */
7926 if (gfc_match_eos () == MATCH_YES
)
7929 if (*st
!= ST_ENDDO
&& *st
!= ST_ENDIF
&& *st
!= ST_END_SELECT
7930 && *st
!= ST_END_FORALL
&& *st
!= ST_END_WHERE
&& *st
!= ST_END_BLOCK
7931 && *st
!= ST_END_ASSOCIATE
&& *st
!= ST_END_CRITICAL
)
7937 gfc_error ("Expected block name of %qs in %s statement at %L",
7938 block_name
, gfc_ascii_statement (*st
), &old_loc
);
7943 /* END INTERFACE has a special handler for its several possible endings. */
7944 if (*st
== ST_END_INTERFACE
)
7945 return gfc_match_end_interface ();
7947 /* We haven't hit the end of statement, so what is left must be an
7949 m
= gfc_match_space ();
7951 m
= gfc_match_name (name
);
7954 gfc_error ("Expected terminating name at %C");
7958 if (block_name
== NULL
)
7961 /* We have to pick out the declared submodule name from the composite
7962 required by F2008:11.2.3 para 2, which ends in the declared name. */
7963 if (state
== COMP_SUBMODULE
)
7964 block_name
= strchr (block_name
, '.') + 1;
7966 if (strcmp (name
, block_name
) != 0 && strcmp (block_name
, "ppr@") != 0)
7968 gfc_error ("Expected label %qs for %s statement at %C", block_name
,
7969 gfc_ascii_statement (*st
));
7972 /* Procedure pointer as function result. */
7973 else if (strcmp (block_name
, "ppr@") == 0
7974 && strcmp (name
, gfc_current_block ()->ns
->proc_name
->name
) != 0)
7976 gfc_error ("Expected label %qs for %s statement at %C",
7977 gfc_current_block ()->ns
->proc_name
->name
,
7978 gfc_ascii_statement (*st
));
7982 if (gfc_match_eos () == MATCH_YES
)
7986 gfc_syntax_error (*st
);
7989 gfc_current_locus
= old_loc
;
7991 /* If we are missing an END BLOCK, we created a half-ready namespace.
7992 Remove it from the parent namespace's sibling list. */
7994 while (state
== COMP_BLOCK
&& !got_matching_end
)
7996 parent_ns
= gfc_current_ns
->parent
;
7998 nsp
= &(gfc_state_stack
->previous
->tail
->ext
.block
.ns
);
8004 if (ns
== gfc_current_ns
)
8006 if (prev_ns
== NULL
)
8009 prev_ns
->sibling
= ns
->sibling
;
8015 gfc_free_namespace (gfc_current_ns
);
8016 gfc_current_ns
= parent_ns
;
8017 gfc_state_stack
= gfc_state_stack
->previous
;
8018 state
= gfc_current_state ();
8026 /***************** Attribute declaration statements ****************/
8028 /* Set the attribute of a single variable. */
8033 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8036 /* Workaround -Wmaybe-uninitialized false positive during
8037 profiledbootstrap by initializing them. */
8038 gfc_symbol
*sym
= NULL
;
8044 m
= gfc_match_name (name
);
8048 if (find_special (name
, &sym
, false))
8051 if (!check_function_name (name
))
8057 var_locus
= gfc_current_locus
;
8059 /* Deal with possible array specification for certain attributes. */
8060 if (current_attr
.dimension
8061 || current_attr
.codimension
8062 || current_attr
.allocatable
8063 || current_attr
.pointer
8064 || current_attr
.target
)
8066 m
= gfc_match_array_spec (&as
, !current_attr
.codimension
,
8067 !current_attr
.dimension
8068 && !current_attr
.pointer
8069 && !current_attr
.target
);
8070 if (m
== MATCH_ERROR
)
8073 if (current_attr
.dimension
&& m
== MATCH_NO
)
8075 gfc_error ("Missing array specification at %L in DIMENSION "
8076 "statement", &var_locus
);
8081 if (current_attr
.dimension
&& sym
->value
)
8083 gfc_error ("Dimensions specified for %s at %L after its "
8084 "initialization", sym
->name
, &var_locus
);
8089 if (current_attr
.codimension
&& m
== MATCH_NO
)
8091 gfc_error ("Missing array specification at %L in CODIMENSION "
8092 "statement", &var_locus
);
8097 if ((current_attr
.allocatable
|| current_attr
.pointer
)
8098 && (m
== MATCH_YES
) && (as
->type
!= AS_DEFERRED
))
8100 gfc_error ("Array specification must be deferred at %L", &var_locus
);
8106 /* Update symbol table. DIMENSION attribute is set in
8107 gfc_set_array_spec(). For CLASS variables, this must be applied
8108 to the first component, or '_data' field. */
8109 if (sym
->ts
.type
== BT_CLASS
&& sym
->ts
.u
.derived
->attr
.is_class
)
8111 if (!gfc_copy_attr (&CLASS_DATA(sym
)->attr
, ¤t_attr
, &var_locus
))
8119 if (current_attr
.dimension
== 0 && current_attr
.codimension
== 0
8120 && !gfc_copy_attr (&sym
->attr
, ¤t_attr
, &var_locus
))
8127 if (sym
->ts
.type
== BT_CLASS
8128 && !gfc_build_class_symbol (&sym
->ts
, &sym
->attr
, &sym
->as
))
8134 if (!gfc_set_array_spec (sym
, as
, &var_locus
))
8140 if (sym
->attr
.cray_pointee
&& sym
->as
!= NULL
)
8142 /* Fix the array spec. */
8143 m
= gfc_mod_pointee_as (sym
->as
);
8144 if (m
== MATCH_ERROR
)
8148 if (!gfc_add_attribute (&sym
->attr
, &var_locus
))
8154 if ((current_attr
.external
|| current_attr
.intrinsic
)
8155 && sym
->attr
.flavor
!= FL_PROCEDURE
8156 && !gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, NULL
))
8162 add_hidden_procptr_result (sym
);
8167 gfc_free_array_spec (as
);
8172 /* Generic attribute declaration subroutine. Used for attributes that
8173 just have a list of names. */
8180 /* Gobble the optional double colon, by simply ignoring the result
8190 if (gfc_match_eos () == MATCH_YES
)
8196 if (gfc_match_char (',') != MATCH_YES
)
8198 gfc_error ("Unexpected character in variable list at %C");
8208 /* This routine matches Cray Pointer declarations of the form:
8209 pointer ( <pointer>, <pointee> )
8211 pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...
8212 The pointer, if already declared, should be an integer. Otherwise, we
8213 set it as BT_INTEGER with kind gfc_index_integer_kind. The pointee may
8214 be either a scalar, or an array declaration. No space is allocated for
8215 the pointee. For the statement
8216 pointer (ipt, ar(10))
8217 any subsequent uses of ar will be translated (in C-notation) as
8218 ar(i) => ((<type> *) ipt)(i)
8219 After gimplification, pointee variable will disappear in the code. */
8222 cray_pointer_decl (void)
8225 gfc_array_spec
*as
= NULL
;
8226 gfc_symbol
*cptr
; /* Pointer symbol. */
8227 gfc_symbol
*cpte
; /* Pointee symbol. */
8233 if (gfc_match_char ('(') != MATCH_YES
)
8235 gfc_error ("Expected %<(%> at %C");
8239 /* Match pointer. */
8240 var_locus
= gfc_current_locus
;
8241 gfc_clear_attr (¤t_attr
);
8242 gfc_add_cray_pointer (¤t_attr
, &var_locus
);
8243 current_ts
.type
= BT_INTEGER
;
8244 current_ts
.kind
= gfc_index_integer_kind
;
8246 m
= gfc_match_symbol (&cptr
, 0);
8249 gfc_error ("Expected variable name at %C");
8253 if (!gfc_add_cray_pointer (&cptr
->attr
, &var_locus
))
8256 gfc_set_sym_referenced (cptr
);
8258 if (cptr
->ts
.type
== BT_UNKNOWN
) /* Override the type, if necessary. */
8260 cptr
->ts
.type
= BT_INTEGER
;
8261 cptr
->ts
.kind
= gfc_index_integer_kind
;
8263 else if (cptr
->ts
.type
!= BT_INTEGER
)
8265 gfc_error ("Cray pointer at %C must be an integer");
8268 else if (cptr
->ts
.kind
< gfc_index_integer_kind
)
8269 gfc_warning (0, "Cray pointer at %C has %d bytes of precision;"
8270 " memory addresses require %d bytes",
8271 cptr
->ts
.kind
, gfc_index_integer_kind
);
8273 if (gfc_match_char (',') != MATCH_YES
)
8275 gfc_error ("Expected \",\" at %C");
8279 /* Match Pointee. */
8280 var_locus
= gfc_current_locus
;
8281 gfc_clear_attr (¤t_attr
);
8282 gfc_add_cray_pointee (¤t_attr
, &var_locus
);
8283 current_ts
.type
= BT_UNKNOWN
;
8284 current_ts
.kind
= 0;
8286 m
= gfc_match_symbol (&cpte
, 0);
8289 gfc_error ("Expected variable name at %C");
8293 /* Check for an optional array spec. */
8294 m
= gfc_match_array_spec (&as
, true, false);
8295 if (m
== MATCH_ERROR
)
8297 gfc_free_array_spec (as
);
8300 else if (m
== MATCH_NO
)
8302 gfc_free_array_spec (as
);
8306 if (!gfc_add_cray_pointee (&cpte
->attr
, &var_locus
))
8309 gfc_set_sym_referenced (cpte
);
8311 if (cpte
->as
== NULL
)
8313 if (!gfc_set_array_spec (cpte
, as
, &var_locus
))
8314 gfc_internal_error ("Couldn't set Cray pointee array spec.");
8316 else if (as
!= NULL
)
8318 gfc_error ("Duplicate array spec for Cray pointee at %C");
8319 gfc_free_array_spec (as
);
8325 if (cpte
->as
!= NULL
)
8327 /* Fix array spec. */
8328 m
= gfc_mod_pointee_as (cpte
->as
);
8329 if (m
== MATCH_ERROR
)
8333 /* Point the Pointee at the Pointer. */
8334 cpte
->cp_pointer
= cptr
;
8336 if (gfc_match_char (')') != MATCH_YES
)
8338 gfc_error ("Expected \")\" at %C");
8341 m
= gfc_match_char (',');
8343 done
= true; /* Stop searching for more declarations. */
8347 if (m
== MATCH_ERROR
/* Failed when trying to find ',' above. */
8348 || gfc_match_eos () != MATCH_YES
)
8350 gfc_error ("Expected %<,%> or end of statement at %C");
8358 gfc_match_external (void)
8361 gfc_clear_attr (¤t_attr
);
8362 current_attr
.external
= 1;
8364 return attr_decl ();
8369 gfc_match_intent (void)
8373 /* This is not allowed within a BLOCK construct! */
8374 if (gfc_current_state () == COMP_BLOCK
)
8376 gfc_error ("INTENT is not allowed inside of BLOCK at %C");
8380 intent
= match_intent_spec ();
8381 if (intent
== INTENT_UNKNOWN
)
8384 gfc_clear_attr (¤t_attr
);
8385 current_attr
.intent
= intent
;
8387 return attr_decl ();
8392 gfc_match_intrinsic (void)
8395 gfc_clear_attr (¤t_attr
);
8396 current_attr
.intrinsic
= 1;
8398 return attr_decl ();
8403 gfc_match_optional (void)
8405 /* This is not allowed within a BLOCK construct! */
8406 if (gfc_current_state () == COMP_BLOCK
)
8408 gfc_error ("OPTIONAL is not allowed inside of BLOCK at %C");
8412 gfc_clear_attr (¤t_attr
);
8413 current_attr
.optional
= 1;
8415 return attr_decl ();
8420 gfc_match_pointer (void)
8422 gfc_gobble_whitespace ();
8423 if (gfc_peek_ascii_char () == '(')
8425 if (!flag_cray_pointer
)
8427 gfc_error ("Cray pointer declaration at %C requires -fcray-pointer "
8431 return cray_pointer_decl ();
8435 gfc_clear_attr (¤t_attr
);
8436 current_attr
.pointer
= 1;
8438 return attr_decl ();
8444 gfc_match_allocatable (void)
8446 gfc_clear_attr (¤t_attr
);
8447 current_attr
.allocatable
= 1;
8449 return attr_decl ();
8454 gfc_match_codimension (void)
8456 gfc_clear_attr (¤t_attr
);
8457 current_attr
.codimension
= 1;
8459 return attr_decl ();
8464 gfc_match_contiguous (void)
8466 if (!gfc_notify_std (GFC_STD_F2008
, "CONTIGUOUS statement at %C"))
8469 gfc_clear_attr (¤t_attr
);
8470 current_attr
.contiguous
= 1;
8472 return attr_decl ();
8477 gfc_match_dimension (void)
8479 gfc_clear_attr (¤t_attr
);
8480 current_attr
.dimension
= 1;
8482 return attr_decl ();
8487 gfc_match_target (void)
8489 gfc_clear_attr (¤t_attr
);
8490 current_attr
.target
= 1;
8492 return attr_decl ();
8496 /* Match the list of entities being specified in a PUBLIC or PRIVATE
8500 access_attr_decl (gfc_statement st
)
8502 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8503 interface_type type
;
8505 gfc_symbol
*sym
, *dt_sym
;
8506 gfc_intrinsic_op op
;
8509 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
8514 m
= gfc_match_generic_spec (&type
, name
, &op
);
8517 if (m
== MATCH_ERROR
)
8522 case INTERFACE_NAMELESS
:
8523 case INTERFACE_ABSTRACT
:
8526 case INTERFACE_GENERIC
:
8527 case INTERFACE_DTIO
:
8529 if (gfc_get_symbol (name
, NULL
, &sym
))
8532 if (type
== INTERFACE_DTIO
8533 && gfc_current_ns
->proc_name
8534 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
8535 && sym
->attr
.flavor
== FL_UNKNOWN
)
8536 sym
->attr
.flavor
= FL_PROCEDURE
;
8538 if (!gfc_add_access (&sym
->attr
,
8540 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
,
8544 if (sym
->attr
.generic
&& (dt_sym
= gfc_find_dt_in_generic (sym
))
8545 && !gfc_add_access (&dt_sym
->attr
,
8547 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
,
8553 case INTERFACE_INTRINSIC_OP
:
8554 if (gfc_current_ns
->operator_access
[op
] == ACCESS_UNKNOWN
)
8556 gfc_intrinsic_op other_op
;
8558 gfc_current_ns
->operator_access
[op
] =
8559 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
8561 /* Handle the case if there is another op with the same
8562 function, for INTRINSIC_EQ vs. INTRINSIC_EQ_OS and so on. */
8563 other_op
= gfc_equivalent_op (op
);
8565 if (other_op
!= INTRINSIC_NONE
)
8566 gfc_current_ns
->operator_access
[other_op
] =
8567 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
8572 gfc_error ("Access specification of the %s operator at %C has "
8573 "already been specified", gfc_op2string (op
));
8579 case INTERFACE_USER_OP
:
8580 uop
= gfc_get_uop (name
);
8582 if (uop
->access
== ACCESS_UNKNOWN
)
8584 uop
->access
= (st
== ST_PUBLIC
)
8585 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
8589 gfc_error ("Access specification of the .%s. operator at %C "
8590 "has already been specified", sym
->name
);
8597 if (gfc_match_char (',') == MATCH_NO
)
8601 if (gfc_match_eos () != MATCH_YES
)
8606 gfc_syntax_error (st
);
8614 gfc_match_protected (void)
8619 if (!gfc_current_ns
->proc_name
8620 || gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
8622 gfc_error ("PROTECTED at %C only allowed in specification "
8623 "part of a module");
8628 if (!gfc_notify_std (GFC_STD_F2003
, "PROTECTED statement at %C"))
8631 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
8636 if (gfc_match_eos () == MATCH_YES
)
8641 m
= gfc_match_symbol (&sym
, 0);
8645 if (!gfc_add_protected (&sym
->attr
, sym
->name
, &gfc_current_locus
))
8657 if (gfc_match_eos () == MATCH_YES
)
8659 if (gfc_match_char (',') != MATCH_YES
)
8666 gfc_error ("Syntax error in PROTECTED statement at %C");
8671 /* The PRIVATE statement is a bit weird in that it can be an attribute
8672 declaration, but also works as a standalone statement inside of a
8673 type declaration or a module. */
8676 gfc_match_private (gfc_statement
*st
)
8679 if (gfc_match ("private") != MATCH_YES
)
8682 if (gfc_current_state () != COMP_MODULE
8683 && !(gfc_current_state () == COMP_DERIVED
8684 && gfc_state_stack
->previous
8685 && gfc_state_stack
->previous
->state
== COMP_MODULE
)
8686 && !(gfc_current_state () == COMP_DERIVED_CONTAINS
8687 && gfc_state_stack
->previous
&& gfc_state_stack
->previous
->previous
8688 && gfc_state_stack
->previous
->previous
->state
== COMP_MODULE
))
8690 gfc_error ("PRIVATE statement at %C is only allowed in the "
8691 "specification part of a module");
8695 if (gfc_current_state () == COMP_DERIVED
)
8697 if (gfc_match_eos () == MATCH_YES
)
8703 gfc_syntax_error (ST_PRIVATE
);
8707 if (gfc_match_eos () == MATCH_YES
)
8714 return access_attr_decl (ST_PRIVATE
);
8719 gfc_match_public (gfc_statement
*st
)
8722 if (gfc_match ("public") != MATCH_YES
)
8725 if (gfc_current_state () != COMP_MODULE
)
8727 gfc_error ("PUBLIC statement at %C is only allowed in the "
8728 "specification part of a module");
8732 if (gfc_match_eos () == MATCH_YES
)
8739 return access_attr_decl (ST_PUBLIC
);
8743 /* Workhorse for gfc_match_parameter. */
8753 m
= gfc_match_symbol (&sym
, 0);
8755 gfc_error ("Expected variable name at %C in PARAMETER statement");
8760 if (gfc_match_char ('=') == MATCH_NO
)
8762 gfc_error ("Expected = sign in PARAMETER statement at %C");
8766 m
= gfc_match_init_expr (&init
);
8768 gfc_error ("Expected expression at %C in PARAMETER statement");
8772 if (sym
->ts
.type
== BT_UNKNOWN
8773 && !gfc_set_default_type (sym
, 1, NULL
))
8779 if (!gfc_check_assign_symbol (sym
, NULL
, init
)
8780 || !gfc_add_flavor (&sym
->attr
, FL_PARAMETER
, sym
->name
, NULL
))
8788 gfc_error ("Initializing already initialized variable at %C");
8793 t
= add_init_expr_to_sym (sym
->name
, &init
, &gfc_current_locus
);
8794 return (t
) ? MATCH_YES
: MATCH_ERROR
;
8797 gfc_free_expr (init
);
8802 /* Match a parameter statement, with the weird syntax that these have. */
8805 gfc_match_parameter (void)
8807 const char *term
= " )%t";
8810 if (gfc_match_char ('(') == MATCH_NO
)
8812 /* With legacy PARAMETER statements, don't expect a terminating ')'. */
8813 if (!gfc_notify_std (GFC_STD_LEGACY
, "PARAMETER without '()' at %C"))
8824 if (gfc_match (term
) == MATCH_YES
)
8827 if (gfc_match_char (',') != MATCH_YES
)
8829 gfc_error ("Unexpected characters in PARAMETER statement at %C");
8840 gfc_match_automatic (void)
8844 bool seen_symbol
= false;
8846 if (!flag_dec_static
)
8848 gfc_error ("%s at %C is a DEC extension, enable with "
8859 m
= gfc_match_symbol (&sym
, 0);
8869 if (!gfc_add_automatic (&sym
->attr
, sym
->name
, &gfc_current_locus
))
8875 if (gfc_match_eos () == MATCH_YES
)
8877 if (gfc_match_char (',') != MATCH_YES
)
8883 gfc_error ("Expected entity-list in AUTOMATIC statement at %C");
8890 gfc_error ("Syntax error in AUTOMATIC statement at %C");
8896 gfc_match_static (void)
8900 bool seen_symbol
= false;
8902 if (!flag_dec_static
)
8904 gfc_error ("%s at %C is a DEC extension, enable with "
8914 m
= gfc_match_symbol (&sym
, 0);
8924 if (!gfc_add_save (&sym
->attr
, SAVE_EXPLICIT
, sym
->name
,
8925 &gfc_current_locus
))
8931 if (gfc_match_eos () == MATCH_YES
)
8933 if (gfc_match_char (',') != MATCH_YES
)
8939 gfc_error ("Expected entity-list in STATIC statement at %C");
8946 gfc_error ("Syntax error in STATIC statement at %C");
8951 /* Save statements have a special syntax. */
8954 gfc_match_save (void)
8956 char n
[GFC_MAX_SYMBOL_LEN
+1];
8961 if (gfc_match_eos () == MATCH_YES
)
8963 if (gfc_current_ns
->seen_save
)
8965 if (!gfc_notify_std (GFC_STD_LEGACY
, "Blanket SAVE statement at %C "
8966 "follows previous SAVE statement"))
8970 gfc_current_ns
->save_all
= gfc_current_ns
->seen_save
= 1;
8974 if (gfc_current_ns
->save_all
)
8976 if (!gfc_notify_std (GFC_STD_LEGACY
, "SAVE statement at %C follows "
8977 "blanket SAVE statement"))
8985 m
= gfc_match_symbol (&sym
, 0);
8989 if (!gfc_add_save (&sym
->attr
, SAVE_EXPLICIT
, sym
->name
,
8990 &gfc_current_locus
))
9001 m
= gfc_match (" / %n /", &n
);
9002 if (m
== MATCH_ERROR
)
9007 c
= gfc_get_common (n
, 0);
9010 gfc_current_ns
->seen_save
= 1;
9013 if (gfc_match_eos () == MATCH_YES
)
9015 if (gfc_match_char (',') != MATCH_YES
)
9022 gfc_error ("Syntax error in SAVE statement at %C");
9028 gfc_match_value (void)
9033 /* This is not allowed within a BLOCK construct! */
9034 if (gfc_current_state () == COMP_BLOCK
)
9036 gfc_error ("VALUE is not allowed inside of BLOCK at %C");
9040 if (!gfc_notify_std (GFC_STD_F2003
, "VALUE statement at %C"))
9043 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
9048 if (gfc_match_eos () == MATCH_YES
)
9053 m
= gfc_match_symbol (&sym
, 0);
9057 if (!gfc_add_value (&sym
->attr
, sym
->name
, &gfc_current_locus
))
9069 if (gfc_match_eos () == MATCH_YES
)
9071 if (gfc_match_char (',') != MATCH_YES
)
9078 gfc_error ("Syntax error in VALUE statement at %C");
9084 gfc_match_volatile (void)
9089 if (!gfc_notify_std (GFC_STD_F2003
, "VOLATILE statement at %C"))
9092 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
9097 if (gfc_match_eos () == MATCH_YES
)
9102 /* VOLATILE is special because it can be added to host-associated
9103 symbols locally. Except for coarrays. */
9104 m
= gfc_match_symbol (&sym
, 1);
9108 /* F2008, C560+C561. VOLATILE for host-/use-associated variable or
9109 for variable in a BLOCK which is defined outside of the BLOCK. */
9110 if (sym
->ns
!= gfc_current_ns
&& sym
->attr
.codimension
)
9112 gfc_error ("Specifying VOLATILE for coarray variable %qs at "
9113 "%C, which is use-/host-associated", sym
->name
);
9116 if (!gfc_add_volatile (&sym
->attr
, sym
->name
, &gfc_current_locus
))
9128 if (gfc_match_eos () == MATCH_YES
)
9130 if (gfc_match_char (',') != MATCH_YES
)
9137 gfc_error ("Syntax error in VOLATILE statement at %C");
9143 gfc_match_asynchronous (void)
9148 if (!gfc_notify_std (GFC_STD_F2003
, "ASYNCHRONOUS statement at %C"))
9151 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
9156 if (gfc_match_eos () == MATCH_YES
)
9161 /* ASYNCHRONOUS is special because it can be added to host-associated
9163 m
= gfc_match_symbol (&sym
, 1);
9167 if (!gfc_add_asynchronous (&sym
->attr
, sym
->name
, &gfc_current_locus
))
9179 if (gfc_match_eos () == MATCH_YES
)
9181 if (gfc_match_char (',') != MATCH_YES
)
9188 gfc_error ("Syntax error in ASYNCHRONOUS statement at %C");
9193 /* Match a module procedure statement in a submodule. */
9196 gfc_match_submod_proc (void)
9198 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9199 gfc_symbol
*sym
, *fsym
;
9201 gfc_formal_arglist
*formal
, *head
, *tail
;
9203 if (gfc_current_state () != COMP_CONTAINS
9204 || !(gfc_state_stack
->previous
9205 && (gfc_state_stack
->previous
->state
== COMP_SUBMODULE
9206 || gfc_state_stack
->previous
->state
== COMP_MODULE
)))
9209 m
= gfc_match (" module% procedure% %n", name
);
9213 if (!gfc_notify_std (GFC_STD_F2008
, "MODULE PROCEDURE declaration "
9217 if (get_proc_name (name
, &sym
, false))
9220 /* Make sure that the result field is appropriately filled, even though
9221 the result symbol will be replaced later on. */
9222 if (sym
->tlink
&& sym
->tlink
->attr
.function
)
9224 if (sym
->tlink
->result
9225 && sym
->tlink
->result
!= sym
->tlink
)
9226 sym
->result
= sym
->tlink
->result
;
9231 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
9232 the symbol existed before. */
9233 sym
->declared_at
= gfc_current_locus
;
9235 if (!sym
->attr
.module_procedure
)
9238 /* Signal match_end to expect "end procedure". */
9239 sym
->abr_modproc_decl
= 1;
9241 /* Change from IFSRC_IFBODY coming from the interface declaration. */
9242 sym
->attr
.if_source
= IFSRC_DECL
;
9244 gfc_new_block
= sym
;
9246 /* Make a new formal arglist with the symbols in the procedure
9249 for (formal
= sym
->formal
; formal
&& formal
->sym
; formal
= formal
->next
)
9251 if (formal
== sym
->formal
)
9252 head
= tail
= gfc_get_formal_arglist ();
9255 tail
->next
= gfc_get_formal_arglist ();
9259 if (gfc_copy_dummy_sym (&fsym
, formal
->sym
, 0))
9263 gfc_set_sym_referenced (fsym
);
9266 /* The dummy symbols get cleaned up, when the formal_namespace of the
9267 interface declaration is cleared. This allows us to add the
9268 explicit interface as is done for other type of procedure. */
9269 if (!gfc_add_explicit_interface (sym
, IFSRC_DECL
, head
,
9270 &gfc_current_locus
))
9273 if (gfc_match_eos () != MATCH_YES
)
9275 gfc_syntax_error (ST_MODULE_PROC
);
9282 gfc_free_formal_arglist (head
);
9287 /* Match a module procedure statement. Note that we have to modify
9288 symbols in the parent's namespace because the current one was there
9289 to receive symbols that are in an interface's formal argument list. */
9292 gfc_match_modproc (void)
9294 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9298 gfc_namespace
*module_ns
;
9299 gfc_interface
*old_interface_head
, *interface
;
9301 if (gfc_state_stack
->state
!= COMP_INTERFACE
9302 || gfc_state_stack
->previous
== NULL
9303 || current_interface
.type
== INTERFACE_NAMELESS
9304 || current_interface
.type
== INTERFACE_ABSTRACT
)
9306 gfc_error ("MODULE PROCEDURE at %C must be in a generic module "
9311 module_ns
= gfc_current_ns
->parent
;
9312 for (; module_ns
; module_ns
= module_ns
->parent
)
9313 if (module_ns
->proc_name
->attr
.flavor
== FL_MODULE
9314 || module_ns
->proc_name
->attr
.flavor
== FL_PROGRAM
9315 || (module_ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
9316 && !module_ns
->proc_name
->attr
.contained
))
9319 if (module_ns
== NULL
)
9322 /* Store the current state of the interface. We will need it if we
9323 end up with a syntax error and need to recover. */
9324 old_interface_head
= gfc_current_interface_head ();
9326 /* Check if the F2008 optional double colon appears. */
9327 gfc_gobble_whitespace ();
9328 old_locus
= gfc_current_locus
;
9329 if (gfc_match ("::") == MATCH_YES
)
9331 if (!gfc_notify_std (GFC_STD_F2008
, "double colon in "
9332 "MODULE PROCEDURE statement at %L", &old_locus
))
9336 gfc_current_locus
= old_locus
;
9341 old_locus
= gfc_current_locus
;
9343 m
= gfc_match_name (name
);
9349 /* Check for syntax error before starting to add symbols to the
9350 current namespace. */
9351 if (gfc_match_eos () == MATCH_YES
)
9354 if (!last
&& gfc_match_char (',') != MATCH_YES
)
9357 /* Now we're sure the syntax is valid, we process this item
9359 if (gfc_get_symbol (name
, module_ns
, &sym
))
9362 if (sym
->attr
.intrinsic
)
9364 gfc_error ("Intrinsic procedure at %L cannot be a MODULE "
9365 "PROCEDURE", &old_locus
);
9369 if (sym
->attr
.proc
!= PROC_MODULE
9370 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
9373 if (!gfc_add_interface (sym
))
9376 sym
->attr
.mod_proc
= 1;
9377 sym
->declared_at
= old_locus
;
9386 /* Restore the previous state of the interface. */
9387 interface
= gfc_current_interface_head ();
9388 gfc_set_current_interface_head (old_interface_head
);
9390 /* Free the new interfaces. */
9391 while (interface
!= old_interface_head
)
9393 gfc_interface
*i
= interface
->next
;
9398 /* And issue a syntax error. */
9399 gfc_syntax_error (ST_MODULE_PROC
);
9404 /* Check a derived type that is being extended. */
9407 check_extended_derived_type (char *name
)
9409 gfc_symbol
*extended
;
9411 if (gfc_find_symbol (name
, gfc_current_ns
, 1, &extended
))
9413 gfc_error ("Ambiguous symbol in TYPE definition at %C");
9417 extended
= gfc_find_dt_in_generic (extended
);
9422 gfc_error ("Symbol %qs at %C has not been previously defined", name
);
9426 if (extended
->attr
.flavor
!= FL_DERIVED
)
9428 gfc_error ("%qs in EXTENDS expression at %C is not a "
9429 "derived type", name
);
9433 if (extended
->attr
.is_bind_c
)
9435 gfc_error ("%qs cannot be extended at %C because it "
9436 "is BIND(C)", extended
->name
);
9440 if (extended
->attr
.sequence
)
9442 gfc_error ("%qs cannot be extended at %C because it "
9443 "is a SEQUENCE type", extended
->name
);
9451 /* Match the optional attribute specifiers for a type declaration.
9452 Return MATCH_ERROR if an error is encountered in one of the handled
9453 attributes (public, private, bind(c)), MATCH_NO if what's found is
9454 not a handled attribute, and MATCH_YES otherwise. TODO: More error
9455 checking on attribute conflicts needs to be done. */
9458 gfc_get_type_attr_spec (symbol_attribute
*attr
, char *name
)
9460 /* See if the derived type is marked as private. */
9461 if (gfc_match (" , private") == MATCH_YES
)
9463 if (gfc_current_state () != COMP_MODULE
)
9465 gfc_error ("Derived type at %C can only be PRIVATE in the "
9466 "specification part of a module");
9470 if (!gfc_add_access (attr
, ACCESS_PRIVATE
, NULL
, NULL
))
9473 else if (gfc_match (" , public") == MATCH_YES
)
9475 if (gfc_current_state () != COMP_MODULE
)
9477 gfc_error ("Derived type at %C can only be PUBLIC in the "
9478 "specification part of a module");
9482 if (!gfc_add_access (attr
, ACCESS_PUBLIC
, NULL
, NULL
))
9485 else if (gfc_match (" , bind ( c )") == MATCH_YES
)
9487 /* If the type is defined to be bind(c) it then needs to make
9488 sure that all fields are interoperable. This will
9489 need to be a semantic check on the finished derived type.
9490 See 15.2.3 (lines 9-12) of F2003 draft. */
9491 if (!gfc_add_is_bind_c (attr
, NULL
, &gfc_current_locus
, 0))
9494 /* TODO: attr conflicts need to be checked, probably in symbol.c. */
9496 else if (gfc_match (" , abstract") == MATCH_YES
)
9498 if (!gfc_notify_std (GFC_STD_F2003
, "ABSTRACT type at %C"))
9501 if (!gfc_add_abstract (attr
, &gfc_current_locus
))
9504 else if (name
&& gfc_match (" , extends ( %n )", name
) == MATCH_YES
)
9506 if (!gfc_add_extension (attr
, &gfc_current_locus
))
9512 /* If we get here, something matched. */
9517 /* Common function for type declaration blocks similar to derived types, such
9518 as STRUCTURES and MAPs. Unlike derived types, a structure type
9519 does NOT have a generic symbol matching the name given by the user.
9520 STRUCTUREs can share names with variables and PARAMETERs so we must allow
9521 for the creation of an independent symbol.
9522 Other parameters are a message to prefix errors with, the name of the new
9523 type to be created, and the flavor to add to the resulting symbol. */
9526 get_struct_decl (const char *name
, sym_flavor fl
, locus
*decl
,
9527 gfc_symbol
**result
)
9532 gcc_assert (name
[0] == (char) TOUPPER (name
[0]));
9537 where
= gfc_current_locus
;
9539 if (gfc_get_symbol (name
, NULL
, &sym
))
9544 gfc_internal_error ("Failed to create structure type '%s' at %C", name
);
9548 if (sym
->components
!= NULL
|| sym
->attr
.zero_comp
)
9550 gfc_error ("Type definition of %qs at %C was already defined at %L",
9551 sym
->name
, &sym
->declared_at
);
9555 sym
->declared_at
= where
;
9557 if (sym
->attr
.flavor
!= fl
9558 && !gfc_add_flavor (&sym
->attr
, fl
, sym
->name
, NULL
))
9561 if (!sym
->hash_value
)
9562 /* Set the hash for the compound name for this type. */
9563 sym
->hash_value
= gfc_hash_value (sym
);
9565 /* Normally the type is expected to have been completely parsed by the time
9566 a field declaration with this type is seen. For unions, maps, and nested
9567 structure declarations, we need to indicate that it is okay that we
9568 haven't seen any components yet. This will be updated after the structure
9570 sym
->attr
.zero_comp
= 0;
9572 /* Structures always act like derived-types with the SEQUENCE attribute */
9573 gfc_add_sequence (&sym
->attr
, sym
->name
, NULL
);
9575 if (result
) *result
= sym
;
9581 /* Match the opening of a MAP block. Like a struct within a union in C;
9582 behaves identical to STRUCTURE blocks. */
9585 gfc_match_map (void)
9587 /* Counter used to give unique internal names to map structures. */
9588 static unsigned int gfc_map_id
= 0;
9589 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9593 old_loc
= gfc_current_locus
;
9595 if (gfc_match_eos () != MATCH_YES
)
9597 gfc_error ("Junk after MAP statement at %C");
9598 gfc_current_locus
= old_loc
;
9602 /* Map blocks are anonymous so we make up unique names for the symbol table
9603 which are invalid Fortran identifiers. */
9604 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "MM$%u", gfc_map_id
++);
9606 if (!get_struct_decl (name
, FL_STRUCT
, &old_loc
, &sym
))
9609 gfc_new_block
= sym
;
9615 /* Match the opening of a UNION block. */
9618 gfc_match_union (void)
9620 /* Counter used to give unique internal names to union types. */
9621 static unsigned int gfc_union_id
= 0;
9622 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9626 old_loc
= gfc_current_locus
;
9628 if (gfc_match_eos () != MATCH_YES
)
9630 gfc_error ("Junk after UNION statement at %C");
9631 gfc_current_locus
= old_loc
;
9635 /* Unions are anonymous so we make up unique names for the symbol table
9636 which are invalid Fortran identifiers. */
9637 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "UU$%u", gfc_union_id
++);
9639 if (!get_struct_decl (name
, FL_UNION
, &old_loc
, &sym
))
9642 gfc_new_block
= sym
;
9648 /* Match the beginning of a STRUCTURE declaration. This is similar to
9649 matching the beginning of a derived type declaration with a few
9650 twists. The resulting type symbol has no access control or other
9651 interesting attributes. */
9654 gfc_match_structure_decl (void)
9656 /* Counter used to give unique internal names to anonymous structures. */
9657 static unsigned int gfc_structure_id
= 0;
9658 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9663 if (!flag_dec_structure
)
9665 gfc_error ("%s at %C is a DEC extension, enable with "
9666 "%<-fdec-structure%>",
9673 m
= gfc_match (" /%n/", name
);
9676 /* Non-nested structure declarations require a structure name. */
9677 if (!gfc_comp_struct (gfc_current_state ()))
9679 gfc_error ("Structure name expected in non-nested structure "
9680 "declaration at %C");
9683 /* This is an anonymous structure; make up a unique name for it
9684 (upper-case letters never make it to symbol names from the source).
9685 The important thing is initializing the type variable
9686 and setting gfc_new_symbol, which is immediately used by
9687 parse_structure () and variable_decl () to add components of
9689 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "SS$%u", gfc_structure_id
++);
9692 where
= gfc_current_locus
;
9693 /* No field list allowed after non-nested structure declaration. */
9694 if (!gfc_comp_struct (gfc_current_state ())
9695 && gfc_match_eos () != MATCH_YES
)
9697 gfc_error ("Junk after non-nested STRUCTURE statement at %C");
9701 /* Make sure the name is not the name of an intrinsic type. */
9702 if (gfc_is_intrinsic_typename (name
))
9704 gfc_error ("Structure name %qs at %C cannot be the same as an"
9705 " intrinsic type", name
);
9709 /* Store the actual type symbol for the structure with an upper-case first
9710 letter (an invalid Fortran identifier). */
9712 if (!get_struct_decl (gfc_dt_upper_string (name
), FL_STRUCT
, &where
, &sym
))
9715 gfc_new_block
= sym
;
9720 /* This function does some work to determine which matcher should be used to
9721 * match a statement beginning with "TYPE". This is used to disambiguate TYPE
9722 * as an alias for PRINT from derived type declarations, TYPE IS statements,
9723 * and derived type data declarations. */
9726 gfc_match_type (gfc_statement
*st
)
9728 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9732 /* Requires -fdec. */
9736 m
= gfc_match ("type");
9739 /* If we already have an error in the buffer, it is probably from failing to
9740 * match a derived type data declaration. Let it happen. */
9741 else if (gfc_error_flag_test ())
9744 old_loc
= gfc_current_locus
;
9747 /* If we see an attribute list before anything else it's definitely a derived
9748 * type declaration. */
9749 if (gfc_match (" ,") == MATCH_YES
|| gfc_match (" ::") == MATCH_YES
)
9751 gfc_current_locus
= old_loc
;
9752 *st
= ST_DERIVED_DECL
;
9753 return gfc_match_derived_decl ();
9756 /* By now "TYPE" has already been matched. If we do not see a name, this may
9757 * be something like "TYPE *" or "TYPE <fmt>". */
9758 m
= gfc_match_name (name
);
9761 /* Let print match if it can, otherwise throw an error from
9762 * gfc_match_derived_decl. */
9763 gfc_current_locus
= old_loc
;
9764 if (gfc_match_print () == MATCH_YES
)
9769 gfc_current_locus
= old_loc
;
9770 *st
= ST_DERIVED_DECL
;
9771 return gfc_match_derived_decl ();
9774 /* A derived type declaration requires an EOS. Without it, assume print. */
9775 m
= gfc_match_eos ();
9778 /* Check manually for TYPE IS (... - this is invalid print syntax. */
9779 if (strncmp ("is", name
, 3) == 0
9780 && gfc_match (" (", name
) == MATCH_YES
)
9782 gfc_current_locus
= old_loc
;
9783 gcc_assert (gfc_match (" is") == MATCH_YES
);
9785 return gfc_match_type_is ();
9787 gfc_current_locus
= old_loc
;
9789 return gfc_match_print ();
9793 /* By now we have "TYPE <name> <EOS>". Check first if the name is an
9794 * intrinsic typename - if so let gfc_match_derived_decl dump an error.
9795 * Otherwise if gfc_match_derived_decl fails it's probably an existing
9796 * symbol which can be printed. */
9797 gfc_current_locus
= old_loc
;
9798 m
= gfc_match_derived_decl ();
9799 if (gfc_is_intrinsic_typename (name
) || m
== MATCH_YES
)
9801 *st
= ST_DERIVED_DECL
;
9804 gfc_current_locus
= old_loc
;
9806 return gfc_match_print ();
9813 /* Match the beginning of a derived type declaration. If a type name
9814 was the result of a function, then it is possible to have a symbol
9815 already to be known as a derived type yet have no components. */
9818 gfc_match_derived_decl (void)
9820 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9821 char parent
[GFC_MAX_SYMBOL_LEN
+ 1];
9822 symbol_attribute attr
;
9823 gfc_symbol
*sym
, *gensym
;
9824 gfc_symbol
*extended
;
9826 match is_type_attr_spec
= MATCH_NO
;
9827 bool seen_attr
= false;
9828 gfc_interface
*intr
= NULL
, *head
;
9829 bool parameterized_type
= false;
9830 bool seen_colons
= false;
9832 if (gfc_comp_struct (gfc_current_state ()))
9837 gfc_clear_attr (&attr
);
9842 is_type_attr_spec
= gfc_get_type_attr_spec (&attr
, parent
);
9843 if (is_type_attr_spec
== MATCH_ERROR
)
9845 if (is_type_attr_spec
== MATCH_YES
)
9847 } while (is_type_attr_spec
== MATCH_YES
);
9849 /* Deal with derived type extensions. The extension attribute has
9850 been added to 'attr' but now the parent type must be found and
9853 extended
= check_extended_derived_type (parent
);
9855 if (parent
[0] && !extended
)
9858 m
= gfc_match (" ::");
9865 gfc_error ("Expected :: in TYPE definition at %C");
9869 m
= gfc_match (" %n ", name
);
9873 /* Make sure that we don't identify TYPE IS (...) as a parameterized
9874 derived type named 'is'.
9875 TODO Expand the check, when 'name' = "is" by matching " (tname) "
9876 and checking if this is a(n intrinsic) typename. his picks up
9877 misplaced TYPE IS statements such as in select_type_1.f03. */
9878 if (gfc_peek_ascii_char () == '(')
9880 if (gfc_current_state () == COMP_SELECT_TYPE
9881 || (!seen_colons
&& !strcmp (name
, "is")))
9883 parameterized_type
= true;
9886 m
= gfc_match_eos ();
9887 if (m
!= MATCH_YES
&& !parameterized_type
)
9890 /* Make sure the name is not the name of an intrinsic type. */
9891 if (gfc_is_intrinsic_typename (name
))
9893 gfc_error ("Type name %qs at %C cannot be the same as an intrinsic "
9898 if (gfc_get_symbol (name
, NULL
, &gensym
))
9901 if (!gensym
->attr
.generic
&& gensym
->ts
.type
!= BT_UNKNOWN
)
9903 gfc_error ("Derived type name %qs at %C already has a basic type "
9904 "of %s", gensym
->name
, gfc_typename (&gensym
->ts
));
9908 if (!gensym
->attr
.generic
9909 && !gfc_add_generic (&gensym
->attr
, gensym
->name
, NULL
))
9912 if (!gensym
->attr
.function
9913 && !gfc_add_function (&gensym
->attr
, gensym
->name
, NULL
))
9916 sym
= gfc_find_dt_in_generic (gensym
);
9918 if (sym
&& (sym
->components
!= NULL
|| sym
->attr
.zero_comp
))
9920 gfc_error ("Derived type definition of %qs at %C has already been "
9921 "defined", sym
->name
);
9927 /* Use upper case to save the actual derived-type symbol. */
9928 gfc_get_symbol (gfc_dt_upper_string (gensym
->name
), NULL
, &sym
);
9929 sym
->name
= gfc_get_string ("%s", gensym
->name
);
9930 head
= gensym
->generic
;
9931 intr
= gfc_get_interface ();
9933 intr
->where
= gfc_current_locus
;
9934 intr
->sym
->declared_at
= gfc_current_locus
;
9936 gensym
->generic
= intr
;
9937 gensym
->attr
.if_source
= IFSRC_DECL
;
9940 /* The symbol may already have the derived attribute without the
9941 components. The ways this can happen is via a function
9942 definition, an INTRINSIC statement or a subtype in another
9943 derived type that is a pointer. The first part of the AND clause
9944 is true if the symbol is not the return value of a function. */
9945 if (sym
->attr
.flavor
!= FL_DERIVED
9946 && !gfc_add_flavor (&sym
->attr
, FL_DERIVED
, sym
->name
, NULL
))
9949 if (attr
.access
!= ACCESS_UNKNOWN
9950 && !gfc_add_access (&sym
->attr
, attr
.access
, sym
->name
, NULL
))
9952 else if (sym
->attr
.access
== ACCESS_UNKNOWN
9953 && gensym
->attr
.access
!= ACCESS_UNKNOWN
9954 && !gfc_add_access (&sym
->attr
, gensym
->attr
.access
,
9958 if (sym
->attr
.access
!= ACCESS_UNKNOWN
9959 && gensym
->attr
.access
== ACCESS_UNKNOWN
)
9960 gensym
->attr
.access
= sym
->attr
.access
;
9962 /* See if the derived type was labeled as bind(c). */
9963 if (attr
.is_bind_c
!= 0)
9964 sym
->attr
.is_bind_c
= attr
.is_bind_c
;
9966 /* Construct the f2k_derived namespace if it is not yet there. */
9967 if (!sym
->f2k_derived
)
9968 sym
->f2k_derived
= gfc_get_namespace (NULL
, 0);
9970 if (parameterized_type
)
9972 /* Ignore error or mismatches by going to the end of the statement
9973 in order to avoid the component declarations causing problems. */
9974 m
= gfc_match_formal_arglist (sym
, 0, 0, true);
9976 gfc_error_recovery ();
9977 m
= gfc_match_eos ();
9980 gfc_error_recovery ();
9981 gfc_error_now ("Garbage after PARAMETERIZED TYPE declaration at %C");
9983 sym
->attr
.pdt_template
= 1;
9986 if (extended
&& !sym
->components
)
9989 gfc_formal_arglist
*f
, *g
, *h
;
9991 /* Add the extended derived type as the first component. */
9992 gfc_add_component (sym
, parent
, &p
);
9994 gfc_set_sym_referenced (extended
);
9996 p
->ts
.type
= BT_DERIVED
;
9997 p
->ts
.u
.derived
= extended
;
9998 p
->initializer
= gfc_default_initializer (&p
->ts
);
10000 /* Set extension level. */
10001 if (extended
->attr
.extension
== 255)
10003 /* Since the extension field is 8 bit wide, we can only have
10004 up to 255 extension levels. */
10005 gfc_error ("Maximum extension level reached with type %qs at %L",
10006 extended
->name
, &extended
->declared_at
);
10007 return MATCH_ERROR
;
10009 sym
->attr
.extension
= extended
->attr
.extension
+ 1;
10011 /* Provide the links between the extended type and its extension. */
10012 if (!extended
->f2k_derived
)
10013 extended
->f2k_derived
= gfc_get_namespace (NULL
, 0);
10015 /* Copy the extended type-param-name-list from the extended type,
10016 append those of the extension and add the whole lot to the
10018 if (extended
->attr
.pdt_template
)
10021 sym
->attr
.pdt_template
= 1;
10022 for (f
= extended
->formal
; f
; f
= f
->next
)
10024 if (f
== extended
->formal
)
10026 g
= gfc_get_formal_arglist ();
10031 g
->next
= gfc_get_formal_arglist ();
10036 g
->next
= sym
->formal
;
10041 if (!sym
->hash_value
)
10042 /* Set the hash for the compound name for this type. */
10043 sym
->hash_value
= gfc_hash_value (sym
);
10045 /* Take over the ABSTRACT attribute. */
10046 sym
->attr
.abstract
= attr
.abstract
;
10048 gfc_new_block
= sym
;
10054 /* Cray Pointees can be declared as:
10055 pointer (ipt, a (n,m,...,*)) */
10058 gfc_mod_pointee_as (gfc_array_spec
*as
)
10060 as
->cray_pointee
= true; /* This will be useful to know later. */
10061 if (as
->type
== AS_ASSUMED_SIZE
)
10062 as
->cp_was_assumed
= true;
10063 else if (as
->type
== AS_ASSUMED_SHAPE
)
10065 gfc_error ("Cray Pointee at %C cannot be assumed shape array");
10066 return MATCH_ERROR
;
10072 /* Match the enum definition statement, here we are trying to match
10073 the first line of enum definition statement.
10074 Returns MATCH_YES if match is found. */
10077 gfc_match_enum (void)
10081 m
= gfc_match_eos ();
10082 if (m
!= MATCH_YES
)
10085 if (!gfc_notify_std (GFC_STD_F2003
, "ENUM and ENUMERATOR at %C"))
10086 return MATCH_ERROR
;
10092 /* Returns an initializer whose value is one higher than the value of the
10093 LAST_INITIALIZER argument. If the argument is NULL, the
10094 initializers value will be set to zero. The initializer's kind
10095 will be set to gfc_c_int_kind.
10097 If -fshort-enums is given, the appropriate kind will be selected
10098 later after all enumerators have been parsed. A warning is issued
10099 here if an initializer exceeds gfc_c_int_kind. */
10102 enum_initializer (gfc_expr
*last_initializer
, locus where
)
10105 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_c_int_kind
, &where
);
10107 mpz_init (result
->value
.integer
);
10109 if (last_initializer
!= NULL
)
10111 mpz_add_ui (result
->value
.integer
, last_initializer
->value
.integer
, 1);
10112 result
->where
= last_initializer
->where
;
10114 if (gfc_check_integer_range (result
->value
.integer
,
10115 gfc_c_int_kind
) != ARITH_OK
)
10117 gfc_error ("Enumerator exceeds the C integer type at %C");
10123 /* Control comes here, if it's the very first enumerator and no
10124 initializer has been given. It will be initialized to zero. */
10125 mpz_set_si (result
->value
.integer
, 0);
10132 /* Match a variable name with an optional initializer. When this
10133 subroutine is called, a variable is expected to be parsed next.
10134 Depending on what is happening at the moment, updates either the
10135 symbol table or the current interface. */
10138 enumerator_decl (void)
10140 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10141 gfc_expr
*initializer
;
10142 gfc_array_spec
*as
= NULL
;
10149 initializer
= NULL
;
10150 old_locus
= gfc_current_locus
;
10152 /* When we get here, we've just matched a list of attributes and
10153 maybe a type and a double colon. The next thing we expect to see
10154 is the name of the symbol. */
10155 m
= gfc_match_name (name
);
10156 if (m
!= MATCH_YES
)
10159 var_locus
= gfc_current_locus
;
10161 /* OK, we've successfully matched the declaration. Now put the
10162 symbol in the current namespace. If we fail to create the symbol,
10164 if (!build_sym (name
, NULL
, false, &as
, &var_locus
))
10170 /* The double colon must be present in order to have initializers.
10171 Otherwise the statement is ambiguous with an assignment statement. */
10174 if (gfc_match_char ('=') == MATCH_YES
)
10176 m
= gfc_match_init_expr (&initializer
);
10179 gfc_error ("Expected an initialization expression at %C");
10183 if (m
!= MATCH_YES
)
10188 /* If we do not have an initializer, the initialization value of the
10189 previous enumerator (stored in last_initializer) is incremented
10190 by 1 and is used to initialize the current enumerator. */
10191 if (initializer
== NULL
)
10192 initializer
= enum_initializer (last_initializer
, old_locus
);
10194 if (initializer
== NULL
|| initializer
->ts
.type
!= BT_INTEGER
)
10196 gfc_error ("ENUMERATOR %L not initialized with integer expression",
10202 /* Store this current initializer, for the next enumerator variable
10203 to be parsed. add_init_expr_to_sym() zeros initializer, so we
10204 use last_initializer below. */
10205 last_initializer
= initializer
;
10206 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
10208 /* Maintain enumerator history. */
10209 gfc_find_symbol (name
, NULL
, 0, &sym
);
10210 create_enum_history (sym
, last_initializer
);
10212 return (t
) ? MATCH_YES
: MATCH_ERROR
;
10215 /* Free stuff up and return. */
10216 gfc_free_expr (initializer
);
10222 /* Match the enumerator definition statement. */
10225 gfc_match_enumerator_def (void)
10230 gfc_clear_ts (¤t_ts
);
10232 m
= gfc_match (" enumerator");
10233 if (m
!= MATCH_YES
)
10236 m
= gfc_match (" :: ");
10237 if (m
== MATCH_ERROR
)
10240 colon_seen
= (m
== MATCH_YES
);
10242 if (gfc_current_state () != COMP_ENUM
)
10244 gfc_error ("ENUM definition statement expected before %C");
10245 gfc_free_enum_history ();
10246 return MATCH_ERROR
;
10249 (¤t_ts
)->type
= BT_INTEGER
;
10250 (¤t_ts
)->kind
= gfc_c_int_kind
;
10252 gfc_clear_attr (¤t_attr
);
10253 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, NULL
);
10262 m
= enumerator_decl ();
10263 if (m
== MATCH_ERROR
)
10265 gfc_free_enum_history ();
10271 if (gfc_match_eos () == MATCH_YES
)
10273 if (gfc_match_char (',') != MATCH_YES
)
10277 if (gfc_current_state () == COMP_ENUM
)
10279 gfc_free_enum_history ();
10280 gfc_error ("Syntax error in ENUMERATOR definition at %C");
10285 gfc_free_array_spec (current_as
);
10292 /* Match binding attributes. */
10295 match_binding_attributes (gfc_typebound_proc
* ba
, bool generic
, bool ppc
)
10297 bool found_passing
= false;
10298 bool seen_ptr
= false;
10299 match m
= MATCH_YES
;
10301 /* Initialize to defaults. Do so even before the MATCH_NO check so that in
10302 this case the defaults are in there. */
10303 ba
->access
= ACCESS_UNKNOWN
;
10304 ba
->pass_arg
= NULL
;
10305 ba
->pass_arg_num
= 0;
10307 ba
->non_overridable
= 0;
10311 /* If we find a comma, we believe there are binding attributes. */
10312 m
= gfc_match_char (',');
10318 /* Access specifier. */
10320 m
= gfc_match (" public");
10321 if (m
== MATCH_ERROR
)
10323 if (m
== MATCH_YES
)
10325 if (ba
->access
!= ACCESS_UNKNOWN
)
10327 gfc_error ("Duplicate access-specifier at %C");
10331 ba
->access
= ACCESS_PUBLIC
;
10335 m
= gfc_match (" private");
10336 if (m
== MATCH_ERROR
)
10338 if (m
== MATCH_YES
)
10340 if (ba
->access
!= ACCESS_UNKNOWN
)
10342 gfc_error ("Duplicate access-specifier at %C");
10346 ba
->access
= ACCESS_PRIVATE
;
10350 /* If inside GENERIC, the following is not allowed. */
10355 m
= gfc_match (" nopass");
10356 if (m
== MATCH_ERROR
)
10358 if (m
== MATCH_YES
)
10362 gfc_error ("Binding attributes already specify passing,"
10363 " illegal NOPASS at %C");
10367 found_passing
= true;
10372 /* PASS possibly including argument. */
10373 m
= gfc_match (" pass");
10374 if (m
== MATCH_ERROR
)
10376 if (m
== MATCH_YES
)
10378 char arg
[GFC_MAX_SYMBOL_LEN
+ 1];
10382 gfc_error ("Binding attributes already specify passing,"
10383 " illegal PASS at %C");
10387 m
= gfc_match (" ( %n )", arg
);
10388 if (m
== MATCH_ERROR
)
10390 if (m
== MATCH_YES
)
10391 ba
->pass_arg
= gfc_get_string ("%s", arg
);
10392 gcc_assert ((m
== MATCH_YES
) == (ba
->pass_arg
!= NULL
));
10394 found_passing
= true;
10401 /* POINTER flag. */
10402 m
= gfc_match (" pointer");
10403 if (m
== MATCH_ERROR
)
10405 if (m
== MATCH_YES
)
10409 gfc_error ("Duplicate POINTER attribute at %C");
10419 /* NON_OVERRIDABLE flag. */
10420 m
= gfc_match (" non_overridable");
10421 if (m
== MATCH_ERROR
)
10423 if (m
== MATCH_YES
)
10425 if (ba
->non_overridable
)
10427 gfc_error ("Duplicate NON_OVERRIDABLE at %C");
10431 ba
->non_overridable
= 1;
10435 /* DEFERRED flag. */
10436 m
= gfc_match (" deferred");
10437 if (m
== MATCH_ERROR
)
10439 if (m
== MATCH_YES
)
10443 gfc_error ("Duplicate DEFERRED at %C");
10454 /* Nothing matching found. */
10456 gfc_error ("Expected access-specifier at %C");
10458 gfc_error ("Expected binding attribute at %C");
10461 while (gfc_match_char (',') == MATCH_YES
);
10463 /* NON_OVERRIDABLE and DEFERRED exclude themselves. */
10464 if (ba
->non_overridable
&& ba
->deferred
)
10466 gfc_error ("NON_OVERRIDABLE and DEFERRED can't both appear at %C");
10473 if (ba
->access
== ACCESS_UNKNOWN
)
10474 ba
->access
= gfc_typebound_default_access
;
10476 if (ppc
&& !seen_ptr
)
10478 gfc_error ("POINTER attribute is required for procedure pointer component"
10486 return MATCH_ERROR
;
10490 /* Match a PROCEDURE specific binding inside a derived type. */
10493 match_procedure_in_type (void)
10495 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10496 char target_buf
[GFC_MAX_SYMBOL_LEN
+ 1];
10497 char* target
= NULL
, *ifc
= NULL
;
10498 gfc_typebound_proc tb
;
10502 gfc_symtree
* stree
;
10507 /* Check current state. */
10508 gcc_assert (gfc_state_stack
->state
== COMP_DERIVED_CONTAINS
);
10509 block
= gfc_state_stack
->previous
->sym
;
10510 gcc_assert (block
);
10512 /* Try to match PROCEDURE(interface). */
10513 if (gfc_match (" (") == MATCH_YES
)
10515 m
= gfc_match_name (target_buf
);
10516 if (m
== MATCH_ERROR
)
10518 if (m
!= MATCH_YES
)
10520 gfc_error ("Interface-name expected after %<(%> at %C");
10521 return MATCH_ERROR
;
10524 if (gfc_match (" )") != MATCH_YES
)
10526 gfc_error ("%<)%> expected at %C");
10527 return MATCH_ERROR
;
10533 /* Construct the data structure. */
10534 memset (&tb
, 0, sizeof (tb
));
10535 tb
.where
= gfc_current_locus
;
10537 /* Match binding attributes. */
10538 m
= match_binding_attributes (&tb
, false, false);
10539 if (m
== MATCH_ERROR
)
10541 seen_attrs
= (m
== MATCH_YES
);
10543 /* Check that attribute DEFERRED is given if an interface is specified. */
10544 if (tb
.deferred
&& !ifc
)
10546 gfc_error ("Interface must be specified for DEFERRED binding at %C");
10547 return MATCH_ERROR
;
10549 if (ifc
&& !tb
.deferred
)
10551 gfc_error ("PROCEDURE(interface) at %C should be declared DEFERRED");
10552 return MATCH_ERROR
;
10555 /* Match the colons. */
10556 m
= gfc_match (" ::");
10557 if (m
== MATCH_ERROR
)
10559 seen_colons
= (m
== MATCH_YES
);
10560 if (seen_attrs
&& !seen_colons
)
10562 gfc_error ("Expected %<::%> after binding-attributes at %C");
10563 return MATCH_ERROR
;
10566 /* Match the binding names. */
10569 m
= gfc_match_name (name
);
10570 if (m
== MATCH_ERROR
)
10574 gfc_error ("Expected binding name at %C");
10575 return MATCH_ERROR
;
10578 if (num
>1 && !gfc_notify_std (GFC_STD_F2008
, "PROCEDURE list at %C"))
10579 return MATCH_ERROR
;
10581 /* Try to match the '=> target', if it's there. */
10583 m
= gfc_match (" =>");
10584 if (m
== MATCH_ERROR
)
10586 if (m
== MATCH_YES
)
10590 gfc_error ("%<=> target%> is invalid for DEFERRED binding at %C");
10591 return MATCH_ERROR
;
10596 gfc_error ("%<::%> needed in PROCEDURE binding with explicit target"
10598 return MATCH_ERROR
;
10601 m
= gfc_match_name (target_buf
);
10602 if (m
== MATCH_ERROR
)
10606 gfc_error ("Expected binding target after %<=>%> at %C");
10607 return MATCH_ERROR
;
10609 target
= target_buf
;
10612 /* If no target was found, it has the same name as the binding. */
10616 /* Get the namespace to insert the symbols into. */
10617 ns
= block
->f2k_derived
;
10620 /* If the binding is DEFERRED, check that the containing type is ABSTRACT. */
10621 if (tb
.deferred
&& !block
->attr
.abstract
)
10623 gfc_error ("Type %qs containing DEFERRED binding at %C "
10624 "is not ABSTRACT", block
->name
);
10625 return MATCH_ERROR
;
10628 /* See if we already have a binding with this name in the symtree which
10629 would be an error. If a GENERIC already targeted this binding, it may
10630 be already there but then typebound is still NULL. */
10631 stree
= gfc_find_symtree (ns
->tb_sym_root
, name
);
10632 if (stree
&& stree
->n
.tb
)
10634 gfc_error ("There is already a procedure with binding name %qs for "
10635 "the derived type %qs at %C", name
, block
->name
);
10636 return MATCH_ERROR
;
10639 /* Insert it and set attributes. */
10643 stree
= gfc_new_symtree (&ns
->tb_sym_root
, name
);
10644 gcc_assert (stree
);
10646 stree
->n
.tb
= gfc_get_typebound_proc (&tb
);
10648 if (gfc_get_sym_tree (target
, gfc_current_ns
, &stree
->n
.tb
->u
.specific
,
10650 return MATCH_ERROR
;
10651 gfc_set_sym_referenced (stree
->n
.tb
->u
.specific
->n
.sym
);
10652 gfc_add_flavor(&stree
->n
.tb
->u
.specific
->n
.sym
->attr
, FL_PROCEDURE
,
10653 target
, &stree
->n
.tb
->u
.specific
->n
.sym
->declared_at
);
10655 if (gfc_match_eos () == MATCH_YES
)
10657 if (gfc_match_char (',') != MATCH_YES
)
10662 gfc_error ("Syntax error in PROCEDURE statement at %C");
10663 return MATCH_ERROR
;
10667 /* Match a GENERIC procedure binding inside a derived type. */
10670 gfc_match_generic (void)
10672 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10673 char bind_name
[GFC_MAX_SYMBOL_LEN
+ 16]; /* Allow space for OPERATOR(...). */
10675 gfc_typebound_proc tbattr
; /* Used for match_binding_attributes. */
10676 gfc_typebound_proc
* tb
;
10678 interface_type op_type
;
10679 gfc_intrinsic_op op
;
10682 /* Check current state. */
10683 if (gfc_current_state () == COMP_DERIVED
)
10685 gfc_error ("GENERIC at %C must be inside a derived-type CONTAINS");
10686 return MATCH_ERROR
;
10688 if (gfc_current_state () != COMP_DERIVED_CONTAINS
)
10690 block
= gfc_state_stack
->previous
->sym
;
10691 ns
= block
->f2k_derived
;
10692 gcc_assert (block
&& ns
);
10694 memset (&tbattr
, 0, sizeof (tbattr
));
10695 tbattr
.where
= gfc_current_locus
;
10697 /* See if we get an access-specifier. */
10698 m
= match_binding_attributes (&tbattr
, true, false);
10699 if (m
== MATCH_ERROR
)
10702 /* Now the colons, those are required. */
10703 if (gfc_match (" ::") != MATCH_YES
)
10705 gfc_error ("Expected %<::%> at %C");
10709 /* Match the binding name; depending on type (operator / generic) format
10710 it for future error messages into bind_name. */
10712 m
= gfc_match_generic_spec (&op_type
, name
, &op
);
10713 if (m
== MATCH_ERROR
)
10714 return MATCH_ERROR
;
10717 gfc_error ("Expected generic name or operator descriptor at %C");
10723 case INTERFACE_GENERIC
:
10724 case INTERFACE_DTIO
:
10725 snprintf (bind_name
, sizeof (bind_name
), "%s", name
);
10728 case INTERFACE_USER_OP
:
10729 snprintf (bind_name
, sizeof (bind_name
), "OPERATOR(.%s.)", name
);
10732 case INTERFACE_INTRINSIC_OP
:
10733 snprintf (bind_name
, sizeof (bind_name
), "OPERATOR(%s)",
10734 gfc_op2string (op
));
10737 case INTERFACE_NAMELESS
:
10738 gfc_error ("Malformed GENERIC statement at %C");
10743 gcc_unreachable ();
10746 /* Match the required =>. */
10747 if (gfc_match (" =>") != MATCH_YES
)
10749 gfc_error ("Expected %<=>%> at %C");
10753 /* Try to find existing GENERIC binding with this name / for this operator;
10754 if there is something, check that it is another GENERIC and then extend
10755 it rather than building a new node. Otherwise, create it and put it
10756 at the right position. */
10760 case INTERFACE_DTIO
:
10761 case INTERFACE_USER_OP
:
10762 case INTERFACE_GENERIC
:
10764 const bool is_op
= (op_type
== INTERFACE_USER_OP
);
10767 st
= gfc_find_symtree (is_op
? ns
->tb_uop_root
: ns
->tb_sym_root
, name
);
10768 tb
= st
? st
->n
.tb
: NULL
;
10772 case INTERFACE_INTRINSIC_OP
:
10773 tb
= ns
->tb_op
[op
];
10777 gcc_unreachable ();
10782 if (!tb
->is_generic
)
10784 gcc_assert (op_type
== INTERFACE_GENERIC
);
10785 gfc_error ("There's already a non-generic procedure with binding name"
10786 " %qs for the derived type %qs at %C",
10787 bind_name
, block
->name
);
10791 if (tb
->access
!= tbattr
.access
)
10793 gfc_error ("Binding at %C must have the same access as already"
10794 " defined binding %qs", bind_name
);
10800 tb
= gfc_get_typebound_proc (NULL
);
10801 tb
->where
= gfc_current_locus
;
10802 tb
->access
= tbattr
.access
;
10803 tb
->is_generic
= 1;
10804 tb
->u
.generic
= NULL
;
10808 case INTERFACE_DTIO
:
10809 case INTERFACE_GENERIC
:
10810 case INTERFACE_USER_OP
:
10812 const bool is_op
= (op_type
== INTERFACE_USER_OP
);
10813 gfc_symtree
* st
= gfc_get_tbp_symtree (is_op
? &ns
->tb_uop_root
:
10814 &ns
->tb_sym_root
, name
);
10821 case INTERFACE_INTRINSIC_OP
:
10822 ns
->tb_op
[op
] = tb
;
10826 gcc_unreachable ();
10830 /* Now, match all following names as specific targets. */
10833 gfc_symtree
* target_st
;
10834 gfc_tbp_generic
* target
;
10836 m
= gfc_match_name (name
);
10837 if (m
== MATCH_ERROR
)
10841 gfc_error ("Expected specific binding name at %C");
10845 target_st
= gfc_get_tbp_symtree (&ns
->tb_sym_root
, name
);
10847 /* See if this is a duplicate specification. */
10848 for (target
= tb
->u
.generic
; target
; target
= target
->next
)
10849 if (target_st
== target
->specific_st
)
10851 gfc_error ("%qs already defined as specific binding for the"
10852 " generic %qs at %C", name
, bind_name
);
10856 target
= gfc_get_tbp_generic ();
10857 target
->specific_st
= target_st
;
10858 target
->specific
= NULL
;
10859 target
->next
= tb
->u
.generic
;
10860 target
->is_operator
= ((op_type
== INTERFACE_USER_OP
)
10861 || (op_type
== INTERFACE_INTRINSIC_OP
));
10862 tb
->u
.generic
= target
;
10864 while (gfc_match (" ,") == MATCH_YES
);
10866 /* Here should be the end. */
10867 if (gfc_match_eos () != MATCH_YES
)
10869 gfc_error ("Junk after GENERIC binding at %C");
10876 return MATCH_ERROR
;
10880 /* Match a FINAL declaration inside a derived type. */
10883 gfc_match_final_decl (void)
10885 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10888 gfc_namespace
* module_ns
;
10892 if (gfc_current_form
== FORM_FREE
)
10894 char c
= gfc_peek_ascii_char ();
10895 if (!gfc_is_whitespace (c
) && c
!= ':')
10899 if (gfc_state_stack
->state
!= COMP_DERIVED_CONTAINS
)
10901 if (gfc_current_form
== FORM_FIXED
)
10904 gfc_error ("FINAL declaration at %C must be inside a derived type "
10905 "CONTAINS section");
10906 return MATCH_ERROR
;
10909 block
= gfc_state_stack
->previous
->sym
;
10910 gcc_assert (block
);
10912 if (!gfc_state_stack
->previous
|| !gfc_state_stack
->previous
->previous
10913 || gfc_state_stack
->previous
->previous
->state
!= COMP_MODULE
)
10915 gfc_error ("Derived type declaration with FINAL at %C must be in the"
10916 " specification part of a MODULE");
10917 return MATCH_ERROR
;
10920 module_ns
= gfc_current_ns
;
10921 gcc_assert (module_ns
);
10922 gcc_assert (module_ns
->proc_name
->attr
.flavor
== FL_MODULE
);
10924 /* Match optional ::, don't care about MATCH_YES or MATCH_NO. */
10925 if (gfc_match (" ::") == MATCH_ERROR
)
10926 return MATCH_ERROR
;
10928 /* Match the sequence of procedure names. */
10935 if (first
&& gfc_match_eos () == MATCH_YES
)
10937 gfc_error ("Empty FINAL at %C");
10938 return MATCH_ERROR
;
10941 m
= gfc_match_name (name
);
10944 gfc_error ("Expected module procedure name at %C");
10945 return MATCH_ERROR
;
10947 else if (m
!= MATCH_YES
)
10948 return MATCH_ERROR
;
10950 if (gfc_match_eos () == MATCH_YES
)
10952 if (!last
&& gfc_match_char (',') != MATCH_YES
)
10954 gfc_error ("Expected %<,%> at %C");
10955 return MATCH_ERROR
;
10958 if (gfc_get_symbol (name
, module_ns
, &sym
))
10960 gfc_error ("Unknown procedure name %qs at %C", name
);
10961 return MATCH_ERROR
;
10964 /* Mark the symbol as module procedure. */
10965 if (sym
->attr
.proc
!= PROC_MODULE
10966 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
10967 return MATCH_ERROR
;
10969 /* Check if we already have this symbol in the list, this is an error. */
10970 for (f
= block
->f2k_derived
->finalizers
; f
; f
= f
->next
)
10971 if (f
->proc_sym
== sym
)
10973 gfc_error ("%qs at %C is already defined as FINAL procedure",
10975 return MATCH_ERROR
;
10978 /* Add this symbol to the list of finalizers. */
10979 gcc_assert (block
->f2k_derived
);
10981 f
= XCNEW (gfc_finalizer
);
10983 f
->proc_tree
= NULL
;
10984 f
->where
= gfc_current_locus
;
10985 f
->next
= block
->f2k_derived
->finalizers
;
10986 block
->f2k_derived
->finalizers
= f
;
10996 const ext_attr_t ext_attr_list
[] = {
10997 { "dllimport", EXT_ATTR_DLLIMPORT
, "dllimport" },
10998 { "dllexport", EXT_ATTR_DLLEXPORT
, "dllexport" },
10999 { "cdecl", EXT_ATTR_CDECL
, "cdecl" },
11000 { "stdcall", EXT_ATTR_STDCALL
, "stdcall" },
11001 { "fastcall", EXT_ATTR_FASTCALL
, "fastcall" },
11002 { "no_arg_check", EXT_ATTR_NO_ARG_CHECK
, NULL
},
11003 { NULL
, EXT_ATTR_LAST
, NULL
}
11006 /* Match a !GCC$ ATTRIBUTES statement of the form:
11007 !GCC$ ATTRIBUTES attribute-list :: var-name [, var-name] ...
11008 When we come here, we have already matched the !GCC$ ATTRIBUTES string.
11010 TODO: We should support all GCC attributes using the same syntax for
11011 the attribute list, i.e. the list in C
11012 __attributes(( attribute-list ))
11014 !GCC$ ATTRIBUTES attribute-list ::
11015 Cf. c-parser.c's c_parser_attributes; the data can then directly be
11018 As there is absolutely no risk of confusion, we should never return
11021 gfc_match_gcc_attributes (void)
11023 symbol_attribute attr
;
11024 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
11029 gfc_clear_attr (&attr
);
11034 if (gfc_match_name (name
) != MATCH_YES
)
11035 return MATCH_ERROR
;
11037 for (id
= 0; id
< EXT_ATTR_LAST
; id
++)
11038 if (strcmp (name
, ext_attr_list
[id
].name
) == 0)
11041 if (id
== EXT_ATTR_LAST
)
11043 gfc_error ("Unknown attribute in !GCC$ ATTRIBUTES statement at %C");
11044 return MATCH_ERROR
;
11047 if (!gfc_add_ext_attribute (&attr
, (ext_attr_id_t
)id
, &gfc_current_locus
))
11048 return MATCH_ERROR
;
11050 gfc_gobble_whitespace ();
11051 ch
= gfc_next_ascii_char ();
11054 /* This is the successful exit condition for the loop. */
11055 if (gfc_next_ascii_char () == ':')
11065 if (gfc_match_eos () == MATCH_YES
)
11070 m
= gfc_match_name (name
);
11071 if (m
!= MATCH_YES
)
11074 if (find_special (name
, &sym
, true))
11075 return MATCH_ERROR
;
11077 sym
->attr
.ext_attr
|= attr
.ext_attr
;
11079 if (gfc_match_eos () == MATCH_YES
)
11082 if (gfc_match_char (',') != MATCH_YES
)
11089 gfc_error ("Syntax error in !GCC$ ATTRIBUTES statement at %C");
11090 return MATCH_ERROR
;
11094 /* Match a !GCC$ UNROLL statement of the form:
11097 The parameter n is the number of times we are supposed to unroll.
11099 When we come here, we have already matched the !GCC$ UNROLL string. */
11101 gfc_match_gcc_unroll (void)
11105 if (gfc_match_small_int (&value
) == MATCH_YES
)
11107 if (value
< 0 || value
> USHRT_MAX
)
11109 gfc_error ("%<GCC unroll%> directive requires a"
11110 " non-negative integral constant"
11111 " less than or equal to %u at %C",
11114 return MATCH_ERROR
;
11116 if (gfc_match_eos () == MATCH_YES
)
11118 directive_unroll
= value
== 0 ? 1 : value
;
11123 gfc_error ("Syntax error in !GCC$ UNROLL directive at %C");
11124 return MATCH_ERROR
;