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
)
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 /* Trap a procedure with a name the same as interface in the
1218 encompassing scope. */
1219 if (sym
->attr
.generic
!= 0
1220 && (sym
->attr
.subroutine
|| sym
->attr
.function
)
1221 && !sym
->attr
.mod_proc
)
1222 gfc_error_now ("Name %qs at %C is already defined"
1223 " as a generic interface at %L",
1224 name
, &sym
->declared_at
);
1226 /* Trap declarations of attributes in encompassing scope. The
1227 signature for this is that ts.kind is set. Legitimate
1228 references only set ts.type. */
1229 if (sym
->ts
.kind
!= 0
1230 && !sym
->attr
.implicit_type
1231 && sym
->attr
.proc
== 0
1232 && gfc_current_ns
->parent
!= NULL
1233 && sym
->attr
.access
== 0
1234 && !module_fcn_entry
)
1235 gfc_error_now ("Procedure %qs at %C has an explicit interface "
1236 "and must not have attributes declared at %L",
1237 name
, &sym
->declared_at
);
1240 if (gfc_current_ns
->parent
== NULL
|| *result
== NULL
)
1243 /* Module function entries will already have a symtree in
1244 the current namespace but will need one at module level. */
1245 if (module_fcn_entry
)
1247 /* Present if entry is declared to be a module procedure. */
1248 rc
= gfc_find_sym_tree (name
, gfc_current_ns
->parent
, 0, &st
);
1250 st
= gfc_new_symtree (&gfc_current_ns
->parent
->sym_root
, name
);
1253 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, name
);
1258 /* See if the procedure should be a module procedure. */
1260 if (((sym
->ns
->proc_name
!= NULL
1261 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
1262 && sym
->attr
.proc
!= PROC_MODULE
)
1263 || (module_fcn_entry
&& sym
->attr
.proc
!= PROC_MODULE
))
1264 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
1271 /* Verify that the given symbol representing a parameter is C
1272 interoperable, by checking to see if it was marked as such after
1273 its declaration. If the given symbol is not interoperable, a
1274 warning is reported, thus removing the need to return the status to
1275 the calling function. The standard does not require the user use
1276 one of the iso_c_binding named constants to declare an
1277 interoperable parameter, but we can't be sure if the param is C
1278 interop or not if the user doesn't. For example, integer(4) may be
1279 legal Fortran, but doesn't have meaning in C. It may interop with
1280 a number of the C types, which causes a problem because the
1281 compiler can't know which one. This code is almost certainly not
1282 portable, and the user will get what they deserve if the C type
1283 across platforms isn't always interoperable with integer(4). If
1284 the user had used something like integer(c_int) or integer(c_long),
1285 the compiler could have automatically handled the varying sizes
1286 across platforms. */
1289 gfc_verify_c_interop_param (gfc_symbol
*sym
)
1291 int is_c_interop
= 0;
1294 /* We check implicitly typed variables in symbol.c:gfc_set_default_type().
1295 Don't repeat the checks here. */
1296 if (sym
->attr
.implicit_type
)
1299 /* For subroutines or functions that are passed to a BIND(C) procedure,
1300 they're interoperable if they're BIND(C) and their params are all
1302 if (sym
->attr
.flavor
== FL_PROCEDURE
)
1304 if (sym
->attr
.is_bind_c
== 0)
1306 gfc_error_now ("Procedure %qs at %L must have the BIND(C) "
1307 "attribute to be C interoperable", sym
->name
,
1308 &(sym
->declared_at
));
1313 if (sym
->attr
.is_c_interop
== 1)
1314 /* We've already checked this procedure; don't check it again. */
1317 return verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
1322 /* See if we've stored a reference to a procedure that owns sym. */
1323 if (sym
->ns
!= NULL
&& sym
->ns
->proc_name
!= NULL
)
1325 if (sym
->ns
->proc_name
->attr
.is_bind_c
== 1)
1327 is_c_interop
= (gfc_verify_c_interop(&(sym
->ts
)) ? 1 : 0);
1329 if (is_c_interop
!= 1)
1331 /* Make personalized messages to give better feedback. */
1332 if (sym
->ts
.type
== BT_DERIVED
)
1333 gfc_error ("Variable %qs at %L is a dummy argument to the "
1334 "BIND(C) procedure %qs but is not C interoperable "
1335 "because derived type %qs is not C interoperable",
1336 sym
->name
, &(sym
->declared_at
),
1337 sym
->ns
->proc_name
->name
,
1338 sym
->ts
.u
.derived
->name
);
1339 else if (sym
->ts
.type
== BT_CLASS
)
1340 gfc_error ("Variable %qs at %L is a dummy argument to the "
1341 "BIND(C) procedure %qs but is not C interoperable "
1342 "because it is polymorphic",
1343 sym
->name
, &(sym
->declared_at
),
1344 sym
->ns
->proc_name
->name
);
1345 else if (warn_c_binding_type
)
1346 gfc_warning (OPT_Wc_binding_type
,
1347 "Variable %qs at %L is a dummy argument of the "
1348 "BIND(C) procedure %qs but may not be C "
1350 sym
->name
, &(sym
->declared_at
),
1351 sym
->ns
->proc_name
->name
);
1354 /* Character strings are only C interoperable if they have a
1356 if (sym
->ts
.type
== BT_CHARACTER
)
1358 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
1359 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
1360 || mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
1362 gfc_error ("Character argument %qs at %L "
1363 "must be length 1 because "
1364 "procedure %qs is BIND(C)",
1365 sym
->name
, &sym
->declared_at
,
1366 sym
->ns
->proc_name
->name
);
1371 /* We have to make sure that any param to a bind(c) routine does
1372 not have the allocatable, pointer, or optional attributes,
1373 according to J3/04-007, section 5.1. */
1374 if (sym
->attr
.allocatable
== 1
1375 && !gfc_notify_std (GFC_STD_F2008_TS
, "Variable %qs at %L with "
1376 "ALLOCATABLE attribute in procedure %qs "
1377 "with BIND(C)", sym
->name
,
1378 &(sym
->declared_at
),
1379 sym
->ns
->proc_name
->name
))
1382 if (sym
->attr
.pointer
== 1
1383 && !gfc_notify_std (GFC_STD_F2008_TS
, "Variable %qs at %L with "
1384 "POINTER attribute in procedure %qs "
1385 "with BIND(C)", sym
->name
,
1386 &(sym
->declared_at
),
1387 sym
->ns
->proc_name
->name
))
1390 if ((sym
->attr
.allocatable
|| sym
->attr
.pointer
) && !sym
->as
)
1392 gfc_error ("Scalar variable %qs at %L with POINTER or "
1393 "ALLOCATABLE in procedure %qs with BIND(C) is not yet"
1394 " supported", sym
->name
, &(sym
->declared_at
),
1395 sym
->ns
->proc_name
->name
);
1399 if (sym
->attr
.optional
== 1 && sym
->attr
.value
)
1401 gfc_error ("Variable %qs at %L cannot have both the OPTIONAL "
1402 "and the VALUE attribute because procedure %qs "
1403 "is BIND(C)", sym
->name
, &(sym
->declared_at
),
1404 sym
->ns
->proc_name
->name
);
1407 else if (sym
->attr
.optional
== 1
1408 && !gfc_notify_std (GFC_STD_F2008_TS
, "Variable %qs "
1409 "at %L with OPTIONAL attribute in "
1410 "procedure %qs which is BIND(C)",
1411 sym
->name
, &(sym
->declared_at
),
1412 sym
->ns
->proc_name
->name
))
1415 /* Make sure that if it has the dimension attribute, that it is
1416 either assumed size or explicit shape. Deferred shape is already
1417 covered by the pointer/allocatable attribute. */
1418 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SHAPE
1419 && !gfc_notify_std (GFC_STD_F2008_TS
, "Assumed-shape array %qs "
1420 "at %L as dummy argument to the BIND(C) "
1421 "procedure %qs at %L", sym
->name
,
1422 &(sym
->declared_at
),
1423 sym
->ns
->proc_name
->name
,
1424 &(sym
->ns
->proc_name
->declared_at
)))
1434 /* Function called by variable_decl() that adds a name to the symbol table. */
1437 build_sym (const char *name
, gfc_charlen
*cl
, bool cl_deferred
,
1438 gfc_array_spec
**as
, locus
*var_locus
)
1440 symbol_attribute attr
;
1445 /* Symbols in a submodule are host associated from the parent module or
1446 submodules. Therefore, they can be overridden by declarations in the
1447 submodule scope. Deal with this by attaching the existing symbol to
1448 a new symtree and recycling the old symtree with a new symbol... */
1449 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
1450 if (st
!= NULL
&& gfc_state_stack
->state
== COMP_SUBMODULE
1451 && st
->n
.sym
!= NULL
1452 && st
->n
.sym
->attr
.host_assoc
&& st
->n
.sym
->attr
.used_in_submodule
)
1454 gfc_symtree
*s
= gfc_get_unique_symtree (gfc_current_ns
);
1455 s
->n
.sym
= st
->n
.sym
;
1456 sym
= gfc_new_symbol (name
, gfc_current_ns
);
1461 gfc_set_sym_referenced (sym
);
1463 /* ...Otherwise generate a new symtree and new symbol. */
1464 else if (gfc_get_symbol (name
, NULL
, &sym
))
1467 /* Check if the name has already been defined as a type. The
1468 first letter of the symtree will be in upper case then. Of
1469 course, this is only necessary if the upper case letter is
1470 actually different. */
1472 upper
= TOUPPER(name
[0]);
1473 if (upper
!= name
[0])
1475 char u_name
[GFC_MAX_SYMBOL_LEN
+ 1];
1478 gcc_assert (strlen(name
) <= GFC_MAX_SYMBOL_LEN
);
1479 strcpy (u_name
, name
);
1482 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, u_name
);
1484 /* STRUCTURE types can alias symbol names */
1485 if (st
!= 0 && st
->n
.sym
->attr
.flavor
!= FL_STRUCT
)
1487 gfc_error ("Symbol %qs at %C also declared as a type at %L", name
,
1488 &st
->n
.sym
->declared_at
);
1493 /* Start updating the symbol table. Add basic type attribute if present. */
1494 if (current_ts
.type
!= BT_UNKNOWN
1495 && (sym
->attr
.implicit_type
== 0
1496 || !gfc_compare_types (&sym
->ts
, ¤t_ts
))
1497 && !gfc_add_type (sym
, ¤t_ts
, var_locus
))
1500 if (sym
->ts
.type
== BT_CHARACTER
)
1503 sym
->ts
.deferred
= cl_deferred
;
1506 /* Add dimension attribute if present. */
1507 if (!gfc_set_array_spec (sym
, *as
, var_locus
))
1511 /* Add attribute to symbol. The copy is so that we can reset the
1512 dimension attribute. */
1513 attr
= current_attr
;
1515 attr
.codimension
= 0;
1517 if (!gfc_copy_attr (&sym
->attr
, &attr
, var_locus
))
1520 /* Finish any work that may need to be done for the binding label,
1521 if it's a bind(c). The bind(c) attr is found before the symbol
1522 is made, and before the symbol name (for data decls), so the
1523 current_ts is holding the binding label, or nothing if the
1524 name= attr wasn't given. Therefore, test here if we're dealing
1525 with a bind(c) and make sure the binding label is set correctly. */
1526 if (sym
->attr
.is_bind_c
== 1)
1528 if (!sym
->binding_label
)
1530 /* Set the binding label and verify that if a NAME= was specified
1531 then only one identifier was in the entity-decl-list. */
1532 if (!set_binding_label (&sym
->binding_label
, sym
->name
,
1533 num_idents_on_line
))
1538 /* See if we know we're in a common block, and if it's a bind(c)
1539 common then we need to make sure we're an interoperable type. */
1540 if (sym
->attr
.in_common
== 1)
1542 /* Test the common block object. */
1543 if (sym
->common_block
!= NULL
&& sym
->common_block
->is_bind_c
== 1
1544 && sym
->ts
.is_c_interop
!= 1)
1546 gfc_error_now ("Variable %qs in common block %qs at %C "
1547 "must be declared with a C interoperable "
1548 "kind since common block %qs is BIND(C)",
1549 sym
->name
, sym
->common_block
->name
,
1550 sym
->common_block
->name
);
1555 sym
->attr
.implied_index
= 0;
1557 /* Use the parameter expressions for a parameterized derived type. */
1558 if ((sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
1559 && sym
->ts
.u
.derived
->attr
.pdt_type
&& type_param_spec_list
)
1560 sym
->param_list
= gfc_copy_actual_arglist (type_param_spec_list
);
1562 if (sym
->ts
.type
== BT_CLASS
)
1563 return gfc_build_class_symbol (&sym
->ts
, &sym
->attr
, &sym
->as
);
1569 /* Set character constant to the given length. The constant will be padded or
1570 truncated. If we're inside an array constructor without a typespec, we
1571 additionally check that all elements have the same length; check_len -1
1572 means no checking. */
1575 gfc_set_constant_character_len (gfc_charlen_t len
, gfc_expr
*expr
,
1576 gfc_charlen_t check_len
)
1581 if (expr
->ts
.type
!= BT_CHARACTER
)
1584 if (expr
->expr_type
!= EXPR_CONSTANT
)
1586 gfc_error_now ("CHARACTER length must be a constant at %L", &expr
->where
);
1590 slen
= expr
->value
.character
.length
;
1593 s
= gfc_get_wide_string (len
+ 1);
1594 memcpy (s
, expr
->value
.character
.string
,
1595 MIN (len
, slen
) * sizeof (gfc_char_t
));
1597 gfc_wide_memset (&s
[slen
], ' ', len
- slen
);
1599 if (warn_character_truncation
&& slen
> len
)
1600 gfc_warning_now (OPT_Wcharacter_truncation
,
1601 "CHARACTER expression at %L is being truncated "
1602 "(%ld/%ld)", &expr
->where
,
1603 (long) slen
, (long) len
);
1605 /* Apply the standard by 'hand' otherwise it gets cleared for
1607 if (check_len
!= -1 && slen
!= check_len
1608 && !(gfc_option
.allow_std
& GFC_STD_GNU
))
1609 gfc_error_now ("The CHARACTER elements of the array constructor "
1610 "at %L must have the same length (%ld/%ld)",
1611 &expr
->where
, (long) slen
,
1615 free (expr
->value
.character
.string
);
1616 expr
->value
.character
.string
= s
;
1617 expr
->value
.character
.length
= len
;
1622 /* Function to create and update the enumerator history
1623 using the information passed as arguments.
1624 Pointer "max_enum" is also updated, to point to
1625 enum history node containing largest initializer.
1627 SYM points to the symbol node of enumerator.
1628 INIT points to its enumerator value. */
1631 create_enum_history (gfc_symbol
*sym
, gfc_expr
*init
)
1633 enumerator_history
*new_enum_history
;
1634 gcc_assert (sym
!= NULL
&& init
!= NULL
);
1636 new_enum_history
= XCNEW (enumerator_history
);
1638 new_enum_history
->sym
= sym
;
1639 new_enum_history
->initializer
= init
;
1640 new_enum_history
->next
= NULL
;
1642 if (enum_history
== NULL
)
1644 enum_history
= new_enum_history
;
1645 max_enum
= enum_history
;
1649 new_enum_history
->next
= enum_history
;
1650 enum_history
= new_enum_history
;
1652 if (mpz_cmp (max_enum
->initializer
->value
.integer
,
1653 new_enum_history
->initializer
->value
.integer
) < 0)
1654 max_enum
= new_enum_history
;
1659 /* Function to free enum kind history. */
1662 gfc_free_enum_history (void)
1664 enumerator_history
*current
= enum_history
;
1665 enumerator_history
*next
;
1667 while (current
!= NULL
)
1669 next
= current
->next
;
1674 enum_history
= NULL
;
1678 /* Function called by variable_decl() that adds an initialization
1679 expression to a symbol. */
1682 add_init_expr_to_sym (const char *name
, gfc_expr
**initp
, locus
*var_locus
)
1684 symbol_attribute attr
;
1689 if (find_special (name
, &sym
, false))
1694 /* If this symbol is confirming an implicit parameter type,
1695 then an initialization expression is not allowed. */
1696 if (attr
.flavor
== FL_PARAMETER
1697 && sym
->value
!= NULL
1700 gfc_error ("Initializer not allowed for PARAMETER %qs at %C",
1707 /* An initializer is required for PARAMETER declarations. */
1708 if (attr
.flavor
== FL_PARAMETER
)
1710 gfc_error ("PARAMETER at %L is missing an initializer", var_locus
);
1716 /* If a variable appears in a DATA block, it cannot have an
1720 gfc_error ("Variable %qs at %C with an initializer already "
1721 "appears in a DATA statement", sym
->name
);
1725 /* Check if the assignment can happen. This has to be put off
1726 until later for derived type variables and procedure pointers. */
1727 if (!gfc_bt_struct (sym
->ts
.type
) && !gfc_bt_struct (init
->ts
.type
)
1728 && sym
->ts
.type
!= BT_CLASS
&& init
->ts
.type
!= BT_CLASS
1729 && !sym
->attr
.proc_pointer
1730 && !gfc_check_assign_symbol (sym
, NULL
, init
))
1733 if (sym
->ts
.type
== BT_CHARACTER
&& sym
->ts
.u
.cl
1734 && init
->ts
.type
== BT_CHARACTER
)
1736 /* Update symbol character length according initializer. */
1737 if (!gfc_check_assign_symbol (sym
, NULL
, init
))
1740 if (sym
->ts
.u
.cl
->length
== NULL
)
1743 /* If there are multiple CHARACTER variables declared on the
1744 same line, we don't want them to share the same length. */
1745 sym
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1747 if (sym
->attr
.flavor
== FL_PARAMETER
)
1749 if (init
->expr_type
== EXPR_CONSTANT
)
1751 clen
= init
->value
.character
.length
;
1752 sym
->ts
.u
.cl
->length
1753 = gfc_get_int_expr (gfc_charlen_int_kind
,
1756 else if (init
->expr_type
== EXPR_ARRAY
)
1758 if (init
->ts
.u
.cl
&& init
->ts
.u
.cl
->length
)
1760 const gfc_expr
*length
= init
->ts
.u
.cl
->length
;
1761 if (length
->expr_type
!= EXPR_CONSTANT
)
1763 gfc_error ("Cannot initialize parameter array "
1765 "with variable length elements",
1769 clen
= mpz_get_si (length
->value
.integer
);
1771 else if (init
->value
.constructor
)
1774 c
= gfc_constructor_first (init
->value
.constructor
);
1775 clen
= c
->expr
->value
.character
.length
;
1779 sym
->ts
.u
.cl
->length
1780 = gfc_get_int_expr (gfc_charlen_int_kind
,
1783 else if (init
->ts
.u
.cl
&& init
->ts
.u
.cl
->length
)
1784 sym
->ts
.u
.cl
->length
=
1785 gfc_copy_expr (sym
->value
->ts
.u
.cl
->length
);
1788 /* Update initializer character length according symbol. */
1789 else if (sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1791 if (!gfc_specification_expr (sym
->ts
.u
.cl
->length
))
1794 int k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
,
1796 /* resolve_charlen will complain later on if the length
1797 is too large. Just skeep the initialization in that case. */
1798 if (mpz_cmp (sym
->ts
.u
.cl
->length
->value
.integer
,
1799 gfc_integer_kinds
[k
].huge
) <= 0)
1802 = gfc_mpz_get_hwi (sym
->ts
.u
.cl
->length
->value
.integer
);
1804 if (init
->expr_type
== EXPR_CONSTANT
)
1805 gfc_set_constant_character_len (len
, init
, -1);
1806 else if (init
->expr_type
== EXPR_ARRAY
)
1810 /* Build a new charlen to prevent simplification from
1811 deleting the length before it is resolved. */
1812 init
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1813 init
->ts
.u
.cl
->length
1814 = gfc_copy_expr (sym
->ts
.u
.cl
->length
);
1816 for (c
= gfc_constructor_first (init
->value
.constructor
);
1817 c
; c
= gfc_constructor_next (c
))
1818 gfc_set_constant_character_len (len
, c
->expr
, -1);
1824 /* If sym is implied-shape, set its upper bounds from init. */
1825 if (sym
->attr
.flavor
== FL_PARAMETER
&& sym
->attr
.dimension
1826 && sym
->as
->type
== AS_IMPLIED_SHAPE
)
1830 if (init
->rank
== 0)
1832 gfc_error ("Can't initialize implied-shape array at %L"
1833 " with scalar", &sym
->declared_at
);
1837 /* Shape should be present, we get an initialization expression. */
1838 gcc_assert (init
->shape
);
1840 for (dim
= 0; dim
< sym
->as
->rank
; ++dim
)
1843 gfc_expr
*e
, *lower
;
1845 lower
= sym
->as
->lower
[dim
];
1847 /* If the lower bound is an array element from another
1848 parameterized array, then it is marked with EXPR_VARIABLE and
1849 is an initialization expression. Try to reduce it. */
1850 if (lower
->expr_type
== EXPR_VARIABLE
)
1851 gfc_reduce_init_expr (lower
);
1853 if (lower
->expr_type
== EXPR_CONSTANT
)
1855 /* All dimensions must be without upper bound. */
1856 gcc_assert (!sym
->as
->upper
[dim
]);
1859 e
= gfc_get_constant_expr (BT_INTEGER
, k
, &sym
->declared_at
);
1860 mpz_add (e
->value
.integer
, lower
->value
.integer
,
1862 mpz_sub_ui (e
->value
.integer
, e
->value
.integer
, 1);
1863 sym
->as
->upper
[dim
] = e
;
1867 gfc_error ("Non-constant lower bound in implied-shape"
1868 " declaration at %L", &lower
->where
);
1873 sym
->as
->type
= AS_EXPLICIT
;
1876 /* Need to check if the expression we initialized this
1877 to was one of the iso_c_binding named constants. If so,
1878 and we're a parameter (constant), let it be iso_c.
1880 integer(c_int), parameter :: my_int = c_int
1881 integer(my_int) :: my_int_2
1882 If we mark my_int as iso_c (since we can see it's value
1883 is equal to one of the named constants), then my_int_2
1884 will be considered C interoperable. */
1885 if (sym
->ts
.type
!= BT_CHARACTER
&& !gfc_bt_struct (sym
->ts
.type
))
1887 sym
->ts
.is_iso_c
|= init
->ts
.is_iso_c
;
1888 sym
->ts
.is_c_interop
|= init
->ts
.is_c_interop
;
1889 /* attr bits needed for module files. */
1890 sym
->attr
.is_iso_c
|= init
->ts
.is_iso_c
;
1891 sym
->attr
.is_c_interop
|= init
->ts
.is_c_interop
;
1892 if (init
->ts
.is_iso_c
)
1893 sym
->ts
.f90_type
= init
->ts
.f90_type
;
1896 /* Add initializer. Make sure we keep the ranks sane. */
1897 if (sym
->attr
.dimension
&& init
->rank
== 0)
1902 if (sym
->attr
.flavor
== FL_PARAMETER
1903 && init
->expr_type
== EXPR_CONSTANT
1904 && spec_size (sym
->as
, &size
)
1905 && mpz_cmp_si (size
, 0) > 0)
1907 array
= gfc_get_array_expr (init
->ts
.type
, init
->ts
.kind
,
1909 for (n
= 0; n
< (int)mpz_get_si (size
); n
++)
1910 gfc_constructor_append_expr (&array
->value
.constructor
,
1913 : gfc_copy_expr (init
),
1916 array
->shape
= gfc_get_shape (sym
->as
->rank
);
1917 for (n
= 0; n
< sym
->as
->rank
; n
++)
1918 spec_dimen_size (sym
->as
, n
, &array
->shape
[n
]);
1923 init
->rank
= sym
->as
->rank
;
1927 if (sym
->attr
.save
== SAVE_NONE
)
1928 sym
->attr
.save
= SAVE_IMPLICIT
;
1936 /* Function called by variable_decl() that adds a name to a structure
1940 build_struct (const char *name
, gfc_charlen
*cl
, gfc_expr
**init
,
1941 gfc_array_spec
**as
)
1946 /* F03:C438/C439. If the current symbol is of the same derived type that we're
1947 constructing, it must have the pointer attribute. */
1948 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
1949 && current_ts
.u
.derived
== gfc_current_block ()
1950 && current_attr
.pointer
== 0)
1952 if (current_attr
.allocatable
1953 && !gfc_notify_std(GFC_STD_F2008
, "Component at %C "
1954 "must have the POINTER attribute"))
1958 else if (current_attr
.allocatable
== 0)
1960 gfc_error ("Component at %C must have the POINTER attribute");
1966 if (current_ts
.type
== BT_CLASS
1967 && !(current_attr
.pointer
|| current_attr
.allocatable
))
1969 gfc_error ("Component %qs with CLASS at %C must be allocatable "
1970 "or pointer", name
);
1974 if (gfc_current_block ()->attr
.pointer
&& (*as
)->rank
!= 0)
1976 if ((*as
)->type
!= AS_DEFERRED
&& (*as
)->type
!= AS_EXPLICIT
)
1978 gfc_error ("Array component of structure at %C must have explicit "
1979 "or deferred shape");
1984 /* If we are in a nested union/map definition, gfc_add_component will not
1985 properly find repeated components because:
1986 (i) gfc_add_component does a flat search, where components of unions
1987 and maps are implicity chained so nested components may conflict.
1988 (ii) Unions and maps are not linked as components of their parent
1989 structures until after they are parsed.
1990 For (i) we use gfc_find_component which searches recursively, and for (ii)
1991 we search each block directly from the parse stack until we find the top
1994 s
= gfc_state_stack
;
1995 if (s
->state
== COMP_UNION
|| s
->state
== COMP_MAP
)
1997 while (s
->state
== COMP_UNION
|| gfc_comp_struct (s
->state
))
1999 c
= gfc_find_component (s
->sym
, name
, true, true, NULL
);
2002 gfc_error_now ("Component %qs at %C already declared at %L",
2006 /* Break after we've searched the entire chain. */
2007 if (s
->state
== COMP_DERIVED
|| s
->state
== COMP_STRUCTURE
)
2013 if (!gfc_add_component (gfc_current_block(), name
, &c
))
2017 if (c
->ts
.type
== BT_CHARACTER
)
2020 if (c
->ts
.type
!= BT_CLASS
&& c
->ts
.type
!= BT_DERIVED
2021 && (c
->ts
.kind
== 0 || c
->ts
.type
== BT_CHARACTER
)
2022 && saved_kind_expr
!= NULL
)
2023 c
->kind_expr
= gfc_copy_expr (saved_kind_expr
);
2025 c
->attr
= current_attr
;
2027 c
->initializer
= *init
;
2034 c
->attr
.codimension
= 1;
2036 c
->attr
.dimension
= 1;
2040 gfc_apply_init (&c
->ts
, &c
->attr
, c
->initializer
);
2042 /* Check array components. */
2043 if (!c
->attr
.dimension
)
2046 if (c
->attr
.pointer
)
2048 if (c
->as
->type
!= AS_DEFERRED
)
2050 gfc_error ("Pointer array component of structure at %C must have a "
2055 else if (c
->attr
.allocatable
)
2057 if (c
->as
->type
!= AS_DEFERRED
)
2059 gfc_error ("Allocatable component of structure at %C must have a "
2066 if (c
->as
->type
!= AS_EXPLICIT
)
2068 gfc_error ("Array component of structure at %C must have an "
2075 if (c
->ts
.type
== BT_CLASS
)
2076 return gfc_build_class_symbol (&c
->ts
, &c
->attr
, &c
->as
);
2078 if (c
->attr
.pdt_kind
|| c
->attr
.pdt_len
)
2081 gfc_find_symbol (c
->name
, gfc_current_block ()->f2k_derived
,
2085 gfc_error ("Type parameter %qs at %C has no corresponding entry "
2086 "in the type parameter name list at %L",
2087 c
->name
, &gfc_current_block ()->declared_at
);
2091 sym
->attr
.pdt_kind
= c
->attr
.pdt_kind
;
2092 sym
->attr
.pdt_len
= c
->attr
.pdt_len
;
2094 sym
->value
= gfc_copy_expr (c
->initializer
);
2095 sym
->attr
.flavor
= FL_VARIABLE
;
2098 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
2099 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_template
2100 && decl_type_param_list
)
2101 c
->param_list
= gfc_copy_actual_arglist (decl_type_param_list
);
2107 /* Match a 'NULL()', and possibly take care of some side effects. */
2110 gfc_match_null (gfc_expr
**result
)
2113 match m
, m2
= MATCH_NO
;
2115 if ((m
= gfc_match (" null ( )")) == MATCH_ERROR
)
2121 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2123 if ((m2
= gfc_match (" null (")) != MATCH_YES
)
2126 old_loc
= gfc_current_locus
;
2127 if ((m2
= gfc_match (" %n ) ", name
)) == MATCH_ERROR
)
2130 && ((m2
= gfc_match (" mold = %n )", name
)) == MATCH_ERROR
))
2134 gfc_current_locus
= old_loc
;
2139 /* The NULL symbol now has to be/become an intrinsic function. */
2140 if (gfc_get_symbol ("null", NULL
, &sym
))
2142 gfc_error ("NULL() initialization at %C is ambiguous");
2146 gfc_intrinsic_symbol (sym
);
2148 if (sym
->attr
.proc
!= PROC_INTRINSIC
2149 && !(sym
->attr
.use_assoc
&& sym
->attr
.intrinsic
)
2150 && (!gfc_add_procedure(&sym
->attr
, PROC_INTRINSIC
, sym
->name
, NULL
)
2151 || !gfc_add_function (&sym
->attr
, sym
->name
, NULL
)))
2154 *result
= gfc_get_null_expr (&gfc_current_locus
);
2156 /* Invalid per F2008, C512. */
2157 if (m2
== MATCH_YES
)
2159 gfc_error ("NULL() initialization at %C may not have MOLD");
2167 /* Match the initialization expr for a data pointer or procedure pointer. */
2170 match_pointer_init (gfc_expr
**init
, int procptr
)
2174 if (gfc_pure (NULL
) && !gfc_comp_struct (gfc_state_stack
->state
))
2176 gfc_error ("Initialization of pointer at %C is not allowed in "
2177 "a PURE procedure");
2180 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
2182 /* Match NULL() initialization. */
2183 m
= gfc_match_null (init
);
2187 /* Match non-NULL initialization. */
2188 gfc_matching_ptr_assignment
= !procptr
;
2189 gfc_matching_procptr_assignment
= procptr
;
2190 m
= gfc_match_rvalue (init
);
2191 gfc_matching_ptr_assignment
= 0;
2192 gfc_matching_procptr_assignment
= 0;
2193 if (m
== MATCH_ERROR
)
2195 else if (m
== MATCH_NO
)
2197 gfc_error ("Error in pointer initialization at %C");
2201 if (!procptr
&& !gfc_resolve_expr (*init
))
2204 if (!gfc_notify_std (GFC_STD_F2008
, "non-NULL pointer "
2205 "initialization at %C"))
2213 check_function_name (char *name
)
2215 /* In functions that have a RESULT variable defined, the function name always
2216 refers to function calls. Therefore, the name is not allowed to appear in
2217 specification statements. When checking this, be careful about
2218 'hidden' procedure pointer results ('ppr@'). */
2220 if (gfc_current_state () == COMP_FUNCTION
)
2222 gfc_symbol
*block
= gfc_current_block ();
2223 if (block
&& block
->result
&& block
->result
!= block
2224 && strcmp (block
->result
->name
, "ppr@") != 0
2225 && strcmp (block
->name
, name
) == 0)
2227 gfc_error ("Function name %qs not allowed at %C", name
);
2236 /* Match a variable name with an optional initializer. When this
2237 subroutine is called, a variable is expected to be parsed next.
2238 Depending on what is happening at the moment, updates either the
2239 symbol table or the current interface. */
2242 variable_decl (int elem
)
2244 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2245 static unsigned int fill_id
= 0;
2246 gfc_expr
*initializer
, *char_len
;
2248 gfc_array_spec
*cp_as
; /* Extra copy for Cray Pointees. */
2260 /* When we get here, we've just matched a list of attributes and
2261 maybe a type and a double colon. The next thing we expect to see
2262 is the name of the symbol. */
2264 /* If we are parsing a structure with legacy support, we allow the symbol
2265 name to be '%FILL' which gives it an anonymous (inaccessible) name. */
2267 gfc_gobble_whitespace ();
2268 if (gfc_peek_ascii_char () == '%')
2270 gfc_next_ascii_char ();
2271 m
= gfc_match ("fill");
2276 m
= gfc_match_name (name
);
2284 if (gfc_current_state () != COMP_STRUCTURE
)
2286 if (flag_dec_structure
)
2287 gfc_error ("%qs not allowed outside STRUCTURE at %C", "%FILL");
2289 gfc_error ("%qs at %C is a DEC extension, enable with "
2290 "%<-fdec-structure%>", "%FILL");
2296 gfc_error ("%qs entity cannot have attributes at %C", "%FILL");
2300 /* %FILL components are given invalid fortran names. */
2301 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "%%FILL%u", fill_id
++);
2305 var_locus
= gfc_current_locus
;
2307 /* Now we could see the optional array spec. or character length. */
2308 m
= gfc_match_array_spec (&as
, true, true);
2309 if (m
== MATCH_ERROR
)
2313 as
= gfc_copy_array_spec (current_as
);
2315 && !merge_array_spec (current_as
, as
, true))
2321 if (flag_cray_pointer
)
2322 cp_as
= gfc_copy_array_spec (as
);
2324 /* At this point, we know for sure if the symbol is PARAMETER and can thus
2325 determine (and check) whether it can be implied-shape. If it
2326 was parsed as assumed-size, change it because PARAMETERs can not
2329 An explicit-shape-array cannot appear under several conditions.
2330 That check is done here as well. */
2333 if (as
->type
== AS_IMPLIED_SHAPE
&& current_attr
.flavor
!= FL_PARAMETER
)
2336 gfc_error ("Non-PARAMETER symbol %qs at %L can't be implied-shape",
2341 if (as
->type
== AS_ASSUMED_SIZE
&& as
->rank
== 1
2342 && current_attr
.flavor
== FL_PARAMETER
)
2343 as
->type
= AS_IMPLIED_SHAPE
;
2345 if (as
->type
== AS_IMPLIED_SHAPE
2346 && !gfc_notify_std (GFC_STD_F2008
, "Implied-shape array at %L",
2353 /* F2018:C830 (R816) An explicit-shape-spec whose bounds are not
2354 constant expressions shall appear only in a subprogram, derived
2355 type definition, BLOCK construct, or interface body. */
2356 if (as
->type
== AS_EXPLICIT
2357 && gfc_current_state () != COMP_BLOCK
2358 && gfc_current_state () != COMP_DERIVED
2359 && gfc_current_state () != COMP_FUNCTION
2360 && gfc_current_state () != COMP_INTERFACE
2361 && gfc_current_state () != COMP_SUBROUTINE
)
2364 bool not_constant
= false;
2366 for (int i
= 0; i
< as
->rank
; i
++)
2368 e
= gfc_copy_expr (as
->lower
[i
]);
2369 gfc_resolve_expr (e
);
2370 gfc_simplify_expr (e
, 0);
2371 if (e
&& (e
->expr_type
!= EXPR_CONSTANT
))
2373 not_constant
= true;
2378 e
= gfc_copy_expr (as
->upper
[i
]);
2379 gfc_resolve_expr (e
);
2380 gfc_simplify_expr (e
, 0);
2381 if (e
&& (e
->expr_type
!= EXPR_CONSTANT
))
2383 not_constant
= true;
2391 gfc_error ("Explicit shaped array with nonconstant bounds at %C");
2400 cl_deferred
= false;
2402 if (current_ts
.type
== BT_CHARACTER
)
2404 switch (match_char_length (&char_len
, &cl_deferred
, false))
2407 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2409 cl
->length
= char_len
;
2412 /* Non-constant lengths need to be copied after the first
2413 element. Also copy assumed lengths. */
2416 && (current_ts
.u
.cl
->length
== NULL
2417 || current_ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
2419 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2420 cl
->length
= gfc_copy_expr (current_ts
.u
.cl
->length
);
2423 cl
= current_ts
.u
.cl
;
2425 cl_deferred
= current_ts
.deferred
;
2434 /* The dummy arguments and result of the abreviated form of MODULE
2435 PROCEDUREs, used in SUBMODULES should not be redefined. */
2436 if (gfc_current_ns
->proc_name
2437 && gfc_current_ns
->proc_name
->abr_modproc_decl
)
2439 gfc_find_symbol (name
, gfc_current_ns
, 1, &sym
);
2440 if (sym
!= NULL
&& (sym
->attr
.dummy
|| sym
->attr
.result
))
2443 gfc_error ("%qs at %C is a redefinition of the declaration "
2444 "in the corresponding interface for MODULE "
2445 "PROCEDURE %qs", sym
->name
,
2446 gfc_current_ns
->proc_name
->name
);
2451 /* %FILL components may not have initializers. */
2452 if (strncmp (name
, "%FILL", 5) == 0 && gfc_match_eos () != MATCH_YES
)
2454 gfc_error ("%qs entity cannot have an initializer at %C", "%FILL");
2459 /* If this symbol has already shown up in a Cray Pointer declaration,
2460 and this is not a component declaration,
2461 then we want to set the type & bail out. */
2462 if (flag_cray_pointer
&& !gfc_comp_struct (gfc_current_state ()))
2464 gfc_find_symbol (name
, gfc_current_ns
, 1, &sym
);
2465 if (sym
!= NULL
&& sym
->attr
.cray_pointee
)
2467 sym
->ts
.type
= current_ts
.type
;
2468 sym
->ts
.kind
= current_ts
.kind
;
2470 sym
->ts
.u
.derived
= current_ts
.u
.derived
;
2471 sym
->ts
.is_c_interop
= current_ts
.is_c_interop
;
2472 sym
->ts
.is_iso_c
= current_ts
.is_iso_c
;
2475 /* Check to see if we have an array specification. */
2478 if (sym
->as
!= NULL
)
2480 gfc_error ("Duplicate array spec for Cray pointee at %C");
2481 gfc_free_array_spec (cp_as
);
2487 if (!gfc_set_array_spec (sym
, cp_as
, &var_locus
))
2488 gfc_internal_error ("Couldn't set pointee array spec.");
2490 /* Fix the array spec. */
2491 m
= gfc_mod_pointee_as (sym
->as
);
2492 if (m
== MATCH_ERROR
)
2500 gfc_free_array_spec (cp_as
);
2504 /* Procedure pointer as function result. */
2505 if (gfc_current_state () == COMP_FUNCTION
2506 && strcmp ("ppr@", gfc_current_block ()->name
) == 0
2507 && strcmp (name
, gfc_current_block ()->ns
->proc_name
->name
) == 0)
2508 strcpy (name
, "ppr@");
2510 if (gfc_current_state () == COMP_FUNCTION
2511 && strcmp (name
, gfc_current_block ()->name
) == 0
2512 && gfc_current_block ()->result
2513 && strcmp ("ppr@", gfc_current_block ()->result
->name
) == 0)
2514 strcpy (name
, "ppr@");
2516 /* OK, we've successfully matched the declaration. Now put the
2517 symbol in the current namespace, because it might be used in the
2518 optional initialization expression for this symbol, e.g. this is
2521 integer, parameter :: i = huge(i)
2523 This is only true for parameters or variables of a basic type.
2524 For components of derived types, it is not true, so we don't
2525 create a symbol for those yet. If we fail to create the symbol,
2527 if (!gfc_comp_struct (gfc_current_state ())
2528 && !build_sym (name
, cl
, cl_deferred
, &as
, &var_locus
))
2534 if (!check_function_name (name
))
2540 /* We allow old-style initializations of the form
2541 integer i /2/, j(4) /3*3, 1/
2542 (if no colon has been seen). These are different from data
2543 statements in that initializers are only allowed to apply to the
2544 variable immediately preceding, i.e.
2546 is not allowed. Therefore we have to do some work manually, that
2547 could otherwise be left to the matchers for DATA statements. */
2549 if (!colon_seen
&& gfc_match (" /") == MATCH_YES
)
2551 if (!gfc_notify_std (GFC_STD_GNU
, "Old-style "
2552 "initialization at %C"))
2555 /* Allow old style initializations for components of STRUCTUREs and MAPs
2556 but not components of derived types. */
2557 else if (gfc_current_state () == COMP_DERIVED
)
2559 gfc_error ("Invalid old style initialization for derived type "
2565 /* For structure components, read the initializer as a special
2566 expression and let the rest of this function apply the initializer
2568 else if (gfc_comp_struct (gfc_current_state ()))
2570 m
= match_clist_expr (&initializer
, ¤t_ts
, as
);
2572 gfc_error ("Syntax error in old style initialization of %s at %C",
2578 /* Otherwise we treat the old style initialization just like a
2579 DATA declaration for the current variable. */
2581 return match_old_style_init (name
);
2584 /* The double colon must be present in order to have initializers.
2585 Otherwise the statement is ambiguous with an assignment statement. */
2588 if (gfc_match (" =>") == MATCH_YES
)
2590 if (!current_attr
.pointer
)
2592 gfc_error ("Initialization at %C isn't for a pointer variable");
2597 m
= match_pointer_init (&initializer
, 0);
2601 else if (gfc_match_char ('=') == MATCH_YES
)
2603 if (current_attr
.pointer
)
2605 gfc_error ("Pointer initialization at %C requires %<=>%>, "
2611 m
= gfc_match_init_expr (&initializer
);
2614 gfc_error ("Expected an initialization expression at %C");
2618 if (current_attr
.flavor
!= FL_PARAMETER
&& gfc_pure (NULL
)
2619 && !gfc_comp_struct (gfc_state_stack
->state
))
2621 gfc_error ("Initialization of variable at %C is not allowed in "
2622 "a PURE procedure");
2626 if (current_attr
.flavor
!= FL_PARAMETER
2627 && !gfc_comp_struct (gfc_state_stack
->state
))
2628 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
2635 if (initializer
!= NULL
&& current_attr
.allocatable
2636 && gfc_comp_struct (gfc_current_state ()))
2638 gfc_error ("Initialization of allocatable component at %C is not "
2644 if (gfc_current_state () == COMP_DERIVED
2645 && gfc_current_block ()->attr
.pdt_template
)
2648 gfc_find_symbol (name
, gfc_current_block ()->f2k_derived
,
2650 if (!param
&& (current_attr
.pdt_kind
|| current_attr
.pdt_len
))
2652 gfc_error ("The component with KIND or LEN attribute at %C does not "
2653 "not appear in the type parameter list at %L",
2654 &gfc_current_block ()->declared_at
);
2658 else if (param
&& !(current_attr
.pdt_kind
|| current_attr
.pdt_len
))
2660 gfc_error ("The component at %C that appears in the type parameter "
2661 "list at %L has neither the KIND nor LEN attribute",
2662 &gfc_current_block ()->declared_at
);
2666 else if (as
&& (current_attr
.pdt_kind
|| current_attr
.pdt_len
))
2668 gfc_error ("The component at %C which is a type parameter must be "
2673 else if (param
&& initializer
)
2674 param
->value
= gfc_copy_expr (initializer
);
2677 /* Add the initializer. Note that it is fine if initializer is
2678 NULL here, because we sometimes also need to check if a
2679 declaration *must* have an initialization expression. */
2680 if (!gfc_comp_struct (gfc_current_state ()))
2681 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
2684 if (current_ts
.type
== BT_DERIVED
2685 && !current_attr
.pointer
&& !initializer
)
2686 initializer
= gfc_default_initializer (¤t_ts
);
2687 t
= build_struct (name
, cl
, &initializer
, &as
);
2689 /* If we match a nested structure definition we expect to see the
2690 * body even if the variable declarations blow up, so we need to keep
2691 * the structure declaration around. */
2692 if (gfc_new_block
&& gfc_new_block
->attr
.flavor
== FL_STRUCT
)
2693 gfc_commit_symbol (gfc_new_block
);
2696 m
= (t
) ? MATCH_YES
: MATCH_ERROR
;
2699 /* Free stuff up and return. */
2700 gfc_free_expr (initializer
);
2701 gfc_free_array_spec (as
);
2707 /* Match an extended-f77 "TYPESPEC*bytesize"-style kind specification.
2708 This assumes that the byte size is equal to the kind number for
2709 non-COMPLEX types, and equal to twice the kind number for COMPLEX. */
2712 gfc_match_old_kind_spec (gfc_typespec
*ts
)
2717 if (gfc_match_char ('*') != MATCH_YES
)
2720 m
= gfc_match_small_literal_int (&ts
->kind
, NULL
);
2724 original_kind
= ts
->kind
;
2726 /* Massage the kind numbers for complex types. */
2727 if (ts
->type
== BT_COMPLEX
)
2731 gfc_error ("Old-style type declaration %s*%d not supported at %C",
2732 gfc_basic_typename (ts
->type
), original_kind
);
2739 if (ts
->type
== BT_INTEGER
&& ts
->kind
== 4 && flag_integer4_kind
== 8)
2742 if (ts
->type
== BT_REAL
|| ts
->type
== BT_COMPLEX
)
2746 if (flag_real4_kind
== 8)
2748 if (flag_real4_kind
== 10)
2750 if (flag_real4_kind
== 16)
2756 if (flag_real8_kind
== 4)
2758 if (flag_real8_kind
== 10)
2760 if (flag_real8_kind
== 16)
2765 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
2767 gfc_error ("Old-style type declaration %s*%d not supported at %C",
2768 gfc_basic_typename (ts
->type
), original_kind
);
2772 if (!gfc_notify_std (GFC_STD_GNU
,
2773 "Nonstandard type declaration %s*%d at %C",
2774 gfc_basic_typename(ts
->type
), original_kind
))
2781 /* Match a kind specification. Since kinds are generally optional, we
2782 usually return MATCH_NO if something goes wrong. If a "kind="
2783 string is found, then we know we have an error. */
2786 gfc_match_kind_spec (gfc_typespec
*ts
, bool kind_expr_only
)
2796 saved_kind_expr
= NULL
;
2798 where
= loc
= gfc_current_locus
;
2803 if (gfc_match_char ('(') == MATCH_NO
)
2806 /* Also gobbles optional text. */
2807 if (gfc_match (" kind = ") == MATCH_YES
)
2810 loc
= gfc_current_locus
;
2814 n
= gfc_match_init_expr (&e
);
2816 if (gfc_derived_parameter_expr (e
))
2819 saved_kind_expr
= gfc_copy_expr (e
);
2820 goto close_brackets
;
2825 if (gfc_matching_function
)
2827 /* The function kind expression might include use associated or
2828 imported parameters and try again after the specification
2830 if (gfc_match_char (')') != MATCH_YES
)
2832 gfc_error ("Missing right parenthesis at %C");
2838 gfc_undo_symbols ();
2843 /* ....or else, the match is real. */
2845 gfc_error ("Expected initialization expression at %C");
2853 gfc_error ("Expected scalar initialization expression at %C");
2858 if (gfc_extract_int (e
, &ts
->kind
, 1))
2864 /* Before throwing away the expression, let's see if we had a
2865 C interoperable kind (and store the fact). */
2866 if (e
->ts
.is_c_interop
== 1)
2868 /* Mark this as C interoperable if being declared with one
2869 of the named constants from iso_c_binding. */
2870 ts
->is_c_interop
= e
->ts
.is_iso_c
;
2871 ts
->f90_type
= e
->ts
.f90_type
;
2873 ts
->interop_kind
= e
->symtree
->n
.sym
;
2879 /* Ignore errors to this point, if we've gotten here. This means
2880 we ignore the m=MATCH_ERROR from above. */
2881 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
2883 gfc_error ("Kind %d not supported for type %s at %C", ts
->kind
,
2884 gfc_basic_typename (ts
->type
));
2885 gfc_current_locus
= where
;
2889 /* Warn if, e.g., c_int is used for a REAL variable, but not
2890 if, e.g., c_double is used for COMPLEX as the standard
2891 explicitly says that the kind type parameter for complex and real
2892 variable is the same, i.e. c_float == c_float_complex. */
2893 if (ts
->f90_type
!= BT_UNKNOWN
&& ts
->f90_type
!= ts
->type
2894 && !((ts
->f90_type
== BT_REAL
&& ts
->type
== BT_COMPLEX
)
2895 || (ts
->f90_type
== BT_COMPLEX
&& ts
->type
== BT_REAL
)))
2896 gfc_warning_now (0, "C kind type parameter is for type %s but type at %L "
2897 "is %s", gfc_basic_typename (ts
->f90_type
), &where
,
2898 gfc_basic_typename (ts
->type
));
2902 gfc_gobble_whitespace ();
2903 if ((c
= gfc_next_ascii_char ()) != ')'
2904 && (ts
->type
!= BT_CHARACTER
|| c
!= ','))
2906 if (ts
->type
== BT_CHARACTER
)
2907 gfc_error ("Missing right parenthesis or comma at %C");
2909 gfc_error ("Missing right parenthesis at %C");
2913 /* All tests passed. */
2916 if(m
== MATCH_ERROR
)
2917 gfc_current_locus
= where
;
2919 if (ts
->type
== BT_INTEGER
&& ts
->kind
== 4 && flag_integer4_kind
== 8)
2922 if (ts
->type
== BT_REAL
|| ts
->type
== BT_COMPLEX
)
2926 if (flag_real4_kind
== 8)
2928 if (flag_real4_kind
== 10)
2930 if (flag_real4_kind
== 16)
2936 if (flag_real8_kind
== 4)
2938 if (flag_real8_kind
== 10)
2940 if (flag_real8_kind
== 16)
2945 /* Return what we know from the test(s). */
2950 gfc_current_locus
= where
;
2956 match_char_kind (int * kind
, int * is_iso_c
)
2965 where
= gfc_current_locus
;
2967 n
= gfc_match_init_expr (&e
);
2969 if (n
!= MATCH_YES
&& gfc_matching_function
)
2971 /* The expression might include use-associated or imported
2972 parameters and try again after the specification
2975 gfc_undo_symbols ();
2980 gfc_error ("Expected initialization expression at %C");
2986 gfc_error ("Expected scalar initialization expression at %C");
2991 if (gfc_derived_parameter_expr (e
))
2993 saved_kind_expr
= e
;
2998 fail
= gfc_extract_int (e
, kind
, 1);
2999 *is_iso_c
= e
->ts
.is_iso_c
;
3008 /* Ignore errors to this point, if we've gotten here. This means
3009 we ignore the m=MATCH_ERROR from above. */
3010 if (gfc_validate_kind (BT_CHARACTER
, *kind
, true) < 0)
3012 gfc_error ("Kind %d is not supported for CHARACTER at %C", *kind
);
3016 /* All tests passed. */
3019 if (m
== MATCH_ERROR
)
3020 gfc_current_locus
= where
;
3022 /* Return what we know from the test(s). */
3027 gfc_current_locus
= where
;
3032 /* Match the various kind/length specifications in a CHARACTER
3033 declaration. We don't return MATCH_NO. */
3036 gfc_match_char_spec (gfc_typespec
*ts
)
3038 int kind
, seen_length
, is_iso_c
;
3050 /* Try the old-style specification first. */
3051 old_char_selector
= 0;
3053 m
= match_char_length (&len
, &deferred
, true);
3057 old_char_selector
= 1;
3062 m
= gfc_match_char ('(');
3065 m
= MATCH_YES
; /* Character without length is a single char. */
3069 /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ). */
3070 if (gfc_match (" kind =") == MATCH_YES
)
3072 m
= match_char_kind (&kind
, &is_iso_c
);
3074 if (m
== MATCH_ERROR
)
3079 if (gfc_match (" , len =") == MATCH_NO
)
3082 m
= char_len_param_value (&len
, &deferred
);
3085 if (m
== MATCH_ERROR
)
3092 /* Try to match "LEN = <len-param>" or "LEN = <len-param>, KIND = <int>". */
3093 if (gfc_match (" len =") == MATCH_YES
)
3095 m
= char_len_param_value (&len
, &deferred
);
3098 if (m
== MATCH_ERROR
)
3102 if (gfc_match_char (')') == MATCH_YES
)
3105 if (gfc_match (" , kind =") != MATCH_YES
)
3108 if (match_char_kind (&kind
, &is_iso_c
) == MATCH_ERROR
)
3114 /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ). */
3115 m
= char_len_param_value (&len
, &deferred
);
3118 if (m
== MATCH_ERROR
)
3122 m
= gfc_match_char (')');
3126 if (gfc_match_char (',') != MATCH_YES
)
3129 gfc_match (" kind ="); /* Gobble optional text. */
3131 m
= match_char_kind (&kind
, &is_iso_c
);
3132 if (m
== MATCH_ERROR
)
3138 /* Require a right-paren at this point. */
3139 m
= gfc_match_char (')');
3144 gfc_error ("Syntax error in CHARACTER declaration at %C");
3146 gfc_free_expr (len
);
3150 /* Deal with character functions after USE and IMPORT statements. */
3151 if (gfc_matching_function
)
3153 gfc_free_expr (len
);
3154 gfc_undo_symbols ();
3160 gfc_free_expr (len
);
3164 /* Do some final massaging of the length values. */
3165 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
3167 if (seen_length
== 0)
3168 cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
, 1);
3171 /* If gfortran ends up here, then the len may be reducible to a
3172 constant. Try to do that here. If it does not reduce, simply
3173 assign len to the charlen. */
3174 if (len
&& len
->expr_type
!= EXPR_CONSTANT
)
3177 e
= gfc_copy_expr (len
);
3178 gfc_reduce_init_expr (e
);
3179 if (e
->expr_type
== EXPR_CONSTANT
)
3180 gfc_replace_expr (len
, e
);
3190 ts
->kind
= kind
== 0 ? gfc_default_character_kind
: kind
;
3191 ts
->deferred
= deferred
;
3193 /* We have to know if it was a C interoperable kind so we can
3194 do accurate type checking of bind(c) procs, etc. */
3196 /* Mark this as C interoperable if being declared with one
3197 of the named constants from iso_c_binding. */
3198 ts
->is_c_interop
= is_iso_c
;
3199 else if (len
!= NULL
)
3200 /* Here, we might have parsed something such as: character(c_char)
3201 In this case, the parsing code above grabs the c_char when
3202 looking for the length (line 1690, roughly). it's the last
3203 testcase for parsing the kind params of a character variable.
3204 However, it's not actually the length. this seems like it
3206 To see if the user used a C interop kind, test the expr
3207 of the so called length, and see if it's C interoperable. */
3208 ts
->is_c_interop
= len
->ts
.is_iso_c
;
3214 /* Matches a RECORD declaration. */
3217 match_record_decl (char *name
)
3220 old_loc
= gfc_current_locus
;
3223 m
= gfc_match (" record /");
3226 if (!flag_dec_structure
)
3228 gfc_current_locus
= old_loc
;
3229 gfc_error ("RECORD at %C is an extension, enable it with "
3233 m
= gfc_match (" %n/", name
);
3238 gfc_current_locus
= old_loc
;
3239 if (flag_dec_structure
3240 && (gfc_match (" record% ") == MATCH_YES
3241 || gfc_match (" record%t") == MATCH_YES
))
3242 gfc_error ("Structure name expected after RECORD at %C");
3250 /* This function uses the gfc_actual_arglist 'type_param_spec_list' as a source
3251 of expressions to substitute into the possibly parameterized expression
3252 'e'. Using a list is inefficient but should not be too bad since the
3253 number of type parameters is not likely to be large. */
3255 insert_parameter_exprs (gfc_expr
* e
, gfc_symbol
* sym ATTRIBUTE_UNUSED
,
3258 gfc_actual_arglist
*param
;
3261 if (e
->expr_type
!= EXPR_VARIABLE
)
3264 gcc_assert (e
->symtree
);
3265 if (e
->symtree
->n
.sym
->attr
.pdt_kind
3266 || (*f
!= 0 && e
->symtree
->n
.sym
->attr
.pdt_len
))
3268 for (param
= type_param_spec_list
; param
; param
= param
->next
)
3269 if (strcmp (e
->symtree
->n
.sym
->name
, param
->name
) == 0)
3274 copy
= gfc_copy_expr (param
->expr
);
3285 gfc_insert_kind_parameter_exprs (gfc_expr
*e
)
3287 return gfc_traverse_expr (e
, NULL
, &insert_parameter_exprs
, 0);
3292 gfc_insert_parameter_exprs (gfc_expr
*e
, gfc_actual_arglist
*param_list
)
3294 gfc_actual_arglist
*old_param_spec_list
= type_param_spec_list
;
3295 type_param_spec_list
= param_list
;
3296 return gfc_traverse_expr (e
, NULL
, &insert_parameter_exprs
, 1);
3297 type_param_spec_list
= NULL
;
3298 type_param_spec_list
= old_param_spec_list
;
3301 /* Determines the instance of a parameterized derived type to be used by
3302 matching determining the values of the kind parameters and using them
3303 in the name of the instance. If the instance exists, it is used, otherwise
3304 a new derived type is created. */
3306 gfc_get_pdt_instance (gfc_actual_arglist
*param_list
, gfc_symbol
**sym
,
3307 gfc_actual_arglist
**ext_param_list
)
3309 /* The PDT template symbol. */
3310 gfc_symbol
*pdt
= *sym
;
3311 /* The symbol for the parameter in the template f2k_namespace. */
3313 /* The hoped for instance of the PDT. */
3314 gfc_symbol
*instance
;
3315 /* The list of parameters appearing in the PDT declaration. */
3316 gfc_formal_arglist
*type_param_name_list
;
3317 /* Used to store the parameter specification list during recursive calls. */
3318 gfc_actual_arglist
*old_param_spec_list
;
3319 /* Pointers to the parameter specification being used. */
3320 gfc_actual_arglist
*actual_param
;
3321 gfc_actual_arglist
*tail
= NULL
;
3322 /* Used to build up the name of the PDT instance. The prefix uses 4
3323 characters and each KIND parameter 2 more. Allow 8 of the latter. */
3324 char name
[GFC_MAX_SYMBOL_LEN
+ 21];
3326 bool name_seen
= (param_list
== NULL
);
3327 bool assumed_seen
= false;
3328 bool deferred_seen
= false;
3329 bool spec_error
= false;
3331 gfc_expr
*kind_expr
;
3332 gfc_component
*c1
, *c2
;
3335 type_param_spec_list
= NULL
;
3337 type_param_name_list
= pdt
->formal
;
3338 actual_param
= param_list
;
3339 sprintf (name
, "Pdt%s", pdt
->name
);
3341 /* Run through the parameter name list and pick up the actual
3342 parameter values or use the default values in the PDT declaration. */
3343 for (; type_param_name_list
;
3344 type_param_name_list
= type_param_name_list
->next
)
3346 if (actual_param
&& actual_param
->spec_type
!= SPEC_EXPLICIT
)
3348 if (actual_param
->spec_type
== SPEC_ASSUMED
)
3349 spec_error
= deferred_seen
;
3351 spec_error
= assumed_seen
;
3355 gfc_error ("The type parameter spec list at %C cannot contain "
3356 "both ASSUMED and DEFERRED parameters");
3361 if (actual_param
&& actual_param
->name
)
3363 param
= type_param_name_list
->sym
;
3365 if (!param
|| !param
->name
)
3368 c1
= gfc_find_component (pdt
, param
->name
, false, true, NULL
);
3369 /* An error should already have been thrown in resolve.c
3370 (resolve_fl_derived0). */
3371 if (!pdt
->attr
.use_assoc
&& !c1
)
3377 if (!actual_param
&& !(c1
&& c1
->initializer
))
3379 gfc_error ("The type parameter spec list at %C does not contain "
3380 "enough parameter expressions");
3383 else if (!actual_param
&& c1
&& c1
->initializer
)
3384 kind_expr
= gfc_copy_expr (c1
->initializer
);
3385 else if (actual_param
&& actual_param
->spec_type
== SPEC_EXPLICIT
)
3386 kind_expr
= gfc_copy_expr (actual_param
->expr
);
3390 actual_param
= param_list
;
3391 for (;actual_param
; actual_param
= actual_param
->next
)
3392 if (actual_param
->name
3393 && strcmp (actual_param
->name
, param
->name
) == 0)
3395 if (actual_param
&& actual_param
->spec_type
== SPEC_EXPLICIT
)
3396 kind_expr
= gfc_copy_expr (actual_param
->expr
);
3399 if (c1
->initializer
)
3400 kind_expr
= gfc_copy_expr (c1
->initializer
);
3401 else if (!(actual_param
&& param
->attr
.pdt_len
))
3403 gfc_error ("The derived parameter %qs at %C does not "
3404 "have a default value", param
->name
);
3410 /* Store the current parameter expressions in a temporary actual
3411 arglist 'list' so that they can be substituted in the corresponding
3412 expressions in the PDT instance. */
3413 if (type_param_spec_list
== NULL
)
3415 type_param_spec_list
= gfc_get_actual_arglist ();
3416 tail
= type_param_spec_list
;
3420 tail
->next
= gfc_get_actual_arglist ();
3423 tail
->name
= param
->name
;
3427 /* Try simplification even for LEN expressions. */
3428 gfc_resolve_expr (kind_expr
);
3429 gfc_simplify_expr (kind_expr
, 1);
3430 /* Variable expressions seem to default to BT_PROCEDURE.
3431 TODO find out why this is and fix it. */
3432 if (kind_expr
->ts
.type
!= BT_INTEGER
3433 && kind_expr
->ts
.type
!= BT_PROCEDURE
)
3435 gfc_error ("The parameter expression at %C must be of "
3436 "INTEGER type and not %s type",
3437 gfc_basic_typename (kind_expr
->ts
.type
));
3441 tail
->expr
= gfc_copy_expr (kind_expr
);
3445 tail
->spec_type
= actual_param
->spec_type
;
3447 if (!param
->attr
.pdt_kind
)
3449 if (!name_seen
&& actual_param
)
3450 actual_param
= actual_param
->next
;
3453 gfc_free_expr (kind_expr
);
3460 && (actual_param
->spec_type
== SPEC_ASSUMED
3461 || actual_param
->spec_type
== SPEC_DEFERRED
))
3463 gfc_error ("The KIND parameter %qs at %C cannot either be "
3464 "ASSUMED or DEFERRED", param
->name
);
3468 if (!kind_expr
|| !gfc_is_constant_expr (kind_expr
))
3470 gfc_error ("The value for the KIND parameter %qs at %C does not "
3471 "reduce to a constant expression", param
->name
);
3475 gfc_extract_int (kind_expr
, &kind_value
);
3476 sprintf (name
+ strlen (name
), "_%d", kind_value
);
3478 if (!name_seen
&& actual_param
)
3479 actual_param
= actual_param
->next
;
3480 gfc_free_expr (kind_expr
);
3483 if (!name_seen
&& actual_param
)
3485 gfc_error ("The type parameter spec list at %C contains too many "
3486 "parameter expressions");
3490 /* Now we search for the PDT instance 'name'. If it doesn't exist, we
3491 build it, using 'pdt' as a template. */
3492 if (gfc_get_symbol (name
, pdt
->ns
, &instance
))
3494 gfc_error ("Parameterized derived type at %C is ambiguous");
3500 if (instance
->attr
.flavor
== FL_DERIVED
3501 && instance
->attr
.pdt_type
)
3505 *ext_param_list
= type_param_spec_list
;
3507 gfc_commit_symbols ();
3511 /* Start building the new instance of the parameterized type. */
3512 gfc_copy_attr (&instance
->attr
, &pdt
->attr
, &pdt
->declared_at
);
3513 instance
->attr
.pdt_template
= 0;
3514 instance
->attr
.pdt_type
= 1;
3515 instance
->declared_at
= gfc_current_locus
;
3517 /* Add the components, replacing the parameters in all expressions
3518 with the expressions for their values in 'type_param_spec_list'. */
3519 c1
= pdt
->components
;
3520 tail
= type_param_spec_list
;
3521 for (; c1
; c1
= c1
->next
)
3523 gfc_add_component (instance
, c1
->name
, &c2
);
3526 c2
->attr
= c1
->attr
;
3528 /* The order of declaration of the type_specs might not be the
3529 same as that of the components. */
3530 if (c1
->attr
.pdt_kind
|| c1
->attr
.pdt_len
)
3532 for (tail
= type_param_spec_list
; tail
; tail
= tail
->next
)
3533 if (strcmp (c1
->name
, tail
->name
) == 0)
3537 /* Deal with type extension by recursively calling this function
3538 to obtain the instance of the extended type. */
3539 if (gfc_current_state () != COMP_DERIVED
3540 && c1
== pdt
->components
3541 && (c1
->ts
.type
== BT_DERIVED
|| c1
->ts
.type
== BT_CLASS
)
3542 && c1
->ts
.u
.derived
&& c1
->ts
.u
.derived
->attr
.pdt_template
3543 && gfc_get_derived_super_type (*sym
) == c2
->ts
.u
.derived
)
3545 gfc_formal_arglist
*f
;
3547 old_param_spec_list
= type_param_spec_list
;
3549 /* Obtain a spec list appropriate to the extended type..*/
3550 actual_param
= gfc_copy_actual_arglist (type_param_spec_list
);
3551 type_param_spec_list
= actual_param
;
3552 for (f
= c1
->ts
.u
.derived
->formal
; f
&& f
->next
; f
= f
->next
)
3553 actual_param
= actual_param
->next
;
3556 gfc_free_actual_arglist (actual_param
->next
);
3557 actual_param
->next
= NULL
;
3560 /* Now obtain the PDT instance for the extended type. */
3561 c2
->param_list
= type_param_spec_list
;
3562 m
= gfc_get_pdt_instance (type_param_spec_list
, &c2
->ts
.u
.derived
,
3564 type_param_spec_list
= old_param_spec_list
;
3566 c2
->ts
.u
.derived
->refs
++;
3567 gfc_set_sym_referenced (c2
->ts
.u
.derived
);
3569 /* Set extension level. */
3570 if (c2
->ts
.u
.derived
->attr
.extension
== 255)
3572 /* Since the extension field is 8 bit wide, we can only have
3573 up to 255 extension levels. */
3574 gfc_error ("Maximum extension level reached with type %qs at %L",
3575 c2
->ts
.u
.derived
->name
,
3576 &c2
->ts
.u
.derived
->declared_at
);
3579 instance
->attr
.extension
= c2
->ts
.u
.derived
->attr
.extension
+ 1;
3584 /* Set the component kind using the parameterized expression. */
3585 if ((c1
->ts
.kind
== 0 || c1
->ts
.type
== BT_CHARACTER
)
3586 && c1
->kind_expr
!= NULL
)
3588 gfc_expr
*e
= gfc_copy_expr (c1
->kind_expr
);
3589 gfc_insert_kind_parameter_exprs (e
);
3590 gfc_simplify_expr (e
, 1);
3591 gfc_extract_int (e
, &c2
->ts
.kind
);
3593 if (gfc_validate_kind (c2
->ts
.type
, c2
->ts
.kind
, true) < 0)
3595 gfc_error ("Kind %d not supported for type %s at %C",
3596 c2
->ts
.kind
, gfc_basic_typename (c2
->ts
.type
));
3601 /* Similarly, set the string length if parameterized. */
3602 if (c1
->ts
.type
== BT_CHARACTER
3603 && c1
->ts
.u
.cl
->length
3604 && gfc_derived_parameter_expr (c1
->ts
.u
.cl
->length
))
3607 e
= gfc_copy_expr (c1
->ts
.u
.cl
->length
);
3608 gfc_insert_kind_parameter_exprs (e
);
3609 gfc_simplify_expr (e
, 1);
3610 c2
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
3611 c2
->ts
.u
.cl
->length
= e
;
3612 c2
->attr
.pdt_string
= 1;
3615 /* Set up either the KIND/LEN initializer, if constant,
3616 or the parameterized expression. Use the template
3617 initializer if one is not already set in this instance. */
3618 if (c2
->attr
.pdt_kind
|| c2
->attr
.pdt_len
)
3620 if (tail
&& tail
->expr
&& gfc_is_constant_expr (tail
->expr
))
3621 c2
->initializer
= gfc_copy_expr (tail
->expr
);
3622 else if (tail
&& tail
->expr
)
3624 c2
->param_list
= gfc_get_actual_arglist ();
3625 c2
->param_list
->name
= tail
->name
;
3626 c2
->param_list
->expr
= gfc_copy_expr (tail
->expr
);
3627 c2
->param_list
->next
= NULL
;
3630 if (!c2
->initializer
&& c1
->initializer
)
3631 c2
->initializer
= gfc_copy_expr (c1
->initializer
);
3634 /* Copy the array spec. */
3635 c2
->as
= gfc_copy_array_spec (c1
->as
);
3636 if (c1
->ts
.type
== BT_CLASS
)
3637 CLASS_DATA (c2
)->as
= gfc_copy_array_spec (CLASS_DATA (c1
)->as
);
3639 /* Determine if an array spec is parameterized. If so, substitute
3640 in the parameter expressions for the bounds and set the pdt_array
3641 attribute. Notice that this attribute must be unconditionally set
3642 if this is an array of parameterized character length. */
3643 if (c1
->as
&& c1
->as
->type
== AS_EXPLICIT
)
3645 bool pdt_array
= false;
3647 /* Are the bounds of the array parameterized? */
3648 for (i
= 0; i
< c1
->as
->rank
; i
++)
3650 if (gfc_derived_parameter_expr (c1
->as
->lower
[i
]))
3652 if (gfc_derived_parameter_expr (c1
->as
->upper
[i
]))
3656 /* If they are, free the expressions for the bounds and
3657 replace them with the template expressions with substitute
3659 for (i
= 0; pdt_array
&& i
< c1
->as
->rank
; i
++)
3662 e
= gfc_copy_expr (c1
->as
->lower
[i
]);
3663 gfc_insert_kind_parameter_exprs (e
);
3664 gfc_simplify_expr (e
, 1);
3665 gfc_free_expr (c2
->as
->lower
[i
]);
3666 c2
->as
->lower
[i
] = e
;
3667 e
= gfc_copy_expr (c1
->as
->upper
[i
]);
3668 gfc_insert_kind_parameter_exprs (e
);
3669 gfc_simplify_expr (e
, 1);
3670 gfc_free_expr (c2
->as
->upper
[i
]);
3671 c2
->as
->upper
[i
] = e
;
3673 c2
->attr
.pdt_array
= pdt_array
? 1 : c2
->attr
.pdt_string
;
3674 if (c1
->initializer
)
3676 c2
->initializer
= gfc_copy_expr (c1
->initializer
);
3677 gfc_insert_kind_parameter_exprs (c2
->initializer
);
3678 gfc_simplify_expr (c2
->initializer
, 1);
3682 /* Recurse into this function for PDT components. */
3683 if ((c1
->ts
.type
== BT_DERIVED
|| c1
->ts
.type
== BT_CLASS
)
3684 && c1
->ts
.u
.derived
&& c1
->ts
.u
.derived
->attr
.pdt_template
)
3686 gfc_actual_arglist
*params
;
3687 /* The component in the template has a list of specification
3688 expressions derived from its declaration. */
3689 params
= gfc_copy_actual_arglist (c1
->param_list
);
3690 actual_param
= params
;
3691 /* Substitute the template parameters with the expressions
3692 from the specification list. */
3693 for (;actual_param
; actual_param
= actual_param
->next
)
3694 gfc_insert_parameter_exprs (actual_param
->expr
,
3695 type_param_spec_list
);
3697 /* Now obtain the PDT instance for the component. */
3698 old_param_spec_list
= type_param_spec_list
;
3699 m
= gfc_get_pdt_instance (params
, &c2
->ts
.u
.derived
, NULL
);
3700 type_param_spec_list
= old_param_spec_list
;
3702 c2
->param_list
= params
;
3703 if (!(c2
->attr
.pointer
|| c2
->attr
.allocatable
))
3704 c2
->initializer
= gfc_default_initializer (&c2
->ts
);
3706 if (c2
->attr
.allocatable
)
3707 instance
->attr
.alloc_comp
= 1;
3711 gfc_commit_symbol (instance
);
3713 *ext_param_list
= type_param_spec_list
;
3718 gfc_free_actual_arglist (type_param_spec_list
);
3723 /* Matches a declaration-type-spec (F03:R502). If successful, sets the ts
3724 structure to the matched specification. This is necessary for FUNCTION and
3725 IMPLICIT statements.
3727 If implicit_flag is nonzero, then we don't check for the optional
3728 kind specification. Not doing so is needed for matching an IMPLICIT
3729 statement correctly. */
3732 gfc_match_decl_type_spec (gfc_typespec
*ts
, int implicit_flag
)
3734 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3735 gfc_symbol
*sym
, *dt_sym
;
3738 bool seen_deferred_kind
, matched_type
;
3739 const char *dt_name
;
3741 decl_type_param_list
= NULL
;
3743 /* A belt and braces check that the typespec is correctly being treated
3744 as a deferred characteristic association. */
3745 seen_deferred_kind
= (gfc_current_state () == COMP_FUNCTION
)
3746 && (gfc_current_block ()->result
->ts
.kind
== -1)
3747 && (ts
->kind
== -1);
3749 if (seen_deferred_kind
)
3752 /* Clear the current binding label, in case one is given. */
3753 curr_binding_label
= NULL
;
3755 if (gfc_match (" byte") == MATCH_YES
)
3757 if (!gfc_notify_std (GFC_STD_GNU
, "BYTE type at %C"))
3760 if (gfc_validate_kind (BT_INTEGER
, 1, true) < 0)
3762 gfc_error ("BYTE type used at %C "
3763 "is not available on the target machine");
3767 ts
->type
= BT_INTEGER
;
3773 m
= gfc_match (" type (");
3774 matched_type
= (m
== MATCH_YES
);
3777 gfc_gobble_whitespace ();
3778 if (gfc_peek_ascii_char () == '*')
3780 if ((m
= gfc_match ("*)")) != MATCH_YES
)
3782 if (gfc_comp_struct (gfc_current_state ()))
3784 gfc_error ("Assumed type at %C is not allowed for components");
3787 if (!gfc_notify_std (GFC_STD_F2008_TS
, "Assumed type "
3790 ts
->type
= BT_ASSUMED
;
3794 m
= gfc_match ("%n", name
);
3795 matched_type
= (m
== MATCH_YES
);
3798 if ((matched_type
&& strcmp ("integer", name
) == 0)
3799 || (!matched_type
&& gfc_match (" integer") == MATCH_YES
))
3801 ts
->type
= BT_INTEGER
;
3802 ts
->kind
= gfc_default_integer_kind
;
3806 if ((matched_type
&& strcmp ("character", name
) == 0)
3807 || (!matched_type
&& gfc_match (" character") == MATCH_YES
))
3810 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
3811 "intrinsic-type-spec at %C"))
3814 ts
->type
= BT_CHARACTER
;
3815 if (implicit_flag
== 0)
3816 m
= gfc_match_char_spec (ts
);
3820 if (matched_type
&& m
== MATCH_YES
&& gfc_match_char (')') != MATCH_YES
)
3826 if ((matched_type
&& strcmp ("real", name
) == 0)
3827 || (!matched_type
&& gfc_match (" real") == MATCH_YES
))
3830 ts
->kind
= gfc_default_real_kind
;
3835 && (strcmp ("doubleprecision", name
) == 0
3836 || (strcmp ("double", name
) == 0
3837 && gfc_match (" precision") == MATCH_YES
)))
3838 || (!matched_type
&& gfc_match (" double precision") == MATCH_YES
))
3841 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
3842 "intrinsic-type-spec at %C"))
3844 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
3848 ts
->kind
= gfc_default_double_kind
;
3852 if ((matched_type
&& strcmp ("complex", name
) == 0)
3853 || (!matched_type
&& gfc_match (" complex") == MATCH_YES
))
3855 ts
->type
= BT_COMPLEX
;
3856 ts
->kind
= gfc_default_complex_kind
;
3861 && (strcmp ("doublecomplex", name
) == 0
3862 || (strcmp ("double", name
) == 0
3863 && gfc_match (" complex") == MATCH_YES
)))
3864 || (!matched_type
&& gfc_match (" double complex") == MATCH_YES
))
3866 if (!gfc_notify_std (GFC_STD_GNU
, "DOUBLE COMPLEX at %C"))
3870 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
3871 "intrinsic-type-spec at %C"))
3874 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
3877 ts
->type
= BT_COMPLEX
;
3878 ts
->kind
= gfc_default_double_kind
;
3882 if ((matched_type
&& strcmp ("logical", name
) == 0)
3883 || (!matched_type
&& gfc_match (" logical") == MATCH_YES
))
3885 ts
->type
= BT_LOGICAL
;
3886 ts
->kind
= gfc_default_logical_kind
;
3892 m
= gfc_match_actual_arglist (1, &decl_type_param_list
, true);
3893 if (m
== MATCH_ERROR
)
3896 m
= gfc_match_char (')');
3900 m
= match_record_decl (name
);
3902 if (matched_type
|| m
== MATCH_YES
)
3904 ts
->type
= BT_DERIVED
;
3905 /* We accept record/s/ or type(s) where s is a structure, but we
3906 * don't need all the extra derived-type stuff for structures. */
3907 if (gfc_find_symbol (gfc_dt_upper_string (name
), NULL
, 1, &sym
))
3909 gfc_error ("Type name %qs at %C is ambiguous", name
);
3913 if (sym
&& sym
->attr
.flavor
== FL_DERIVED
3914 && sym
->attr
.pdt_template
3915 && gfc_current_state () != COMP_DERIVED
)
3917 m
= gfc_get_pdt_instance (decl_type_param_list
, &sym
, NULL
);
3920 gcc_assert (!sym
->attr
.pdt_template
&& sym
->attr
.pdt_type
);
3921 ts
->u
.derived
= sym
;
3922 strcpy (name
, gfc_dt_lower_string (sym
->name
));
3925 if (sym
&& sym
->attr
.flavor
== FL_STRUCT
)
3927 ts
->u
.derived
= sym
;
3930 /* Actually a derived type. */
3935 /* Match nested STRUCTURE declarations; only valid within another
3936 structure declaration. */
3937 if (flag_dec_structure
3938 && (gfc_current_state () == COMP_STRUCTURE
3939 || gfc_current_state () == COMP_MAP
))
3941 m
= gfc_match (" structure");
3944 m
= gfc_match_structure_decl ();
3947 /* gfc_new_block is updated by match_structure_decl. */
3948 ts
->type
= BT_DERIVED
;
3949 ts
->u
.derived
= gfc_new_block
;
3953 if (m
== MATCH_ERROR
)
3957 /* Match CLASS declarations. */
3958 m
= gfc_match (" class ( * )");
3959 if (m
== MATCH_ERROR
)
3961 else if (m
== MATCH_YES
)
3965 ts
->type
= BT_CLASS
;
3966 gfc_find_symbol ("STAR", gfc_current_ns
, 1, &upe
);
3969 upe
= gfc_new_symbol ("STAR", gfc_current_ns
);
3970 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "STAR");
3972 gfc_set_sym_referenced (upe
);
3974 upe
->ts
.type
= BT_VOID
;
3975 upe
->attr
.unlimited_polymorphic
= 1;
3976 /* This is essential to force the construction of
3977 unlimited polymorphic component class containers. */
3978 upe
->attr
.zero_comp
= 1;
3979 if (!gfc_add_flavor (&upe
->attr
, FL_DERIVED
, NULL
,
3980 &gfc_current_locus
))
3985 st
= gfc_get_tbp_symtree (&gfc_current_ns
->sym_root
, "STAR");
3989 ts
->u
.derived
= upe
;
3993 m
= gfc_match (" class (");
3996 m
= gfc_match ("%n", name
);
4002 ts
->type
= BT_CLASS
;
4004 if (!gfc_notify_std (GFC_STD_F2003
, "CLASS statement at %C"))
4007 m
= gfc_match_actual_arglist (1, &decl_type_param_list
, true);
4008 if (m
== MATCH_ERROR
)
4011 m
= gfc_match_char (')');
4016 /* Defer association of the derived type until the end of the
4017 specification block. However, if the derived type can be
4018 found, add it to the typespec. */
4019 if (gfc_matching_function
)
4021 ts
->u
.derived
= NULL
;
4022 if (gfc_current_state () != COMP_INTERFACE
4023 && !gfc_find_symbol (name
, NULL
, 1, &sym
) && sym
)
4025 sym
= gfc_find_dt_in_generic (sym
);
4026 ts
->u
.derived
= sym
;
4031 /* Search for the name but allow the components to be defined later. If
4032 type = -1, this typespec has been seen in a function declaration but
4033 the type could not be accessed at that point. The actual derived type is
4034 stored in a symtree with the first letter of the name capitalized; the
4035 symtree with the all lower-case name contains the associated
4036 generic function. */
4037 dt_name
= gfc_dt_upper_string (name
);
4042 gfc_get_ha_symbol (name
, &sym
);
4043 if (sym
->generic
&& gfc_find_symbol (dt_name
, NULL
, 0, &dt_sym
))
4045 gfc_error ("Type name %qs at %C is ambiguous", name
);
4048 if (sym
->generic
&& !dt_sym
)
4049 dt_sym
= gfc_find_dt_in_generic (sym
);
4051 /* Host associated PDTs can get confused with their constructors
4052 because they ar instantiated in the template's namespace. */
4055 if (gfc_find_symbol (dt_name
, NULL
, 1, &dt_sym
))
4057 gfc_error ("Type name %qs at %C is ambiguous", name
);
4060 if (dt_sym
&& !dt_sym
->attr
.pdt_type
)
4064 else if (ts
->kind
== -1)
4066 int iface
= gfc_state_stack
->previous
->state
!= COMP_INTERFACE
4067 || gfc_current_ns
->has_import_set
;
4068 gfc_find_symbol (name
, NULL
, iface
, &sym
);
4069 if (sym
&& sym
->generic
&& gfc_find_symbol (dt_name
, NULL
, 1, &dt_sym
))
4071 gfc_error ("Type name %qs at %C is ambiguous", name
);
4074 if (sym
&& sym
->generic
&& !dt_sym
)
4075 dt_sym
= gfc_find_dt_in_generic (sym
);
4082 if ((sym
->attr
.flavor
!= FL_UNKNOWN
&& sym
->attr
.flavor
!= FL_STRUCT
4083 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.generic
))
4084 || sym
->attr
.subroutine
)
4086 gfc_error ("Type name %qs at %C conflicts with previously declared "
4087 "entity at %L, which has the same name", name
,
4092 if (sym
&& sym
->attr
.flavor
== FL_DERIVED
4093 && sym
->attr
.pdt_template
4094 && gfc_current_state () != COMP_DERIVED
)
4096 m
= gfc_get_pdt_instance (decl_type_param_list
, &sym
, NULL
);
4099 gcc_assert (!sym
->attr
.pdt_template
&& sym
->attr
.pdt_type
);
4100 ts
->u
.derived
= sym
;
4101 strcpy (name
, gfc_dt_lower_string (sym
->name
));
4104 gfc_save_symbol_data (sym
);
4105 gfc_set_sym_referenced (sym
);
4106 if (!sym
->attr
.generic
4107 && !gfc_add_generic (&sym
->attr
, sym
->name
, NULL
))
4110 if (!sym
->attr
.function
4111 && !gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
4114 if (dt_sym
&& dt_sym
->attr
.flavor
== FL_DERIVED
4115 && dt_sym
->attr
.pdt_template
4116 && gfc_current_state () != COMP_DERIVED
)
4118 m
= gfc_get_pdt_instance (decl_type_param_list
, &dt_sym
, NULL
);
4121 gcc_assert (!dt_sym
->attr
.pdt_template
&& dt_sym
->attr
.pdt_type
);
4126 gfc_interface
*intr
, *head
;
4128 /* Use upper case to save the actual derived-type symbol. */
4129 gfc_get_symbol (dt_name
, NULL
, &dt_sym
);
4130 dt_sym
->name
= gfc_get_string ("%s", sym
->name
);
4131 head
= sym
->generic
;
4132 intr
= gfc_get_interface ();
4134 intr
->where
= gfc_current_locus
;
4136 sym
->generic
= intr
;
4137 sym
->attr
.if_source
= IFSRC_DECL
;
4140 gfc_save_symbol_data (dt_sym
);
4142 gfc_set_sym_referenced (dt_sym
);
4144 if (dt_sym
->attr
.flavor
!= FL_DERIVED
&& dt_sym
->attr
.flavor
!= FL_STRUCT
4145 && !gfc_add_flavor (&dt_sym
->attr
, FL_DERIVED
, sym
->name
, NULL
))
4148 ts
->u
.derived
= dt_sym
;
4154 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
4155 "intrinsic-type-spec at %C"))
4158 /* For all types except double, derived and character, look for an
4159 optional kind specifier. MATCH_NO is actually OK at this point. */
4160 if (implicit_flag
== 1)
4162 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
4168 if (gfc_current_form
== FORM_FREE
)
4170 c
= gfc_peek_ascii_char ();
4171 if (!gfc_is_whitespace (c
) && c
!= '*' && c
!= '('
4172 && c
!= ':' && c
!= ',')
4174 if (matched_type
&& c
== ')')
4176 gfc_next_ascii_char ();
4183 m
= gfc_match_kind_spec (ts
, false);
4184 if (m
== MATCH_NO
&& ts
->type
!= BT_CHARACTER
)
4186 m
= gfc_match_old_kind_spec (ts
);
4187 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) == -1)
4191 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
4194 /* Defer association of the KIND expression of function results
4195 until after USE and IMPORT statements. */
4196 if ((gfc_current_state () == COMP_NONE
&& gfc_error_flag_test ())
4197 || gfc_matching_function
)
4201 m
= MATCH_YES
; /* No kind specifier found. */
4207 /* Match an IMPLICIT NONE statement. Actually, this statement is
4208 already matched in parse.c, or we would not end up here in the
4209 first place. So the only thing we need to check, is if there is
4210 trailing garbage. If not, the match is successful. */
4213 gfc_match_implicit_none (void)
4217 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4219 bool external
= false;
4220 locus cur_loc
= gfc_current_locus
;
4222 if (gfc_current_ns
->seen_implicit_none
4223 || gfc_current_ns
->has_implicit_none_export
)
4225 gfc_error ("Duplicate IMPLICIT NONE statement at %C");
4229 gfc_gobble_whitespace ();
4230 c
= gfc_peek_ascii_char ();
4233 (void) gfc_next_ascii_char ();
4234 if (!gfc_notify_std (GFC_STD_F2018
, "IMPORT NONE with spec list at %C"))
4237 gfc_gobble_whitespace ();
4238 if (gfc_peek_ascii_char () == ')')
4240 (void) gfc_next_ascii_char ();
4246 m
= gfc_match (" %n", name
);
4250 if (strcmp (name
, "type") == 0)
4252 else if (strcmp (name
, "external") == 0)
4257 gfc_gobble_whitespace ();
4258 c
= gfc_next_ascii_char ();
4269 if (gfc_match_eos () != MATCH_YES
)
4272 gfc_set_implicit_none (type
, external
, &cur_loc
);
4278 /* Match the letter range(s) of an IMPLICIT statement. */
4281 match_implicit_range (void)
4287 cur_loc
= gfc_current_locus
;
4289 gfc_gobble_whitespace ();
4290 c
= gfc_next_ascii_char ();
4293 gfc_error ("Missing character range in IMPLICIT at %C");
4300 gfc_gobble_whitespace ();
4301 c1
= gfc_next_ascii_char ();
4305 gfc_gobble_whitespace ();
4306 c
= gfc_next_ascii_char ();
4311 inner
= 0; /* Fall through. */
4318 gfc_gobble_whitespace ();
4319 c2
= gfc_next_ascii_char ();
4323 gfc_gobble_whitespace ();
4324 c
= gfc_next_ascii_char ();
4326 if ((c
!= ',') && (c
!= ')'))
4339 gfc_error ("Letters must be in alphabetic order in "
4340 "IMPLICIT statement at %C");
4344 /* See if we can add the newly matched range to the pending
4345 implicits from this IMPLICIT statement. We do not check for
4346 conflicts with whatever earlier IMPLICIT statements may have
4347 set. This is done when we've successfully finished matching
4349 if (!gfc_add_new_implicit_range (c1
, c2
))
4356 gfc_syntax_error (ST_IMPLICIT
);
4358 gfc_current_locus
= cur_loc
;
4363 /* Match an IMPLICIT statement, storing the types for
4364 gfc_set_implicit() if the statement is accepted by the parser.
4365 There is a strange looking, but legal syntactic construction
4366 possible. It looks like:
4368 IMPLICIT INTEGER (a-b) (c-d)
4370 This is legal if "a-b" is a constant expression that happens to
4371 equal one of the legal kinds for integers. The real problem
4372 happens with an implicit specification that looks like:
4374 IMPLICIT INTEGER (a-b)
4376 In this case, a typespec matcher that is "greedy" (as most of the
4377 matchers are) gobbles the character range as a kindspec, leaving
4378 nothing left. We therefore have to go a bit more slowly in the
4379 matching process by inhibiting the kindspec checking during
4380 typespec matching and checking for a kind later. */
4383 gfc_match_implicit (void)
4390 if (gfc_current_ns
->seen_implicit_none
)
4392 gfc_error ("IMPLICIT statement at %C following an IMPLICIT NONE (type) "
4399 /* We don't allow empty implicit statements. */
4400 if (gfc_match_eos () == MATCH_YES
)
4402 gfc_error ("Empty IMPLICIT statement at %C");
4408 /* First cleanup. */
4409 gfc_clear_new_implicit ();
4411 /* A basic type is mandatory here. */
4412 m
= gfc_match_decl_type_spec (&ts
, 1);
4413 if (m
== MATCH_ERROR
)
4418 cur_loc
= gfc_current_locus
;
4419 m
= match_implicit_range ();
4423 /* We may have <TYPE> (<RANGE>). */
4424 gfc_gobble_whitespace ();
4425 c
= gfc_peek_ascii_char ();
4426 if (c
== ',' || c
== '\n' || c
== ';' || c
== '!')
4428 /* Check for CHARACTER with no length parameter. */
4429 if (ts
.type
== BT_CHARACTER
&& !ts
.u
.cl
)
4431 ts
.kind
= gfc_default_character_kind
;
4432 ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4433 ts
.u
.cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
,
4437 /* Record the Successful match. */
4438 if (!gfc_merge_new_implicit (&ts
))
4441 c
= gfc_next_ascii_char ();
4442 else if (gfc_match_eos () == MATCH_ERROR
)
4447 gfc_current_locus
= cur_loc
;
4450 /* Discard the (incorrectly) matched range. */
4451 gfc_clear_new_implicit ();
4453 /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
4454 if (ts
.type
== BT_CHARACTER
)
4455 m
= gfc_match_char_spec (&ts
);
4458 m
= gfc_match_kind_spec (&ts
, false);
4461 m
= gfc_match_old_kind_spec (&ts
);
4462 if (m
== MATCH_ERROR
)
4468 if (m
== MATCH_ERROR
)
4471 m
= match_implicit_range ();
4472 if (m
== MATCH_ERROR
)
4477 gfc_gobble_whitespace ();
4478 c
= gfc_next_ascii_char ();
4479 if (c
!= ',' && gfc_match_eos () != MATCH_YES
)
4482 if (!gfc_merge_new_implicit (&ts
))
4490 gfc_syntax_error (ST_IMPLICIT
);
4498 gfc_match_import (void)
4500 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4505 if (gfc_current_ns
->proc_name
== NULL
4506 || gfc_current_ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
4508 gfc_error ("IMPORT statement at %C only permitted in "
4509 "an INTERFACE body");
4513 if (gfc_current_ns
->proc_name
->attr
.module_procedure
)
4515 gfc_error ("F2008: C1210 IMPORT statement at %C is not permitted "
4516 "in a module procedure interface body");
4520 if (!gfc_notify_std (GFC_STD_F2003
, "IMPORT statement at %C"))
4523 if (gfc_match_eos () == MATCH_YES
)
4525 /* All host variables should be imported. */
4526 gfc_current_ns
->has_import_set
= 1;
4530 if (gfc_match (" ::") == MATCH_YES
)
4532 if (gfc_match_eos () == MATCH_YES
)
4534 gfc_error ("Expecting list of named entities at %C");
4542 m
= gfc_match (" %n", name
);
4546 if (gfc_current_ns
->parent
!= NULL
4547 && gfc_find_symbol (name
, gfc_current_ns
->parent
, 1, &sym
))
4549 gfc_error ("Type name %qs at %C is ambiguous", name
);
4552 else if (!sym
&& gfc_current_ns
->proc_name
->ns
->parent
!= NULL
4553 && gfc_find_symbol (name
,
4554 gfc_current_ns
->proc_name
->ns
->parent
,
4557 gfc_error ("Type name %qs at %C is ambiguous", name
);
4563 gfc_error ("Cannot IMPORT %qs from host scoping unit "
4564 "at %C - does not exist.", name
);
4568 if (gfc_find_symtree (gfc_current_ns
->sym_root
, name
))
4570 gfc_warning (0, "%qs is already IMPORTed from host scoping unit "
4575 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, name
);
4578 sym
->attr
.imported
= 1;
4580 if (sym
->attr
.generic
&& (sym
= gfc_find_dt_in_generic (sym
)))
4582 /* The actual derived type is stored in a symtree with the first
4583 letter of the name capitalized; the symtree with the all
4584 lower-case name contains the associated generic function. */
4585 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
,
4586 gfc_dt_upper_string (name
));
4589 sym
->attr
.imported
= 1;
4602 if (gfc_match_eos () == MATCH_YES
)
4604 if (gfc_match_char (',') != MATCH_YES
)
4611 gfc_error ("Syntax error in IMPORT statement at %C");
4616 /* A minimal implementation of gfc_match without whitespace, escape
4617 characters or variable arguments. Returns true if the next
4618 characters match the TARGET template exactly. */
4621 match_string_p (const char *target
)
4625 for (p
= target
; *p
; p
++)
4626 if ((char) gfc_next_ascii_char () != *p
)
4631 /* Matches an attribute specification including array specs. If
4632 successful, leaves the variables current_attr and current_as
4633 holding the specification. Also sets the colon_seen variable for
4634 later use by matchers associated with initializations.
4636 This subroutine is a little tricky in the sense that we don't know
4637 if we really have an attr-spec until we hit the double colon.
4638 Until that time, we can only return MATCH_NO. This forces us to
4639 check for duplicate specification at this level. */
4642 match_attr_spec (void)
4644 /* Modifiers that can exist in a type statement. */
4646 { GFC_DECL_BEGIN
= 0,
4647 DECL_ALLOCATABLE
= GFC_DECL_BEGIN
, DECL_DIMENSION
, DECL_EXTERNAL
,
4648 DECL_IN
, DECL_OUT
, DECL_INOUT
, DECL_INTRINSIC
, DECL_OPTIONAL
,
4649 DECL_PARAMETER
, DECL_POINTER
, DECL_PROTECTED
, DECL_PRIVATE
,
4650 DECL_STATIC
, DECL_AUTOMATIC
,
4651 DECL_PUBLIC
, DECL_SAVE
, DECL_TARGET
, DECL_VALUE
, DECL_VOLATILE
,
4652 DECL_IS_BIND_C
, DECL_CODIMENSION
, DECL_ASYNCHRONOUS
, DECL_CONTIGUOUS
,
4653 DECL_LEN
, DECL_KIND
, DECL_NONE
, GFC_DECL_END
/* Sentinel */
4656 /* GFC_DECL_END is the sentinel, index starts at 0. */
4657 #define NUM_DECL GFC_DECL_END
4659 locus start
, seen_at
[NUM_DECL
];
4666 gfc_clear_attr (¤t_attr
);
4667 start
= gfc_current_locus
;
4673 /* See if we get all of the keywords up to the final double colon. */
4674 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
4682 gfc_gobble_whitespace ();
4684 ch
= gfc_next_ascii_char ();
4687 /* This is the successful exit condition for the loop. */
4688 if (gfc_next_ascii_char () == ':')
4693 gfc_gobble_whitespace ();
4694 switch (gfc_peek_ascii_char ())
4697 gfc_next_ascii_char ();
4698 switch (gfc_next_ascii_char ())
4701 if (match_string_p ("locatable"))
4703 /* Matched "allocatable". */
4704 d
= DECL_ALLOCATABLE
;
4709 if (match_string_p ("ynchronous"))
4711 /* Matched "asynchronous". */
4712 d
= DECL_ASYNCHRONOUS
;
4717 if (match_string_p ("tomatic"))
4719 /* Matched "automatic". */
4727 /* Try and match the bind(c). */
4728 m
= gfc_match_bind_c (NULL
, true);
4731 else if (m
== MATCH_ERROR
)
4736 gfc_next_ascii_char ();
4737 if ('o' != gfc_next_ascii_char ())
4739 switch (gfc_next_ascii_char ())
4742 if (match_string_p ("imension"))
4744 d
= DECL_CODIMENSION
;
4749 if (match_string_p ("tiguous"))
4751 d
= DECL_CONTIGUOUS
;
4758 if (match_string_p ("dimension"))
4763 if (match_string_p ("external"))
4768 if (match_string_p ("int"))
4770 ch
= gfc_next_ascii_char ();
4773 if (match_string_p ("nt"))
4775 /* Matched "intent". */
4776 /* TODO: Call match_intent_spec from here. */
4777 if (gfc_match (" ( in out )") == MATCH_YES
)
4779 else if (gfc_match (" ( in )") == MATCH_YES
)
4781 else if (gfc_match (" ( out )") == MATCH_YES
)
4787 if (match_string_p ("insic"))
4789 /* Matched "intrinsic". */
4797 if (match_string_p ("kind"))
4802 if (match_string_p ("len"))
4807 if (match_string_p ("optional"))
4812 gfc_next_ascii_char ();
4813 switch (gfc_next_ascii_char ())
4816 if (match_string_p ("rameter"))
4818 /* Matched "parameter". */
4824 if (match_string_p ("inter"))
4826 /* Matched "pointer". */
4832 ch
= gfc_next_ascii_char ();
4835 if (match_string_p ("vate"))
4837 /* Matched "private". */
4843 if (match_string_p ("tected"))
4845 /* Matched "protected". */
4852 if (match_string_p ("blic"))
4854 /* Matched "public". */
4862 gfc_next_ascii_char ();
4863 switch (gfc_next_ascii_char ())
4866 if (match_string_p ("ve"))
4868 /* Matched "save". */
4874 if (match_string_p ("atic"))
4876 /* Matched "static". */
4884 if (match_string_p ("target"))
4889 gfc_next_ascii_char ();
4890 ch
= gfc_next_ascii_char ();
4893 if (match_string_p ("lue"))
4895 /* Matched "value". */
4901 if (match_string_p ("latile"))
4903 /* Matched "volatile". */
4911 /* No double colon and no recognizable decl_type, so assume that
4912 we've been looking at something else the whole time. */
4919 /* Check to make sure any parens are paired up correctly. */
4920 if (gfc_match_parens () == MATCH_ERROR
)
4927 seen_at
[d
] = gfc_current_locus
;
4929 if (d
== DECL_DIMENSION
|| d
== DECL_CODIMENSION
)
4931 gfc_array_spec
*as
= NULL
;
4933 m
= gfc_match_array_spec (&as
, d
== DECL_DIMENSION
,
4934 d
== DECL_CODIMENSION
);
4936 if (current_as
== NULL
)
4938 else if (m
== MATCH_YES
)
4940 if (!merge_array_spec (as
, current_as
, false))
4947 if (d
== DECL_CODIMENSION
)
4948 gfc_error ("Missing codimension specification at %C");
4950 gfc_error ("Missing dimension specification at %C");
4954 if (m
== MATCH_ERROR
)
4959 /* Since we've seen a double colon, we have to be looking at an
4960 attr-spec. This means that we can now issue errors. */
4961 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
4966 case DECL_ALLOCATABLE
:
4967 attr
= "ALLOCATABLE";
4969 case DECL_ASYNCHRONOUS
:
4970 attr
= "ASYNCHRONOUS";
4972 case DECL_CODIMENSION
:
4973 attr
= "CODIMENSION";
4975 case DECL_CONTIGUOUS
:
4976 attr
= "CONTIGUOUS";
4978 case DECL_DIMENSION
:
4985 attr
= "INTENT (IN)";
4988 attr
= "INTENT (OUT)";
4991 attr
= "INTENT (IN OUT)";
4993 case DECL_INTRINSIC
:
5005 case DECL_PARAMETER
:
5011 case DECL_PROTECTED
:
5026 case DECL_AUTOMATIC
:
5032 case DECL_IS_BIND_C
:
5042 attr
= NULL
; /* This shouldn't happen. */
5045 gfc_error ("Duplicate %s attribute at %L", attr
, &seen_at
[d
]);
5050 /* Now that we've dealt with duplicate attributes, add the attributes
5051 to the current attribute. */
5052 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
5059 if ((d
== DECL_STATIC
|| d
== DECL_AUTOMATIC
)
5060 && !flag_dec_static
)
5062 gfc_error ("%s at %L is a DEC extension, enable with "
5064 d
== DECL_STATIC
? "STATIC" : "AUTOMATIC", &seen_at
[d
]);
5068 /* Allow SAVE with STATIC, but don't complain. */
5069 if (d
== DECL_STATIC
&& seen
[DECL_SAVE
])
5072 if (gfc_current_state () == COMP_DERIVED
5073 && d
!= DECL_DIMENSION
&& d
!= DECL_CODIMENSION
5074 && d
!= DECL_POINTER
&& d
!= DECL_PRIVATE
5075 && d
!= DECL_PUBLIC
&& d
!= DECL_CONTIGUOUS
&& d
!= DECL_NONE
)
5077 if (d
== DECL_ALLOCATABLE
)
5079 if (!gfc_notify_std (GFC_STD_F2003
, "ALLOCATABLE "
5080 "attribute at %C in a TYPE definition"))
5086 else if (d
== DECL_KIND
)
5088 if (!gfc_notify_std (GFC_STD_F2003
, "KIND "
5089 "attribute at %C in a TYPE definition"))
5094 if (current_ts
.type
!= BT_INTEGER
)
5096 gfc_error ("Component with KIND attribute at %C must be "
5101 if (current_ts
.kind
!= gfc_default_integer_kind
)
5103 gfc_error ("Component with KIND attribute at %C must be "
5104 "default integer kind (%d)",
5105 gfc_default_integer_kind
);
5110 else if (d
== DECL_LEN
)
5112 if (!gfc_notify_std (GFC_STD_F2003
, "LEN "
5113 "attribute at %C in a TYPE definition"))
5118 if (current_ts
.type
!= BT_INTEGER
)
5120 gfc_error ("Component with LEN attribute at %C must be "
5125 if (current_ts
.kind
!= gfc_default_integer_kind
)
5127 gfc_error ("Component with LEN attribute at %C must be "
5128 "default integer kind (%d)",
5129 gfc_default_integer_kind
);
5136 gfc_error ("Attribute at %L is not allowed in a TYPE definition",
5143 if ((d
== DECL_PRIVATE
|| d
== DECL_PUBLIC
)
5144 && gfc_current_state () != COMP_MODULE
)
5146 if (d
== DECL_PRIVATE
)
5150 if (gfc_current_state () == COMP_DERIVED
5151 && gfc_state_stack
->previous
5152 && gfc_state_stack
->previous
->state
== COMP_MODULE
)
5154 if (!gfc_notify_std (GFC_STD_F2003
, "Attribute %s "
5155 "at %L in a TYPE definition", attr
,
5164 gfc_error ("%s attribute at %L is not allowed outside of the "
5165 "specification part of a module", attr
, &seen_at
[d
]);
5171 if (gfc_current_state () != COMP_DERIVED
5172 && (d
== DECL_KIND
|| d
== DECL_LEN
))
5174 gfc_error ("Attribute at %L is not allowed outside a TYPE "
5175 "definition", &seen_at
[d
]);
5182 case DECL_ALLOCATABLE
:
5183 t
= gfc_add_allocatable (¤t_attr
, &seen_at
[d
]);
5186 case DECL_ASYNCHRONOUS
:
5187 if (!gfc_notify_std (GFC_STD_F2003
, "ASYNCHRONOUS attribute at %C"))
5190 t
= gfc_add_asynchronous (¤t_attr
, NULL
, &seen_at
[d
]);
5193 case DECL_CODIMENSION
:
5194 t
= gfc_add_codimension (¤t_attr
, NULL
, &seen_at
[d
]);
5197 case DECL_CONTIGUOUS
:
5198 if (!gfc_notify_std (GFC_STD_F2008
, "CONTIGUOUS attribute at %C"))
5201 t
= gfc_add_contiguous (¤t_attr
, NULL
, &seen_at
[d
]);
5204 case DECL_DIMENSION
:
5205 t
= gfc_add_dimension (¤t_attr
, NULL
, &seen_at
[d
]);
5209 t
= gfc_add_external (¤t_attr
, &seen_at
[d
]);
5213 t
= gfc_add_intent (¤t_attr
, INTENT_IN
, &seen_at
[d
]);
5217 t
= gfc_add_intent (¤t_attr
, INTENT_OUT
, &seen_at
[d
]);
5221 t
= gfc_add_intent (¤t_attr
, INTENT_INOUT
, &seen_at
[d
]);
5224 case DECL_INTRINSIC
:
5225 t
= gfc_add_intrinsic (¤t_attr
, &seen_at
[d
]);
5229 t
= gfc_add_optional (¤t_attr
, &seen_at
[d
]);
5233 t
= gfc_add_kind (¤t_attr
, &seen_at
[d
]);
5237 t
= gfc_add_len (¤t_attr
, &seen_at
[d
]);
5240 case DECL_PARAMETER
:
5241 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, &seen_at
[d
]);
5245 t
= gfc_add_pointer (¤t_attr
, &seen_at
[d
]);
5248 case DECL_PROTECTED
:
5249 if (gfc_current_state () != COMP_MODULE
5250 || (gfc_current_ns
->proc_name
5251 && gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
))
5253 gfc_error ("PROTECTED at %C only allowed in specification "
5254 "part of a module");
5259 if (!gfc_notify_std (GFC_STD_F2003
, "PROTECTED attribute at %C"))
5262 t
= gfc_add_protected (¤t_attr
, NULL
, &seen_at
[d
]);
5266 t
= gfc_add_access (¤t_attr
, ACCESS_PRIVATE
, NULL
,
5271 t
= gfc_add_access (¤t_attr
, ACCESS_PUBLIC
, NULL
,
5277 t
= gfc_add_save (¤t_attr
, SAVE_EXPLICIT
, NULL
, &seen_at
[d
]);
5280 case DECL_AUTOMATIC
:
5281 t
= gfc_add_automatic (¤t_attr
, NULL
, &seen_at
[d
]);
5285 t
= gfc_add_target (¤t_attr
, &seen_at
[d
]);
5288 case DECL_IS_BIND_C
:
5289 t
= gfc_add_is_bind_c(¤t_attr
, NULL
, &seen_at
[d
], 0);
5293 if (!gfc_notify_std (GFC_STD_F2003
, "VALUE attribute at %C"))
5296 t
= gfc_add_value (¤t_attr
, NULL
, &seen_at
[d
]);
5300 if (!gfc_notify_std (GFC_STD_F2003
, "VOLATILE attribute at %C"))
5303 t
= gfc_add_volatile (¤t_attr
, NULL
, &seen_at
[d
]);
5307 gfc_internal_error ("match_attr_spec(): Bad attribute");
5317 /* Since Fortran 2008 module variables implicitly have the SAVE attribute. */
5318 if ((gfc_current_state () == COMP_MODULE
5319 || gfc_current_state () == COMP_SUBMODULE
)
5320 && !current_attr
.save
5321 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
5322 current_attr
.save
= SAVE_IMPLICIT
;
5328 gfc_current_locus
= start
;
5329 gfc_free_array_spec (current_as
);
5336 /* Set the binding label, dest_label, either with the binding label
5337 stored in the given gfc_typespec, ts, or if none was provided, it
5338 will be the symbol name in all lower case, as required by the draft
5339 (J3/04-007, section 15.4.1). If a binding label was given and
5340 there is more than one argument (num_idents), it is an error. */
5343 set_binding_label (const char **dest_label
, const char *sym_name
,
5346 if (num_idents
> 1 && has_name_equals
)
5348 gfc_error ("Multiple identifiers provided with "
5349 "single NAME= specifier at %C");
5353 if (curr_binding_label
)
5354 /* Binding label given; store in temp holder till have sym. */
5355 *dest_label
= curr_binding_label
;
5358 /* No binding label given, and the NAME= specifier did not exist,
5359 which means there was no NAME="". */
5360 if (sym_name
!= NULL
&& has_name_equals
== 0)
5361 *dest_label
= IDENTIFIER_POINTER (get_identifier (sym_name
));
5368 /* Set the status of the given common block as being BIND(C) or not,
5369 depending on the given parameter, is_bind_c. */
5372 set_com_block_bind_c (gfc_common_head
*com_block
, int is_bind_c
)
5374 com_block
->is_bind_c
= is_bind_c
;
5379 /* Verify that the given gfc_typespec is for a C interoperable type. */
5382 gfc_verify_c_interop (gfc_typespec
*ts
)
5384 if (ts
->type
== BT_DERIVED
&& ts
->u
.derived
!= NULL
)
5385 return (ts
->u
.derived
->ts
.is_c_interop
|| ts
->u
.derived
->attr
.is_bind_c
)
5387 else if (ts
->type
== BT_CLASS
)
5389 else if (ts
->is_c_interop
!= 1 && ts
->type
!= BT_ASSUMED
)
5396 /* Verify that the variables of a given common block, which has been
5397 defined with the attribute specifier bind(c), to be of a C
5398 interoperable type. Errors will be reported here, if
5402 verify_com_block_vars_c_interop (gfc_common_head
*com_block
)
5404 gfc_symbol
*curr_sym
= NULL
;
5407 curr_sym
= com_block
->head
;
5409 /* Make sure we have at least one symbol. */
5410 if (curr_sym
== NULL
)
5413 /* Here we know we have a symbol, so we'll execute this loop
5417 /* The second to last param, 1, says this is in a common block. */
5418 retval
= verify_bind_c_sym (curr_sym
, &(curr_sym
->ts
), 1, com_block
);
5419 curr_sym
= curr_sym
->common_next
;
5420 } while (curr_sym
!= NULL
);
5426 /* Verify that a given BIND(C) symbol is C interoperable. If it is not,
5427 an appropriate error message is reported. */
5430 verify_bind_c_sym (gfc_symbol
*tmp_sym
, gfc_typespec
*ts
,
5431 int is_in_common
, gfc_common_head
*com_block
)
5433 bool bind_c_function
= false;
5436 if (tmp_sym
->attr
.function
&& tmp_sym
->attr
.is_bind_c
)
5437 bind_c_function
= true;
5439 if (tmp_sym
->attr
.function
&& tmp_sym
->result
!= NULL
)
5441 tmp_sym
= tmp_sym
->result
;
5442 /* Make sure it wasn't an implicitly typed result. */
5443 if (tmp_sym
->attr
.implicit_type
&& warn_c_binding_type
)
5445 gfc_warning (OPT_Wc_binding_type
,
5446 "Implicitly declared BIND(C) function %qs at "
5447 "%L may not be C interoperable", tmp_sym
->name
,
5448 &tmp_sym
->declared_at
);
5449 tmp_sym
->ts
.f90_type
= tmp_sym
->ts
.type
;
5450 /* Mark it as C interoperable to prevent duplicate warnings. */
5451 tmp_sym
->ts
.is_c_interop
= 1;
5452 tmp_sym
->attr
.is_c_interop
= 1;
5456 /* Here, we know we have the bind(c) attribute, so if we have
5457 enough type info, then verify that it's a C interop kind.
5458 The info could be in the symbol already, or possibly still in
5459 the given ts (current_ts), so look in both. */
5460 if (tmp_sym
->ts
.type
!= BT_UNKNOWN
|| ts
->type
!= BT_UNKNOWN
)
5462 if (!gfc_verify_c_interop (&(tmp_sym
->ts
)))
5464 /* See if we're dealing with a sym in a common block or not. */
5465 if (is_in_common
== 1 && warn_c_binding_type
)
5467 gfc_warning (OPT_Wc_binding_type
,
5468 "Variable %qs in common block %qs at %L "
5469 "may not be a C interoperable "
5470 "kind though common block %qs is BIND(C)",
5471 tmp_sym
->name
, com_block
->name
,
5472 &(tmp_sym
->declared_at
), com_block
->name
);
5476 if (tmp_sym
->ts
.type
== BT_DERIVED
|| ts
->type
== BT_DERIVED
)
5477 gfc_error ("Type declaration %qs at %L is not C "
5478 "interoperable but it is BIND(C)",
5479 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5480 else if (warn_c_binding_type
)
5481 gfc_warning (OPT_Wc_binding_type
, "Variable %qs at %L "
5482 "may not be a C interoperable "
5483 "kind but it is BIND(C)",
5484 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5488 /* Variables declared w/in a common block can't be bind(c)
5489 since there's no way for C to see these variables, so there's
5490 semantically no reason for the attribute. */
5491 if (is_in_common
== 1 && tmp_sym
->attr
.is_bind_c
== 1)
5493 gfc_error ("Variable %qs in common block %qs at "
5494 "%L cannot be declared with BIND(C) "
5495 "since it is not a global",
5496 tmp_sym
->name
, com_block
->name
,
5497 &(tmp_sym
->declared_at
));
5501 /* Scalar variables that are bind(c) can not have the pointer
5502 or allocatable attributes. */
5503 if (tmp_sym
->attr
.is_bind_c
== 1)
5505 if (tmp_sym
->attr
.pointer
== 1)
5507 gfc_error ("Variable %qs at %L cannot have both the "
5508 "POINTER and BIND(C) attributes",
5509 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5513 if (tmp_sym
->attr
.allocatable
== 1)
5515 gfc_error ("Variable %qs at %L cannot have both the "
5516 "ALLOCATABLE and BIND(C) attributes",
5517 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5523 /* If it is a BIND(C) function, make sure the return value is a
5524 scalar value. The previous tests in this function made sure
5525 the type is interoperable. */
5526 if (bind_c_function
&& tmp_sym
->as
!= NULL
)
5527 gfc_error ("Return type of BIND(C) function %qs at %L cannot "
5528 "be an array", tmp_sym
->name
, &(tmp_sym
->declared_at
));
5530 /* BIND(C) functions can not return a character string. */
5531 if (bind_c_function
&& tmp_sym
->ts
.type
== BT_CHARACTER
)
5532 if (tmp_sym
->ts
.u
.cl
== NULL
|| tmp_sym
->ts
.u
.cl
->length
== NULL
5533 || tmp_sym
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
5534 || mpz_cmp_si (tmp_sym
->ts
.u
.cl
->length
->value
.integer
, 1) != 0)
5535 gfc_error ("Return type of BIND(C) function %qs at %L cannot "
5536 "be a character string", tmp_sym
->name
,
5537 &(tmp_sym
->declared_at
));
5540 /* See if the symbol has been marked as private. If it has, make sure
5541 there is no binding label and warn the user if there is one. */
5542 if (tmp_sym
->attr
.access
== ACCESS_PRIVATE
5543 && tmp_sym
->binding_label
)
5544 /* Use gfc_warning_now because we won't say that the symbol fails
5545 just because of this. */
5546 gfc_warning_now (0, "Symbol %qs at %L is marked PRIVATE but has been "
5547 "given the binding label %qs", tmp_sym
->name
,
5548 &(tmp_sym
->declared_at
), tmp_sym
->binding_label
);
5554 /* Set the appropriate fields for a symbol that's been declared as
5555 BIND(C) (the is_bind_c flag and the binding label), and verify that
5556 the type is C interoperable. Errors are reported by the functions
5557 used to set/test these fields. */
5560 set_verify_bind_c_sym (gfc_symbol
*tmp_sym
, int num_idents
)
5564 /* TODO: Do we need to make sure the vars aren't marked private? */
5566 /* Set the is_bind_c bit in symbol_attribute. */
5567 gfc_add_is_bind_c (&(tmp_sym
->attr
), tmp_sym
->name
, &gfc_current_locus
, 0);
5569 if (!set_binding_label (&tmp_sym
->binding_label
, tmp_sym
->name
, num_idents
))
5576 /* Set the fields marking the given common block as BIND(C), including
5577 a binding label, and report any errors encountered. */
5580 set_verify_bind_c_com_block (gfc_common_head
*com_block
, int num_idents
)
5584 /* destLabel, common name, typespec (which may have binding label). */
5585 if (!set_binding_label (&com_block
->binding_label
, com_block
->name
,
5589 /* Set the given common block (com_block) to being bind(c) (1). */
5590 set_com_block_bind_c (com_block
, 1);
5596 /* Retrieve the list of one or more identifiers that the given bind(c)
5597 attribute applies to. */
5600 get_bind_c_idents (void)
5602 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5604 gfc_symbol
*tmp_sym
= NULL
;
5606 gfc_common_head
*com_block
= NULL
;
5608 if (gfc_match_name (name
) == MATCH_YES
)
5610 found_id
= MATCH_YES
;
5611 gfc_get_ha_symbol (name
, &tmp_sym
);
5613 else if (match_common_name (name
) == MATCH_YES
)
5615 found_id
= MATCH_YES
;
5616 com_block
= gfc_get_common (name
, 0);
5620 gfc_error ("Need either entity or common block name for "
5621 "attribute specification statement at %C");
5625 /* Save the current identifier and look for more. */
5628 /* Increment the number of identifiers found for this spec stmt. */
5631 /* Make sure we have a sym or com block, and verify that it can
5632 be bind(c). Set the appropriate field(s) and look for more
5634 if (tmp_sym
!= NULL
|| com_block
!= NULL
)
5636 if (tmp_sym
!= NULL
)
5638 if (!set_verify_bind_c_sym (tmp_sym
, num_idents
))
5643 if (!set_verify_bind_c_com_block (com_block
, num_idents
))
5647 /* Look to see if we have another identifier. */
5649 if (gfc_match_eos () == MATCH_YES
)
5650 found_id
= MATCH_NO
;
5651 else if (gfc_match_char (',') != MATCH_YES
)
5652 found_id
= MATCH_NO
;
5653 else if (gfc_match_name (name
) == MATCH_YES
)
5655 found_id
= MATCH_YES
;
5656 gfc_get_ha_symbol (name
, &tmp_sym
);
5658 else if (match_common_name (name
) == MATCH_YES
)
5660 found_id
= MATCH_YES
;
5661 com_block
= gfc_get_common (name
, 0);
5665 gfc_error ("Missing entity or common block name for "
5666 "attribute specification statement at %C");
5672 gfc_internal_error ("Missing symbol");
5674 } while (found_id
== MATCH_YES
);
5676 /* if we get here we were successful */
5681 /* Try and match a BIND(C) attribute specification statement. */
5684 gfc_match_bind_c_stmt (void)
5686 match found_match
= MATCH_NO
;
5691 /* This may not be necessary. */
5693 /* Clear the temporary binding label holder. */
5694 curr_binding_label
= NULL
;
5696 /* Look for the bind(c). */
5697 found_match
= gfc_match_bind_c (NULL
, true);
5699 if (found_match
== MATCH_YES
)
5701 if (!gfc_notify_std (GFC_STD_F2003
, "BIND(C) statement at %C"))
5704 /* Look for the :: now, but it is not required. */
5707 /* Get the identifier(s) that needs to be updated. This may need to
5708 change to hand the flag(s) for the attr specified so all identifiers
5709 found can have all appropriate parts updated (assuming that the same
5710 spec stmt can have multiple attrs, such as both bind(c) and
5712 if (!get_bind_c_idents ())
5713 /* Error message should have printed already. */
5721 /* Match a data declaration statement. */
5724 gfc_match_data_decl (void)
5730 type_param_spec_list
= NULL
;
5731 decl_type_param_list
= NULL
;
5733 num_idents_on_line
= 0;
5735 m
= gfc_match_decl_type_spec (¤t_ts
, 0);
5739 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
5740 && !gfc_comp_struct (gfc_current_state ()))
5742 sym
= gfc_use_derived (current_ts
.u
.derived
);
5750 current_ts
.u
.derived
= sym
;
5753 m
= match_attr_spec ();
5754 if (m
== MATCH_ERROR
)
5760 if (current_ts
.type
== BT_CLASS
5761 && current_ts
.u
.derived
->attr
.unlimited_polymorphic
)
5764 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
5765 && current_ts
.u
.derived
->components
== NULL
5766 && !current_ts
.u
.derived
->attr
.zero_comp
)
5769 if (current_attr
.pointer
&& gfc_comp_struct (gfc_current_state ()))
5772 if (current_attr
.allocatable
&& gfc_current_state () == COMP_DERIVED
5773 && current_ts
.u
.derived
== gfc_current_block ())
5776 gfc_find_symbol (current_ts
.u
.derived
->name
,
5777 current_ts
.u
.derived
->ns
, 1, &sym
);
5779 /* Any symbol that we find had better be a type definition
5780 which has its components defined, or be a structure definition
5781 actively being parsed. */
5782 if (sym
!= NULL
&& gfc_fl_struct (sym
->attr
.flavor
)
5783 && (current_ts
.u
.derived
->components
!= NULL
5784 || current_ts
.u
.derived
->attr
.zero_comp
5785 || current_ts
.u
.derived
== gfc_new_block
))
5788 gfc_error ("Derived type at %C has not been previously defined "
5789 "and so cannot appear in a derived type definition");
5795 /* If we have an old-style character declaration, and no new-style
5796 attribute specifications, then there a comma is optional between
5797 the type specification and the variable list. */
5798 if (m
== MATCH_NO
&& current_ts
.type
== BT_CHARACTER
&& old_char_selector
)
5799 gfc_match_char (',');
5801 /* Give the types/attributes to symbols that follow. Give the element
5802 a number so that repeat character length expressions can be copied. */
5806 num_idents_on_line
++;
5807 m
= variable_decl (elem
++);
5808 if (m
== MATCH_ERROR
)
5813 if (gfc_match_eos () == MATCH_YES
)
5815 if (gfc_match_char (',') != MATCH_YES
)
5819 if (!gfc_error_flag_test ())
5821 /* An anonymous structure declaration is unambiguous; if we matched one
5822 according to gfc_match_structure_decl, we need to return MATCH_YES
5823 here to avoid confusing the remaining matchers, even if there was an
5824 error during variable_decl. We must flush any such errors. Note this
5825 causes the parser to gracefully continue parsing the remaining input
5826 as a structure body, which likely follows. */
5827 if (current_ts
.type
== BT_DERIVED
&& current_ts
.u
.derived
5828 && gfc_fl_struct (current_ts
.u
.derived
->attr
.flavor
))
5830 gfc_error_now ("Syntax error in anonymous structure declaration"
5832 /* Skip the bad variable_decl and line up for the start of the
5834 gfc_error_recovery ();
5839 gfc_error ("Syntax error in data declaration at %C");
5844 gfc_free_data_all (gfc_current_ns
);
5847 if (saved_kind_expr
)
5848 gfc_free_expr (saved_kind_expr
);
5849 if (type_param_spec_list
)
5850 gfc_free_actual_arglist (type_param_spec_list
);
5851 if (decl_type_param_list
)
5852 gfc_free_actual_arglist (decl_type_param_list
);
5853 saved_kind_expr
= NULL
;
5854 gfc_free_array_spec (current_as
);
5860 /* Match a prefix associated with a function or subroutine
5861 declaration. If the typespec pointer is nonnull, then a typespec
5862 can be matched. Note that if nothing matches, MATCH_YES is
5863 returned (the null string was matched). */
5866 gfc_match_prefix (gfc_typespec
*ts
)
5872 gfc_clear_attr (¤t_attr
);
5874 seen_impure
= false;
5876 gcc_assert (!gfc_matching_prefix
);
5877 gfc_matching_prefix
= true;
5881 found_prefix
= false;
5883 /* MODULE is a prefix like PURE, ELEMENTAL, etc., having a
5884 corresponding attribute seems natural and distinguishes these
5885 procedures from procedure types of PROC_MODULE, which these are
5887 if (gfc_match ("module% ") == MATCH_YES
)
5889 if (!gfc_notify_std (GFC_STD_F2008
, "MODULE prefix at %C"))
5892 current_attr
.module_procedure
= 1;
5893 found_prefix
= true;
5896 if (!seen_type
&& ts
!= NULL
5897 && gfc_match_decl_type_spec (ts
, 0) == MATCH_YES
5898 && gfc_match_space () == MATCH_YES
)
5902 found_prefix
= true;
5905 if (gfc_match ("elemental% ") == MATCH_YES
)
5907 if (!gfc_add_elemental (¤t_attr
, NULL
))
5910 found_prefix
= true;
5913 if (gfc_match ("pure% ") == MATCH_YES
)
5915 if (!gfc_add_pure (¤t_attr
, NULL
))
5918 found_prefix
= true;
5921 if (gfc_match ("recursive% ") == MATCH_YES
)
5923 if (!gfc_add_recursive (¤t_attr
, NULL
))
5926 found_prefix
= true;
5929 /* IMPURE is a somewhat special case, as it needs not set an actual
5930 attribute but rather only prevents ELEMENTAL routines from being
5931 automatically PURE. */
5932 if (gfc_match ("impure% ") == MATCH_YES
)
5934 if (!gfc_notify_std (GFC_STD_F2008
, "IMPURE procedure at %C"))
5938 found_prefix
= true;
5941 while (found_prefix
);
5943 /* IMPURE and PURE must not both appear, of course. */
5944 if (seen_impure
&& current_attr
.pure
)
5946 gfc_error ("PURE and IMPURE must not appear both at %C");
5950 /* If IMPURE it not seen but the procedure is ELEMENTAL, mark it as PURE. */
5951 if (!seen_impure
&& current_attr
.elemental
&& !current_attr
.pure
)
5953 if (!gfc_add_pure (¤t_attr
, NULL
))
5957 /* At this point, the next item is not a prefix. */
5958 gcc_assert (gfc_matching_prefix
);
5960 gfc_matching_prefix
= false;
5964 gcc_assert (gfc_matching_prefix
);
5965 gfc_matching_prefix
= false;
5970 /* Copy attributes matched by gfc_match_prefix() to attributes on a symbol. */
5973 copy_prefix (symbol_attribute
*dest
, locus
*where
)
5975 if (dest
->module_procedure
)
5977 if (current_attr
.elemental
)
5978 dest
->elemental
= 1;
5980 if (current_attr
.pure
)
5983 if (current_attr
.recursive
)
5984 dest
->recursive
= 1;
5986 /* Module procedures are unusual in that the 'dest' is copied from
5987 the interface declaration. However, this is an oportunity to
5988 check that the submodule declaration is compliant with the
5990 if (dest
->elemental
&& !current_attr
.elemental
)
5992 gfc_error ("ELEMENTAL prefix in MODULE PROCEDURE interface is "
5993 "missing at %L", where
);
5997 if (dest
->pure
&& !current_attr
.pure
)
5999 gfc_error ("PURE prefix in MODULE PROCEDURE interface is "
6000 "missing at %L", where
);
6004 if (dest
->recursive
&& !current_attr
.recursive
)
6006 gfc_error ("RECURSIVE prefix in MODULE PROCEDURE interface is "
6007 "missing at %L", where
);
6014 if (current_attr
.elemental
&& !gfc_add_elemental (dest
, where
))
6017 if (current_attr
.pure
&& !gfc_add_pure (dest
, where
))
6020 if (current_attr
.recursive
&& !gfc_add_recursive (dest
, where
))
6027 /* Match a formal argument list or, if typeparam is true, a
6028 type_param_name_list. */
6031 gfc_match_formal_arglist (gfc_symbol
*progname
, int st_flag
,
6032 int null_flag
, bool typeparam
)
6034 gfc_formal_arglist
*head
, *tail
, *p
, *q
;
6035 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6038 gfc_formal_arglist
*formal
= NULL
;
6042 /* Keep the interface formal argument list and null it so that the
6043 matching for the new declaration can be done. The numbers and
6044 names of the arguments are checked here. The interface formal
6045 arguments are retained in formal_arglist and the characteristics
6046 are compared in resolve.c(resolve_fl_procedure). See the remark
6047 in get_proc_name about the eventual need to copy the formal_arglist
6048 and populate the formal namespace of the interface symbol. */
6049 if (progname
->attr
.module_procedure
6050 && progname
->attr
.host_assoc
)
6052 formal
= progname
->formal
;
6053 progname
->formal
= NULL
;
6056 if (gfc_match_char ('(') != MATCH_YES
)
6063 if (gfc_match_char (')') == MATCH_YES
)
6068 if (gfc_match_char ('*') == MATCH_YES
)
6071 if (!typeparam
&& !gfc_notify_std (GFC_STD_F95_OBS
,
6072 "Alternate-return argument at %C"))
6078 gfc_error_now ("A parameter name is required at %C");
6082 m
= gfc_match_name (name
);
6086 gfc_error_now ("A parameter name is required at %C");
6090 if (!typeparam
&& gfc_get_symbol (name
, NULL
, &sym
))
6093 && gfc_get_symbol (name
, progname
->f2k_derived
, &sym
))
6097 p
= gfc_get_formal_arglist ();
6109 /* We don't add the VARIABLE flavor because the name could be a
6110 dummy procedure. We don't apply these attributes to formal
6111 arguments of statement functions. */
6112 if (sym
!= NULL
&& !st_flag
6113 && (!gfc_add_dummy(&sym
->attr
, sym
->name
, NULL
)
6114 || !gfc_missing_attr (&sym
->attr
, NULL
)))
6120 /* The name of a program unit can be in a different namespace,
6121 so check for it explicitly. After the statement is accepted,
6122 the name is checked for especially in gfc_get_symbol(). */
6123 if (gfc_new_block
!= NULL
&& sym
!= NULL
&& !typeparam
6124 && strcmp (sym
->name
, gfc_new_block
->name
) == 0)
6126 gfc_error ("Name %qs at %C is the name of the procedure",
6132 if (gfc_match_char (')') == MATCH_YES
)
6135 m
= gfc_match_char (',');
6139 gfc_error_now ("Expected parameter list in type declaration "
6142 gfc_error ("Unexpected junk in formal argument list at %C");
6148 /* Check for duplicate symbols in the formal argument list. */
6151 for (p
= head
; p
->next
; p
= p
->next
)
6156 for (q
= p
->next
; q
; q
= q
->next
)
6157 if (p
->sym
== q
->sym
)
6160 gfc_error_now ("Duplicate name %qs in parameter "
6161 "list at %C", p
->sym
->name
);
6163 gfc_error ("Duplicate symbol %qs in formal argument "
6164 "list at %C", p
->sym
->name
);
6172 if (!gfc_add_explicit_interface (progname
, IFSRC_DECL
, head
, NULL
))
6178 /* gfc_error_now used in following and return with MATCH_YES because
6179 doing otherwise results in a cascade of extraneous errors and in
6180 some cases an ICE in symbol.c(gfc_release_symbol). */
6181 if (progname
->attr
.module_procedure
&& progname
->attr
.host_assoc
)
6183 bool arg_count_mismatch
= false;
6185 if (!formal
&& head
)
6186 arg_count_mismatch
= true;
6188 /* Abbreviated module procedure declaration is not meant to have any
6189 formal arguments! */
6190 if (!progname
->abr_modproc_decl
&& formal
&& !head
)
6191 arg_count_mismatch
= true;
6193 for (p
= formal
, q
= head
; p
&& q
; p
= p
->next
, q
= q
->next
)
6195 if ((p
->next
!= NULL
&& q
->next
== NULL
)
6196 || (p
->next
== NULL
&& q
->next
!= NULL
))
6197 arg_count_mismatch
= true;
6198 else if ((p
->sym
== NULL
&& q
->sym
== NULL
)
6199 || strcmp (p
->sym
->name
, q
->sym
->name
) == 0)
6202 gfc_error_now ("Mismatch in MODULE PROCEDURE formal "
6203 "argument names (%s/%s) at %C",
6204 p
->sym
->name
, q
->sym
->name
);
6207 if (arg_count_mismatch
)
6208 gfc_error_now ("Mismatch in number of MODULE PROCEDURE "
6209 "formal arguments at %C");
6215 gfc_free_formal_arglist (head
);
6220 /* Match a RESULT specification following a function declaration or
6221 ENTRY statement. Also matches the end-of-statement. */
6224 match_result (gfc_symbol
*function
, gfc_symbol
**result
)
6226 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6230 if (gfc_match (" result (") != MATCH_YES
)
6233 m
= gfc_match_name (name
);
6237 /* Get the right paren, and that's it because there could be the
6238 bind(c) attribute after the result clause. */
6239 if (gfc_match_char (')') != MATCH_YES
)
6241 /* TODO: should report the missing right paren here. */
6245 if (strcmp (function
->name
, name
) == 0)
6247 gfc_error ("RESULT variable at %C must be different than function name");
6251 if (gfc_get_symbol (name
, NULL
, &r
))
6254 if (!gfc_add_result (&r
->attr
, r
->name
, NULL
))
6263 /* Match a function suffix, which could be a combination of a result
6264 clause and BIND(C), either one, or neither. The draft does not
6265 require them to come in a specific order. */
6268 gfc_match_suffix (gfc_symbol
*sym
, gfc_symbol
**result
)
6270 match is_bind_c
; /* Found bind(c). */
6271 match is_result
; /* Found result clause. */
6272 match found_match
; /* Status of whether we've found a good match. */
6273 char peek_char
; /* Character we're going to peek at. */
6274 bool allow_binding_name
;
6276 /* Initialize to having found nothing. */
6277 found_match
= MATCH_NO
;
6278 is_bind_c
= MATCH_NO
;
6279 is_result
= MATCH_NO
;
6281 /* Get the next char to narrow between result and bind(c). */
6282 gfc_gobble_whitespace ();
6283 peek_char
= gfc_peek_ascii_char ();
6285 /* C binding names are not allowed for internal procedures. */
6286 if (gfc_current_state () == COMP_CONTAINS
6287 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
6288 allow_binding_name
= false;
6290 allow_binding_name
= true;
6295 /* Look for result clause. */
6296 is_result
= match_result (sym
, result
);
6297 if (is_result
== MATCH_YES
)
6299 /* Now see if there is a bind(c) after it. */
6300 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
6301 /* We've found the result clause and possibly bind(c). */
6302 found_match
= MATCH_YES
;
6305 /* This should only be MATCH_ERROR. */
6306 found_match
= is_result
;
6309 /* Look for bind(c) first. */
6310 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
6311 if (is_bind_c
== MATCH_YES
)
6313 /* Now see if a result clause followed it. */
6314 is_result
= match_result (sym
, result
);
6315 found_match
= MATCH_YES
;
6319 /* Should only be a MATCH_ERROR if we get here after seeing 'b'. */
6320 found_match
= MATCH_ERROR
;
6324 gfc_error ("Unexpected junk after function declaration at %C");
6325 found_match
= MATCH_ERROR
;
6329 if (is_bind_c
== MATCH_YES
)
6331 /* Fortran 2008 draft allows BIND(C) for internal procedures. */
6332 if (gfc_current_state () == COMP_CONTAINS
6333 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
6334 && !gfc_notify_std (GFC_STD_F2008
, "BIND(C) attribute "
6335 "at %L may not be specified for an internal "
6336 "procedure", &gfc_current_locus
))
6339 if (!gfc_add_is_bind_c (&(sym
->attr
), sym
->name
, &gfc_current_locus
, 1))
6347 /* Procedure pointer return value without RESULT statement:
6348 Add "hidden" result variable named "ppr@". */
6351 add_hidden_procptr_result (gfc_symbol
*sym
)
6355 if (gfc_notification_std (GFC_STD_F2003
) == ERROR
)
6358 /* First usage case: PROCEDURE and EXTERNAL statements. */
6359 case1
= gfc_current_state () == COMP_FUNCTION
&& gfc_current_block ()
6360 && strcmp (gfc_current_block ()->name
, sym
->name
) == 0
6361 && sym
->attr
.external
;
6362 /* Second usage case: INTERFACE statements. */
6363 case2
= gfc_current_state () == COMP_INTERFACE
&& gfc_state_stack
->previous
6364 && gfc_state_stack
->previous
->state
== COMP_FUNCTION
6365 && strcmp (gfc_state_stack
->previous
->sym
->name
, sym
->name
) == 0;
6371 gfc_get_sym_tree ("ppr@", gfc_current_ns
, &stree
, false);
6375 gfc_get_sym_tree ("ppr@", gfc_current_ns
->parent
, &stree
, false);
6376 st2
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "ppr@");
6377 st2
->n
.sym
= stree
->n
.sym
;
6378 stree
->n
.sym
->refs
++;
6380 sym
->result
= stree
->n
.sym
;
6382 sym
->result
->attr
.proc_pointer
= sym
->attr
.proc_pointer
;
6383 sym
->result
->attr
.pointer
= sym
->attr
.pointer
;
6384 sym
->result
->attr
.external
= sym
->attr
.external
;
6385 sym
->result
->attr
.referenced
= sym
->attr
.referenced
;
6386 sym
->result
->ts
= sym
->ts
;
6387 sym
->attr
.proc_pointer
= 0;
6388 sym
->attr
.pointer
= 0;
6389 sym
->attr
.external
= 0;
6390 if (sym
->result
->attr
.external
&& sym
->result
->attr
.pointer
)
6392 sym
->result
->attr
.pointer
= 0;
6393 sym
->result
->attr
.proc_pointer
= 1;
6396 return gfc_add_result (&sym
->result
->attr
, sym
->result
->name
, NULL
);
6398 /* POINTER after PROCEDURE/EXTERNAL/INTERFACE statement. */
6399 else if (sym
->attr
.function
&& !sym
->attr
.external
&& sym
->attr
.pointer
6400 && sym
->result
&& sym
->result
!= sym
&& sym
->result
->attr
.external
6401 && sym
== gfc_current_ns
->proc_name
6402 && sym
== sym
->result
->ns
->proc_name
6403 && strcmp ("ppr@", sym
->result
->name
) == 0)
6405 sym
->result
->attr
.proc_pointer
= 1;
6406 sym
->attr
.pointer
= 0;
6414 /* Match the interface for a PROCEDURE declaration,
6415 including brackets (R1212). */
6418 match_procedure_interface (gfc_symbol
**proc_if
)
6422 locus old_loc
, entry_loc
;
6423 gfc_namespace
*old_ns
= gfc_current_ns
;
6424 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6426 old_loc
= entry_loc
= gfc_current_locus
;
6427 gfc_clear_ts (¤t_ts
);
6429 if (gfc_match (" (") != MATCH_YES
)
6431 gfc_current_locus
= entry_loc
;
6435 /* Get the type spec. for the procedure interface. */
6436 old_loc
= gfc_current_locus
;
6437 m
= gfc_match_decl_type_spec (¤t_ts
, 0);
6438 gfc_gobble_whitespace ();
6439 if (m
== MATCH_YES
|| (m
== MATCH_NO
&& gfc_peek_ascii_char () == ')'))
6442 if (m
== MATCH_ERROR
)
6445 /* Procedure interface is itself a procedure. */
6446 gfc_current_locus
= old_loc
;
6447 m
= gfc_match_name (name
);
6449 /* First look to see if it is already accessible in the current
6450 namespace because it is use associated or contained. */
6452 if (gfc_find_sym_tree (name
, NULL
, 0, &st
))
6455 /* If it is still not found, then try the parent namespace, if it
6456 exists and create the symbol there if it is still not found. */
6457 if (gfc_current_ns
->parent
)
6458 gfc_current_ns
= gfc_current_ns
->parent
;
6459 if (st
== NULL
&& gfc_get_ha_sym_tree (name
, &st
))
6462 gfc_current_ns
= old_ns
;
6463 *proc_if
= st
->n
.sym
;
6468 /* Resolve interface if possible. That way, attr.procedure is only set
6469 if it is declared by a later procedure-declaration-stmt, which is
6470 invalid per F08:C1216 (cf. resolve_procedure_interface). */
6471 while ((*proc_if
)->ts
.interface
6472 && *proc_if
!= (*proc_if
)->ts
.interface
)
6473 *proc_if
= (*proc_if
)->ts
.interface
;
6475 if ((*proc_if
)->attr
.flavor
== FL_UNKNOWN
6476 && (*proc_if
)->ts
.type
== BT_UNKNOWN
6477 && !gfc_add_flavor (&(*proc_if
)->attr
, FL_PROCEDURE
,
6478 (*proc_if
)->name
, NULL
))
6483 if (gfc_match (" )") != MATCH_YES
)
6485 gfc_current_locus
= entry_loc
;
6493 /* Match a PROCEDURE declaration (R1211). */
6496 match_procedure_decl (void)
6499 gfc_symbol
*sym
, *proc_if
= NULL
;
6501 gfc_expr
*initializer
= NULL
;
6503 /* Parse interface (with brackets). */
6504 m
= match_procedure_interface (&proc_if
);
6508 /* Parse attributes (with colons). */
6509 m
= match_attr_spec();
6510 if (m
== MATCH_ERROR
)
6513 if (proc_if
&& proc_if
->attr
.is_bind_c
&& !current_attr
.is_bind_c
)
6515 current_attr
.is_bind_c
= 1;
6516 has_name_equals
= 0;
6517 curr_binding_label
= NULL
;
6520 /* Get procedure symbols. */
6523 m
= gfc_match_symbol (&sym
, 0);
6526 else if (m
== MATCH_ERROR
)
6529 /* Add current_attr to the symbol attributes. */
6530 if (!gfc_copy_attr (&sym
->attr
, ¤t_attr
, NULL
))
6533 if (sym
->attr
.is_bind_c
)
6535 /* Check for C1218. */
6536 if (!proc_if
|| !proc_if
->attr
.is_bind_c
)
6538 gfc_error ("BIND(C) attribute at %C requires "
6539 "an interface with BIND(C)");
6542 /* Check for C1217. */
6543 if (has_name_equals
&& sym
->attr
.pointer
)
6545 gfc_error ("BIND(C) procedure with NAME may not have "
6546 "POINTER attribute at %C");
6549 if (has_name_equals
&& sym
->attr
.dummy
)
6551 gfc_error ("Dummy procedure at %C may not have "
6552 "BIND(C) attribute with NAME");
6555 /* Set binding label for BIND(C). */
6556 if (!set_binding_label (&sym
->binding_label
, sym
->name
, num
))
6560 if (!gfc_add_external (&sym
->attr
, NULL
))
6563 if (add_hidden_procptr_result (sym
))
6566 if (!gfc_add_proc (&sym
->attr
, sym
->name
, NULL
))
6569 /* Set interface. */
6570 if (proc_if
!= NULL
)
6572 if (sym
->ts
.type
!= BT_UNKNOWN
)
6574 gfc_error ("Procedure %qs at %L already has basic type of %s",
6575 sym
->name
, &gfc_current_locus
,
6576 gfc_basic_typename (sym
->ts
.type
));
6579 sym
->ts
.interface
= proc_if
;
6580 sym
->attr
.untyped
= 1;
6581 sym
->attr
.if_source
= IFSRC_IFBODY
;
6583 else if (current_ts
.type
!= BT_UNKNOWN
)
6585 if (!gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
6587 sym
->ts
.interface
= gfc_new_symbol ("", gfc_current_ns
);
6588 sym
->ts
.interface
->ts
= current_ts
;
6589 sym
->ts
.interface
->attr
.flavor
= FL_PROCEDURE
;
6590 sym
->ts
.interface
->attr
.function
= 1;
6591 sym
->attr
.function
= 1;
6592 sym
->attr
.if_source
= IFSRC_UNKNOWN
;
6595 if (gfc_match (" =>") == MATCH_YES
)
6597 if (!current_attr
.pointer
)
6599 gfc_error ("Initialization at %C isn't for a pointer variable");
6604 m
= match_pointer_init (&initializer
, 1);
6608 if (!add_init_expr_to_sym (sym
->name
, &initializer
, &gfc_current_locus
))
6613 if (gfc_match_eos () == MATCH_YES
)
6615 if (gfc_match_char (',') != MATCH_YES
)
6620 gfc_error ("Syntax error in PROCEDURE statement at %C");
6624 /* Free stuff up and return. */
6625 gfc_free_expr (initializer
);
6631 match_binding_attributes (gfc_typebound_proc
* ba
, bool generic
, bool ppc
);
6634 /* Match a procedure pointer component declaration (R445). */
6637 match_ppc_decl (void)
6640 gfc_symbol
*proc_if
= NULL
;
6644 gfc_expr
*initializer
= NULL
;
6645 gfc_typebound_proc
* tb
;
6646 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6648 /* Parse interface (with brackets). */
6649 m
= match_procedure_interface (&proc_if
);
6653 /* Parse attributes. */
6654 tb
= XCNEW (gfc_typebound_proc
);
6655 tb
->where
= gfc_current_locus
;
6656 m
= match_binding_attributes (tb
, false, true);
6657 if (m
== MATCH_ERROR
)
6660 gfc_clear_attr (¤t_attr
);
6661 current_attr
.procedure
= 1;
6662 current_attr
.proc_pointer
= 1;
6663 current_attr
.access
= tb
->access
;
6664 current_attr
.flavor
= FL_PROCEDURE
;
6666 /* Match the colons (required). */
6667 if (gfc_match (" ::") != MATCH_YES
)
6669 gfc_error ("Expected %<::%> after binding-attributes at %C");
6673 /* Check for C450. */
6674 if (!tb
->nopass
&& proc_if
== NULL
)
6676 gfc_error("NOPASS or explicit interface required at %C");
6680 if (!gfc_notify_std (GFC_STD_F2003
, "Procedure pointer component at %C"))
6683 /* Match PPC names. */
6687 m
= gfc_match_name (name
);
6690 else if (m
== MATCH_ERROR
)
6693 if (!gfc_add_component (gfc_current_block(), name
, &c
))
6696 /* Add current_attr to the symbol attributes. */
6697 if (!gfc_copy_attr (&c
->attr
, ¤t_attr
, NULL
))
6700 if (!gfc_add_external (&c
->attr
, NULL
))
6703 if (!gfc_add_proc (&c
->attr
, name
, NULL
))
6710 c
->tb
= XCNEW (gfc_typebound_proc
);
6711 c
->tb
->where
= gfc_current_locus
;
6715 /* Set interface. */
6716 if (proc_if
!= NULL
)
6718 c
->ts
.interface
= proc_if
;
6719 c
->attr
.untyped
= 1;
6720 c
->attr
.if_source
= IFSRC_IFBODY
;
6722 else if (ts
.type
!= BT_UNKNOWN
)
6725 c
->ts
.interface
= gfc_new_symbol ("", gfc_current_ns
);
6726 c
->ts
.interface
->result
= c
->ts
.interface
;
6727 c
->ts
.interface
->ts
= ts
;
6728 c
->ts
.interface
->attr
.flavor
= FL_PROCEDURE
;
6729 c
->ts
.interface
->attr
.function
= 1;
6730 c
->attr
.function
= 1;
6731 c
->attr
.if_source
= IFSRC_UNKNOWN
;
6734 if (gfc_match (" =>") == MATCH_YES
)
6736 m
= match_pointer_init (&initializer
, 1);
6739 gfc_free_expr (initializer
);
6742 c
->initializer
= initializer
;
6745 if (gfc_match_eos () == MATCH_YES
)
6747 if (gfc_match_char (',') != MATCH_YES
)
6752 gfc_error ("Syntax error in procedure pointer component at %C");
6757 /* Match a PROCEDURE declaration inside an interface (R1206). */
6760 match_procedure_in_interface (void)
6764 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6767 if (current_interface
.type
== INTERFACE_NAMELESS
6768 || current_interface
.type
== INTERFACE_ABSTRACT
)
6770 gfc_error ("PROCEDURE at %C must be in a generic interface");
6774 /* Check if the F2008 optional double colon appears. */
6775 gfc_gobble_whitespace ();
6776 old_locus
= gfc_current_locus
;
6777 if (gfc_match ("::") == MATCH_YES
)
6779 if (!gfc_notify_std (GFC_STD_F2008
, "double colon in "
6780 "MODULE PROCEDURE statement at %L", &old_locus
))
6784 gfc_current_locus
= old_locus
;
6788 m
= gfc_match_name (name
);
6791 else if (m
== MATCH_ERROR
)
6793 if (gfc_get_symbol (name
, gfc_current_ns
->parent
, &sym
))
6796 if (!gfc_add_interface (sym
))
6799 if (gfc_match_eos () == MATCH_YES
)
6801 if (gfc_match_char (',') != MATCH_YES
)
6808 gfc_error ("Syntax error in PROCEDURE statement at %C");
6813 /* General matcher for PROCEDURE declarations. */
6815 static match
match_procedure_in_type (void);
6818 gfc_match_procedure (void)
6822 switch (gfc_current_state ())
6827 case COMP_SUBMODULE
:
6828 case COMP_SUBROUTINE
:
6831 m
= match_procedure_decl ();
6833 case COMP_INTERFACE
:
6834 m
= match_procedure_in_interface ();
6837 m
= match_ppc_decl ();
6839 case COMP_DERIVED_CONTAINS
:
6840 m
= match_procedure_in_type ();
6849 if (!gfc_notify_std (GFC_STD_F2003
, "PROCEDURE statement at %C"))
6856 /* Warn if a matched procedure has the same name as an intrinsic; this is
6857 simply a wrapper around gfc_warn_intrinsic_shadow that interprets the current
6858 parser-state-stack to find out whether we're in a module. */
6861 do_warn_intrinsic_shadow (const gfc_symbol
* sym
, bool func
)
6865 in_module
= (gfc_state_stack
->previous
6866 && (gfc_state_stack
->previous
->state
== COMP_MODULE
6867 || gfc_state_stack
->previous
->state
== COMP_SUBMODULE
));
6869 gfc_warn_intrinsic_shadow (sym
, in_module
, func
);
6873 /* Match a function declaration. */
6876 gfc_match_function_decl (void)
6878 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6879 gfc_symbol
*sym
, *result
;
6883 match found_match
; /* Status returned by match func. */
6885 if (gfc_current_state () != COMP_NONE
6886 && gfc_current_state () != COMP_INTERFACE
6887 && gfc_current_state () != COMP_CONTAINS
)
6890 gfc_clear_ts (¤t_ts
);
6892 old_loc
= gfc_current_locus
;
6894 m
= gfc_match_prefix (¤t_ts
);
6897 gfc_current_locus
= old_loc
;
6901 if (gfc_match ("function% %n", name
) != MATCH_YES
)
6903 gfc_current_locus
= old_loc
;
6907 if (get_proc_name (name
, &sym
, false))
6910 if (add_hidden_procptr_result (sym
))
6913 if (current_attr
.module_procedure
)
6914 sym
->attr
.module_procedure
= 1;
6916 gfc_new_block
= sym
;
6918 m
= gfc_match_formal_arglist (sym
, 0, 0);
6921 gfc_error ("Expected formal argument list in function "
6922 "definition at %C");
6926 else if (m
== MATCH_ERROR
)
6931 /* According to the draft, the bind(c) and result clause can
6932 come in either order after the formal_arg_list (i.e., either
6933 can be first, both can exist together or by themselves or neither
6934 one). Therefore, the match_result can't match the end of the
6935 string, and check for the bind(c) or result clause in either order. */
6936 found_match
= gfc_match_eos ();
6938 /* Make sure that it isn't already declared as BIND(C). If it is, it
6939 must have been marked BIND(C) with a BIND(C) attribute and that is
6940 not allowed for procedures. */
6941 if (sym
->attr
.is_bind_c
== 1)
6943 sym
->attr
.is_bind_c
= 0;
6944 if (sym
->old_symbol
!= NULL
)
6945 gfc_error_now ("BIND(C) attribute at %L can only be used for "
6946 "variables or common blocks",
6947 &(sym
->old_symbol
->declared_at
));
6949 gfc_error_now ("BIND(C) attribute at %L can only be used for "
6950 "variables or common blocks", &gfc_current_locus
);
6953 if (found_match
!= MATCH_YES
)
6955 /* If we haven't found the end-of-statement, look for a suffix. */
6956 suffix_match
= gfc_match_suffix (sym
, &result
);
6957 if (suffix_match
== MATCH_YES
)
6958 /* Need to get the eos now. */
6959 found_match
= gfc_match_eos ();
6961 found_match
= suffix_match
;
6964 if(found_match
!= MATCH_YES
)
6968 /* Make changes to the symbol. */
6971 if (!gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
6974 if (!gfc_missing_attr (&sym
->attr
, NULL
))
6977 if (!copy_prefix (&sym
->attr
, &sym
->declared_at
))
6979 if(!sym
->attr
.module_procedure
)
6985 /* Delay matching the function characteristics until after the
6986 specification block by signalling kind=-1. */
6987 sym
->declared_at
= old_loc
;
6988 if (current_ts
.type
!= BT_UNKNOWN
)
6989 current_ts
.kind
= -1;
6991 current_ts
.kind
= 0;
6995 if (current_ts
.type
!= BT_UNKNOWN
6996 && !gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
7002 if (current_ts
.type
!= BT_UNKNOWN
7003 && !gfc_add_type (result
, ¤t_ts
, &gfc_current_locus
))
7005 sym
->result
= result
;
7008 /* Warn if this procedure has the same name as an intrinsic. */
7009 do_warn_intrinsic_shadow (sym
, true);
7015 gfc_current_locus
= old_loc
;
7020 /* This is mostly a copy of parse.c(add_global_procedure) but modified to
7021 pass the name of the entry, rather than the gfc_current_block name, and
7022 to return false upon finding an existing global entry. */
7025 add_global_entry (const char *name
, const char *binding_label
, bool sub
,
7029 enum gfc_symbol_type type
;
7031 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
7033 /* Only in Fortran 2003: For procedures with a binding label also the Fortran
7034 name is a global identifier. */
7035 if (!binding_label
|| gfc_notification_std (GFC_STD_F2008
))
7037 s
= gfc_get_gsymbol (name
);
7039 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= type
))
7041 gfc_global_used (s
, where
);
7050 s
->ns
= gfc_current_ns
;
7054 /* Don't add the symbol multiple times. */
7056 && (!gfc_notification_std (GFC_STD_F2008
)
7057 || strcmp (name
, binding_label
) != 0))
7059 s
= gfc_get_gsymbol (binding_label
);
7061 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= type
))
7063 gfc_global_used (s
, where
);
7070 s
->binding_label
= binding_label
;
7073 s
->ns
= gfc_current_ns
;
7081 /* Match an ENTRY statement. */
7084 gfc_match_entry (void)
7089 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7090 gfc_compile_state state
;
7094 bool module_procedure
;
7098 m
= gfc_match_name (name
);
7102 if (!gfc_notify_std (GFC_STD_F2008_OBS
, "ENTRY statement at %C"))
7105 state
= gfc_current_state ();
7106 if (state
!= COMP_SUBROUTINE
&& state
!= COMP_FUNCTION
)
7111 gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
7114 gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
7116 case COMP_SUBMODULE
:
7117 gfc_error ("ENTRY statement at %C cannot appear within a SUBMODULE");
7119 case COMP_BLOCK_DATA
:
7120 gfc_error ("ENTRY statement at %C cannot appear within "
7123 case COMP_INTERFACE
:
7124 gfc_error ("ENTRY statement at %C cannot appear within "
7127 case COMP_STRUCTURE
:
7128 gfc_error ("ENTRY statement at %C cannot appear within "
7129 "a STRUCTURE block");
7132 gfc_error ("ENTRY statement at %C cannot appear within "
7133 "a DERIVED TYPE block");
7136 gfc_error ("ENTRY statement at %C cannot appear within "
7137 "an IF-THEN block");
7140 case COMP_DO_CONCURRENT
:
7141 gfc_error ("ENTRY statement at %C cannot appear within "
7145 gfc_error ("ENTRY statement at %C cannot appear within "
7149 gfc_error ("ENTRY statement at %C cannot appear within "
7153 gfc_error ("ENTRY statement at %C cannot appear within "
7157 gfc_error ("ENTRY statement at %C cannot appear within "
7158 "a contained subprogram");
7161 gfc_error ("Unexpected ENTRY statement at %C");
7166 if ((state
== COMP_SUBROUTINE
|| state
== COMP_FUNCTION
)
7167 && gfc_state_stack
->previous
->state
== COMP_INTERFACE
)
7169 gfc_error ("ENTRY statement at %C cannot appear within an INTERFACE");
7173 module_procedure
= gfc_current_ns
->parent
!= NULL
7174 && gfc_current_ns
->parent
->proc_name
7175 && gfc_current_ns
->parent
->proc_name
->attr
.flavor
7178 if (gfc_current_ns
->parent
!= NULL
7179 && gfc_current_ns
->parent
->proc_name
7180 && !module_procedure
)
7182 gfc_error("ENTRY statement at %C cannot appear in a "
7183 "contained procedure");
7187 /* Module function entries need special care in get_proc_name
7188 because previous references within the function will have
7189 created symbols attached to the current namespace. */
7190 if (get_proc_name (name
, &entry
,
7191 gfc_current_ns
->parent
!= NULL
7192 && module_procedure
))
7195 proc
= gfc_current_block ();
7197 /* Make sure that it isn't already declared as BIND(C). If it is, it
7198 must have been marked BIND(C) with a BIND(C) attribute and that is
7199 not allowed for procedures. */
7200 if (entry
->attr
.is_bind_c
== 1)
7202 entry
->attr
.is_bind_c
= 0;
7203 if (entry
->old_symbol
!= NULL
)
7204 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7205 "variables or common blocks",
7206 &(entry
->old_symbol
->declared_at
));
7208 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7209 "variables or common blocks", &gfc_current_locus
);
7212 /* Check what next non-whitespace character is so we can tell if there
7213 is the required parens if we have a BIND(C). */
7214 old_loc
= gfc_current_locus
;
7215 gfc_gobble_whitespace ();
7216 peek_char
= gfc_peek_ascii_char ();
7218 if (state
== COMP_SUBROUTINE
)
7220 m
= gfc_match_formal_arglist (entry
, 0, 1);
7224 /* Call gfc_match_bind_c with allow_binding_name = true as ENTRY can
7225 never be an internal procedure. */
7226 is_bind_c
= gfc_match_bind_c (entry
, true);
7227 if (is_bind_c
== MATCH_ERROR
)
7229 if (is_bind_c
== MATCH_YES
)
7231 if (peek_char
!= '(')
7233 gfc_error ("Missing required parentheses before BIND(C) at %C");
7236 if (!gfc_add_is_bind_c (&(entry
->attr
), entry
->name
,
7237 &(entry
->declared_at
), 1))
7241 if (!gfc_current_ns
->parent
7242 && !add_global_entry (name
, entry
->binding_label
, true,
7246 /* An entry in a subroutine. */
7247 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
7248 || !gfc_add_subroutine (&entry
->attr
, entry
->name
, NULL
))
7253 /* An entry in a function.
7254 We need to take special care because writing
7259 ENTRY f() RESULT (r)
7261 ENTRY f RESULT (r). */
7262 if (gfc_match_eos () == MATCH_YES
)
7264 gfc_current_locus
= old_loc
;
7265 /* Match the empty argument list, and add the interface to
7267 m
= gfc_match_formal_arglist (entry
, 0, 1);
7270 m
= gfc_match_formal_arglist (entry
, 0, 0);
7277 if (gfc_match_eos () == MATCH_YES
)
7279 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
7280 || !gfc_add_function (&entry
->attr
, entry
->name
, NULL
))
7283 entry
->result
= entry
;
7287 m
= gfc_match_suffix (entry
, &result
);
7289 gfc_syntax_error (ST_ENTRY
);
7295 if (!gfc_add_result (&result
->attr
, result
->name
, NULL
)
7296 || !gfc_add_entry (&entry
->attr
, result
->name
, NULL
)
7297 || !gfc_add_function (&entry
->attr
, result
->name
, NULL
))
7299 entry
->result
= result
;
7303 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
7304 || !gfc_add_function (&entry
->attr
, entry
->name
, NULL
))
7306 entry
->result
= entry
;
7310 if (!gfc_current_ns
->parent
7311 && !add_global_entry (name
, entry
->binding_label
, false,
7316 if (gfc_match_eos () != MATCH_YES
)
7318 gfc_syntax_error (ST_ENTRY
);
7322 entry
->attr
.recursive
= proc
->attr
.recursive
;
7323 entry
->attr
.elemental
= proc
->attr
.elemental
;
7324 entry
->attr
.pure
= proc
->attr
.pure
;
7326 el
= gfc_get_entry_list ();
7328 el
->next
= gfc_current_ns
->entries
;
7329 gfc_current_ns
->entries
= el
;
7331 el
->id
= el
->next
->id
+ 1;
7335 new_st
.op
= EXEC_ENTRY
;
7336 new_st
.ext
.entry
= el
;
7342 /* Match a subroutine statement, including optional prefixes. */
7345 gfc_match_subroutine (void)
7347 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7352 bool allow_binding_name
;
7354 if (gfc_current_state () != COMP_NONE
7355 && gfc_current_state () != COMP_INTERFACE
7356 && gfc_current_state () != COMP_CONTAINS
)
7359 m
= gfc_match_prefix (NULL
);
7363 m
= gfc_match ("subroutine% %n", name
);
7367 if (get_proc_name (name
, &sym
, false))
7370 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
7371 the symbol existed before. */
7372 sym
->declared_at
= gfc_current_locus
;
7374 if (current_attr
.module_procedure
)
7375 sym
->attr
.module_procedure
= 1;
7377 if (add_hidden_procptr_result (sym
))
7380 gfc_new_block
= sym
;
7382 /* Check what next non-whitespace character is so we can tell if there
7383 is the required parens if we have a BIND(C). */
7384 gfc_gobble_whitespace ();
7385 peek_char
= gfc_peek_ascii_char ();
7387 if (!gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
))
7390 if (gfc_match_formal_arglist (sym
, 0, 1) != MATCH_YES
)
7393 /* Make sure that it isn't already declared as BIND(C). If it is, it
7394 must have been marked BIND(C) with a BIND(C) attribute and that is
7395 not allowed for procedures. */
7396 if (sym
->attr
.is_bind_c
== 1)
7398 sym
->attr
.is_bind_c
= 0;
7399 if (sym
->old_symbol
!= NULL
)
7400 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7401 "variables or common blocks",
7402 &(sym
->old_symbol
->declared_at
));
7404 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7405 "variables or common blocks", &gfc_current_locus
);
7408 /* C binding names are not allowed for internal procedures. */
7409 if (gfc_current_state () == COMP_CONTAINS
7410 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
7411 allow_binding_name
= false;
7413 allow_binding_name
= true;
7415 /* Here, we are just checking if it has the bind(c) attribute, and if
7416 so, then we need to make sure it's all correct. If it doesn't,
7417 we still need to continue matching the rest of the subroutine line. */
7418 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
7419 if (is_bind_c
== MATCH_ERROR
)
7421 /* There was an attempt at the bind(c), but it was wrong. An
7422 error message should have been printed w/in the gfc_match_bind_c
7423 so here we'll just return the MATCH_ERROR. */
7427 if (is_bind_c
== MATCH_YES
)
7429 /* The following is allowed in the Fortran 2008 draft. */
7430 if (gfc_current_state () == COMP_CONTAINS
7431 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
7432 && !gfc_notify_std (GFC_STD_F2008
, "BIND(C) attribute "
7433 "at %L may not be specified for an internal "
7434 "procedure", &gfc_current_locus
))
7437 if (peek_char
!= '(')
7439 gfc_error ("Missing required parentheses before BIND(C) at %C");
7442 if (!gfc_add_is_bind_c (&(sym
->attr
), sym
->name
,
7443 &(sym
->declared_at
), 1))
7447 if (gfc_match_eos () != MATCH_YES
)
7449 gfc_syntax_error (ST_SUBROUTINE
);
7453 if (!copy_prefix (&sym
->attr
, &sym
->declared_at
))
7455 if(!sym
->attr
.module_procedure
)
7461 /* Warn if it has the same name as an intrinsic. */
7462 do_warn_intrinsic_shadow (sym
, false);
7468 /* Check that the NAME identifier in a BIND attribute or statement
7469 is conform to C identifier rules. */
7472 check_bind_name_identifier (char **name
)
7474 char *n
= *name
, *p
;
7476 /* Remove leading spaces. */
7480 /* On an empty string, free memory and set name to NULL. */
7488 /* Remove trailing spaces. */
7489 p
= n
+ strlen(n
) - 1;
7493 /* Insert the identifier into the symbol table. */
7498 /* Now check that identifier is valid under C rules. */
7501 gfc_error ("Invalid C identifier in NAME= specifier at %C");
7506 if (!(ISALNUM (*p
) || *p
== '_' || *p
== '$'))
7508 gfc_error ("Invalid C identifier in NAME= specifier at %C");
7516 /* Match a BIND(C) specifier, with the optional 'name=' specifier if
7517 given, and set the binding label in either the given symbol (if not
7518 NULL), or in the current_ts. The symbol may be NULL because we may
7519 encounter the BIND(C) before the declaration itself. Return
7520 MATCH_NO if what we're looking at isn't a BIND(C) specifier,
7521 MATCH_ERROR if it is a BIND(C) clause but an error was encountered,
7522 or MATCH_YES if the specifier was correct and the binding label and
7523 bind(c) fields were set correctly for the given symbol or the
7524 current_ts. If allow_binding_name is false, no binding name may be
7528 gfc_match_bind_c (gfc_symbol
*sym
, bool allow_binding_name
)
7530 char *binding_label
= NULL
;
7533 /* Initialize the flag that specifies whether we encountered a NAME=
7534 specifier or not. */
7535 has_name_equals
= 0;
7537 /* This much we have to be able to match, in this order, if
7538 there is a bind(c) label. */
7539 if (gfc_match (" bind ( c ") != MATCH_YES
)
7542 /* Now see if there is a binding label, or if we've reached the
7543 end of the bind(c) attribute without one. */
7544 if (gfc_match_char (',') == MATCH_YES
)
7546 if (gfc_match (" name = ") != MATCH_YES
)
7548 gfc_error ("Syntax error in NAME= specifier for binding label "
7550 /* should give an error message here */
7554 has_name_equals
= 1;
7556 if (gfc_match_init_expr (&e
) != MATCH_YES
)
7562 if (!gfc_simplify_expr(e
, 0))
7564 gfc_error ("NAME= specifier at %C should be a constant expression");
7569 if (e
->expr_type
!= EXPR_CONSTANT
|| e
->ts
.type
!= BT_CHARACTER
7570 || e
->ts
.kind
!= gfc_default_character_kind
|| e
->rank
!= 0)
7572 gfc_error ("NAME= specifier at %C should be a scalar of "
7573 "default character kind");
7578 // Get a C string from the Fortran string constant
7579 binding_label
= gfc_widechar_to_char (e
->value
.character
.string
,
7580 e
->value
.character
.length
);
7583 // Check that it is valid (old gfc_match_name_C)
7584 if (check_bind_name_identifier (&binding_label
) != MATCH_YES
)
7588 /* Get the required right paren. */
7589 if (gfc_match_char (')') != MATCH_YES
)
7591 gfc_error ("Missing closing paren for binding label at %C");
7595 if (has_name_equals
&& !allow_binding_name
)
7597 gfc_error ("No binding name is allowed in BIND(C) at %C");
7601 if (has_name_equals
&& sym
!= NULL
&& sym
->attr
.dummy
)
7603 gfc_error ("For dummy procedure %s, no binding name is "
7604 "allowed in BIND(C) at %C", sym
->name
);
7609 /* Save the binding label to the symbol. If sym is null, we're
7610 probably matching the typespec attributes of a declaration and
7611 haven't gotten the name yet, and therefore, no symbol yet. */
7615 sym
->binding_label
= binding_label
;
7617 curr_binding_label
= binding_label
;
7619 else if (allow_binding_name
)
7621 /* No binding label, but if symbol isn't null, we
7622 can set the label for it here.
7623 If name="" or allow_binding_name is false, no C binding name is
7625 if (sym
!= NULL
&& sym
->name
!= NULL
&& has_name_equals
== 0)
7626 sym
->binding_label
= IDENTIFIER_POINTER (get_identifier (sym
->name
));
7629 if (has_name_equals
&& gfc_current_state () == COMP_INTERFACE
7630 && current_interface
.type
== INTERFACE_ABSTRACT
)
7632 gfc_error ("NAME not allowed on BIND(C) for ABSTRACT INTERFACE at %C");
7640 /* Return nonzero if we're currently compiling a contained procedure. */
7643 contained_procedure (void)
7645 gfc_state_data
*s
= gfc_state_stack
;
7647 if ((s
->state
== COMP_SUBROUTINE
|| s
->state
== COMP_FUNCTION
)
7648 && s
->previous
!= NULL
&& s
->previous
->state
== COMP_CONTAINS
)
7654 /* Set the kind of each enumerator. The kind is selected such that it is
7655 interoperable with the corresponding C enumeration type, making
7656 sure that -fshort-enums is honored. */
7661 enumerator_history
*current_history
= NULL
;
7665 if (max_enum
== NULL
|| enum_history
== NULL
)
7668 if (!flag_short_enums
)
7674 kind
= gfc_integer_kinds
[i
++].kind
;
7676 while (kind
< gfc_c_int_kind
7677 && gfc_check_integer_range (max_enum
->initializer
->value
.integer
,
7680 current_history
= enum_history
;
7681 while (current_history
!= NULL
)
7683 current_history
->sym
->ts
.kind
= kind
;
7684 current_history
= current_history
->next
;
7689 /* Match any of the various end-block statements. Returns the type of
7690 END to the caller. The END INTERFACE, END IF, END DO, END SELECT
7691 and END BLOCK statements cannot be replaced by a single END statement. */
7694 gfc_match_end (gfc_statement
*st
)
7696 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7697 gfc_compile_state state
;
7699 const char *block_name
;
7703 gfc_namespace
*parent_ns
, *ns
, *prev_ns
;
7704 gfc_namespace
**nsp
;
7705 bool abreviated_modproc_decl
= false;
7706 bool got_matching_end
= false;
7708 old_loc
= gfc_current_locus
;
7709 if (gfc_match ("end") != MATCH_YES
)
7712 state
= gfc_current_state ();
7713 block_name
= gfc_current_block () == NULL
7714 ? NULL
: gfc_current_block ()->name
;
7718 case COMP_ASSOCIATE
:
7720 if (!strncmp (block_name
, "block@", strlen("block@")))
7725 case COMP_DERIVED_CONTAINS
:
7726 state
= gfc_state_stack
->previous
->state
;
7727 block_name
= gfc_state_stack
->previous
->sym
== NULL
7728 ? NULL
: gfc_state_stack
->previous
->sym
->name
;
7729 abreviated_modproc_decl
= gfc_state_stack
->previous
->sym
7730 && gfc_state_stack
->previous
->sym
->abr_modproc_decl
;
7737 if (!abreviated_modproc_decl
)
7738 abreviated_modproc_decl
= gfc_current_block ()
7739 && gfc_current_block ()->abr_modproc_decl
;
7745 *st
= ST_END_PROGRAM
;
7746 target
= " program";
7750 case COMP_SUBROUTINE
:
7751 *st
= ST_END_SUBROUTINE
;
7752 if (!abreviated_modproc_decl
)
7753 target
= " subroutine";
7755 target
= " procedure";
7756 eos_ok
= !contained_procedure ();
7760 *st
= ST_END_FUNCTION
;
7761 if (!abreviated_modproc_decl
)
7762 target
= " function";
7764 target
= " procedure";
7765 eos_ok
= !contained_procedure ();
7768 case COMP_BLOCK_DATA
:
7769 *st
= ST_END_BLOCK_DATA
;
7770 target
= " block data";
7775 *st
= ST_END_MODULE
;
7780 case COMP_SUBMODULE
:
7781 *st
= ST_END_SUBMODULE
;
7782 target
= " submodule";
7786 case COMP_INTERFACE
:
7787 *st
= ST_END_INTERFACE
;
7788 target
= " interface";
7804 case COMP_STRUCTURE
:
7805 *st
= ST_END_STRUCTURE
;
7806 target
= " structure";
7811 case COMP_DERIVED_CONTAINS
:
7817 case COMP_ASSOCIATE
:
7818 *st
= ST_END_ASSOCIATE
;
7819 target
= " associate";
7836 case COMP_DO_CONCURRENT
:
7843 *st
= ST_END_CRITICAL
;
7844 target
= " critical";
7849 case COMP_SELECT_TYPE
:
7850 *st
= ST_END_SELECT
;
7856 *st
= ST_END_FORALL
;
7871 last_initializer
= NULL
;
7873 gfc_free_enum_history ();
7877 gfc_error ("Unexpected END statement at %C");
7881 old_loc
= gfc_current_locus
;
7882 if (gfc_match_eos () == MATCH_YES
)
7884 if (!eos_ok
&& (*st
== ST_END_SUBROUTINE
|| *st
== ST_END_FUNCTION
))
7886 if (!gfc_notify_std (GFC_STD_F2008
, "END statement "
7887 "instead of %s statement at %L",
7888 abreviated_modproc_decl
? "END PROCEDURE"
7889 : gfc_ascii_statement(*st
), &old_loc
))
7894 /* We would have required END [something]. */
7895 gfc_error ("%s statement expected at %L",
7896 gfc_ascii_statement (*st
), &old_loc
);
7903 /* Verify that we've got the sort of end-block that we're expecting. */
7904 if (gfc_match (target
) != MATCH_YES
)
7906 gfc_error ("Expecting %s statement at %L", abreviated_modproc_decl
7907 ? "END PROCEDURE" : gfc_ascii_statement(*st
), &old_loc
);
7911 got_matching_end
= true;
7913 old_loc
= gfc_current_locus
;
7914 /* If we're at the end, make sure a block name wasn't required. */
7915 if (gfc_match_eos () == MATCH_YES
)
7918 if (*st
!= ST_ENDDO
&& *st
!= ST_ENDIF
&& *st
!= ST_END_SELECT
7919 && *st
!= ST_END_FORALL
&& *st
!= ST_END_WHERE
&& *st
!= ST_END_BLOCK
7920 && *st
!= ST_END_ASSOCIATE
&& *st
!= ST_END_CRITICAL
)
7926 gfc_error ("Expected block name of %qs in %s statement at %L",
7927 block_name
, gfc_ascii_statement (*st
), &old_loc
);
7932 /* END INTERFACE has a special handler for its several possible endings. */
7933 if (*st
== ST_END_INTERFACE
)
7934 return gfc_match_end_interface ();
7936 /* We haven't hit the end of statement, so what is left must be an
7938 m
= gfc_match_space ();
7940 m
= gfc_match_name (name
);
7943 gfc_error ("Expected terminating name at %C");
7947 if (block_name
== NULL
)
7950 /* We have to pick out the declared submodule name from the composite
7951 required by F2008:11.2.3 para 2, which ends in the declared name. */
7952 if (state
== COMP_SUBMODULE
)
7953 block_name
= strchr (block_name
, '.') + 1;
7955 if (strcmp (name
, block_name
) != 0 && strcmp (block_name
, "ppr@") != 0)
7957 gfc_error ("Expected label %qs for %s statement at %C", block_name
,
7958 gfc_ascii_statement (*st
));
7961 /* Procedure pointer as function result. */
7962 else if (strcmp (block_name
, "ppr@") == 0
7963 && strcmp (name
, gfc_current_block ()->ns
->proc_name
->name
) != 0)
7965 gfc_error ("Expected label %qs for %s statement at %C",
7966 gfc_current_block ()->ns
->proc_name
->name
,
7967 gfc_ascii_statement (*st
));
7971 if (gfc_match_eos () == MATCH_YES
)
7975 gfc_syntax_error (*st
);
7978 gfc_current_locus
= old_loc
;
7980 /* If we are missing an END BLOCK, we created a half-ready namespace.
7981 Remove it from the parent namespace's sibling list. */
7983 while (state
== COMP_BLOCK
&& !got_matching_end
)
7985 parent_ns
= gfc_current_ns
->parent
;
7987 nsp
= &(gfc_state_stack
->previous
->tail
->ext
.block
.ns
);
7993 if (ns
== gfc_current_ns
)
7995 if (prev_ns
== NULL
)
7998 prev_ns
->sibling
= ns
->sibling
;
8004 gfc_free_namespace (gfc_current_ns
);
8005 gfc_current_ns
= parent_ns
;
8006 gfc_state_stack
= gfc_state_stack
->previous
;
8007 state
= gfc_current_state ();
8015 /***************** Attribute declaration statements ****************/
8017 /* Set the attribute of a single variable. */
8022 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8025 /* Workaround -Wmaybe-uninitialized false positive during
8026 profiledbootstrap by initializing them. */
8027 gfc_symbol
*sym
= NULL
;
8033 m
= gfc_match_name (name
);
8037 if (find_special (name
, &sym
, false))
8040 if (!check_function_name (name
))
8046 var_locus
= gfc_current_locus
;
8048 /* Deal with possible array specification for certain attributes. */
8049 if (current_attr
.dimension
8050 || current_attr
.codimension
8051 || current_attr
.allocatable
8052 || current_attr
.pointer
8053 || current_attr
.target
)
8055 m
= gfc_match_array_spec (&as
, !current_attr
.codimension
,
8056 !current_attr
.dimension
8057 && !current_attr
.pointer
8058 && !current_attr
.target
);
8059 if (m
== MATCH_ERROR
)
8062 if (current_attr
.dimension
&& m
== MATCH_NO
)
8064 gfc_error ("Missing array specification at %L in DIMENSION "
8065 "statement", &var_locus
);
8070 if (current_attr
.dimension
&& sym
->value
)
8072 gfc_error ("Dimensions specified for %s at %L after its "
8073 "initialization", sym
->name
, &var_locus
);
8078 if (current_attr
.codimension
&& m
== MATCH_NO
)
8080 gfc_error ("Missing array specification at %L in CODIMENSION "
8081 "statement", &var_locus
);
8086 if ((current_attr
.allocatable
|| current_attr
.pointer
)
8087 && (m
== MATCH_YES
) && (as
->type
!= AS_DEFERRED
))
8089 gfc_error ("Array specification must be deferred at %L", &var_locus
);
8095 /* Update symbol table. DIMENSION attribute is set in
8096 gfc_set_array_spec(). For CLASS variables, this must be applied
8097 to the first component, or '_data' field. */
8098 if (sym
->ts
.type
== BT_CLASS
&& sym
->ts
.u
.derived
->attr
.is_class
)
8100 if (!gfc_copy_attr (&CLASS_DATA(sym
)->attr
, ¤t_attr
, &var_locus
))
8108 if (current_attr
.dimension
== 0 && current_attr
.codimension
== 0
8109 && !gfc_copy_attr (&sym
->attr
, ¤t_attr
, &var_locus
))
8116 if (sym
->ts
.type
== BT_CLASS
8117 && !gfc_build_class_symbol (&sym
->ts
, &sym
->attr
, &sym
->as
))
8123 if (!gfc_set_array_spec (sym
, as
, &var_locus
))
8129 if (sym
->attr
.cray_pointee
&& sym
->as
!= NULL
)
8131 /* Fix the array spec. */
8132 m
= gfc_mod_pointee_as (sym
->as
);
8133 if (m
== MATCH_ERROR
)
8137 if (!gfc_add_attribute (&sym
->attr
, &var_locus
))
8143 if ((current_attr
.external
|| current_attr
.intrinsic
)
8144 && sym
->attr
.flavor
!= FL_PROCEDURE
8145 && !gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, NULL
))
8151 add_hidden_procptr_result (sym
);
8156 gfc_free_array_spec (as
);
8161 /* Generic attribute declaration subroutine. Used for attributes that
8162 just have a list of names. */
8169 /* Gobble the optional double colon, by simply ignoring the result
8179 if (gfc_match_eos () == MATCH_YES
)
8185 if (gfc_match_char (',') != MATCH_YES
)
8187 gfc_error ("Unexpected character in variable list at %C");
8197 /* This routine matches Cray Pointer declarations of the form:
8198 pointer ( <pointer>, <pointee> )
8200 pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...
8201 The pointer, if already declared, should be an integer. Otherwise, we
8202 set it as BT_INTEGER with kind gfc_index_integer_kind. The pointee may
8203 be either a scalar, or an array declaration. No space is allocated for
8204 the pointee. For the statement
8205 pointer (ipt, ar(10))
8206 any subsequent uses of ar will be translated (in C-notation) as
8207 ar(i) => ((<type> *) ipt)(i)
8208 After gimplification, pointee variable will disappear in the code. */
8211 cray_pointer_decl (void)
8214 gfc_array_spec
*as
= NULL
;
8215 gfc_symbol
*cptr
; /* Pointer symbol. */
8216 gfc_symbol
*cpte
; /* Pointee symbol. */
8222 if (gfc_match_char ('(') != MATCH_YES
)
8224 gfc_error ("Expected %<(%> at %C");
8228 /* Match pointer. */
8229 var_locus
= gfc_current_locus
;
8230 gfc_clear_attr (¤t_attr
);
8231 gfc_add_cray_pointer (¤t_attr
, &var_locus
);
8232 current_ts
.type
= BT_INTEGER
;
8233 current_ts
.kind
= gfc_index_integer_kind
;
8235 m
= gfc_match_symbol (&cptr
, 0);
8238 gfc_error ("Expected variable name at %C");
8242 if (!gfc_add_cray_pointer (&cptr
->attr
, &var_locus
))
8245 gfc_set_sym_referenced (cptr
);
8247 if (cptr
->ts
.type
== BT_UNKNOWN
) /* Override the type, if necessary. */
8249 cptr
->ts
.type
= BT_INTEGER
;
8250 cptr
->ts
.kind
= gfc_index_integer_kind
;
8252 else if (cptr
->ts
.type
!= BT_INTEGER
)
8254 gfc_error ("Cray pointer at %C must be an integer");
8257 else if (cptr
->ts
.kind
< gfc_index_integer_kind
)
8258 gfc_warning (0, "Cray pointer at %C has %d bytes of precision;"
8259 " memory addresses require %d bytes",
8260 cptr
->ts
.kind
, gfc_index_integer_kind
);
8262 if (gfc_match_char (',') != MATCH_YES
)
8264 gfc_error ("Expected \",\" at %C");
8268 /* Match Pointee. */
8269 var_locus
= gfc_current_locus
;
8270 gfc_clear_attr (¤t_attr
);
8271 gfc_add_cray_pointee (¤t_attr
, &var_locus
);
8272 current_ts
.type
= BT_UNKNOWN
;
8273 current_ts
.kind
= 0;
8275 m
= gfc_match_symbol (&cpte
, 0);
8278 gfc_error ("Expected variable name at %C");
8282 /* Check for an optional array spec. */
8283 m
= gfc_match_array_spec (&as
, true, false);
8284 if (m
== MATCH_ERROR
)
8286 gfc_free_array_spec (as
);
8289 else if (m
== MATCH_NO
)
8291 gfc_free_array_spec (as
);
8295 if (!gfc_add_cray_pointee (&cpte
->attr
, &var_locus
))
8298 gfc_set_sym_referenced (cpte
);
8300 if (cpte
->as
== NULL
)
8302 if (!gfc_set_array_spec (cpte
, as
, &var_locus
))
8303 gfc_internal_error ("Couldn't set Cray pointee array spec.");
8305 else if (as
!= NULL
)
8307 gfc_error ("Duplicate array spec for Cray pointee at %C");
8308 gfc_free_array_spec (as
);
8314 if (cpte
->as
!= NULL
)
8316 /* Fix array spec. */
8317 m
= gfc_mod_pointee_as (cpte
->as
);
8318 if (m
== MATCH_ERROR
)
8322 /* Point the Pointee at the Pointer. */
8323 cpte
->cp_pointer
= cptr
;
8325 if (gfc_match_char (')') != MATCH_YES
)
8327 gfc_error ("Expected \")\" at %C");
8330 m
= gfc_match_char (',');
8332 done
= true; /* Stop searching for more declarations. */
8336 if (m
== MATCH_ERROR
/* Failed when trying to find ',' above. */
8337 || gfc_match_eos () != MATCH_YES
)
8339 gfc_error ("Expected %<,%> or end of statement at %C");
8347 gfc_match_external (void)
8350 gfc_clear_attr (¤t_attr
);
8351 current_attr
.external
= 1;
8353 return attr_decl ();
8358 gfc_match_intent (void)
8362 /* This is not allowed within a BLOCK construct! */
8363 if (gfc_current_state () == COMP_BLOCK
)
8365 gfc_error ("INTENT is not allowed inside of BLOCK at %C");
8369 intent
= match_intent_spec ();
8370 if (intent
== INTENT_UNKNOWN
)
8373 gfc_clear_attr (¤t_attr
);
8374 current_attr
.intent
= intent
;
8376 return attr_decl ();
8381 gfc_match_intrinsic (void)
8384 gfc_clear_attr (¤t_attr
);
8385 current_attr
.intrinsic
= 1;
8387 return attr_decl ();
8392 gfc_match_optional (void)
8394 /* This is not allowed within a BLOCK construct! */
8395 if (gfc_current_state () == COMP_BLOCK
)
8397 gfc_error ("OPTIONAL is not allowed inside of BLOCK at %C");
8401 gfc_clear_attr (¤t_attr
);
8402 current_attr
.optional
= 1;
8404 return attr_decl ();
8409 gfc_match_pointer (void)
8411 gfc_gobble_whitespace ();
8412 if (gfc_peek_ascii_char () == '(')
8414 if (!flag_cray_pointer
)
8416 gfc_error ("Cray pointer declaration at %C requires -fcray-pointer "
8420 return cray_pointer_decl ();
8424 gfc_clear_attr (¤t_attr
);
8425 current_attr
.pointer
= 1;
8427 return attr_decl ();
8433 gfc_match_allocatable (void)
8435 gfc_clear_attr (¤t_attr
);
8436 current_attr
.allocatable
= 1;
8438 return attr_decl ();
8443 gfc_match_codimension (void)
8445 gfc_clear_attr (¤t_attr
);
8446 current_attr
.codimension
= 1;
8448 return attr_decl ();
8453 gfc_match_contiguous (void)
8455 if (!gfc_notify_std (GFC_STD_F2008
, "CONTIGUOUS statement at %C"))
8458 gfc_clear_attr (¤t_attr
);
8459 current_attr
.contiguous
= 1;
8461 return attr_decl ();
8466 gfc_match_dimension (void)
8468 gfc_clear_attr (¤t_attr
);
8469 current_attr
.dimension
= 1;
8471 return attr_decl ();
8476 gfc_match_target (void)
8478 gfc_clear_attr (¤t_attr
);
8479 current_attr
.target
= 1;
8481 return attr_decl ();
8485 /* Match the list of entities being specified in a PUBLIC or PRIVATE
8489 access_attr_decl (gfc_statement st
)
8491 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8492 interface_type type
;
8494 gfc_symbol
*sym
, *dt_sym
;
8495 gfc_intrinsic_op op
;
8498 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
8503 m
= gfc_match_generic_spec (&type
, name
, &op
);
8506 if (m
== MATCH_ERROR
)
8511 case INTERFACE_NAMELESS
:
8512 case INTERFACE_ABSTRACT
:
8515 case INTERFACE_GENERIC
:
8516 case INTERFACE_DTIO
:
8518 if (gfc_get_symbol (name
, NULL
, &sym
))
8521 if (type
== INTERFACE_DTIO
8522 && gfc_current_ns
->proc_name
8523 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
8524 && sym
->attr
.flavor
== FL_UNKNOWN
)
8525 sym
->attr
.flavor
= FL_PROCEDURE
;
8527 if (!gfc_add_access (&sym
->attr
,
8529 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
,
8533 if (sym
->attr
.generic
&& (dt_sym
= gfc_find_dt_in_generic (sym
))
8534 && !gfc_add_access (&dt_sym
->attr
,
8536 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
,
8542 case INTERFACE_INTRINSIC_OP
:
8543 if (gfc_current_ns
->operator_access
[op
] == ACCESS_UNKNOWN
)
8545 gfc_intrinsic_op other_op
;
8547 gfc_current_ns
->operator_access
[op
] =
8548 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
8550 /* Handle the case if there is another op with the same
8551 function, for INTRINSIC_EQ vs. INTRINSIC_EQ_OS and so on. */
8552 other_op
= gfc_equivalent_op (op
);
8554 if (other_op
!= INTRINSIC_NONE
)
8555 gfc_current_ns
->operator_access
[other_op
] =
8556 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
8561 gfc_error ("Access specification of the %s operator at %C has "
8562 "already been specified", gfc_op2string (op
));
8568 case INTERFACE_USER_OP
:
8569 uop
= gfc_get_uop (name
);
8571 if (uop
->access
== ACCESS_UNKNOWN
)
8573 uop
->access
= (st
== ST_PUBLIC
)
8574 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
8578 gfc_error ("Access specification of the .%s. operator at %C "
8579 "has already been specified", sym
->name
);
8586 if (gfc_match_char (',') == MATCH_NO
)
8590 if (gfc_match_eos () != MATCH_YES
)
8595 gfc_syntax_error (st
);
8603 gfc_match_protected (void)
8608 if (!gfc_current_ns
->proc_name
8609 || gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
8611 gfc_error ("PROTECTED at %C only allowed in specification "
8612 "part of a module");
8617 if (!gfc_notify_std (GFC_STD_F2003
, "PROTECTED statement at %C"))
8620 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
8625 if (gfc_match_eos () == MATCH_YES
)
8630 m
= gfc_match_symbol (&sym
, 0);
8634 if (!gfc_add_protected (&sym
->attr
, sym
->name
, &gfc_current_locus
))
8646 if (gfc_match_eos () == MATCH_YES
)
8648 if (gfc_match_char (',') != MATCH_YES
)
8655 gfc_error ("Syntax error in PROTECTED statement at %C");
8660 /* The PRIVATE statement is a bit weird in that it can be an attribute
8661 declaration, but also works as a standalone statement inside of a
8662 type declaration or a module. */
8665 gfc_match_private (gfc_statement
*st
)
8668 if (gfc_match ("private") != MATCH_YES
)
8671 if (gfc_current_state () != COMP_MODULE
8672 && !(gfc_current_state () == COMP_DERIVED
8673 && gfc_state_stack
->previous
8674 && gfc_state_stack
->previous
->state
== COMP_MODULE
)
8675 && !(gfc_current_state () == COMP_DERIVED_CONTAINS
8676 && gfc_state_stack
->previous
&& gfc_state_stack
->previous
->previous
8677 && gfc_state_stack
->previous
->previous
->state
== COMP_MODULE
))
8679 gfc_error ("PRIVATE statement at %C is only allowed in the "
8680 "specification part of a module");
8684 if (gfc_current_state () == COMP_DERIVED
)
8686 if (gfc_match_eos () == MATCH_YES
)
8692 gfc_syntax_error (ST_PRIVATE
);
8696 if (gfc_match_eos () == MATCH_YES
)
8703 return access_attr_decl (ST_PRIVATE
);
8708 gfc_match_public (gfc_statement
*st
)
8711 if (gfc_match ("public") != MATCH_YES
)
8714 if (gfc_current_state () != COMP_MODULE
)
8716 gfc_error ("PUBLIC statement at %C is only allowed in the "
8717 "specification part of a module");
8721 if (gfc_match_eos () == MATCH_YES
)
8728 return access_attr_decl (ST_PUBLIC
);
8732 /* Workhorse for gfc_match_parameter. */
8742 m
= gfc_match_symbol (&sym
, 0);
8744 gfc_error ("Expected variable name at %C in PARAMETER statement");
8749 if (gfc_match_char ('=') == MATCH_NO
)
8751 gfc_error ("Expected = sign in PARAMETER statement at %C");
8755 m
= gfc_match_init_expr (&init
);
8757 gfc_error ("Expected expression at %C in PARAMETER statement");
8761 if (sym
->ts
.type
== BT_UNKNOWN
8762 && !gfc_set_default_type (sym
, 1, NULL
))
8768 if (!gfc_check_assign_symbol (sym
, NULL
, init
)
8769 || !gfc_add_flavor (&sym
->attr
, FL_PARAMETER
, sym
->name
, NULL
))
8777 gfc_error ("Initializing already initialized variable at %C");
8782 t
= add_init_expr_to_sym (sym
->name
, &init
, &gfc_current_locus
);
8783 return (t
) ? MATCH_YES
: MATCH_ERROR
;
8786 gfc_free_expr (init
);
8791 /* Match a parameter statement, with the weird syntax that these have. */
8794 gfc_match_parameter (void)
8796 const char *term
= " )%t";
8799 if (gfc_match_char ('(') == MATCH_NO
)
8801 /* With legacy PARAMETER statements, don't expect a terminating ')'. */
8802 if (!gfc_notify_std (GFC_STD_LEGACY
, "PARAMETER without '()' at %C"))
8813 if (gfc_match (term
) == MATCH_YES
)
8816 if (gfc_match_char (',') != MATCH_YES
)
8818 gfc_error ("Unexpected characters in PARAMETER statement at %C");
8829 gfc_match_automatic (void)
8833 bool seen_symbol
= false;
8835 if (!flag_dec_static
)
8837 gfc_error ("%s at %C is a DEC extension, enable with "
8848 m
= gfc_match_symbol (&sym
, 0);
8858 if (!gfc_add_automatic (&sym
->attr
, sym
->name
, &gfc_current_locus
))
8864 if (gfc_match_eos () == MATCH_YES
)
8866 if (gfc_match_char (',') != MATCH_YES
)
8872 gfc_error ("Expected entity-list in AUTOMATIC statement at %C");
8879 gfc_error ("Syntax error in AUTOMATIC statement at %C");
8885 gfc_match_static (void)
8889 bool seen_symbol
= false;
8891 if (!flag_dec_static
)
8893 gfc_error ("%s at %C is a DEC extension, enable with "
8903 m
= gfc_match_symbol (&sym
, 0);
8913 if (!gfc_add_save (&sym
->attr
, SAVE_EXPLICIT
, sym
->name
,
8914 &gfc_current_locus
))
8920 if (gfc_match_eos () == MATCH_YES
)
8922 if (gfc_match_char (',') != MATCH_YES
)
8928 gfc_error ("Expected entity-list in STATIC statement at %C");
8935 gfc_error ("Syntax error in STATIC statement at %C");
8940 /* Save statements have a special syntax. */
8943 gfc_match_save (void)
8945 char n
[GFC_MAX_SYMBOL_LEN
+1];
8950 if (gfc_match_eos () == MATCH_YES
)
8952 if (gfc_current_ns
->seen_save
)
8954 if (!gfc_notify_std (GFC_STD_LEGACY
, "Blanket SAVE statement at %C "
8955 "follows previous SAVE statement"))
8959 gfc_current_ns
->save_all
= gfc_current_ns
->seen_save
= 1;
8963 if (gfc_current_ns
->save_all
)
8965 if (!gfc_notify_std (GFC_STD_LEGACY
, "SAVE statement at %C follows "
8966 "blanket SAVE statement"))
8974 m
= gfc_match_symbol (&sym
, 0);
8978 if (!gfc_add_save (&sym
->attr
, SAVE_EXPLICIT
, sym
->name
,
8979 &gfc_current_locus
))
8990 m
= gfc_match (" / %n /", &n
);
8991 if (m
== MATCH_ERROR
)
8996 c
= gfc_get_common (n
, 0);
8999 gfc_current_ns
->seen_save
= 1;
9002 if (gfc_match_eos () == MATCH_YES
)
9004 if (gfc_match_char (',') != MATCH_YES
)
9011 gfc_error ("Syntax error in SAVE statement at %C");
9017 gfc_match_value (void)
9022 /* This is not allowed within a BLOCK construct! */
9023 if (gfc_current_state () == COMP_BLOCK
)
9025 gfc_error ("VALUE is not allowed inside of BLOCK at %C");
9029 if (!gfc_notify_std (GFC_STD_F2003
, "VALUE statement at %C"))
9032 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
9037 if (gfc_match_eos () == MATCH_YES
)
9042 m
= gfc_match_symbol (&sym
, 0);
9046 if (!gfc_add_value (&sym
->attr
, sym
->name
, &gfc_current_locus
))
9058 if (gfc_match_eos () == MATCH_YES
)
9060 if (gfc_match_char (',') != MATCH_YES
)
9067 gfc_error ("Syntax error in VALUE statement at %C");
9073 gfc_match_volatile (void)
9078 if (!gfc_notify_std (GFC_STD_F2003
, "VOLATILE statement at %C"))
9081 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
9086 if (gfc_match_eos () == MATCH_YES
)
9091 /* VOLATILE is special because it can be added to host-associated
9092 symbols locally. Except for coarrays. */
9093 m
= gfc_match_symbol (&sym
, 1);
9097 /* F2008, C560+C561. VOLATILE for host-/use-associated variable or
9098 for variable in a BLOCK which is defined outside of the BLOCK. */
9099 if (sym
->ns
!= gfc_current_ns
&& sym
->attr
.codimension
)
9101 gfc_error ("Specifying VOLATILE for coarray variable %qs at "
9102 "%C, which is use-/host-associated", sym
->name
);
9105 if (!gfc_add_volatile (&sym
->attr
, sym
->name
, &gfc_current_locus
))
9117 if (gfc_match_eos () == MATCH_YES
)
9119 if (gfc_match_char (',') != MATCH_YES
)
9126 gfc_error ("Syntax error in VOLATILE statement at %C");
9132 gfc_match_asynchronous (void)
9137 if (!gfc_notify_std (GFC_STD_F2003
, "ASYNCHRONOUS statement at %C"))
9140 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
9145 if (gfc_match_eos () == MATCH_YES
)
9150 /* ASYNCHRONOUS is special because it can be added to host-associated
9152 m
= gfc_match_symbol (&sym
, 1);
9156 if (!gfc_add_asynchronous (&sym
->attr
, sym
->name
, &gfc_current_locus
))
9168 if (gfc_match_eos () == MATCH_YES
)
9170 if (gfc_match_char (',') != MATCH_YES
)
9177 gfc_error ("Syntax error in ASYNCHRONOUS statement at %C");
9182 /* Match a module procedure statement in a submodule. */
9185 gfc_match_submod_proc (void)
9187 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9188 gfc_symbol
*sym
, *fsym
;
9190 gfc_formal_arglist
*formal
, *head
, *tail
;
9192 if (gfc_current_state () != COMP_CONTAINS
9193 || !(gfc_state_stack
->previous
9194 && (gfc_state_stack
->previous
->state
== COMP_SUBMODULE
9195 || gfc_state_stack
->previous
->state
== COMP_MODULE
)))
9198 m
= gfc_match (" module% procedure% %n", name
);
9202 if (!gfc_notify_std (GFC_STD_F2008
, "MODULE PROCEDURE declaration "
9206 if (get_proc_name (name
, &sym
, false))
9209 /* Make sure that the result field is appropriately filled, even though
9210 the result symbol will be replaced later on. */
9211 if (sym
->tlink
&& sym
->tlink
->attr
.function
)
9213 if (sym
->tlink
->result
9214 && sym
->tlink
->result
!= sym
->tlink
)
9215 sym
->result
= sym
->tlink
->result
;
9220 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
9221 the symbol existed before. */
9222 sym
->declared_at
= gfc_current_locus
;
9224 if (!sym
->attr
.module_procedure
)
9227 /* Signal match_end to expect "end procedure". */
9228 sym
->abr_modproc_decl
= 1;
9230 /* Change from IFSRC_IFBODY coming from the interface declaration. */
9231 sym
->attr
.if_source
= IFSRC_DECL
;
9233 gfc_new_block
= sym
;
9235 /* Make a new formal arglist with the symbols in the procedure
9238 for (formal
= sym
->formal
; formal
&& formal
->sym
; formal
= formal
->next
)
9240 if (formal
== sym
->formal
)
9241 head
= tail
= gfc_get_formal_arglist ();
9244 tail
->next
= gfc_get_formal_arglist ();
9248 if (gfc_copy_dummy_sym (&fsym
, formal
->sym
, 0))
9252 gfc_set_sym_referenced (fsym
);
9255 /* The dummy symbols get cleaned up, when the formal_namespace of the
9256 interface declaration is cleared. This allows us to add the
9257 explicit interface as is done for other type of procedure. */
9258 if (!gfc_add_explicit_interface (sym
, IFSRC_DECL
, head
,
9259 &gfc_current_locus
))
9262 if (gfc_match_eos () != MATCH_YES
)
9264 gfc_syntax_error (ST_MODULE_PROC
);
9271 gfc_free_formal_arglist (head
);
9276 /* Match a module procedure statement. Note that we have to modify
9277 symbols in the parent's namespace because the current one was there
9278 to receive symbols that are in an interface's formal argument list. */
9281 gfc_match_modproc (void)
9283 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9287 gfc_namespace
*module_ns
;
9288 gfc_interface
*old_interface_head
, *interface
;
9290 if (gfc_state_stack
->state
!= COMP_INTERFACE
9291 || gfc_state_stack
->previous
== NULL
9292 || current_interface
.type
== INTERFACE_NAMELESS
9293 || current_interface
.type
== INTERFACE_ABSTRACT
)
9295 gfc_error ("MODULE PROCEDURE at %C must be in a generic module "
9300 module_ns
= gfc_current_ns
->parent
;
9301 for (; module_ns
; module_ns
= module_ns
->parent
)
9302 if (module_ns
->proc_name
->attr
.flavor
== FL_MODULE
9303 || module_ns
->proc_name
->attr
.flavor
== FL_PROGRAM
9304 || (module_ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
9305 && !module_ns
->proc_name
->attr
.contained
))
9308 if (module_ns
== NULL
)
9311 /* Store the current state of the interface. We will need it if we
9312 end up with a syntax error and need to recover. */
9313 old_interface_head
= gfc_current_interface_head ();
9315 /* Check if the F2008 optional double colon appears. */
9316 gfc_gobble_whitespace ();
9317 old_locus
= gfc_current_locus
;
9318 if (gfc_match ("::") == MATCH_YES
)
9320 if (!gfc_notify_std (GFC_STD_F2008
, "double colon in "
9321 "MODULE PROCEDURE statement at %L", &old_locus
))
9325 gfc_current_locus
= old_locus
;
9330 old_locus
= gfc_current_locus
;
9332 m
= gfc_match_name (name
);
9338 /* Check for syntax error before starting to add symbols to the
9339 current namespace. */
9340 if (gfc_match_eos () == MATCH_YES
)
9343 if (!last
&& gfc_match_char (',') != MATCH_YES
)
9346 /* Now we're sure the syntax is valid, we process this item
9348 if (gfc_get_symbol (name
, module_ns
, &sym
))
9351 if (sym
->attr
.intrinsic
)
9353 gfc_error ("Intrinsic procedure at %L cannot be a MODULE "
9354 "PROCEDURE", &old_locus
);
9358 if (sym
->attr
.proc
!= PROC_MODULE
9359 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
9362 if (!gfc_add_interface (sym
))
9365 sym
->attr
.mod_proc
= 1;
9366 sym
->declared_at
= old_locus
;
9375 /* Restore the previous state of the interface. */
9376 interface
= gfc_current_interface_head ();
9377 gfc_set_current_interface_head (old_interface_head
);
9379 /* Free the new interfaces. */
9380 while (interface
!= old_interface_head
)
9382 gfc_interface
*i
= interface
->next
;
9387 /* And issue a syntax error. */
9388 gfc_syntax_error (ST_MODULE_PROC
);
9393 /* Check a derived type that is being extended. */
9396 check_extended_derived_type (char *name
)
9398 gfc_symbol
*extended
;
9400 if (gfc_find_symbol (name
, gfc_current_ns
, 1, &extended
))
9402 gfc_error ("Ambiguous symbol in TYPE definition at %C");
9406 extended
= gfc_find_dt_in_generic (extended
);
9411 gfc_error ("Symbol %qs at %C has not been previously defined", name
);
9415 if (extended
->attr
.flavor
!= FL_DERIVED
)
9417 gfc_error ("%qs in EXTENDS expression at %C is not a "
9418 "derived type", name
);
9422 if (extended
->attr
.is_bind_c
)
9424 gfc_error ("%qs cannot be extended at %C because it "
9425 "is BIND(C)", extended
->name
);
9429 if (extended
->attr
.sequence
)
9431 gfc_error ("%qs cannot be extended at %C because it "
9432 "is a SEQUENCE type", extended
->name
);
9440 /* Match the optional attribute specifiers for a type declaration.
9441 Return MATCH_ERROR if an error is encountered in one of the handled
9442 attributes (public, private, bind(c)), MATCH_NO if what's found is
9443 not a handled attribute, and MATCH_YES otherwise. TODO: More error
9444 checking on attribute conflicts needs to be done. */
9447 gfc_get_type_attr_spec (symbol_attribute
*attr
, char *name
)
9449 /* See if the derived type is marked as private. */
9450 if (gfc_match (" , private") == MATCH_YES
)
9452 if (gfc_current_state () != COMP_MODULE
)
9454 gfc_error ("Derived type at %C can only be PRIVATE in the "
9455 "specification part of a module");
9459 if (!gfc_add_access (attr
, ACCESS_PRIVATE
, NULL
, NULL
))
9462 else if (gfc_match (" , public") == MATCH_YES
)
9464 if (gfc_current_state () != COMP_MODULE
)
9466 gfc_error ("Derived type at %C can only be PUBLIC in the "
9467 "specification part of a module");
9471 if (!gfc_add_access (attr
, ACCESS_PUBLIC
, NULL
, NULL
))
9474 else if (gfc_match (" , bind ( c )") == MATCH_YES
)
9476 /* If the type is defined to be bind(c) it then needs to make
9477 sure that all fields are interoperable. This will
9478 need to be a semantic check on the finished derived type.
9479 See 15.2.3 (lines 9-12) of F2003 draft. */
9480 if (!gfc_add_is_bind_c (attr
, NULL
, &gfc_current_locus
, 0))
9483 /* TODO: attr conflicts need to be checked, probably in symbol.c. */
9485 else if (gfc_match (" , abstract") == MATCH_YES
)
9487 if (!gfc_notify_std (GFC_STD_F2003
, "ABSTRACT type at %C"))
9490 if (!gfc_add_abstract (attr
, &gfc_current_locus
))
9493 else if (name
&& gfc_match (" , extends ( %n )", name
) == MATCH_YES
)
9495 if (!gfc_add_extension (attr
, &gfc_current_locus
))
9501 /* If we get here, something matched. */
9506 /* Common function for type declaration blocks similar to derived types, such
9507 as STRUCTURES and MAPs. Unlike derived types, a structure type
9508 does NOT have a generic symbol matching the name given by the user.
9509 STRUCTUREs can share names with variables and PARAMETERs so we must allow
9510 for the creation of an independent symbol.
9511 Other parameters are a message to prefix errors with, the name of the new
9512 type to be created, and the flavor to add to the resulting symbol. */
9515 get_struct_decl (const char *name
, sym_flavor fl
, locus
*decl
,
9516 gfc_symbol
**result
)
9521 gcc_assert (name
[0] == (char) TOUPPER (name
[0]));
9526 where
= gfc_current_locus
;
9528 if (gfc_get_symbol (name
, NULL
, &sym
))
9533 gfc_internal_error ("Failed to create structure type '%s' at %C", name
);
9537 if (sym
->components
!= NULL
|| sym
->attr
.zero_comp
)
9539 gfc_error ("Type definition of %qs at %C was already defined at %L",
9540 sym
->name
, &sym
->declared_at
);
9544 sym
->declared_at
= where
;
9546 if (sym
->attr
.flavor
!= fl
9547 && !gfc_add_flavor (&sym
->attr
, fl
, sym
->name
, NULL
))
9550 if (!sym
->hash_value
)
9551 /* Set the hash for the compound name for this type. */
9552 sym
->hash_value
= gfc_hash_value (sym
);
9554 /* Normally the type is expected to have been completely parsed by the time
9555 a field declaration with this type is seen. For unions, maps, and nested
9556 structure declarations, we need to indicate that it is okay that we
9557 haven't seen any components yet. This will be updated after the structure
9559 sym
->attr
.zero_comp
= 0;
9561 /* Structures always act like derived-types with the SEQUENCE attribute */
9562 gfc_add_sequence (&sym
->attr
, sym
->name
, NULL
);
9564 if (result
) *result
= sym
;
9570 /* Match the opening of a MAP block. Like a struct within a union in C;
9571 behaves identical to STRUCTURE blocks. */
9574 gfc_match_map (void)
9576 /* Counter used to give unique internal names to map structures. */
9577 static unsigned int gfc_map_id
= 0;
9578 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9582 old_loc
= gfc_current_locus
;
9584 if (gfc_match_eos () != MATCH_YES
)
9586 gfc_error ("Junk after MAP statement at %C");
9587 gfc_current_locus
= old_loc
;
9591 /* Map blocks are anonymous so we make up unique names for the symbol table
9592 which are invalid Fortran identifiers. */
9593 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "MM$%u", gfc_map_id
++);
9595 if (!get_struct_decl (name
, FL_STRUCT
, &old_loc
, &sym
))
9598 gfc_new_block
= sym
;
9604 /* Match the opening of a UNION block. */
9607 gfc_match_union (void)
9609 /* Counter used to give unique internal names to union types. */
9610 static unsigned int gfc_union_id
= 0;
9611 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9615 old_loc
= gfc_current_locus
;
9617 if (gfc_match_eos () != MATCH_YES
)
9619 gfc_error ("Junk after UNION statement at %C");
9620 gfc_current_locus
= old_loc
;
9624 /* Unions are anonymous so we make up unique names for the symbol table
9625 which are invalid Fortran identifiers. */
9626 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "UU$%u", gfc_union_id
++);
9628 if (!get_struct_decl (name
, FL_UNION
, &old_loc
, &sym
))
9631 gfc_new_block
= sym
;
9637 /* Match the beginning of a STRUCTURE declaration. This is similar to
9638 matching the beginning of a derived type declaration with a few
9639 twists. The resulting type symbol has no access control or other
9640 interesting attributes. */
9643 gfc_match_structure_decl (void)
9645 /* Counter used to give unique internal names to anonymous structures. */
9646 static unsigned int gfc_structure_id
= 0;
9647 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9652 if (!flag_dec_structure
)
9654 gfc_error ("%s at %C is a DEC extension, enable with "
9655 "%<-fdec-structure%>",
9662 m
= gfc_match (" /%n/", name
);
9665 /* Non-nested structure declarations require a structure name. */
9666 if (!gfc_comp_struct (gfc_current_state ()))
9668 gfc_error ("Structure name expected in non-nested structure "
9669 "declaration at %C");
9672 /* This is an anonymous structure; make up a unique name for it
9673 (upper-case letters never make it to symbol names from the source).
9674 The important thing is initializing the type variable
9675 and setting gfc_new_symbol, which is immediately used by
9676 parse_structure () and variable_decl () to add components of
9678 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "SS$%u", gfc_structure_id
++);
9681 where
= gfc_current_locus
;
9682 /* No field list allowed after non-nested structure declaration. */
9683 if (!gfc_comp_struct (gfc_current_state ())
9684 && gfc_match_eos () != MATCH_YES
)
9686 gfc_error ("Junk after non-nested STRUCTURE statement at %C");
9690 /* Make sure the name is not the name of an intrinsic type. */
9691 if (gfc_is_intrinsic_typename (name
))
9693 gfc_error ("Structure name %qs at %C cannot be the same as an"
9694 " intrinsic type", name
);
9698 /* Store the actual type symbol for the structure with an upper-case first
9699 letter (an invalid Fortran identifier). */
9701 if (!get_struct_decl (gfc_dt_upper_string (name
), FL_STRUCT
, &where
, &sym
))
9704 gfc_new_block
= sym
;
9709 /* This function does some work to determine which matcher should be used to
9710 * match a statement beginning with "TYPE". This is used to disambiguate TYPE
9711 * as an alias for PRINT from derived type declarations, TYPE IS statements,
9712 * and derived type data declarations. */
9715 gfc_match_type (gfc_statement
*st
)
9717 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9721 /* Requires -fdec. */
9725 m
= gfc_match ("type");
9728 /* If we already have an error in the buffer, it is probably from failing to
9729 * match a derived type data declaration. Let it happen. */
9730 else if (gfc_error_flag_test ())
9733 old_loc
= gfc_current_locus
;
9736 /* If we see an attribute list before anything else it's definitely a derived
9737 * type declaration. */
9738 if (gfc_match (" ,") == MATCH_YES
|| gfc_match (" ::") == MATCH_YES
)
9740 gfc_current_locus
= old_loc
;
9741 *st
= ST_DERIVED_DECL
;
9742 return gfc_match_derived_decl ();
9745 /* By now "TYPE" has already been matched. If we do not see a name, this may
9746 * be something like "TYPE *" or "TYPE <fmt>". */
9747 m
= gfc_match_name (name
);
9750 /* Let print match if it can, otherwise throw an error from
9751 * gfc_match_derived_decl. */
9752 gfc_current_locus
= old_loc
;
9753 if (gfc_match_print () == MATCH_YES
)
9758 gfc_current_locus
= old_loc
;
9759 *st
= ST_DERIVED_DECL
;
9760 return gfc_match_derived_decl ();
9763 /* A derived type declaration requires an EOS. Without it, assume print. */
9764 m
= gfc_match_eos ();
9767 /* Check manually for TYPE IS (... - this is invalid print syntax. */
9768 if (strncmp ("is", name
, 3) == 0
9769 && gfc_match (" (", name
) == MATCH_YES
)
9771 gfc_current_locus
= old_loc
;
9772 gcc_assert (gfc_match (" is") == MATCH_YES
);
9774 return gfc_match_type_is ();
9776 gfc_current_locus
= old_loc
;
9778 return gfc_match_print ();
9782 /* By now we have "TYPE <name> <EOS>". Check first if the name is an
9783 * intrinsic typename - if so let gfc_match_derived_decl dump an error.
9784 * Otherwise if gfc_match_derived_decl fails it's probably an existing
9785 * symbol which can be printed. */
9786 gfc_current_locus
= old_loc
;
9787 m
= gfc_match_derived_decl ();
9788 if (gfc_is_intrinsic_typename (name
) || m
== MATCH_YES
)
9790 *st
= ST_DERIVED_DECL
;
9793 gfc_current_locus
= old_loc
;
9795 return gfc_match_print ();
9802 /* Match the beginning of a derived type declaration. If a type name
9803 was the result of a function, then it is possible to have a symbol
9804 already to be known as a derived type yet have no components. */
9807 gfc_match_derived_decl (void)
9809 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9810 char parent
[GFC_MAX_SYMBOL_LEN
+ 1];
9811 symbol_attribute attr
;
9812 gfc_symbol
*sym
, *gensym
;
9813 gfc_symbol
*extended
;
9815 match is_type_attr_spec
= MATCH_NO
;
9816 bool seen_attr
= false;
9817 gfc_interface
*intr
= NULL
, *head
;
9818 bool parameterized_type
= false;
9819 bool seen_colons
= false;
9821 if (gfc_comp_struct (gfc_current_state ()))
9826 gfc_clear_attr (&attr
);
9831 is_type_attr_spec
= gfc_get_type_attr_spec (&attr
, parent
);
9832 if (is_type_attr_spec
== MATCH_ERROR
)
9834 if (is_type_attr_spec
== MATCH_YES
)
9836 } while (is_type_attr_spec
== MATCH_YES
);
9838 /* Deal with derived type extensions. The extension attribute has
9839 been added to 'attr' but now the parent type must be found and
9842 extended
= check_extended_derived_type (parent
);
9844 if (parent
[0] && !extended
)
9847 m
= gfc_match (" ::");
9854 gfc_error ("Expected :: in TYPE definition at %C");
9858 m
= gfc_match (" %n ", name
);
9862 /* Make sure that we don't identify TYPE IS (...) as a parameterized
9863 derived type named 'is'.
9864 TODO Expand the check, when 'name' = "is" by matching " (tname) "
9865 and checking if this is a(n intrinsic) typename. his picks up
9866 misplaced TYPE IS statements such as in select_type_1.f03. */
9867 if (gfc_peek_ascii_char () == '(')
9869 if (gfc_current_state () == COMP_SELECT_TYPE
9870 || (!seen_colons
&& !strcmp (name
, "is")))
9872 parameterized_type
= true;
9875 m
= gfc_match_eos ();
9876 if (m
!= MATCH_YES
&& !parameterized_type
)
9879 /* Make sure the name is not the name of an intrinsic type. */
9880 if (gfc_is_intrinsic_typename (name
))
9882 gfc_error ("Type name %qs at %C cannot be the same as an intrinsic "
9887 if (gfc_get_symbol (name
, NULL
, &gensym
))
9890 if (!gensym
->attr
.generic
&& gensym
->ts
.type
!= BT_UNKNOWN
)
9892 gfc_error ("Derived type name %qs at %C already has a basic type "
9893 "of %s", gensym
->name
, gfc_typename (&gensym
->ts
));
9897 if (!gensym
->attr
.generic
9898 && !gfc_add_generic (&gensym
->attr
, gensym
->name
, NULL
))
9901 if (!gensym
->attr
.function
9902 && !gfc_add_function (&gensym
->attr
, gensym
->name
, NULL
))
9905 sym
= gfc_find_dt_in_generic (gensym
);
9907 if (sym
&& (sym
->components
!= NULL
|| sym
->attr
.zero_comp
))
9909 gfc_error ("Derived type definition of %qs at %C has already been "
9910 "defined", sym
->name
);
9916 /* Use upper case to save the actual derived-type symbol. */
9917 gfc_get_symbol (gfc_dt_upper_string (gensym
->name
), NULL
, &sym
);
9918 sym
->name
= gfc_get_string ("%s", gensym
->name
);
9919 head
= gensym
->generic
;
9920 intr
= gfc_get_interface ();
9922 intr
->where
= gfc_current_locus
;
9923 intr
->sym
->declared_at
= gfc_current_locus
;
9925 gensym
->generic
= intr
;
9926 gensym
->attr
.if_source
= IFSRC_DECL
;
9929 /* The symbol may already have the derived attribute without the
9930 components. The ways this can happen is via a function
9931 definition, an INTRINSIC statement or a subtype in another
9932 derived type that is a pointer. The first part of the AND clause
9933 is true if the symbol is not the return value of a function. */
9934 if (sym
->attr
.flavor
!= FL_DERIVED
9935 && !gfc_add_flavor (&sym
->attr
, FL_DERIVED
, sym
->name
, NULL
))
9938 if (attr
.access
!= ACCESS_UNKNOWN
9939 && !gfc_add_access (&sym
->attr
, attr
.access
, sym
->name
, NULL
))
9941 else if (sym
->attr
.access
== ACCESS_UNKNOWN
9942 && gensym
->attr
.access
!= ACCESS_UNKNOWN
9943 && !gfc_add_access (&sym
->attr
, gensym
->attr
.access
,
9947 if (sym
->attr
.access
!= ACCESS_UNKNOWN
9948 && gensym
->attr
.access
== ACCESS_UNKNOWN
)
9949 gensym
->attr
.access
= sym
->attr
.access
;
9951 /* See if the derived type was labeled as bind(c). */
9952 if (attr
.is_bind_c
!= 0)
9953 sym
->attr
.is_bind_c
= attr
.is_bind_c
;
9955 /* Construct the f2k_derived namespace if it is not yet there. */
9956 if (!sym
->f2k_derived
)
9957 sym
->f2k_derived
= gfc_get_namespace (NULL
, 0);
9959 if (parameterized_type
)
9961 /* Ignore error or mismatches by going to the end of the statement
9962 in order to avoid the component declarations causing problems. */
9963 m
= gfc_match_formal_arglist (sym
, 0, 0, true);
9965 gfc_error_recovery ();
9966 m
= gfc_match_eos ();
9969 gfc_error_recovery ();
9970 gfc_error_now ("Garbage after PARAMETERIZED TYPE declaration at %C");
9972 sym
->attr
.pdt_template
= 1;
9975 if (extended
&& !sym
->components
)
9978 gfc_formal_arglist
*f
, *g
, *h
;
9980 /* Add the extended derived type as the first component. */
9981 gfc_add_component (sym
, parent
, &p
);
9983 gfc_set_sym_referenced (extended
);
9985 p
->ts
.type
= BT_DERIVED
;
9986 p
->ts
.u
.derived
= extended
;
9987 p
->initializer
= gfc_default_initializer (&p
->ts
);
9989 /* Set extension level. */
9990 if (extended
->attr
.extension
== 255)
9992 /* Since the extension field is 8 bit wide, we can only have
9993 up to 255 extension levels. */
9994 gfc_error ("Maximum extension level reached with type %qs at %L",
9995 extended
->name
, &extended
->declared_at
);
9998 sym
->attr
.extension
= extended
->attr
.extension
+ 1;
10000 /* Provide the links between the extended type and its extension. */
10001 if (!extended
->f2k_derived
)
10002 extended
->f2k_derived
= gfc_get_namespace (NULL
, 0);
10004 /* Copy the extended type-param-name-list from the extended type,
10005 append those of the extension and add the whole lot to the
10007 if (extended
->attr
.pdt_template
)
10010 sym
->attr
.pdt_template
= 1;
10011 for (f
= extended
->formal
; f
; f
= f
->next
)
10013 if (f
== extended
->formal
)
10015 g
= gfc_get_formal_arglist ();
10020 g
->next
= gfc_get_formal_arglist ();
10025 g
->next
= sym
->formal
;
10030 if (!sym
->hash_value
)
10031 /* Set the hash for the compound name for this type. */
10032 sym
->hash_value
= gfc_hash_value (sym
);
10034 /* Take over the ABSTRACT attribute. */
10035 sym
->attr
.abstract
= attr
.abstract
;
10037 gfc_new_block
= sym
;
10043 /* Cray Pointees can be declared as:
10044 pointer (ipt, a (n,m,...,*)) */
10047 gfc_mod_pointee_as (gfc_array_spec
*as
)
10049 as
->cray_pointee
= true; /* This will be useful to know later. */
10050 if (as
->type
== AS_ASSUMED_SIZE
)
10051 as
->cp_was_assumed
= true;
10052 else if (as
->type
== AS_ASSUMED_SHAPE
)
10054 gfc_error ("Cray Pointee at %C cannot be assumed shape array");
10055 return MATCH_ERROR
;
10061 /* Match the enum definition statement, here we are trying to match
10062 the first line of enum definition statement.
10063 Returns MATCH_YES if match is found. */
10066 gfc_match_enum (void)
10070 m
= gfc_match_eos ();
10071 if (m
!= MATCH_YES
)
10074 if (!gfc_notify_std (GFC_STD_F2003
, "ENUM and ENUMERATOR at %C"))
10075 return MATCH_ERROR
;
10081 /* Returns an initializer whose value is one higher than the value of the
10082 LAST_INITIALIZER argument. If the argument is NULL, the
10083 initializers value will be set to zero. The initializer's kind
10084 will be set to gfc_c_int_kind.
10086 If -fshort-enums is given, the appropriate kind will be selected
10087 later after all enumerators have been parsed. A warning is issued
10088 here if an initializer exceeds gfc_c_int_kind. */
10091 enum_initializer (gfc_expr
*last_initializer
, locus where
)
10094 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_c_int_kind
, &where
);
10096 mpz_init (result
->value
.integer
);
10098 if (last_initializer
!= NULL
)
10100 mpz_add_ui (result
->value
.integer
, last_initializer
->value
.integer
, 1);
10101 result
->where
= last_initializer
->where
;
10103 if (gfc_check_integer_range (result
->value
.integer
,
10104 gfc_c_int_kind
) != ARITH_OK
)
10106 gfc_error ("Enumerator exceeds the C integer type at %C");
10112 /* Control comes here, if it's the very first enumerator and no
10113 initializer has been given. It will be initialized to zero. */
10114 mpz_set_si (result
->value
.integer
, 0);
10121 /* Match a variable name with an optional initializer. When this
10122 subroutine is called, a variable is expected to be parsed next.
10123 Depending on what is happening at the moment, updates either the
10124 symbol table or the current interface. */
10127 enumerator_decl (void)
10129 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10130 gfc_expr
*initializer
;
10131 gfc_array_spec
*as
= NULL
;
10138 initializer
= NULL
;
10139 old_locus
= gfc_current_locus
;
10141 /* When we get here, we've just matched a list of attributes and
10142 maybe a type and a double colon. The next thing we expect to see
10143 is the name of the symbol. */
10144 m
= gfc_match_name (name
);
10145 if (m
!= MATCH_YES
)
10148 var_locus
= gfc_current_locus
;
10150 /* OK, we've successfully matched the declaration. Now put the
10151 symbol in the current namespace. If we fail to create the symbol,
10153 if (!build_sym (name
, NULL
, false, &as
, &var_locus
))
10159 /* The double colon must be present in order to have initializers.
10160 Otherwise the statement is ambiguous with an assignment statement. */
10163 if (gfc_match_char ('=') == MATCH_YES
)
10165 m
= gfc_match_init_expr (&initializer
);
10168 gfc_error ("Expected an initialization expression at %C");
10172 if (m
!= MATCH_YES
)
10177 /* If we do not have an initializer, the initialization value of the
10178 previous enumerator (stored in last_initializer) is incremented
10179 by 1 and is used to initialize the current enumerator. */
10180 if (initializer
== NULL
)
10181 initializer
= enum_initializer (last_initializer
, old_locus
);
10183 if (initializer
== NULL
|| initializer
->ts
.type
!= BT_INTEGER
)
10185 gfc_error ("ENUMERATOR %L not initialized with integer expression",
10191 /* Store this current initializer, for the next enumerator variable
10192 to be parsed. add_init_expr_to_sym() zeros initializer, so we
10193 use last_initializer below. */
10194 last_initializer
= initializer
;
10195 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
10197 /* Maintain enumerator history. */
10198 gfc_find_symbol (name
, NULL
, 0, &sym
);
10199 create_enum_history (sym
, last_initializer
);
10201 return (t
) ? MATCH_YES
: MATCH_ERROR
;
10204 /* Free stuff up and return. */
10205 gfc_free_expr (initializer
);
10211 /* Match the enumerator definition statement. */
10214 gfc_match_enumerator_def (void)
10219 gfc_clear_ts (¤t_ts
);
10221 m
= gfc_match (" enumerator");
10222 if (m
!= MATCH_YES
)
10225 m
= gfc_match (" :: ");
10226 if (m
== MATCH_ERROR
)
10229 colon_seen
= (m
== MATCH_YES
);
10231 if (gfc_current_state () != COMP_ENUM
)
10233 gfc_error ("ENUM definition statement expected before %C");
10234 gfc_free_enum_history ();
10235 return MATCH_ERROR
;
10238 (¤t_ts
)->type
= BT_INTEGER
;
10239 (¤t_ts
)->kind
= gfc_c_int_kind
;
10241 gfc_clear_attr (¤t_attr
);
10242 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, NULL
);
10251 m
= enumerator_decl ();
10252 if (m
== MATCH_ERROR
)
10254 gfc_free_enum_history ();
10260 if (gfc_match_eos () == MATCH_YES
)
10262 if (gfc_match_char (',') != MATCH_YES
)
10266 if (gfc_current_state () == COMP_ENUM
)
10268 gfc_free_enum_history ();
10269 gfc_error ("Syntax error in ENUMERATOR definition at %C");
10274 gfc_free_array_spec (current_as
);
10281 /* Match binding attributes. */
10284 match_binding_attributes (gfc_typebound_proc
* ba
, bool generic
, bool ppc
)
10286 bool found_passing
= false;
10287 bool seen_ptr
= false;
10288 match m
= MATCH_YES
;
10290 /* Initialize to defaults. Do so even before the MATCH_NO check so that in
10291 this case the defaults are in there. */
10292 ba
->access
= ACCESS_UNKNOWN
;
10293 ba
->pass_arg
= NULL
;
10294 ba
->pass_arg_num
= 0;
10296 ba
->non_overridable
= 0;
10300 /* If we find a comma, we believe there are binding attributes. */
10301 m
= gfc_match_char (',');
10307 /* Access specifier. */
10309 m
= gfc_match (" public");
10310 if (m
== MATCH_ERROR
)
10312 if (m
== MATCH_YES
)
10314 if (ba
->access
!= ACCESS_UNKNOWN
)
10316 gfc_error ("Duplicate access-specifier at %C");
10320 ba
->access
= ACCESS_PUBLIC
;
10324 m
= gfc_match (" private");
10325 if (m
== MATCH_ERROR
)
10327 if (m
== MATCH_YES
)
10329 if (ba
->access
!= ACCESS_UNKNOWN
)
10331 gfc_error ("Duplicate access-specifier at %C");
10335 ba
->access
= ACCESS_PRIVATE
;
10339 /* If inside GENERIC, the following is not allowed. */
10344 m
= gfc_match (" nopass");
10345 if (m
== MATCH_ERROR
)
10347 if (m
== MATCH_YES
)
10351 gfc_error ("Binding attributes already specify passing,"
10352 " illegal NOPASS at %C");
10356 found_passing
= true;
10361 /* PASS possibly including argument. */
10362 m
= gfc_match (" pass");
10363 if (m
== MATCH_ERROR
)
10365 if (m
== MATCH_YES
)
10367 char arg
[GFC_MAX_SYMBOL_LEN
+ 1];
10371 gfc_error ("Binding attributes already specify passing,"
10372 " illegal PASS at %C");
10376 m
= gfc_match (" ( %n )", arg
);
10377 if (m
== MATCH_ERROR
)
10379 if (m
== MATCH_YES
)
10380 ba
->pass_arg
= gfc_get_string ("%s", arg
);
10381 gcc_assert ((m
== MATCH_YES
) == (ba
->pass_arg
!= NULL
));
10383 found_passing
= true;
10390 /* POINTER flag. */
10391 m
= gfc_match (" pointer");
10392 if (m
== MATCH_ERROR
)
10394 if (m
== MATCH_YES
)
10398 gfc_error ("Duplicate POINTER attribute at %C");
10408 /* NON_OVERRIDABLE flag. */
10409 m
= gfc_match (" non_overridable");
10410 if (m
== MATCH_ERROR
)
10412 if (m
== MATCH_YES
)
10414 if (ba
->non_overridable
)
10416 gfc_error ("Duplicate NON_OVERRIDABLE at %C");
10420 ba
->non_overridable
= 1;
10424 /* DEFERRED flag. */
10425 m
= gfc_match (" deferred");
10426 if (m
== MATCH_ERROR
)
10428 if (m
== MATCH_YES
)
10432 gfc_error ("Duplicate DEFERRED at %C");
10443 /* Nothing matching found. */
10445 gfc_error ("Expected access-specifier at %C");
10447 gfc_error ("Expected binding attribute at %C");
10450 while (gfc_match_char (',') == MATCH_YES
);
10452 /* NON_OVERRIDABLE and DEFERRED exclude themselves. */
10453 if (ba
->non_overridable
&& ba
->deferred
)
10455 gfc_error ("NON_OVERRIDABLE and DEFERRED can't both appear at %C");
10462 if (ba
->access
== ACCESS_UNKNOWN
)
10463 ba
->access
= gfc_typebound_default_access
;
10465 if (ppc
&& !seen_ptr
)
10467 gfc_error ("POINTER attribute is required for procedure pointer component"
10475 return MATCH_ERROR
;
10479 /* Match a PROCEDURE specific binding inside a derived type. */
10482 match_procedure_in_type (void)
10484 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10485 char target_buf
[GFC_MAX_SYMBOL_LEN
+ 1];
10486 char* target
= NULL
, *ifc
= NULL
;
10487 gfc_typebound_proc tb
;
10491 gfc_symtree
* stree
;
10496 /* Check current state. */
10497 gcc_assert (gfc_state_stack
->state
== COMP_DERIVED_CONTAINS
);
10498 block
= gfc_state_stack
->previous
->sym
;
10499 gcc_assert (block
);
10501 /* Try to match PROCEDURE(interface). */
10502 if (gfc_match (" (") == MATCH_YES
)
10504 m
= gfc_match_name (target_buf
);
10505 if (m
== MATCH_ERROR
)
10507 if (m
!= MATCH_YES
)
10509 gfc_error ("Interface-name expected after %<(%> at %C");
10510 return MATCH_ERROR
;
10513 if (gfc_match (" )") != MATCH_YES
)
10515 gfc_error ("%<)%> expected at %C");
10516 return MATCH_ERROR
;
10522 /* Construct the data structure. */
10523 memset (&tb
, 0, sizeof (tb
));
10524 tb
.where
= gfc_current_locus
;
10526 /* Match binding attributes. */
10527 m
= match_binding_attributes (&tb
, false, false);
10528 if (m
== MATCH_ERROR
)
10530 seen_attrs
= (m
== MATCH_YES
);
10532 /* Check that attribute DEFERRED is given if an interface is specified. */
10533 if (tb
.deferred
&& !ifc
)
10535 gfc_error ("Interface must be specified for DEFERRED binding at %C");
10536 return MATCH_ERROR
;
10538 if (ifc
&& !tb
.deferred
)
10540 gfc_error ("PROCEDURE(interface) at %C should be declared DEFERRED");
10541 return MATCH_ERROR
;
10544 /* Match the colons. */
10545 m
= gfc_match (" ::");
10546 if (m
== MATCH_ERROR
)
10548 seen_colons
= (m
== MATCH_YES
);
10549 if (seen_attrs
&& !seen_colons
)
10551 gfc_error ("Expected %<::%> after binding-attributes at %C");
10552 return MATCH_ERROR
;
10555 /* Match the binding names. */
10558 m
= gfc_match_name (name
);
10559 if (m
== MATCH_ERROR
)
10563 gfc_error ("Expected binding name at %C");
10564 return MATCH_ERROR
;
10567 if (num
>1 && !gfc_notify_std (GFC_STD_F2008
, "PROCEDURE list at %C"))
10568 return MATCH_ERROR
;
10570 /* Try to match the '=> target', if it's there. */
10572 m
= gfc_match (" =>");
10573 if (m
== MATCH_ERROR
)
10575 if (m
== MATCH_YES
)
10579 gfc_error ("%<=> target%> is invalid for DEFERRED binding at %C");
10580 return MATCH_ERROR
;
10585 gfc_error ("%<::%> needed in PROCEDURE binding with explicit target"
10587 return MATCH_ERROR
;
10590 m
= gfc_match_name (target_buf
);
10591 if (m
== MATCH_ERROR
)
10595 gfc_error ("Expected binding target after %<=>%> at %C");
10596 return MATCH_ERROR
;
10598 target
= target_buf
;
10601 /* If no target was found, it has the same name as the binding. */
10605 /* Get the namespace to insert the symbols into. */
10606 ns
= block
->f2k_derived
;
10609 /* If the binding is DEFERRED, check that the containing type is ABSTRACT. */
10610 if (tb
.deferred
&& !block
->attr
.abstract
)
10612 gfc_error ("Type %qs containing DEFERRED binding at %C "
10613 "is not ABSTRACT", block
->name
);
10614 return MATCH_ERROR
;
10617 /* See if we already have a binding with this name in the symtree which
10618 would be an error. If a GENERIC already targeted this binding, it may
10619 be already there but then typebound is still NULL. */
10620 stree
= gfc_find_symtree (ns
->tb_sym_root
, name
);
10621 if (stree
&& stree
->n
.tb
)
10623 gfc_error ("There is already a procedure with binding name %qs for "
10624 "the derived type %qs at %C", name
, block
->name
);
10625 return MATCH_ERROR
;
10628 /* Insert it and set attributes. */
10632 stree
= gfc_new_symtree (&ns
->tb_sym_root
, name
);
10633 gcc_assert (stree
);
10635 stree
->n
.tb
= gfc_get_typebound_proc (&tb
);
10637 if (gfc_get_sym_tree (target
, gfc_current_ns
, &stree
->n
.tb
->u
.specific
,
10639 return MATCH_ERROR
;
10640 gfc_set_sym_referenced (stree
->n
.tb
->u
.specific
->n
.sym
);
10641 gfc_add_flavor(&stree
->n
.tb
->u
.specific
->n
.sym
->attr
, FL_PROCEDURE
,
10642 target
, &stree
->n
.tb
->u
.specific
->n
.sym
->declared_at
);
10644 if (gfc_match_eos () == MATCH_YES
)
10646 if (gfc_match_char (',') != MATCH_YES
)
10651 gfc_error ("Syntax error in PROCEDURE statement at %C");
10652 return MATCH_ERROR
;
10656 /* Match a GENERIC procedure binding inside a derived type. */
10659 gfc_match_generic (void)
10661 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10662 char bind_name
[GFC_MAX_SYMBOL_LEN
+ 16]; /* Allow space for OPERATOR(...). */
10664 gfc_typebound_proc tbattr
; /* Used for match_binding_attributes. */
10665 gfc_typebound_proc
* tb
;
10667 interface_type op_type
;
10668 gfc_intrinsic_op op
;
10671 /* Check current state. */
10672 if (gfc_current_state () == COMP_DERIVED
)
10674 gfc_error ("GENERIC at %C must be inside a derived-type CONTAINS");
10675 return MATCH_ERROR
;
10677 if (gfc_current_state () != COMP_DERIVED_CONTAINS
)
10679 block
= gfc_state_stack
->previous
->sym
;
10680 ns
= block
->f2k_derived
;
10681 gcc_assert (block
&& ns
);
10683 memset (&tbattr
, 0, sizeof (tbattr
));
10684 tbattr
.where
= gfc_current_locus
;
10686 /* See if we get an access-specifier. */
10687 m
= match_binding_attributes (&tbattr
, true, false);
10688 if (m
== MATCH_ERROR
)
10691 /* Now the colons, those are required. */
10692 if (gfc_match (" ::") != MATCH_YES
)
10694 gfc_error ("Expected %<::%> at %C");
10698 /* Match the binding name; depending on type (operator / generic) format
10699 it for future error messages into bind_name. */
10701 m
= gfc_match_generic_spec (&op_type
, name
, &op
);
10702 if (m
== MATCH_ERROR
)
10703 return MATCH_ERROR
;
10706 gfc_error ("Expected generic name or operator descriptor at %C");
10712 case INTERFACE_GENERIC
:
10713 case INTERFACE_DTIO
:
10714 snprintf (bind_name
, sizeof (bind_name
), "%s", name
);
10717 case INTERFACE_USER_OP
:
10718 snprintf (bind_name
, sizeof (bind_name
), "OPERATOR(.%s.)", name
);
10721 case INTERFACE_INTRINSIC_OP
:
10722 snprintf (bind_name
, sizeof (bind_name
), "OPERATOR(%s)",
10723 gfc_op2string (op
));
10726 case INTERFACE_NAMELESS
:
10727 gfc_error ("Malformed GENERIC statement at %C");
10732 gcc_unreachable ();
10735 /* Match the required =>. */
10736 if (gfc_match (" =>") != MATCH_YES
)
10738 gfc_error ("Expected %<=>%> at %C");
10742 /* Try to find existing GENERIC binding with this name / for this operator;
10743 if there is something, check that it is another GENERIC and then extend
10744 it rather than building a new node. Otherwise, create it and put it
10745 at the right position. */
10749 case INTERFACE_DTIO
:
10750 case INTERFACE_USER_OP
:
10751 case INTERFACE_GENERIC
:
10753 const bool is_op
= (op_type
== INTERFACE_USER_OP
);
10756 st
= gfc_find_symtree (is_op
? ns
->tb_uop_root
: ns
->tb_sym_root
, name
);
10757 tb
= st
? st
->n
.tb
: NULL
;
10761 case INTERFACE_INTRINSIC_OP
:
10762 tb
= ns
->tb_op
[op
];
10766 gcc_unreachable ();
10771 if (!tb
->is_generic
)
10773 gcc_assert (op_type
== INTERFACE_GENERIC
);
10774 gfc_error ("There's already a non-generic procedure with binding name"
10775 " %qs for the derived type %qs at %C",
10776 bind_name
, block
->name
);
10780 if (tb
->access
!= tbattr
.access
)
10782 gfc_error ("Binding at %C must have the same access as already"
10783 " defined binding %qs", bind_name
);
10789 tb
= gfc_get_typebound_proc (NULL
);
10790 tb
->where
= gfc_current_locus
;
10791 tb
->access
= tbattr
.access
;
10792 tb
->is_generic
= 1;
10793 tb
->u
.generic
= NULL
;
10797 case INTERFACE_DTIO
:
10798 case INTERFACE_GENERIC
:
10799 case INTERFACE_USER_OP
:
10801 const bool is_op
= (op_type
== INTERFACE_USER_OP
);
10802 gfc_symtree
* st
= gfc_get_tbp_symtree (is_op
? &ns
->tb_uop_root
:
10803 &ns
->tb_sym_root
, name
);
10810 case INTERFACE_INTRINSIC_OP
:
10811 ns
->tb_op
[op
] = tb
;
10815 gcc_unreachable ();
10819 /* Now, match all following names as specific targets. */
10822 gfc_symtree
* target_st
;
10823 gfc_tbp_generic
* target
;
10825 m
= gfc_match_name (name
);
10826 if (m
== MATCH_ERROR
)
10830 gfc_error ("Expected specific binding name at %C");
10834 target_st
= gfc_get_tbp_symtree (&ns
->tb_sym_root
, name
);
10836 /* See if this is a duplicate specification. */
10837 for (target
= tb
->u
.generic
; target
; target
= target
->next
)
10838 if (target_st
== target
->specific_st
)
10840 gfc_error ("%qs already defined as specific binding for the"
10841 " generic %qs at %C", name
, bind_name
);
10845 target
= gfc_get_tbp_generic ();
10846 target
->specific_st
= target_st
;
10847 target
->specific
= NULL
;
10848 target
->next
= tb
->u
.generic
;
10849 target
->is_operator
= ((op_type
== INTERFACE_USER_OP
)
10850 || (op_type
== INTERFACE_INTRINSIC_OP
));
10851 tb
->u
.generic
= target
;
10853 while (gfc_match (" ,") == MATCH_YES
);
10855 /* Here should be the end. */
10856 if (gfc_match_eos () != MATCH_YES
)
10858 gfc_error ("Junk after GENERIC binding at %C");
10865 return MATCH_ERROR
;
10869 /* Match a FINAL declaration inside a derived type. */
10872 gfc_match_final_decl (void)
10874 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10877 gfc_namespace
* module_ns
;
10881 if (gfc_current_form
== FORM_FREE
)
10883 char c
= gfc_peek_ascii_char ();
10884 if (!gfc_is_whitespace (c
) && c
!= ':')
10888 if (gfc_state_stack
->state
!= COMP_DERIVED_CONTAINS
)
10890 if (gfc_current_form
== FORM_FIXED
)
10893 gfc_error ("FINAL declaration at %C must be inside a derived type "
10894 "CONTAINS section");
10895 return MATCH_ERROR
;
10898 block
= gfc_state_stack
->previous
->sym
;
10899 gcc_assert (block
);
10901 if (!gfc_state_stack
->previous
|| !gfc_state_stack
->previous
->previous
10902 || gfc_state_stack
->previous
->previous
->state
!= COMP_MODULE
)
10904 gfc_error ("Derived type declaration with FINAL at %C must be in the"
10905 " specification part of a MODULE");
10906 return MATCH_ERROR
;
10909 module_ns
= gfc_current_ns
;
10910 gcc_assert (module_ns
);
10911 gcc_assert (module_ns
->proc_name
->attr
.flavor
== FL_MODULE
);
10913 /* Match optional ::, don't care about MATCH_YES or MATCH_NO. */
10914 if (gfc_match (" ::") == MATCH_ERROR
)
10915 return MATCH_ERROR
;
10917 /* Match the sequence of procedure names. */
10924 if (first
&& gfc_match_eos () == MATCH_YES
)
10926 gfc_error ("Empty FINAL at %C");
10927 return MATCH_ERROR
;
10930 m
= gfc_match_name (name
);
10933 gfc_error ("Expected module procedure name at %C");
10934 return MATCH_ERROR
;
10936 else if (m
!= MATCH_YES
)
10937 return MATCH_ERROR
;
10939 if (gfc_match_eos () == MATCH_YES
)
10941 if (!last
&& gfc_match_char (',') != MATCH_YES
)
10943 gfc_error ("Expected %<,%> at %C");
10944 return MATCH_ERROR
;
10947 if (gfc_get_symbol (name
, module_ns
, &sym
))
10949 gfc_error ("Unknown procedure name %qs at %C", name
);
10950 return MATCH_ERROR
;
10953 /* Mark the symbol as module procedure. */
10954 if (sym
->attr
.proc
!= PROC_MODULE
10955 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
10956 return MATCH_ERROR
;
10958 /* Check if we already have this symbol in the list, this is an error. */
10959 for (f
= block
->f2k_derived
->finalizers
; f
; f
= f
->next
)
10960 if (f
->proc_sym
== sym
)
10962 gfc_error ("%qs at %C is already defined as FINAL procedure",
10964 return MATCH_ERROR
;
10967 /* Add this symbol to the list of finalizers. */
10968 gcc_assert (block
->f2k_derived
);
10970 f
= XCNEW (gfc_finalizer
);
10972 f
->proc_tree
= NULL
;
10973 f
->where
= gfc_current_locus
;
10974 f
->next
= block
->f2k_derived
->finalizers
;
10975 block
->f2k_derived
->finalizers
= f
;
10985 const ext_attr_t ext_attr_list
[] = {
10986 { "dllimport", EXT_ATTR_DLLIMPORT
, "dllimport" },
10987 { "dllexport", EXT_ATTR_DLLEXPORT
, "dllexport" },
10988 { "cdecl", EXT_ATTR_CDECL
, "cdecl" },
10989 { "stdcall", EXT_ATTR_STDCALL
, "stdcall" },
10990 { "fastcall", EXT_ATTR_FASTCALL
, "fastcall" },
10991 { "no_arg_check", EXT_ATTR_NO_ARG_CHECK
, NULL
},
10992 { NULL
, EXT_ATTR_LAST
, NULL
}
10995 /* Match a !GCC$ ATTRIBUTES statement of the form:
10996 !GCC$ ATTRIBUTES attribute-list :: var-name [, var-name] ...
10997 When we come here, we have already matched the !GCC$ ATTRIBUTES string.
10999 TODO: We should support all GCC attributes using the same syntax for
11000 the attribute list, i.e. the list in C
11001 __attributes(( attribute-list ))
11003 !GCC$ ATTRIBUTES attribute-list ::
11004 Cf. c-parser.c's c_parser_attributes; the data can then directly be
11007 As there is absolutely no risk of confusion, we should never return
11010 gfc_match_gcc_attributes (void)
11012 symbol_attribute attr
;
11013 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
11018 gfc_clear_attr (&attr
);
11023 if (gfc_match_name (name
) != MATCH_YES
)
11024 return MATCH_ERROR
;
11026 for (id
= 0; id
< EXT_ATTR_LAST
; id
++)
11027 if (strcmp (name
, ext_attr_list
[id
].name
) == 0)
11030 if (id
== EXT_ATTR_LAST
)
11032 gfc_error ("Unknown attribute in !GCC$ ATTRIBUTES statement at %C");
11033 return MATCH_ERROR
;
11036 if (!gfc_add_ext_attribute (&attr
, (ext_attr_id_t
)id
, &gfc_current_locus
))
11037 return MATCH_ERROR
;
11039 gfc_gobble_whitespace ();
11040 ch
= gfc_next_ascii_char ();
11043 /* This is the successful exit condition for the loop. */
11044 if (gfc_next_ascii_char () == ':')
11054 if (gfc_match_eos () == MATCH_YES
)
11059 m
= gfc_match_name (name
);
11060 if (m
!= MATCH_YES
)
11063 if (find_special (name
, &sym
, true))
11064 return MATCH_ERROR
;
11066 sym
->attr
.ext_attr
|= attr
.ext_attr
;
11068 if (gfc_match_eos () == MATCH_YES
)
11071 if (gfc_match_char (',') != MATCH_YES
)
11078 gfc_error ("Syntax error in !GCC$ ATTRIBUTES statement at %C");
11079 return MATCH_ERROR
;
11083 /* Match a !GCC$ UNROLL statement of the form:
11086 The parameter n is the number of times we are supposed to unroll.
11088 When we come here, we have already matched the !GCC$ UNROLL string. */
11090 gfc_match_gcc_unroll (void)
11094 if (gfc_match_small_int (&value
) == MATCH_YES
)
11096 if (value
< 0 || value
> USHRT_MAX
)
11098 gfc_error ("%<GCC unroll%> directive requires a"
11099 " non-negative integral constant"
11100 " less than or equal to %u at %C",
11103 return MATCH_ERROR
;
11105 if (gfc_match_eos () == MATCH_YES
)
11107 directive_unroll
= value
== 0 ? 1 : value
;
11112 gfc_error ("Syntax error in !GCC$ UNROLL directive at %C");
11113 return MATCH_ERROR
;