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 /* Map of middle-end built-ins that should be vectorized. */
102 hash_map
<nofree_string_hash
, int> *gfc_vectorized_builtins
;
104 /* If a kind expression of a component of a parameterized derived type is
105 parameterized, temporarily store the expression here. */
106 static gfc_expr
*saved_kind_expr
= NULL
;
108 /* Used to store the parameter list arising in a PDT declaration and
109 in the typespec of a PDT variable or component. */
110 static gfc_actual_arglist
*decl_type_param_list
;
111 static gfc_actual_arglist
*type_param_spec_list
;
113 /********************* DATA statement subroutines *********************/
115 static bool in_match_data
= false;
118 gfc_in_match_data (void)
120 return in_match_data
;
124 set_in_match_data (bool set_value
)
126 in_match_data
= set_value
;
129 /* Free a gfc_data_variable structure and everything beneath it. */
132 free_variable (gfc_data_variable
*p
)
134 gfc_data_variable
*q
;
139 gfc_free_expr (p
->expr
);
140 gfc_free_iterator (&p
->iter
, 0);
141 free_variable (p
->list
);
147 /* Free a gfc_data_value structure and everything beneath it. */
150 free_value (gfc_data_value
*p
)
157 mpz_clear (p
->repeat
);
158 gfc_free_expr (p
->expr
);
164 /* Free a list of gfc_data structures. */
167 gfc_free_data (gfc_data
*p
)
174 free_variable (p
->var
);
175 free_value (p
->value
);
181 /* Free all data in a namespace. */
184 gfc_free_data_all (gfc_namespace
*ns
)
196 /* Reject data parsed since the last restore point was marked. */
199 gfc_reject_data (gfc_namespace
*ns
)
203 while (ns
->data
&& ns
->data
!= ns
->old_data
)
211 static match
var_element (gfc_data_variable
*);
213 /* Match a list of variables terminated by an iterator and a right
217 var_list (gfc_data_variable
*parent
)
219 gfc_data_variable
*tail
, var
;
222 m
= var_element (&var
);
223 if (m
== MATCH_ERROR
)
228 tail
= gfc_get_data_variable ();
235 if (gfc_match_char (',') != MATCH_YES
)
238 m
= gfc_match_iterator (&parent
->iter
, 1);
241 if (m
== MATCH_ERROR
)
244 m
= var_element (&var
);
245 if (m
== MATCH_ERROR
)
250 tail
->next
= gfc_get_data_variable ();
256 if (gfc_match_char (')') != MATCH_YES
)
261 gfc_syntax_error (ST_DATA
);
266 /* Match a single element in a data variable list, which can be a
267 variable-iterator list. */
270 var_element (gfc_data_variable
*new_var
)
275 memset (new_var
, 0, sizeof (gfc_data_variable
));
277 if (gfc_match_char ('(') == MATCH_YES
)
278 return var_list (new_var
);
280 m
= gfc_match_variable (&new_var
->expr
, 0);
284 if (new_var
->expr
->expr_type
== EXPR_CONSTANT
285 && new_var
->expr
->symtree
== NULL
)
287 gfc_error ("Inquiry parameter cannot appear in a "
288 "data-stmt-object-list at %C");
292 sym
= new_var
->expr
->symtree
->n
.sym
;
294 /* Symbol should already have an associated type. */
295 if (!gfc_check_symbol_typed (sym
, gfc_current_ns
, false, gfc_current_locus
))
298 if (!sym
->attr
.function
&& gfc_current_ns
->parent
299 && gfc_current_ns
->parent
== sym
->ns
)
301 gfc_error ("Host associated variable %qs may not be in the DATA "
302 "statement at %C", sym
->name
);
306 if (gfc_current_state () != COMP_BLOCK_DATA
307 && sym
->attr
.in_common
308 && !gfc_notify_std (GFC_STD_GNU
, "initialization of "
309 "common block variable %qs in DATA statement at %C",
313 if (!gfc_add_data (&sym
->attr
, sym
->name
, &new_var
->expr
->where
))
320 /* Match the top-level list of data variables. */
323 top_var_list (gfc_data
*d
)
325 gfc_data_variable var
, *tail
, *new_var
;
332 m
= var_element (&var
);
335 if (m
== MATCH_ERROR
)
338 new_var
= gfc_get_data_variable ();
344 tail
->next
= new_var
;
348 if (gfc_match_char ('/') == MATCH_YES
)
350 if (gfc_match_char (',') != MATCH_YES
)
357 gfc_syntax_error (ST_DATA
);
358 gfc_free_data_all (gfc_current_ns
);
364 match_data_constant (gfc_expr
**result
)
366 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
367 gfc_symbol
*sym
, *dt_sym
= NULL
;
372 m
= gfc_match_literal_constant (&expr
, 1);
379 if (m
== MATCH_ERROR
)
382 m
= gfc_match_null (result
);
386 old_loc
= gfc_current_locus
;
388 /* Should this be a structure component, try to match it
389 before matching a name. */
390 m
= gfc_match_rvalue (result
);
391 if (m
== MATCH_ERROR
)
394 if (m
== MATCH_YES
&& (*result
)->expr_type
== EXPR_STRUCTURE
)
396 if (!gfc_simplify_expr (*result
, 0))
400 else if (m
== MATCH_YES
)
402 /* If a parameter inquiry ends up here, symtree is NULL but **result
403 contains the right constant expression. Check here. */
404 if ((*result
)->symtree
== NULL
405 && (*result
)->expr_type
== EXPR_CONSTANT
406 && ((*result
)->ts
.type
== BT_INTEGER
407 || (*result
)->ts
.type
== BT_REAL
))
410 /* F2018:R845 data-stmt-constant is initial-data-target.
411 A data-stmt-constant shall be ... initial-data-target if and
412 only if the corresponding data-stmt-object has the POINTER
413 attribute. ... If data-stmt-constant is initial-data-target
414 the corresponding data statement object shall be
415 data-pointer-initialization compatible (7.5.4.6) with the initial
416 data target; the data statement object is initially associated
418 if ((*result
)->symtree
->n
.sym
->attr
.save
419 && (*result
)->symtree
->n
.sym
->attr
.target
)
421 gfc_free_expr (*result
);
424 gfc_current_locus
= old_loc
;
426 m
= gfc_match_name (name
);
430 if (gfc_find_symbol (name
, NULL
, 1, &sym
))
433 if (sym
&& sym
->attr
.generic
)
434 dt_sym
= gfc_find_dt_in_generic (sym
);
437 || (sym
->attr
.flavor
!= FL_PARAMETER
438 && (!dt_sym
|| !gfc_fl_struct (dt_sym
->attr
.flavor
))))
440 gfc_error ("Symbol %qs must be a PARAMETER in DATA statement at %C",
445 else if (dt_sym
&& gfc_fl_struct (dt_sym
->attr
.flavor
))
446 return gfc_match_structure_constructor (dt_sym
, result
);
448 /* Check to see if the value is an initialization array expression. */
449 if (sym
->value
->expr_type
== EXPR_ARRAY
)
451 gfc_current_locus
= old_loc
;
453 m
= gfc_match_init_expr (result
);
454 if (m
== MATCH_ERROR
)
459 if (!gfc_simplify_expr (*result
, 0))
462 if ((*result
)->expr_type
== EXPR_CONSTANT
)
466 gfc_error ("Invalid initializer %s in Data statement at %C", name
);
472 *result
= gfc_copy_expr (sym
->value
);
477 /* Match a list of values in a DATA statement. The leading '/' has
478 already been seen at this point. */
481 top_val_list (gfc_data
*data
)
483 gfc_data_value
*new_val
, *tail
;
491 m
= match_data_constant (&expr
);
494 if (m
== MATCH_ERROR
)
497 new_val
= gfc_get_data_value ();
498 mpz_init (new_val
->repeat
);
501 data
->value
= new_val
;
503 tail
->next
= new_val
;
507 if (expr
->ts
.type
!= BT_INTEGER
|| gfc_match_char ('*') != MATCH_YES
)
510 mpz_set_ui (tail
->repeat
, 1);
514 mpz_set (tail
->repeat
, expr
->value
.integer
);
515 gfc_free_expr (expr
);
517 m
= match_data_constant (&tail
->expr
);
520 if (m
== MATCH_ERROR
)
524 if (gfc_match_char ('/') == MATCH_YES
)
526 if (gfc_match_char (',') == MATCH_NO
)
533 gfc_syntax_error (ST_DATA
);
534 gfc_free_data_all (gfc_current_ns
);
539 /* Matches an old style initialization. */
542 match_old_style_init (const char *name
)
549 /* Set up data structure to hold initializers. */
550 gfc_find_sym_tree (name
, NULL
, 0, &st
);
553 newdata
= gfc_get_data ();
554 newdata
->var
= gfc_get_data_variable ();
555 newdata
->var
->expr
= gfc_get_variable_expr (st
);
556 newdata
->var
->expr
->where
= sym
->declared_at
;
557 newdata
->where
= gfc_current_locus
;
559 /* Match initial value list. This also eats the terminal '/'. */
560 m
= top_val_list (newdata
);
569 gfc_error ("Initialization at %C is not allowed in a PURE procedure");
573 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
575 /* Mark the variable as having appeared in a data statement. */
576 if (!gfc_add_data (&sym
->attr
, sym
->name
, &sym
->declared_at
))
582 /* Chain in namespace list of DATA initializers. */
583 newdata
->next
= gfc_current_ns
->data
;
584 gfc_current_ns
->data
= newdata
;
590 /* Match the stuff following a DATA statement. If ERROR_FLAG is set,
591 we are matching a DATA statement and are therefore issuing an error
592 if we encounter something unexpected, if not, we're trying to match
593 an old-style initialization expression of the form INTEGER I /2/. */
596 gfc_match_data (void)
602 /* Before parsing the rest of a DATA statement, check F2008:c1206. */
603 if ((gfc_current_state () == COMP_FUNCTION
604 || gfc_current_state () == COMP_SUBROUTINE
)
605 && gfc_state_stack
->previous
->state
== COMP_INTERFACE
)
607 gfc_error ("DATA statement at %C cannot appear within an INTERFACE");
611 set_in_match_data (true);
615 new_data
= gfc_get_data ();
616 new_data
->where
= gfc_current_locus
;
618 m
= top_var_list (new_data
);
622 if (new_data
->var
->iter
.var
623 && new_data
->var
->iter
.var
->ts
.type
== BT_INTEGER
624 && new_data
->var
->iter
.var
->symtree
->n
.sym
->attr
.implied_index
== 1
625 && new_data
->var
->list
626 && new_data
->var
->list
->expr
627 && new_data
->var
->list
->expr
->ts
.type
== BT_CHARACTER
628 && new_data
->var
->list
->expr
->ref
629 && new_data
->var
->list
->expr
->ref
->type
== REF_SUBSTRING
)
631 gfc_error ("Invalid substring in data-implied-do at %L in DATA "
632 "statement", &new_data
->var
->list
->expr
->where
);
636 /* Check for an entity with an allocatable component, which is not
638 e
= new_data
->var
->expr
;
644 for (gfc_ref
*ref
= e
->ref
; ref
; ref
= ref
->next
)
645 if ((ref
->type
== REF_COMPONENT
646 && ref
->u
.c
.component
->attr
.allocatable
)
647 || (ref
->type
== REF_ARRAY
648 && e
->symtree
->n
.sym
->attr
.pointer
!= 1
649 && ref
->u
.ar
.as
&& ref
->u
.ar
.as
->type
== AS_DEFERRED
))
654 gfc_error ("Allocatable component or deferred-shaped array "
655 "near %C in DATA statement");
660 m
= top_val_list (new_data
);
664 new_data
->next
= gfc_current_ns
->data
;
665 gfc_current_ns
->data
= new_data
;
667 if (gfc_match_eos () == MATCH_YES
)
670 gfc_match_char (','); /* Optional comma */
673 set_in_match_data (false);
677 gfc_error ("DATA statement at %C is not allowed in a PURE procedure");
680 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
685 set_in_match_data (false);
686 gfc_free_data (new_data
);
691 /************************ Declaration statements *********************/
694 /* Like gfc_match_init_expr, but matches a 'clist' (old-style initialization
695 list). The difference here is the expression is a list of constants
696 and is surrounded by '/'.
697 The typespec ts must match the typespec of the variable which the
698 clist is initializing.
699 The arrayspec tells whether this should match a list of constants
700 corresponding to array elements or a scalar (as == NULL). */
703 match_clist_expr (gfc_expr
**result
, gfc_typespec
*ts
, gfc_array_spec
*as
)
705 gfc_constructor_base array_head
= NULL
;
706 gfc_expr
*expr
= NULL
;
707 match m
= MATCH_ERROR
;
709 mpz_t repeat
, cons_size
, as_size
;
715 /* We have already matched '/' - now look for a constant list, as with
716 top_val_list from decl.c, but append the result to an array. */
717 if (gfc_match ("/") == MATCH_YES
)
719 gfc_error ("Empty old style initializer list at %C");
723 where
= gfc_current_locus
;
724 scalar
= !as
|| !as
->rank
;
726 if (!scalar
&& !spec_size (as
, &as_size
))
728 gfc_error ("Array in initializer list at %L must have an explicit shape",
729 as
->type
== AS_EXPLICIT
? &as
->upper
[0]->where
: &where
);
730 /* Nothing to cleanup yet. */
734 mpz_init_set_ui (repeat
, 0);
738 m
= match_data_constant (&expr
);
740 expr
= NULL
; /* match_data_constant may set expr to garbage */
743 if (m
== MATCH_ERROR
)
746 /* Found r in repeat spec r*c; look for the constant to repeat. */
747 if ( gfc_match_char ('*') == MATCH_YES
)
751 gfc_error ("Repeat spec invalid in scalar initializer at %C");
754 if (expr
->ts
.type
!= BT_INTEGER
)
756 gfc_error ("Repeat spec must be an integer at %C");
759 mpz_set (repeat
, expr
->value
.integer
);
760 gfc_free_expr (expr
);
763 m
= match_data_constant (&expr
);
767 gfc_error ("Expected data constant after repeat spec at %C");
772 /* No repeat spec, we matched the data constant itself. */
774 mpz_set_ui (repeat
, 1);
778 /* Add the constant initializer as many times as repeated. */
779 for (; mpz_cmp_ui (repeat
, 0) > 0; mpz_sub_ui (repeat
, repeat
, 1))
781 /* Make sure types of elements match */
782 if(ts
&& !gfc_compare_types (&expr
->ts
, ts
)
783 && !gfc_convert_type (expr
, ts
, 1))
786 gfc_constructor_append_expr (&array_head
,
787 gfc_copy_expr (expr
), &gfc_current_locus
);
790 gfc_free_expr (expr
);
794 /* For scalar initializers quit after one element. */
797 if(gfc_match_char ('/') != MATCH_YES
)
799 gfc_error ("End of scalar initializer expected at %C");
805 if (gfc_match_char ('/') == MATCH_YES
)
807 if (gfc_match_char (',') == MATCH_NO
)
811 /* If we break early from here out, we encountered an error. */
814 /* Set up expr as an array constructor. */
817 expr
= gfc_get_array_expr (ts
->type
, ts
->kind
, &where
);
819 expr
->value
.constructor
= array_head
;
821 expr
->rank
= as
->rank
;
822 expr
->shape
= gfc_get_shape (expr
->rank
);
824 /* Validate sizes. We built expr ourselves, so cons_size will be
825 constant (we fail above for non-constant expressions).
826 We still need to verify that the sizes match. */
827 gcc_assert (gfc_array_size (expr
, &cons_size
));
828 cmp
= mpz_cmp (cons_size
, as_size
);
830 gfc_error ("Not enough elements in array initializer at %C");
832 gfc_error ("Too many elements in array initializer at %C");
833 mpz_clear (cons_size
);
838 /* Make sure scalar types match. */
839 else if (!gfc_compare_types (&expr
->ts
, ts
)
840 && !gfc_convert_type (expr
, ts
, 1))
844 expr
->ts
.u
.cl
->length_from_typespec
= 1;
852 gfc_error ("Syntax error in old style initializer list at %C");
856 expr
->value
.constructor
= NULL
;
857 gfc_free_expr (expr
);
858 gfc_constructor_free (array_head
);
868 /* Auxiliary function to merge DIMENSION and CODIMENSION array specs. */
871 merge_array_spec (gfc_array_spec
*from
, gfc_array_spec
*to
, bool copy
)
875 if ((from
->type
== AS_ASSUMED_RANK
&& to
->corank
)
876 || (to
->type
== AS_ASSUMED_RANK
&& from
->corank
))
878 gfc_error ("The assumed-rank array at %C shall not have a codimension");
882 if (to
->rank
== 0 && from
->rank
> 0)
884 to
->rank
= from
->rank
;
885 to
->type
= from
->type
;
886 to
->cray_pointee
= from
->cray_pointee
;
887 to
->cp_was_assumed
= from
->cp_was_assumed
;
889 for (i
= 0; i
< to
->corank
; i
++)
891 /* Do not exceed the limits on lower[] and upper[]. gfortran
892 cleans up elsewhere. */
894 if (j
>= GFC_MAX_DIMENSIONS
)
897 to
->lower
[j
] = to
->lower
[i
];
898 to
->upper
[j
] = to
->upper
[i
];
900 for (i
= 0; i
< from
->rank
; i
++)
904 to
->lower
[i
] = gfc_copy_expr (from
->lower
[i
]);
905 to
->upper
[i
] = gfc_copy_expr (from
->upper
[i
]);
909 to
->lower
[i
] = from
->lower
[i
];
910 to
->upper
[i
] = from
->upper
[i
];
914 else if (to
->corank
== 0 && from
->corank
> 0)
916 to
->corank
= from
->corank
;
917 to
->cotype
= from
->cotype
;
919 for (i
= 0; i
< from
->corank
; i
++)
921 /* Do not exceed the limits on lower[] and upper[]. gfortran
922 cleans up elsewhere. */
924 if (j
>= GFC_MAX_DIMENSIONS
)
929 to
->lower
[j
] = gfc_copy_expr (from
->lower
[i
]);
930 to
->upper
[j
] = gfc_copy_expr (from
->upper
[i
]);
934 to
->lower
[j
] = from
->lower
[i
];
935 to
->upper
[j
] = from
->upper
[i
];
940 if (to
->rank
+ to
->corank
> GFC_MAX_DIMENSIONS
)
942 gfc_error ("Sum of array rank %d and corank %d at %C exceeds maximum "
943 "allowed dimensions of %d",
944 to
->rank
, to
->corank
, GFC_MAX_DIMENSIONS
);
945 to
->corank
= GFC_MAX_DIMENSIONS
- to
->rank
;
952 /* Match an intent specification. Since this can only happen after an
953 INTENT word, a legal intent-spec must follow. */
956 match_intent_spec (void)
959 if (gfc_match (" ( in out )") == MATCH_YES
)
961 if (gfc_match (" ( in )") == MATCH_YES
)
963 if (gfc_match (" ( out )") == MATCH_YES
)
966 gfc_error ("Bad INTENT specification at %C");
967 return INTENT_UNKNOWN
;
971 /* Matches a character length specification, which is either a
972 specification expression, '*', or ':'. */
975 char_len_param_value (gfc_expr
**expr
, bool *deferred
)
982 if (gfc_match_char ('*') == MATCH_YES
)
985 if (gfc_match_char (':') == MATCH_YES
)
987 if (!gfc_notify_std (GFC_STD_F2003
, "deferred type parameter at %C"))
995 m
= gfc_match_expr (expr
);
997 if (m
== MATCH_NO
|| m
== MATCH_ERROR
)
1000 if (!gfc_expr_check_typed (*expr
, gfc_current_ns
, false))
1003 if ((*expr
)->expr_type
== EXPR_FUNCTION
)
1005 if ((*expr
)->ts
.type
== BT_INTEGER
1006 || ((*expr
)->ts
.type
== BT_UNKNOWN
1007 && strcmp((*expr
)->symtree
->name
, "null") != 0))
1012 else if ((*expr
)->expr_type
== EXPR_CONSTANT
)
1014 /* F2008, 4.4.3.1: The length is a type parameter; its kind is
1015 processor dependent and its value is greater than or equal to zero.
1016 F2008, 4.4.3.2: If the character length parameter value evaluates
1017 to a negative value, the length of character entities declared
1020 if ((*expr
)->ts
.type
== BT_INTEGER
)
1022 if (mpz_cmp_si ((*expr
)->value
.integer
, 0) < 0)
1023 mpz_set_si ((*expr
)->value
.integer
, 0);
1028 else if ((*expr
)->expr_type
== EXPR_ARRAY
)
1030 else if ((*expr
)->expr_type
== EXPR_VARIABLE
)
1035 e
= gfc_copy_expr (*expr
);
1037 /* This catches the invalid code "[character(m(2:3)) :: 'x', 'y']",
1038 which causes an ICE if gfc_reduce_init_expr() is called. */
1039 if (e
->ref
&& e
->ref
->type
== REF_ARRAY
1040 && e
->ref
->u
.ar
.type
== AR_UNKNOWN
1041 && e
->ref
->u
.ar
.dimen_type
[0] == DIMEN_RANGE
)
1044 t
= gfc_reduce_init_expr (e
);
1046 if (!t
&& e
->ts
.type
== BT_UNKNOWN
1047 && e
->symtree
->n
.sym
->attr
.untyped
== 1
1048 && (flag_implicit_none
1049 || e
->symtree
->n
.sym
->ns
->seen_implicit_none
== 1
1050 || e
->symtree
->n
.sym
->ns
->parent
->seen_implicit_none
== 1))
1056 if ((e
->ref
&& e
->ref
->type
== REF_ARRAY
1057 && e
->ref
->u
.ar
.type
!= AR_ELEMENT
)
1058 || (!e
->ref
&& e
->expr_type
== EXPR_ARRAY
))
1070 gfc_error ("Scalar INTEGER expression expected at %L", &(*expr
)->where
);
1075 /* A character length is a '*' followed by a literal integer or a
1076 char_len_param_value in parenthesis. */
1079 match_char_length (gfc_expr
**expr
, bool *deferred
, bool obsolescent_check
)
1085 m
= gfc_match_char ('*');
1089 m
= gfc_match_small_literal_int (&length
, NULL
);
1090 if (m
== MATCH_ERROR
)
1095 if (obsolescent_check
1096 && !gfc_notify_std (GFC_STD_F95_OBS
, "Old-style character length at %C"))
1098 *expr
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
, length
);
1102 if (gfc_match_char ('(') == MATCH_NO
)
1105 m
= char_len_param_value (expr
, deferred
);
1106 if (m
!= MATCH_YES
&& gfc_matching_function
)
1108 gfc_undo_symbols ();
1112 if (m
== MATCH_ERROR
)
1117 if (gfc_match_char (')') == MATCH_NO
)
1119 gfc_free_expr (*expr
);
1127 gfc_error ("Syntax error in character length specification at %C");
1132 /* Special subroutine for finding a symbol. Check if the name is found
1133 in the current name space. If not, and we're compiling a function or
1134 subroutine and the parent compilation unit is an interface, then check
1135 to see if the name we've been given is the name of the interface
1136 (located in another namespace). */
1139 find_special (const char *name
, gfc_symbol
**result
, bool allow_subroutine
)
1145 i
= gfc_get_sym_tree (name
, NULL
, &st
, allow_subroutine
);
1148 *result
= st
? st
->n
.sym
: NULL
;
1152 if (gfc_current_state () != COMP_SUBROUTINE
1153 && gfc_current_state () != COMP_FUNCTION
)
1156 s
= gfc_state_stack
->previous
;
1160 if (s
->state
!= COMP_INTERFACE
)
1163 goto end
; /* Nameless interface. */
1165 if (strcmp (name
, s
->sym
->name
) == 0)
1176 /* Special subroutine for getting a symbol node associated with a
1177 procedure name, used in SUBROUTINE and FUNCTION statements. The
1178 symbol is created in the parent using with symtree node in the
1179 child unit pointing to the symbol. If the current namespace has no
1180 parent, then the symbol is just created in the current unit. */
1183 get_proc_name (const char *name
, gfc_symbol
**result
, bool module_fcn_entry
)
1189 /* Module functions have to be left in their own namespace because
1190 they have potentially (almost certainly!) already been referenced.
1191 In this sense, they are rather like external functions. This is
1192 fixed up in resolve.c(resolve_entries), where the symbol name-
1193 space is set to point to the master function, so that the fake
1194 result mechanism can work. */
1195 if (module_fcn_entry
)
1197 /* Present if entry is declared to be a module procedure. */
1198 rc
= gfc_find_symbol (name
, gfc_current_ns
->parent
, 0, result
);
1200 if (*result
== NULL
)
1201 rc
= gfc_get_symbol (name
, NULL
, result
);
1202 else if (!gfc_get_symbol (name
, NULL
, &sym
) && sym
1203 && (*result
)->ts
.type
== BT_UNKNOWN
1204 && sym
->attr
.flavor
== FL_UNKNOWN
)
1205 /* Pick up the typespec for the entry, if declared in the function
1206 body. Note that this symbol is FL_UNKNOWN because it will
1207 only have appeared in a type declaration. The local symtree
1208 is set to point to the module symbol and a unique symtree
1209 to the local version. This latter ensures a correct clearing
1212 /* If the ENTRY proceeds its specification, we need to ensure
1213 that this does not raise a "has no IMPLICIT type" error. */
1214 if (sym
->ts
.type
== BT_UNKNOWN
)
1215 sym
->attr
.untyped
= 1;
1217 (*result
)->ts
= sym
->ts
;
1219 /* Put the symbol in the procedure namespace so that, should
1220 the ENTRY precede its specification, the specification
1222 (*result
)->ns
= gfc_current_ns
;
1224 gfc_find_sym_tree (name
, gfc_current_ns
, 0, &st
);
1225 st
->n
.sym
= *result
;
1226 st
= gfc_get_unique_symtree (gfc_current_ns
);
1232 rc
= gfc_get_symbol (name
, gfc_current_ns
->parent
, result
);
1238 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
1241 if (sym
->attr
.module_procedure
&& sym
->attr
.if_source
== IFSRC_IFBODY
)
1243 /* Create a partially populated interface symbol to carry the
1244 characteristics of the procedure and the result. */
1245 sym
->tlink
= gfc_new_symbol (name
, sym
->ns
);
1246 gfc_add_type (sym
->tlink
, &(sym
->ts
), &gfc_current_locus
);
1247 gfc_copy_attr (&sym
->tlink
->attr
, &sym
->attr
, NULL
);
1248 if (sym
->attr
.dimension
)
1249 sym
->tlink
->as
= gfc_copy_array_spec (sym
->as
);
1251 /* Ideally, at this point, a copy would be made of the formal
1252 arguments and their namespace. However, this does not appear
1253 to be necessary, albeit at the expense of not being able to
1254 use gfc_compare_interfaces directly. */
1256 if (sym
->result
&& sym
->result
!= sym
)
1258 sym
->tlink
->result
= sym
->result
;
1261 else if (sym
->result
)
1263 sym
->tlink
->result
= sym
->tlink
;
1266 else if (sym
&& !sym
->gfc_new
1267 && gfc_current_state () != COMP_INTERFACE
)
1269 /* Trap another encompassed procedure with the same name. All
1270 these conditions are necessary to avoid picking up an entry
1271 whose name clashes with that of the encompassing procedure;
1272 this is handled using gsymbols to register unique, globally
1273 accessible names. */
1274 if (sym
->attr
.flavor
!= 0
1275 && sym
->attr
.proc
!= 0
1276 && (sym
->attr
.subroutine
|| sym
->attr
.function
|| sym
->attr
.entry
)
1277 && sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
1279 gfc_error_now ("Procedure %qs at %C is already defined at %L",
1280 name
, &sym
->declared_at
);
1283 if (sym
->attr
.flavor
!= 0
1284 && sym
->attr
.entry
&& sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
1286 gfc_error_now ("Procedure %qs at %C is already defined at %L",
1287 name
, &sym
->declared_at
);
1291 if (sym
->attr
.external
&& sym
->attr
.procedure
1292 && gfc_current_state () == COMP_CONTAINS
)
1294 gfc_error_now ("Contained procedure %qs at %C clashes with "
1295 "procedure defined at %L",
1296 name
, &sym
->declared_at
);
1300 /* Trap a procedure with a name the same as interface in the
1301 encompassing scope. */
1302 if (sym
->attr
.generic
!= 0
1303 && (sym
->attr
.subroutine
|| sym
->attr
.function
)
1304 && !sym
->attr
.mod_proc
)
1306 gfc_error_now ("Name %qs at %C is already defined"
1307 " as a generic interface at %L",
1308 name
, &sym
->declared_at
);
1312 /* Trap declarations of attributes in encompassing scope. The
1313 signature for this is that ts.kind is set. Legitimate
1314 references only set ts.type. */
1315 if (sym
->ts
.kind
!= 0
1316 && !sym
->attr
.implicit_type
1317 && sym
->attr
.proc
== 0
1318 && gfc_current_ns
->parent
!= NULL
1319 && sym
->attr
.access
== 0
1320 && !module_fcn_entry
)
1322 gfc_error_now ("Procedure %qs at %C has an explicit interface "
1323 "from a previous declaration", name
);
1328 /* C1246 (R1225) MODULE shall appear only in the function-stmt or
1329 subroutine-stmt of a module subprogram or of a nonabstract interface
1330 body that is declared in the scoping unit of a module or submodule. */
1331 if (sym
->attr
.external
1332 && (sym
->attr
.subroutine
|| sym
->attr
.function
)
1333 && sym
->attr
.if_source
== IFSRC_IFBODY
1334 && !current_attr
.module_procedure
1335 && sym
->attr
.proc
== PROC_MODULE
1336 && gfc_state_stack
->state
== COMP_CONTAINS
)
1338 gfc_error_now ("Procedure %qs defined in interface body at %L "
1339 "clashes with internal procedure defined at %C",
1340 name
, &sym
->declared_at
);
1344 if (sym
&& !sym
->gfc_new
1345 && sym
->attr
.flavor
!= FL_UNKNOWN
1346 && sym
->attr
.referenced
== 0 && sym
->attr
.subroutine
== 1
1347 && gfc_state_stack
->state
== COMP_CONTAINS
1348 && gfc_state_stack
->previous
->state
== COMP_SUBROUTINE
)
1350 gfc_error_now ("Procedure %qs at %C is already defined at %L",
1351 name
, &sym
->declared_at
);
1355 if (gfc_current_ns
->parent
== NULL
|| *result
== NULL
)
1358 /* Module function entries will already have a symtree in
1359 the current namespace but will need one at module level. */
1360 if (module_fcn_entry
)
1362 /* Present if entry is declared to be a module procedure. */
1363 rc
= gfc_find_sym_tree (name
, gfc_current_ns
->parent
, 0, &st
);
1365 st
= gfc_new_symtree (&gfc_current_ns
->parent
->sym_root
, name
);
1368 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, name
);
1373 /* See if the procedure should be a module procedure. */
1375 if (((sym
->ns
->proc_name
!= NULL
1376 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
1377 && sym
->attr
.proc
!= PROC_MODULE
)
1378 || (module_fcn_entry
&& sym
->attr
.proc
!= PROC_MODULE
))
1379 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
1386 /* Verify that the given symbol representing a parameter is C
1387 interoperable, by checking to see if it was marked as such after
1388 its declaration. If the given symbol is not interoperable, a
1389 warning is reported, thus removing the need to return the status to
1390 the calling function. The standard does not require the user use
1391 one of the iso_c_binding named constants to declare an
1392 interoperable parameter, but we can't be sure if the param is C
1393 interop or not if the user doesn't. For example, integer(4) may be
1394 legal Fortran, but doesn't have meaning in C. It may interop with
1395 a number of the C types, which causes a problem because the
1396 compiler can't know which one. This code is almost certainly not
1397 portable, and the user will get what they deserve if the C type
1398 across platforms isn't always interoperable with integer(4). If
1399 the user had used something like integer(c_int) or integer(c_long),
1400 the compiler could have automatically handled the varying sizes
1401 across platforms. */
1404 gfc_verify_c_interop_param (gfc_symbol
*sym
)
1406 int is_c_interop
= 0;
1409 /* We check implicitly typed variables in symbol.c:gfc_set_default_type().
1410 Don't repeat the checks here. */
1411 if (sym
->attr
.implicit_type
)
1414 /* For subroutines or functions that are passed to a BIND(C) procedure,
1415 they're interoperable if they're BIND(C) and their params are all
1417 if (sym
->attr
.flavor
== FL_PROCEDURE
)
1419 if (sym
->attr
.is_bind_c
== 0)
1421 gfc_error_now ("Procedure %qs at %L must have the BIND(C) "
1422 "attribute to be C interoperable", sym
->name
,
1423 &(sym
->declared_at
));
1428 if (sym
->attr
.is_c_interop
== 1)
1429 /* We've already checked this procedure; don't check it again. */
1432 return verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
1437 /* See if we've stored a reference to a procedure that owns sym. */
1438 if (sym
->ns
!= NULL
&& sym
->ns
->proc_name
!= NULL
)
1440 if (sym
->ns
->proc_name
->attr
.is_bind_c
== 1)
1442 is_c_interop
= (gfc_verify_c_interop(&(sym
->ts
)) ? 1 : 0);
1444 if (is_c_interop
!= 1)
1446 /* Make personalized messages to give better feedback. */
1447 if (sym
->ts
.type
== BT_DERIVED
)
1448 gfc_error ("Variable %qs at %L is a dummy argument to the "
1449 "BIND(C) procedure %qs but is not C interoperable "
1450 "because derived type %qs is not C interoperable",
1451 sym
->name
, &(sym
->declared_at
),
1452 sym
->ns
->proc_name
->name
,
1453 sym
->ts
.u
.derived
->name
);
1454 else if (sym
->ts
.type
== BT_CLASS
)
1455 gfc_error ("Variable %qs at %L is a dummy argument to the "
1456 "BIND(C) procedure %qs but is not C interoperable "
1457 "because it is polymorphic",
1458 sym
->name
, &(sym
->declared_at
),
1459 sym
->ns
->proc_name
->name
);
1460 else if (warn_c_binding_type
)
1461 gfc_warning (OPT_Wc_binding_type
,
1462 "Variable %qs at %L is a dummy argument of the "
1463 "BIND(C) procedure %qs but may not be C "
1465 sym
->name
, &(sym
->declared_at
),
1466 sym
->ns
->proc_name
->name
);
1469 /* Character strings are only C interoperable if they have a
1471 if (sym
->ts
.type
== BT_CHARACTER
)
1473 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
1474 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
1475 || mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
1477 gfc_error ("Character argument %qs at %L "
1478 "must be length 1 because "
1479 "procedure %qs is BIND(C)",
1480 sym
->name
, &sym
->declared_at
,
1481 sym
->ns
->proc_name
->name
);
1486 /* We have to make sure that any param to a bind(c) routine does
1487 not have the allocatable, pointer, or optional attributes,
1488 according to J3/04-007, section 5.1. */
1489 if (sym
->attr
.allocatable
== 1
1490 && !gfc_notify_std (GFC_STD_F2018
, "Variable %qs at %L with "
1491 "ALLOCATABLE attribute in procedure %qs "
1492 "with BIND(C)", sym
->name
,
1493 &(sym
->declared_at
),
1494 sym
->ns
->proc_name
->name
))
1497 if (sym
->attr
.pointer
== 1
1498 && !gfc_notify_std (GFC_STD_F2018
, "Variable %qs at %L with "
1499 "POINTER attribute in procedure %qs "
1500 "with BIND(C)", sym
->name
,
1501 &(sym
->declared_at
),
1502 sym
->ns
->proc_name
->name
))
1505 if ((sym
->attr
.allocatable
|| sym
->attr
.pointer
) && !sym
->as
)
1507 gfc_error ("Scalar variable %qs at %L with POINTER or "
1508 "ALLOCATABLE in procedure %qs with BIND(C) is not yet"
1509 " supported", sym
->name
, &(sym
->declared_at
),
1510 sym
->ns
->proc_name
->name
);
1514 if (sym
->attr
.optional
== 1 && sym
->attr
.value
)
1516 gfc_error ("Variable %qs at %L cannot have both the OPTIONAL "
1517 "and the VALUE attribute because procedure %qs "
1518 "is BIND(C)", sym
->name
, &(sym
->declared_at
),
1519 sym
->ns
->proc_name
->name
);
1522 else if (sym
->attr
.optional
== 1
1523 && !gfc_notify_std (GFC_STD_F2018
, "Variable %qs "
1524 "at %L with OPTIONAL attribute in "
1525 "procedure %qs which is BIND(C)",
1526 sym
->name
, &(sym
->declared_at
),
1527 sym
->ns
->proc_name
->name
))
1530 /* Make sure that if it has the dimension attribute, that it is
1531 either assumed size or explicit shape. Deferred shape is already
1532 covered by the pointer/allocatable attribute. */
1533 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SHAPE
1534 && !gfc_notify_std (GFC_STD_F2018
, "Assumed-shape array %qs "
1535 "at %L as dummy argument to the BIND(C) "
1536 "procedure %qs at %L", sym
->name
,
1537 &(sym
->declared_at
),
1538 sym
->ns
->proc_name
->name
,
1539 &(sym
->ns
->proc_name
->declared_at
)))
1549 /* Function called by variable_decl() that adds a name to the symbol table. */
1552 build_sym (const char *name
, gfc_charlen
*cl
, bool cl_deferred
,
1553 gfc_array_spec
**as
, locus
*var_locus
)
1555 symbol_attribute attr
;
1560 /* Symbols in a submodule are host associated from the parent module or
1561 submodules. Therefore, they can be overridden by declarations in the
1562 submodule scope. Deal with this by attaching the existing symbol to
1563 a new symtree and recycling the old symtree with a new symbol... */
1564 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
1565 if (st
!= NULL
&& gfc_state_stack
->state
== COMP_SUBMODULE
1566 && st
->n
.sym
!= NULL
1567 && st
->n
.sym
->attr
.host_assoc
&& st
->n
.sym
->attr
.used_in_submodule
)
1569 gfc_symtree
*s
= gfc_get_unique_symtree (gfc_current_ns
);
1570 s
->n
.sym
= st
->n
.sym
;
1571 sym
= gfc_new_symbol (name
, gfc_current_ns
);
1576 gfc_set_sym_referenced (sym
);
1578 /* ...Otherwise generate a new symtree and new symbol. */
1579 else if (gfc_get_symbol (name
, NULL
, &sym
))
1582 /* Check if the name has already been defined as a type. The
1583 first letter of the symtree will be in upper case then. Of
1584 course, this is only necessary if the upper case letter is
1585 actually different. */
1587 upper
= TOUPPER(name
[0]);
1588 if (upper
!= name
[0])
1590 char u_name
[GFC_MAX_SYMBOL_LEN
+ 1];
1593 gcc_assert (strlen(name
) <= GFC_MAX_SYMBOL_LEN
);
1594 strcpy (u_name
, name
);
1597 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, u_name
);
1599 /* STRUCTURE types can alias symbol names */
1600 if (st
!= 0 && st
->n
.sym
->attr
.flavor
!= FL_STRUCT
)
1602 gfc_error ("Symbol %qs at %C also declared as a type at %L", name
,
1603 &st
->n
.sym
->declared_at
);
1608 /* Start updating the symbol table. Add basic type attribute if present. */
1609 if (current_ts
.type
!= BT_UNKNOWN
1610 && (sym
->attr
.implicit_type
== 0
1611 || !gfc_compare_types (&sym
->ts
, ¤t_ts
))
1612 && !gfc_add_type (sym
, ¤t_ts
, var_locus
))
1615 if (sym
->ts
.type
== BT_CHARACTER
)
1618 sym
->ts
.deferred
= cl_deferred
;
1621 /* Add dimension attribute if present. */
1622 if (!gfc_set_array_spec (sym
, *as
, var_locus
))
1626 /* Add attribute to symbol. The copy is so that we can reset the
1627 dimension attribute. */
1628 attr
= current_attr
;
1630 attr
.codimension
= 0;
1632 if (!gfc_copy_attr (&sym
->attr
, &attr
, var_locus
))
1635 /* Finish any work that may need to be done for the binding label,
1636 if it's a bind(c). The bind(c) attr is found before the symbol
1637 is made, and before the symbol name (for data decls), so the
1638 current_ts is holding the binding label, or nothing if the
1639 name= attr wasn't given. Therefore, test here if we're dealing
1640 with a bind(c) and make sure the binding label is set correctly. */
1641 if (sym
->attr
.is_bind_c
== 1)
1643 if (!sym
->binding_label
)
1645 /* Set the binding label and verify that if a NAME= was specified
1646 then only one identifier was in the entity-decl-list. */
1647 if (!set_binding_label (&sym
->binding_label
, sym
->name
,
1648 num_idents_on_line
))
1653 /* See if we know we're in a common block, and if it's a bind(c)
1654 common then we need to make sure we're an interoperable type. */
1655 if (sym
->attr
.in_common
== 1)
1657 /* Test the common block object. */
1658 if (sym
->common_block
!= NULL
&& sym
->common_block
->is_bind_c
== 1
1659 && sym
->ts
.is_c_interop
!= 1)
1661 gfc_error_now ("Variable %qs in common block %qs at %C "
1662 "must be declared with a C interoperable "
1663 "kind since common block %qs is BIND(C)",
1664 sym
->name
, sym
->common_block
->name
,
1665 sym
->common_block
->name
);
1670 sym
->attr
.implied_index
= 0;
1672 /* Use the parameter expressions for a parameterized derived type. */
1673 if ((sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
1674 && sym
->ts
.u
.derived
->attr
.pdt_type
&& type_param_spec_list
)
1675 sym
->param_list
= gfc_copy_actual_arglist (type_param_spec_list
);
1677 if (sym
->ts
.type
== BT_CLASS
)
1678 return gfc_build_class_symbol (&sym
->ts
, &sym
->attr
, &sym
->as
);
1684 /* Set character constant to the given length. The constant will be padded or
1685 truncated. If we're inside an array constructor without a typespec, we
1686 additionally check that all elements have the same length; check_len -1
1687 means no checking. */
1690 gfc_set_constant_character_len (gfc_charlen_t len
, gfc_expr
*expr
,
1691 gfc_charlen_t check_len
)
1696 if (expr
->ts
.type
!= BT_CHARACTER
)
1699 if (expr
->expr_type
!= EXPR_CONSTANT
)
1701 gfc_error_now ("CHARACTER length must be a constant at %L", &expr
->where
);
1705 slen
= expr
->value
.character
.length
;
1708 s
= gfc_get_wide_string (len
+ 1);
1709 memcpy (s
, expr
->value
.character
.string
,
1710 MIN (len
, slen
) * sizeof (gfc_char_t
));
1712 gfc_wide_memset (&s
[slen
], ' ', len
- slen
);
1714 if (warn_character_truncation
&& slen
> len
)
1715 gfc_warning_now (OPT_Wcharacter_truncation
,
1716 "CHARACTER expression at %L is being truncated "
1717 "(%ld/%ld)", &expr
->where
,
1718 (long) slen
, (long) len
);
1720 /* Apply the standard by 'hand' otherwise it gets cleared for
1722 if (check_len
!= -1 && slen
!= check_len
1723 && !(gfc_option
.allow_std
& GFC_STD_GNU
))
1724 gfc_error_now ("The CHARACTER elements of the array constructor "
1725 "at %L must have the same length (%ld/%ld)",
1726 &expr
->where
, (long) slen
,
1730 free (expr
->value
.character
.string
);
1731 expr
->value
.character
.string
= s
;
1732 expr
->value
.character
.length
= len
;
1737 /* Function to create and update the enumerator history
1738 using the information passed as arguments.
1739 Pointer "max_enum" is also updated, to point to
1740 enum history node containing largest initializer.
1742 SYM points to the symbol node of enumerator.
1743 INIT points to its enumerator value. */
1746 create_enum_history (gfc_symbol
*sym
, gfc_expr
*init
)
1748 enumerator_history
*new_enum_history
;
1749 gcc_assert (sym
!= NULL
&& init
!= NULL
);
1751 new_enum_history
= XCNEW (enumerator_history
);
1753 new_enum_history
->sym
= sym
;
1754 new_enum_history
->initializer
= init
;
1755 new_enum_history
->next
= NULL
;
1757 if (enum_history
== NULL
)
1759 enum_history
= new_enum_history
;
1760 max_enum
= enum_history
;
1764 new_enum_history
->next
= enum_history
;
1765 enum_history
= new_enum_history
;
1767 if (mpz_cmp (max_enum
->initializer
->value
.integer
,
1768 new_enum_history
->initializer
->value
.integer
) < 0)
1769 max_enum
= new_enum_history
;
1774 /* Function to free enum kind history. */
1777 gfc_free_enum_history (void)
1779 enumerator_history
*current
= enum_history
;
1780 enumerator_history
*next
;
1782 while (current
!= NULL
)
1784 next
= current
->next
;
1789 enum_history
= NULL
;
1793 /* Function called by variable_decl() that adds an initialization
1794 expression to a symbol. */
1797 add_init_expr_to_sym (const char *name
, gfc_expr
**initp
, locus
*var_locus
)
1799 symbol_attribute attr
;
1804 if (find_special (name
, &sym
, false))
1809 /* If this symbol is confirming an implicit parameter type,
1810 then an initialization expression is not allowed. */
1811 if (attr
.flavor
== FL_PARAMETER
1812 && sym
->value
!= NULL
1815 gfc_error ("Initializer not allowed for PARAMETER %qs at %C",
1822 /* An initializer is required for PARAMETER declarations. */
1823 if (attr
.flavor
== FL_PARAMETER
)
1825 gfc_error ("PARAMETER at %L is missing an initializer", var_locus
);
1831 /* If a variable appears in a DATA block, it cannot have an
1835 gfc_error ("Variable %qs at %C with an initializer already "
1836 "appears in a DATA statement", sym
->name
);
1840 /* Check if the assignment can happen. This has to be put off
1841 until later for derived type variables and procedure pointers. */
1842 if (!gfc_bt_struct (sym
->ts
.type
) && !gfc_bt_struct (init
->ts
.type
)
1843 && sym
->ts
.type
!= BT_CLASS
&& init
->ts
.type
!= BT_CLASS
1844 && !sym
->attr
.proc_pointer
1845 && !gfc_check_assign_symbol (sym
, NULL
, init
))
1848 if (sym
->ts
.type
== BT_CHARACTER
&& sym
->ts
.u
.cl
1849 && init
->ts
.type
== BT_CHARACTER
)
1851 /* Update symbol character length according initializer. */
1852 if (!gfc_check_assign_symbol (sym
, NULL
, init
))
1855 if (sym
->ts
.u
.cl
->length
== NULL
)
1858 /* If there are multiple CHARACTER variables declared on the
1859 same line, we don't want them to share the same length. */
1860 sym
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1862 if (sym
->attr
.flavor
== FL_PARAMETER
)
1864 if (init
->expr_type
== EXPR_CONSTANT
)
1866 clen
= init
->value
.character
.length
;
1867 sym
->ts
.u
.cl
->length
1868 = gfc_get_int_expr (gfc_charlen_int_kind
,
1871 else if (init
->expr_type
== EXPR_ARRAY
)
1873 if (init
->ts
.u
.cl
&& init
->ts
.u
.cl
->length
)
1875 const gfc_expr
*length
= init
->ts
.u
.cl
->length
;
1876 if (length
->expr_type
!= EXPR_CONSTANT
)
1878 gfc_error ("Cannot initialize parameter array "
1880 "with variable length elements",
1884 clen
= mpz_get_si (length
->value
.integer
);
1886 else if (init
->value
.constructor
)
1889 c
= gfc_constructor_first (init
->value
.constructor
);
1890 clen
= c
->expr
->value
.character
.length
;
1894 sym
->ts
.u
.cl
->length
1895 = gfc_get_int_expr (gfc_charlen_int_kind
,
1898 else if (init
->ts
.u
.cl
&& init
->ts
.u
.cl
->length
)
1899 sym
->ts
.u
.cl
->length
=
1900 gfc_copy_expr (sym
->value
->ts
.u
.cl
->length
);
1903 /* Update initializer character length according symbol. */
1904 else if (sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1906 if (!gfc_specification_expr (sym
->ts
.u
.cl
->length
))
1909 int k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
,
1911 /* resolve_charlen will complain later on if the length
1912 is too large. Just skeep the initialization in that case. */
1913 if (mpz_cmp (sym
->ts
.u
.cl
->length
->value
.integer
,
1914 gfc_integer_kinds
[k
].huge
) <= 0)
1917 = gfc_mpz_get_hwi (sym
->ts
.u
.cl
->length
->value
.integer
);
1919 if (init
->expr_type
== EXPR_CONSTANT
)
1920 gfc_set_constant_character_len (len
, init
, -1);
1921 else if (init
->expr_type
== EXPR_ARRAY
)
1925 /* Build a new charlen to prevent simplification from
1926 deleting the length before it is resolved. */
1927 init
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1928 init
->ts
.u
.cl
->length
1929 = gfc_copy_expr (sym
->ts
.u
.cl
->length
);
1931 for (c
= gfc_constructor_first (init
->value
.constructor
);
1932 c
; c
= gfc_constructor_next (c
))
1933 gfc_set_constant_character_len (len
, c
->expr
, -1);
1939 /* If sym is implied-shape, set its upper bounds from init. */
1940 if (sym
->attr
.flavor
== FL_PARAMETER
&& sym
->attr
.dimension
1941 && sym
->as
->type
== AS_IMPLIED_SHAPE
)
1945 if (init
->rank
== 0)
1947 gfc_error ("Can't initialize implied-shape array at %L"
1948 " with scalar", &sym
->declared_at
);
1952 /* Shape should be present, we get an initialization expression. */
1953 gcc_assert (init
->shape
);
1955 for (dim
= 0; dim
< sym
->as
->rank
; ++dim
)
1958 gfc_expr
*e
, *lower
;
1960 lower
= sym
->as
->lower
[dim
];
1962 /* If the lower bound is an array element from another
1963 parameterized array, then it is marked with EXPR_VARIABLE and
1964 is an initialization expression. Try to reduce it. */
1965 if (lower
->expr_type
== EXPR_VARIABLE
)
1966 gfc_reduce_init_expr (lower
);
1968 if (lower
->expr_type
== EXPR_CONSTANT
)
1970 /* All dimensions must be without upper bound. */
1971 gcc_assert (!sym
->as
->upper
[dim
]);
1974 e
= gfc_get_constant_expr (BT_INTEGER
, k
, &sym
->declared_at
);
1975 mpz_add (e
->value
.integer
, lower
->value
.integer
,
1977 mpz_sub_ui (e
->value
.integer
, e
->value
.integer
, 1);
1978 sym
->as
->upper
[dim
] = e
;
1982 gfc_error ("Non-constant lower bound in implied-shape"
1983 " declaration at %L", &lower
->where
);
1988 sym
->as
->type
= AS_EXPLICIT
;
1991 /* Need to check if the expression we initialized this
1992 to was one of the iso_c_binding named constants. If so,
1993 and we're a parameter (constant), let it be iso_c.
1995 integer(c_int), parameter :: my_int = c_int
1996 integer(my_int) :: my_int_2
1997 If we mark my_int as iso_c (since we can see it's value
1998 is equal to one of the named constants), then my_int_2
1999 will be considered C interoperable. */
2000 if (sym
->ts
.type
!= BT_CHARACTER
&& !gfc_bt_struct (sym
->ts
.type
))
2002 sym
->ts
.is_iso_c
|= init
->ts
.is_iso_c
;
2003 sym
->ts
.is_c_interop
|= init
->ts
.is_c_interop
;
2004 /* attr bits needed for module files. */
2005 sym
->attr
.is_iso_c
|= init
->ts
.is_iso_c
;
2006 sym
->attr
.is_c_interop
|= init
->ts
.is_c_interop
;
2007 if (init
->ts
.is_iso_c
)
2008 sym
->ts
.f90_type
= init
->ts
.f90_type
;
2011 /* Add initializer. Make sure we keep the ranks sane. */
2012 if (sym
->attr
.dimension
&& init
->rank
== 0)
2017 if (sym
->attr
.flavor
== FL_PARAMETER
2018 && init
->expr_type
== EXPR_CONSTANT
2019 && spec_size (sym
->as
, &size
)
2020 && mpz_cmp_si (size
, 0) > 0)
2022 array
= gfc_get_array_expr (init
->ts
.type
, init
->ts
.kind
,
2024 for (n
= 0; n
< (int)mpz_get_si (size
); n
++)
2025 gfc_constructor_append_expr (&array
->value
.constructor
,
2028 : gfc_copy_expr (init
),
2031 array
->shape
= gfc_get_shape (sym
->as
->rank
);
2032 for (n
= 0; n
< sym
->as
->rank
; n
++)
2033 spec_dimen_size (sym
->as
, n
, &array
->shape
[n
]);
2038 init
->rank
= sym
->as
->rank
;
2042 if (sym
->attr
.save
== SAVE_NONE
)
2043 sym
->attr
.save
= SAVE_IMPLICIT
;
2051 /* Function called by variable_decl() that adds a name to a structure
2055 build_struct (const char *name
, gfc_charlen
*cl
, gfc_expr
**init
,
2056 gfc_array_spec
**as
)
2061 /* F03:C438/C439. If the current symbol is of the same derived type that we're
2062 constructing, it must have the pointer attribute. */
2063 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
2064 && current_ts
.u
.derived
== gfc_current_block ()
2065 && current_attr
.pointer
== 0)
2067 if (current_attr
.allocatable
2068 && !gfc_notify_std(GFC_STD_F2008
, "Component at %C "
2069 "must have the POINTER attribute"))
2073 else if (current_attr
.allocatable
== 0)
2075 gfc_error ("Component at %C must have the POINTER attribute");
2081 if (current_ts
.type
== BT_CLASS
2082 && !(current_attr
.pointer
|| current_attr
.allocatable
))
2084 gfc_error ("Component %qs with CLASS at %C must be allocatable "
2085 "or pointer", name
);
2089 if (gfc_current_block ()->attr
.pointer
&& (*as
)->rank
!= 0)
2091 if ((*as
)->type
!= AS_DEFERRED
&& (*as
)->type
!= AS_EXPLICIT
)
2093 gfc_error ("Array component of structure at %C must have explicit "
2094 "or deferred shape");
2099 /* If we are in a nested union/map definition, gfc_add_component will not
2100 properly find repeated components because:
2101 (i) gfc_add_component does a flat search, where components of unions
2102 and maps are implicity chained so nested components may conflict.
2103 (ii) Unions and maps are not linked as components of their parent
2104 structures until after they are parsed.
2105 For (i) we use gfc_find_component which searches recursively, and for (ii)
2106 we search each block directly from the parse stack until we find the top
2109 s
= gfc_state_stack
;
2110 if (s
->state
== COMP_UNION
|| s
->state
== COMP_MAP
)
2112 while (s
->state
== COMP_UNION
|| gfc_comp_struct (s
->state
))
2114 c
= gfc_find_component (s
->sym
, name
, true, true, NULL
);
2117 gfc_error_now ("Component %qs at %C already declared at %L",
2121 /* Break after we've searched the entire chain. */
2122 if (s
->state
== COMP_DERIVED
|| s
->state
== COMP_STRUCTURE
)
2128 if (!gfc_add_component (gfc_current_block(), name
, &c
))
2132 if (c
->ts
.type
== BT_CHARACTER
)
2135 if (c
->ts
.type
!= BT_CLASS
&& c
->ts
.type
!= BT_DERIVED
2136 && (c
->ts
.kind
== 0 || c
->ts
.type
== BT_CHARACTER
)
2137 && saved_kind_expr
!= NULL
)
2138 c
->kind_expr
= gfc_copy_expr (saved_kind_expr
);
2140 c
->attr
= current_attr
;
2142 c
->initializer
= *init
;
2149 c
->attr
.codimension
= 1;
2151 c
->attr
.dimension
= 1;
2155 gfc_apply_init (&c
->ts
, &c
->attr
, c
->initializer
);
2157 /* Check array components. */
2158 if (!c
->attr
.dimension
)
2161 if (c
->attr
.pointer
)
2163 if (c
->as
->type
!= AS_DEFERRED
)
2165 gfc_error ("Pointer array component of structure at %C must have a "
2170 else if (c
->attr
.allocatable
)
2172 if (c
->as
->type
!= AS_DEFERRED
)
2174 gfc_error ("Allocatable component of structure at %C must have a "
2181 if (c
->as
->type
!= AS_EXPLICIT
)
2183 gfc_error ("Array component of structure at %C must have an "
2190 if (c
->ts
.type
== BT_CLASS
)
2191 return gfc_build_class_symbol (&c
->ts
, &c
->attr
, &c
->as
);
2193 if (c
->attr
.pdt_kind
|| c
->attr
.pdt_len
)
2196 gfc_find_symbol (c
->name
, gfc_current_block ()->f2k_derived
,
2200 gfc_error ("Type parameter %qs at %C has no corresponding entry "
2201 "in the type parameter name list at %L",
2202 c
->name
, &gfc_current_block ()->declared_at
);
2206 sym
->attr
.pdt_kind
= c
->attr
.pdt_kind
;
2207 sym
->attr
.pdt_len
= c
->attr
.pdt_len
;
2209 sym
->value
= gfc_copy_expr (c
->initializer
);
2210 sym
->attr
.flavor
= FL_VARIABLE
;
2213 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
2214 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_template
2215 && decl_type_param_list
)
2216 c
->param_list
= gfc_copy_actual_arglist (decl_type_param_list
);
2222 /* Match a 'NULL()', and possibly take care of some side effects. */
2225 gfc_match_null (gfc_expr
**result
)
2228 match m
, m2
= MATCH_NO
;
2230 if ((m
= gfc_match (" null ( )")) == MATCH_ERROR
)
2236 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2238 if ((m2
= gfc_match (" null (")) != MATCH_YES
)
2241 old_loc
= gfc_current_locus
;
2242 if ((m2
= gfc_match (" %n ) ", name
)) == MATCH_ERROR
)
2245 && ((m2
= gfc_match (" mold = %n )", name
)) == MATCH_ERROR
))
2249 gfc_current_locus
= old_loc
;
2254 /* The NULL symbol now has to be/become an intrinsic function. */
2255 if (gfc_get_symbol ("null", NULL
, &sym
))
2257 gfc_error ("NULL() initialization at %C is ambiguous");
2261 gfc_intrinsic_symbol (sym
);
2263 if (sym
->attr
.proc
!= PROC_INTRINSIC
2264 && !(sym
->attr
.use_assoc
&& sym
->attr
.intrinsic
)
2265 && (!gfc_add_procedure(&sym
->attr
, PROC_INTRINSIC
, sym
->name
, NULL
)
2266 || !gfc_add_function (&sym
->attr
, sym
->name
, NULL
)))
2269 *result
= gfc_get_null_expr (&gfc_current_locus
);
2271 /* Invalid per F2008, C512. */
2272 if (m2
== MATCH_YES
)
2274 gfc_error ("NULL() initialization at %C may not have MOLD");
2282 /* Match the initialization expr for a data pointer or procedure pointer. */
2285 match_pointer_init (gfc_expr
**init
, int procptr
)
2289 if (gfc_pure (NULL
) && !gfc_comp_struct (gfc_state_stack
->state
))
2291 gfc_error ("Initialization of pointer at %C is not allowed in "
2292 "a PURE procedure");
2295 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
2297 /* Match NULL() initialization. */
2298 m
= gfc_match_null (init
);
2302 /* Match non-NULL initialization. */
2303 gfc_matching_ptr_assignment
= !procptr
;
2304 gfc_matching_procptr_assignment
= procptr
;
2305 m
= gfc_match_rvalue (init
);
2306 gfc_matching_ptr_assignment
= 0;
2307 gfc_matching_procptr_assignment
= 0;
2308 if (m
== MATCH_ERROR
)
2310 else if (m
== MATCH_NO
)
2312 gfc_error ("Error in pointer initialization at %C");
2316 if (!procptr
&& !gfc_resolve_expr (*init
))
2319 if (!gfc_notify_std (GFC_STD_F2008
, "non-NULL pointer "
2320 "initialization at %C"))
2328 check_function_name (char *name
)
2330 /* In functions that have a RESULT variable defined, the function name always
2331 refers to function calls. Therefore, the name is not allowed to appear in
2332 specification statements. When checking this, be careful about
2333 'hidden' procedure pointer results ('ppr@'). */
2335 if (gfc_current_state () == COMP_FUNCTION
)
2337 gfc_symbol
*block
= gfc_current_block ();
2338 if (block
&& block
->result
&& block
->result
!= block
2339 && strcmp (block
->result
->name
, "ppr@") != 0
2340 && strcmp (block
->name
, name
) == 0)
2342 gfc_error ("RESULT variable %qs at %L prohibits FUNCTION name %qs at %C "
2343 "from appearing in a specification statement",
2344 block
->result
->name
, &block
->result
->declared_at
, name
);
2353 /* Match a variable name with an optional initializer. When this
2354 subroutine is called, a variable is expected to be parsed next.
2355 Depending on what is happening at the moment, updates either the
2356 symbol table or the current interface. */
2359 variable_decl (int elem
)
2361 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2362 static unsigned int fill_id
= 0;
2363 gfc_expr
*initializer
, *char_len
;
2365 gfc_array_spec
*cp_as
; /* Extra copy for Cray Pointees. */
2377 /* When we get here, we've just matched a list of attributes and
2378 maybe a type and a double colon. The next thing we expect to see
2379 is the name of the symbol. */
2381 /* If we are parsing a structure with legacy support, we allow the symbol
2382 name to be '%FILL' which gives it an anonymous (inaccessible) name. */
2384 gfc_gobble_whitespace ();
2385 if (gfc_peek_ascii_char () == '%')
2387 gfc_next_ascii_char ();
2388 m
= gfc_match ("fill");
2393 m
= gfc_match_name (name
);
2401 if (gfc_current_state () != COMP_STRUCTURE
)
2403 if (flag_dec_structure
)
2404 gfc_error ("%qs not allowed outside STRUCTURE at %C", "%FILL");
2406 gfc_error ("%qs at %C is a DEC extension, enable with "
2407 "%<-fdec-structure%>", "%FILL");
2413 gfc_error ("%qs entity cannot have attributes at %C", "%FILL");
2417 /* %FILL components are given invalid fortran names. */
2418 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "%%FILL%u", fill_id
++);
2422 var_locus
= gfc_current_locus
;
2424 /* Now we could see the optional array spec. or character length. */
2425 m
= gfc_match_array_spec (&as
, true, true);
2426 if (m
== MATCH_ERROR
)
2430 as
= gfc_copy_array_spec (current_as
);
2432 && !merge_array_spec (current_as
, as
, true))
2438 if (flag_cray_pointer
)
2439 cp_as
= gfc_copy_array_spec (as
);
2441 /* At this point, we know for sure if the symbol is PARAMETER and can thus
2442 determine (and check) whether it can be implied-shape. If it
2443 was parsed as assumed-size, change it because PARAMETERs can not
2446 An explicit-shape-array cannot appear under several conditions.
2447 That check is done here as well. */
2450 if (as
->type
== AS_IMPLIED_SHAPE
&& current_attr
.flavor
!= FL_PARAMETER
)
2453 gfc_error ("Non-PARAMETER symbol %qs at %L can't be implied-shape",
2458 if (as
->type
== AS_ASSUMED_SIZE
&& as
->rank
== 1
2459 && current_attr
.flavor
== FL_PARAMETER
)
2460 as
->type
= AS_IMPLIED_SHAPE
;
2462 if (as
->type
== AS_IMPLIED_SHAPE
2463 && !gfc_notify_std (GFC_STD_F2008
, "Implied-shape array at %L",
2470 /* F2018:C830 (R816) An explicit-shape-spec whose bounds are not
2471 constant expressions shall appear only in a subprogram, derived
2472 type definition, BLOCK construct, or interface body. */
2473 if (as
->type
== AS_EXPLICIT
2474 && gfc_current_state () != COMP_BLOCK
2475 && gfc_current_state () != COMP_DERIVED
2476 && gfc_current_state () != COMP_FUNCTION
2477 && gfc_current_state () != COMP_INTERFACE
2478 && gfc_current_state () != COMP_SUBROUTINE
)
2481 bool not_constant
= false;
2483 for (int i
= 0; i
< as
->rank
; i
++)
2485 e
= gfc_copy_expr (as
->lower
[i
]);
2486 gfc_resolve_expr (e
);
2487 gfc_simplify_expr (e
, 0);
2488 if (e
&& (e
->expr_type
!= EXPR_CONSTANT
))
2490 not_constant
= true;
2495 e
= gfc_copy_expr (as
->upper
[i
]);
2496 gfc_resolve_expr (e
);
2497 gfc_simplify_expr (e
, 0);
2498 if (e
&& (e
->expr_type
!= EXPR_CONSTANT
))
2500 not_constant
= true;
2508 gfc_error ("Explicit shaped array with nonconstant bounds at %C");
2513 if (as
->type
== AS_EXPLICIT
)
2515 for (int i
= 0; i
< as
->rank
; i
++)
2519 if (e
->expr_type
!= EXPR_CONSTANT
)
2521 n
= gfc_copy_expr (e
);
2522 gfc_simplify_expr (n
, 1);
2523 if (n
->expr_type
== EXPR_CONSTANT
)
2524 gfc_replace_expr (e
, n
);
2529 if (e
->expr_type
!= EXPR_CONSTANT
)
2531 n
= gfc_copy_expr (e
);
2532 gfc_simplify_expr (n
, 1);
2533 if (n
->expr_type
== EXPR_CONSTANT
)
2534 gfc_replace_expr (e
, n
);
2544 cl_deferred
= false;
2546 if (current_ts
.type
== BT_CHARACTER
)
2548 switch (match_char_length (&char_len
, &cl_deferred
, false))
2551 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2553 cl
->length
= char_len
;
2556 /* Non-constant lengths need to be copied after the first
2557 element. Also copy assumed lengths. */
2560 && (current_ts
.u
.cl
->length
== NULL
2561 || current_ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
2563 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2564 cl
->length
= gfc_copy_expr (current_ts
.u
.cl
->length
);
2567 cl
= current_ts
.u
.cl
;
2569 cl_deferred
= current_ts
.deferred
;
2578 /* The dummy arguments and result of the abreviated form of MODULE
2579 PROCEDUREs, used in SUBMODULES should not be redefined. */
2580 if (gfc_current_ns
->proc_name
2581 && gfc_current_ns
->proc_name
->abr_modproc_decl
)
2583 gfc_find_symbol (name
, gfc_current_ns
, 1, &sym
);
2584 if (sym
!= NULL
&& (sym
->attr
.dummy
|| sym
->attr
.result
))
2587 gfc_error ("%qs at %C is a redefinition of the declaration "
2588 "in the corresponding interface for MODULE "
2589 "PROCEDURE %qs", sym
->name
,
2590 gfc_current_ns
->proc_name
->name
);
2595 /* %FILL components may not have initializers. */
2596 if (gfc_str_startswith (name
, "%FILL") && gfc_match_eos () != MATCH_YES
)
2598 gfc_error ("%qs entity cannot have an initializer at %C", "%FILL");
2603 /* If this symbol has already shown up in a Cray Pointer declaration,
2604 and this is not a component declaration,
2605 then we want to set the type & bail out. */
2606 if (flag_cray_pointer
&& !gfc_comp_struct (gfc_current_state ()))
2608 gfc_find_symbol (name
, gfc_current_ns
, 1, &sym
);
2609 if (sym
!= NULL
&& sym
->attr
.cray_pointee
)
2612 if (!gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
2618 /* Check to see if we have an array specification. */
2621 if (sym
->as
!= NULL
)
2623 gfc_error ("Duplicate array spec for Cray pointee at %C");
2624 gfc_free_array_spec (cp_as
);
2630 if (!gfc_set_array_spec (sym
, cp_as
, &var_locus
))
2631 gfc_internal_error ("Couldn't set pointee array spec.");
2633 /* Fix the array spec. */
2634 m
= gfc_mod_pointee_as (sym
->as
);
2635 if (m
== MATCH_ERROR
)
2643 gfc_free_array_spec (cp_as
);
2647 /* Procedure pointer as function result. */
2648 if (gfc_current_state () == COMP_FUNCTION
2649 && strcmp ("ppr@", gfc_current_block ()->name
) == 0
2650 && strcmp (name
, gfc_current_block ()->ns
->proc_name
->name
) == 0)
2651 strcpy (name
, "ppr@");
2653 if (gfc_current_state () == COMP_FUNCTION
2654 && strcmp (name
, gfc_current_block ()->name
) == 0
2655 && gfc_current_block ()->result
2656 && strcmp ("ppr@", gfc_current_block ()->result
->name
) == 0)
2657 strcpy (name
, "ppr@");
2659 /* OK, we've successfully matched the declaration. Now put the
2660 symbol in the current namespace, because it might be used in the
2661 optional initialization expression for this symbol, e.g. this is
2664 integer, parameter :: i = huge(i)
2666 This is only true for parameters or variables of a basic type.
2667 For components of derived types, it is not true, so we don't
2668 create a symbol for those yet. If we fail to create the symbol,
2670 if (!gfc_comp_struct (gfc_current_state ())
2671 && !build_sym (name
, cl
, cl_deferred
, &as
, &var_locus
))
2677 if (!check_function_name (name
))
2683 /* We allow old-style initializations of the form
2684 integer i /2/, j(4) /3*3, 1/
2685 (if no colon has been seen). These are different from data
2686 statements in that initializers are only allowed to apply to the
2687 variable immediately preceding, i.e.
2689 is not allowed. Therefore we have to do some work manually, that
2690 could otherwise be left to the matchers for DATA statements. */
2692 if (!colon_seen
&& gfc_match (" /") == MATCH_YES
)
2694 if (!gfc_notify_std (GFC_STD_GNU
, "Old-style "
2695 "initialization at %C"))
2698 /* Allow old style initializations for components of STRUCTUREs and MAPs
2699 but not components of derived types. */
2700 else if (gfc_current_state () == COMP_DERIVED
)
2702 gfc_error ("Invalid old style initialization for derived type "
2708 /* For structure components, read the initializer as a special
2709 expression and let the rest of this function apply the initializer
2711 else if (gfc_comp_struct (gfc_current_state ()))
2713 m
= match_clist_expr (&initializer
, ¤t_ts
, as
);
2715 gfc_error ("Syntax error in old style initialization of %s at %C",
2721 /* Otherwise we treat the old style initialization just like a
2722 DATA declaration for the current variable. */
2724 return match_old_style_init (name
);
2727 /* The double colon must be present in order to have initializers.
2728 Otherwise the statement is ambiguous with an assignment statement. */
2731 if (gfc_match (" =>") == MATCH_YES
)
2733 if (!current_attr
.pointer
)
2735 gfc_error ("Initialization at %C isn't for a pointer variable");
2740 m
= match_pointer_init (&initializer
, 0);
2744 else if (gfc_match_char ('=') == MATCH_YES
)
2746 if (current_attr
.pointer
)
2748 gfc_error ("Pointer initialization at %C requires %<=>%>, "
2754 m
= gfc_match_init_expr (&initializer
);
2757 gfc_error ("Expected an initialization expression at %C");
2761 if (current_attr
.flavor
!= FL_PARAMETER
&& gfc_pure (NULL
)
2762 && !gfc_comp_struct (gfc_state_stack
->state
))
2764 gfc_error ("Initialization of variable at %C is not allowed in "
2765 "a PURE procedure");
2769 if (current_attr
.flavor
!= FL_PARAMETER
2770 && !gfc_comp_struct (gfc_state_stack
->state
))
2771 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
2778 if (initializer
!= NULL
&& current_attr
.allocatable
2779 && gfc_comp_struct (gfc_current_state ()))
2781 gfc_error ("Initialization of allocatable component at %C is not "
2787 if (gfc_current_state () == COMP_DERIVED
2788 && gfc_current_block ()->attr
.pdt_template
)
2791 gfc_find_symbol (name
, gfc_current_block ()->f2k_derived
,
2793 if (!param
&& (current_attr
.pdt_kind
|| current_attr
.pdt_len
))
2795 gfc_error ("The component with KIND or LEN attribute at %C does not "
2796 "not appear in the type parameter list at %L",
2797 &gfc_current_block ()->declared_at
);
2801 else if (param
&& !(current_attr
.pdt_kind
|| current_attr
.pdt_len
))
2803 gfc_error ("The component at %C that appears in the type parameter "
2804 "list at %L has neither the KIND nor LEN attribute",
2805 &gfc_current_block ()->declared_at
);
2809 else if (as
&& (current_attr
.pdt_kind
|| current_attr
.pdt_len
))
2811 gfc_error ("The component at %C which is a type parameter must be "
2816 else if (param
&& initializer
)
2817 param
->value
= gfc_copy_expr (initializer
);
2820 /* Before adding a possible initilizer, do a simple check for compatibility
2821 of lhs and rhs types. Assigning a REAL value to a derived type is not a
2823 if (current_ts
.type
== BT_DERIVED
&& initializer
2824 && (gfc_numeric_ts (&initializer
->ts
)
2825 || initializer
->ts
.type
== BT_LOGICAL
2826 || initializer
->ts
.type
== BT_CHARACTER
))
2828 gfc_error ("Incompatible initialization between a derived type "
2829 "entity and an entity with %qs type at %C",
2830 gfc_typename (&initializer
->ts
));
2836 /* Add the initializer. Note that it is fine if initializer is
2837 NULL here, because we sometimes also need to check if a
2838 declaration *must* have an initialization expression. */
2839 if (!gfc_comp_struct (gfc_current_state ()))
2840 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
2843 if (current_ts
.type
== BT_DERIVED
2844 && !current_attr
.pointer
&& !initializer
)
2845 initializer
= gfc_default_initializer (¤t_ts
);
2846 t
= build_struct (name
, cl
, &initializer
, &as
);
2848 /* If we match a nested structure definition we expect to see the
2849 * body even if the variable declarations blow up, so we need to keep
2850 * the structure declaration around. */
2851 if (gfc_new_block
&& gfc_new_block
->attr
.flavor
== FL_STRUCT
)
2852 gfc_commit_symbol (gfc_new_block
);
2855 m
= (t
) ? MATCH_YES
: MATCH_ERROR
;
2858 /* Free stuff up and return. */
2859 gfc_free_expr (initializer
);
2860 gfc_free_array_spec (as
);
2866 /* Match an extended-f77 "TYPESPEC*bytesize"-style kind specification.
2867 This assumes that the byte size is equal to the kind number for
2868 non-COMPLEX types, and equal to twice the kind number for COMPLEX. */
2871 gfc_match_old_kind_spec (gfc_typespec
*ts
)
2876 if (gfc_match_char ('*') != MATCH_YES
)
2879 m
= gfc_match_small_literal_int (&ts
->kind
, NULL
);
2883 original_kind
= ts
->kind
;
2885 /* Massage the kind numbers for complex types. */
2886 if (ts
->type
== BT_COMPLEX
)
2890 gfc_error ("Old-style type declaration %s*%d not supported at %C",
2891 gfc_basic_typename (ts
->type
), original_kind
);
2898 if (ts
->type
== BT_INTEGER
&& ts
->kind
== 4 && flag_integer4_kind
== 8)
2901 if (ts
->type
== BT_REAL
|| ts
->type
== BT_COMPLEX
)
2905 if (flag_real4_kind
== 8)
2907 if (flag_real4_kind
== 10)
2909 if (flag_real4_kind
== 16)
2915 if (flag_real8_kind
== 4)
2917 if (flag_real8_kind
== 10)
2919 if (flag_real8_kind
== 16)
2924 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
2926 gfc_error ("Old-style type declaration %s*%d not supported at %C",
2927 gfc_basic_typename (ts
->type
), original_kind
);
2931 if (!gfc_notify_std (GFC_STD_GNU
,
2932 "Nonstandard type declaration %s*%d at %C",
2933 gfc_basic_typename(ts
->type
), original_kind
))
2940 /* Match a kind specification. Since kinds are generally optional, we
2941 usually return MATCH_NO if something goes wrong. If a "kind="
2942 string is found, then we know we have an error. */
2945 gfc_match_kind_spec (gfc_typespec
*ts
, bool kind_expr_only
)
2955 saved_kind_expr
= NULL
;
2957 where
= loc
= gfc_current_locus
;
2962 if (gfc_match_char ('(') == MATCH_NO
)
2965 /* Also gobbles optional text. */
2966 if (gfc_match (" kind = ") == MATCH_YES
)
2969 loc
= gfc_current_locus
;
2973 n
= gfc_match_init_expr (&e
);
2975 if (gfc_derived_parameter_expr (e
))
2978 saved_kind_expr
= gfc_copy_expr (e
);
2979 goto close_brackets
;
2984 if (gfc_matching_function
)
2986 /* The function kind expression might include use associated or
2987 imported parameters and try again after the specification
2989 if (gfc_match_char (')') != MATCH_YES
)
2991 gfc_error ("Missing right parenthesis at %C");
2997 gfc_undo_symbols ();
3002 /* ....or else, the match is real. */
3004 gfc_error ("Expected initialization expression at %C");
3012 gfc_error ("Expected scalar initialization expression at %C");
3017 if (gfc_extract_int (e
, &ts
->kind
, 1))
3023 /* Before throwing away the expression, let's see if we had a
3024 C interoperable kind (and store the fact). */
3025 if (e
->ts
.is_c_interop
== 1)
3027 /* Mark this as C interoperable if being declared with one
3028 of the named constants from iso_c_binding. */
3029 ts
->is_c_interop
= e
->ts
.is_iso_c
;
3030 ts
->f90_type
= e
->ts
.f90_type
;
3032 ts
->interop_kind
= e
->symtree
->n
.sym
;
3038 /* Ignore errors to this point, if we've gotten here. This means
3039 we ignore the m=MATCH_ERROR from above. */
3040 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
3042 gfc_error ("Kind %d not supported for type %s at %C", ts
->kind
,
3043 gfc_basic_typename (ts
->type
));
3044 gfc_current_locus
= where
;
3048 /* Warn if, e.g., c_int is used for a REAL variable, but not
3049 if, e.g., c_double is used for COMPLEX as the standard
3050 explicitly says that the kind type parameter for complex and real
3051 variable is the same, i.e. c_float == c_float_complex. */
3052 if (ts
->f90_type
!= BT_UNKNOWN
&& ts
->f90_type
!= ts
->type
3053 && !((ts
->f90_type
== BT_REAL
&& ts
->type
== BT_COMPLEX
)
3054 || (ts
->f90_type
== BT_COMPLEX
&& ts
->type
== BT_REAL
)))
3055 gfc_warning_now (0, "C kind type parameter is for type %s but type at %L "
3056 "is %s", gfc_basic_typename (ts
->f90_type
), &where
,
3057 gfc_basic_typename (ts
->type
));
3061 gfc_gobble_whitespace ();
3062 if ((c
= gfc_next_ascii_char ()) != ')'
3063 && (ts
->type
!= BT_CHARACTER
|| c
!= ','))
3065 if (ts
->type
== BT_CHARACTER
)
3066 gfc_error ("Missing right parenthesis or comma at %C");
3068 gfc_error ("Missing right parenthesis at %C");
3072 /* All tests passed. */
3075 if(m
== MATCH_ERROR
)
3076 gfc_current_locus
= where
;
3078 if (ts
->type
== BT_INTEGER
&& ts
->kind
== 4 && flag_integer4_kind
== 8)
3081 if (ts
->type
== BT_REAL
|| ts
->type
== BT_COMPLEX
)
3085 if (flag_real4_kind
== 8)
3087 if (flag_real4_kind
== 10)
3089 if (flag_real4_kind
== 16)
3095 if (flag_real8_kind
== 4)
3097 if (flag_real8_kind
== 10)
3099 if (flag_real8_kind
== 16)
3104 /* Return what we know from the test(s). */
3109 gfc_current_locus
= where
;
3115 match_char_kind (int * kind
, int * is_iso_c
)
3124 where
= gfc_current_locus
;
3126 n
= gfc_match_init_expr (&e
);
3128 if (n
!= MATCH_YES
&& gfc_matching_function
)
3130 /* The expression might include use-associated or imported
3131 parameters and try again after the specification
3134 gfc_undo_symbols ();
3139 gfc_error ("Expected initialization expression at %C");
3145 gfc_error ("Expected scalar initialization expression at %C");
3150 if (gfc_derived_parameter_expr (e
))
3152 saved_kind_expr
= e
;
3157 fail
= gfc_extract_int (e
, kind
, 1);
3158 *is_iso_c
= e
->ts
.is_iso_c
;
3167 /* Ignore errors to this point, if we've gotten here. This means
3168 we ignore the m=MATCH_ERROR from above. */
3169 if (gfc_validate_kind (BT_CHARACTER
, *kind
, true) < 0)
3171 gfc_error ("Kind %d is not supported for CHARACTER at %C", *kind
);
3175 /* All tests passed. */
3178 if (m
== MATCH_ERROR
)
3179 gfc_current_locus
= where
;
3181 /* Return what we know from the test(s). */
3186 gfc_current_locus
= where
;
3191 /* Match the various kind/length specifications in a CHARACTER
3192 declaration. We don't return MATCH_NO. */
3195 gfc_match_char_spec (gfc_typespec
*ts
)
3197 int kind
, seen_length
, is_iso_c
;
3209 /* Try the old-style specification first. */
3210 old_char_selector
= 0;
3212 m
= match_char_length (&len
, &deferred
, true);
3216 old_char_selector
= 1;
3221 m
= gfc_match_char ('(');
3224 m
= MATCH_YES
; /* Character without length is a single char. */
3228 /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ). */
3229 if (gfc_match (" kind =") == MATCH_YES
)
3231 m
= match_char_kind (&kind
, &is_iso_c
);
3233 if (m
== MATCH_ERROR
)
3238 if (gfc_match (" , len =") == MATCH_NO
)
3241 m
= char_len_param_value (&len
, &deferred
);
3244 if (m
== MATCH_ERROR
)
3251 /* Try to match "LEN = <len-param>" or "LEN = <len-param>, KIND = <int>". */
3252 if (gfc_match (" len =") == MATCH_YES
)
3254 m
= char_len_param_value (&len
, &deferred
);
3257 if (m
== MATCH_ERROR
)
3261 if (gfc_match_char (')') == MATCH_YES
)
3264 if (gfc_match (" , kind =") != MATCH_YES
)
3267 if (match_char_kind (&kind
, &is_iso_c
) == MATCH_ERROR
)
3273 /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ). */
3274 m
= char_len_param_value (&len
, &deferred
);
3277 if (m
== MATCH_ERROR
)
3281 m
= gfc_match_char (')');
3285 if (gfc_match_char (',') != MATCH_YES
)
3288 gfc_match (" kind ="); /* Gobble optional text. */
3290 m
= match_char_kind (&kind
, &is_iso_c
);
3291 if (m
== MATCH_ERROR
)
3297 /* Require a right-paren at this point. */
3298 m
= gfc_match_char (')');
3303 gfc_error ("Syntax error in CHARACTER declaration at %C");
3305 gfc_free_expr (len
);
3309 /* Deal with character functions after USE and IMPORT statements. */
3310 if (gfc_matching_function
)
3312 gfc_free_expr (len
);
3313 gfc_undo_symbols ();
3319 gfc_free_expr (len
);
3323 /* Do some final massaging of the length values. */
3324 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
3326 if (seen_length
== 0)
3327 cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
, 1);
3330 /* If gfortran ends up here, then len may be reducible to a constant.
3331 Try to do that here. If it does not reduce, simply assign len to
3332 charlen. A complication occurs with user-defined generic functions,
3333 which are not resolved. Use a private namespace to deal with
3334 generic functions. */
3336 if (len
&& len
->expr_type
!= EXPR_CONSTANT
)
3338 gfc_namespace
*old_ns
;
3341 old_ns
= gfc_current_ns
;
3342 gfc_current_ns
= gfc_get_namespace (NULL
, 0);
3344 e
= gfc_copy_expr (len
);
3345 gfc_reduce_init_expr (e
);
3346 if (e
->expr_type
== EXPR_CONSTANT
)
3348 gfc_replace_expr (len
, e
);
3349 if (mpz_cmp_si (len
->value
.integer
, 0) < 0)
3350 mpz_set_ui (len
->value
.integer
, 0);
3355 gfc_free_namespace (gfc_current_ns
);
3356 gfc_current_ns
= old_ns
;
3363 ts
->kind
= kind
== 0 ? gfc_default_character_kind
: kind
;
3364 ts
->deferred
= deferred
;
3366 /* We have to know if it was a C interoperable kind so we can
3367 do accurate type checking of bind(c) procs, etc. */
3369 /* Mark this as C interoperable if being declared with one
3370 of the named constants from iso_c_binding. */
3371 ts
->is_c_interop
= is_iso_c
;
3372 else if (len
!= NULL
)
3373 /* Here, we might have parsed something such as: character(c_char)
3374 In this case, the parsing code above grabs the c_char when
3375 looking for the length (line 1690, roughly). it's the last
3376 testcase for parsing the kind params of a character variable.
3377 However, it's not actually the length. this seems like it
3379 To see if the user used a C interop kind, test the expr
3380 of the so called length, and see if it's C interoperable. */
3381 ts
->is_c_interop
= len
->ts
.is_iso_c
;
3387 /* Matches a RECORD declaration. */
3390 match_record_decl (char *name
)
3393 old_loc
= gfc_current_locus
;
3396 m
= gfc_match (" record /");
3399 if (!flag_dec_structure
)
3401 gfc_current_locus
= old_loc
;
3402 gfc_error ("RECORD at %C is an extension, enable it with "
3406 m
= gfc_match (" %n/", name
);
3411 gfc_current_locus
= old_loc
;
3412 if (flag_dec_structure
3413 && (gfc_match (" record% ") == MATCH_YES
3414 || gfc_match (" record%t") == MATCH_YES
))
3415 gfc_error ("Structure name expected after RECORD at %C");
3423 /* This function uses the gfc_actual_arglist 'type_param_spec_list' as a source
3424 of expressions to substitute into the possibly parameterized expression
3425 'e'. Using a list is inefficient but should not be too bad since the
3426 number of type parameters is not likely to be large. */
3428 insert_parameter_exprs (gfc_expr
* e
, gfc_symbol
* sym ATTRIBUTE_UNUSED
,
3431 gfc_actual_arglist
*param
;
3434 if (e
->expr_type
!= EXPR_VARIABLE
)
3437 gcc_assert (e
->symtree
);
3438 if (e
->symtree
->n
.sym
->attr
.pdt_kind
3439 || (*f
!= 0 && e
->symtree
->n
.sym
->attr
.pdt_len
))
3441 for (param
= type_param_spec_list
; param
; param
= param
->next
)
3442 if (strcmp (e
->symtree
->n
.sym
->name
, param
->name
) == 0)
3447 copy
= gfc_copy_expr (param
->expr
);
3458 gfc_insert_kind_parameter_exprs (gfc_expr
*e
)
3460 return gfc_traverse_expr (e
, NULL
, &insert_parameter_exprs
, 0);
3465 gfc_insert_parameter_exprs (gfc_expr
*e
, gfc_actual_arglist
*param_list
)
3467 gfc_actual_arglist
*old_param_spec_list
= type_param_spec_list
;
3468 type_param_spec_list
= param_list
;
3469 return gfc_traverse_expr (e
, NULL
, &insert_parameter_exprs
, 1);
3470 type_param_spec_list
= NULL
;
3471 type_param_spec_list
= old_param_spec_list
;
3474 /* Determines the instance of a parameterized derived type to be used by
3475 matching determining the values of the kind parameters and using them
3476 in the name of the instance. If the instance exists, it is used, otherwise
3477 a new derived type is created. */
3479 gfc_get_pdt_instance (gfc_actual_arglist
*param_list
, gfc_symbol
**sym
,
3480 gfc_actual_arglist
**ext_param_list
)
3482 /* The PDT template symbol. */
3483 gfc_symbol
*pdt
= *sym
;
3484 /* The symbol for the parameter in the template f2k_namespace. */
3486 /* The hoped for instance of the PDT. */
3487 gfc_symbol
*instance
;
3488 /* The list of parameters appearing in the PDT declaration. */
3489 gfc_formal_arglist
*type_param_name_list
;
3490 /* Used to store the parameter specification list during recursive calls. */
3491 gfc_actual_arglist
*old_param_spec_list
;
3492 /* Pointers to the parameter specification being used. */
3493 gfc_actual_arglist
*actual_param
;
3494 gfc_actual_arglist
*tail
= NULL
;
3495 /* Used to build up the name of the PDT instance. The prefix uses 4
3496 characters and each KIND parameter 2 more. Allow 8 of the latter. */
3497 char name
[GFC_MAX_SYMBOL_LEN
+ 21];
3499 bool name_seen
= (param_list
== NULL
);
3500 bool assumed_seen
= false;
3501 bool deferred_seen
= false;
3502 bool spec_error
= false;
3504 gfc_expr
*kind_expr
;
3505 gfc_component
*c1
, *c2
;
3508 type_param_spec_list
= NULL
;
3510 type_param_name_list
= pdt
->formal
;
3511 actual_param
= param_list
;
3512 sprintf (name
, "Pdt%s", pdt
->name
);
3514 /* Run through the parameter name list and pick up the actual
3515 parameter values or use the default values in the PDT declaration. */
3516 for (; type_param_name_list
;
3517 type_param_name_list
= type_param_name_list
->next
)
3519 if (actual_param
&& actual_param
->spec_type
!= SPEC_EXPLICIT
)
3521 if (actual_param
->spec_type
== SPEC_ASSUMED
)
3522 spec_error
= deferred_seen
;
3524 spec_error
= assumed_seen
;
3528 gfc_error ("The type parameter spec list at %C cannot contain "
3529 "both ASSUMED and DEFERRED parameters");
3534 if (actual_param
&& actual_param
->name
)
3536 param
= type_param_name_list
->sym
;
3538 if (!param
|| !param
->name
)
3541 c1
= gfc_find_component (pdt
, param
->name
, false, true, NULL
);
3542 /* An error should already have been thrown in resolve.c
3543 (resolve_fl_derived0). */
3544 if (!pdt
->attr
.use_assoc
&& !c1
)
3550 if (!actual_param
&& !(c1
&& c1
->initializer
))
3552 gfc_error ("The type parameter spec list at %C does not contain "
3553 "enough parameter expressions");
3556 else if (!actual_param
&& c1
&& c1
->initializer
)
3557 kind_expr
= gfc_copy_expr (c1
->initializer
);
3558 else if (actual_param
&& actual_param
->spec_type
== SPEC_EXPLICIT
)
3559 kind_expr
= gfc_copy_expr (actual_param
->expr
);
3563 actual_param
= param_list
;
3564 for (;actual_param
; actual_param
= actual_param
->next
)
3565 if (actual_param
->name
3566 && strcmp (actual_param
->name
, param
->name
) == 0)
3568 if (actual_param
&& actual_param
->spec_type
== SPEC_EXPLICIT
)
3569 kind_expr
= gfc_copy_expr (actual_param
->expr
);
3572 if (c1
->initializer
)
3573 kind_expr
= gfc_copy_expr (c1
->initializer
);
3574 else if (!(actual_param
&& param
->attr
.pdt_len
))
3576 gfc_error ("The derived parameter %qs at %C does not "
3577 "have a default value", param
->name
);
3583 /* Store the current parameter expressions in a temporary actual
3584 arglist 'list' so that they can be substituted in the corresponding
3585 expressions in the PDT instance. */
3586 if (type_param_spec_list
== NULL
)
3588 type_param_spec_list
= gfc_get_actual_arglist ();
3589 tail
= type_param_spec_list
;
3593 tail
->next
= gfc_get_actual_arglist ();
3596 tail
->name
= param
->name
;
3600 /* Try simplification even for LEN expressions. */
3601 gfc_resolve_expr (kind_expr
);
3602 gfc_simplify_expr (kind_expr
, 1);
3603 /* Variable expressions seem to default to BT_PROCEDURE.
3604 TODO find out why this is and fix it. */
3605 if (kind_expr
->ts
.type
!= BT_INTEGER
3606 && kind_expr
->ts
.type
!= BT_PROCEDURE
)
3608 gfc_error ("The parameter expression at %C must be of "
3609 "INTEGER type and not %s type",
3610 gfc_basic_typename (kind_expr
->ts
.type
));
3614 tail
->expr
= gfc_copy_expr (kind_expr
);
3618 tail
->spec_type
= actual_param
->spec_type
;
3620 if (!param
->attr
.pdt_kind
)
3622 if (!name_seen
&& actual_param
)
3623 actual_param
= actual_param
->next
;
3626 gfc_free_expr (kind_expr
);
3633 && (actual_param
->spec_type
== SPEC_ASSUMED
3634 || actual_param
->spec_type
== SPEC_DEFERRED
))
3636 gfc_error ("The KIND parameter %qs at %C cannot either be "
3637 "ASSUMED or DEFERRED", param
->name
);
3641 if (!kind_expr
|| !gfc_is_constant_expr (kind_expr
))
3643 gfc_error ("The value for the KIND parameter %qs at %C does not "
3644 "reduce to a constant expression", param
->name
);
3648 gfc_extract_int (kind_expr
, &kind_value
);
3649 sprintf (name
+ strlen (name
), "_%d", kind_value
);
3651 if (!name_seen
&& actual_param
)
3652 actual_param
= actual_param
->next
;
3653 gfc_free_expr (kind_expr
);
3656 if (!name_seen
&& actual_param
)
3658 gfc_error ("The type parameter spec list at %C contains too many "
3659 "parameter expressions");
3663 /* Now we search for the PDT instance 'name'. If it doesn't exist, we
3664 build it, using 'pdt' as a template. */
3665 if (gfc_get_symbol (name
, pdt
->ns
, &instance
))
3667 gfc_error ("Parameterized derived type at %C is ambiguous");
3673 if (instance
->attr
.flavor
== FL_DERIVED
3674 && instance
->attr
.pdt_type
)
3678 *ext_param_list
= type_param_spec_list
;
3680 gfc_commit_symbols ();
3684 /* Start building the new instance of the parameterized type. */
3685 gfc_copy_attr (&instance
->attr
, &pdt
->attr
, &pdt
->declared_at
);
3686 instance
->attr
.pdt_template
= 0;
3687 instance
->attr
.pdt_type
= 1;
3688 instance
->declared_at
= gfc_current_locus
;
3690 /* Add the components, replacing the parameters in all expressions
3691 with the expressions for their values in 'type_param_spec_list'. */
3692 c1
= pdt
->components
;
3693 tail
= type_param_spec_list
;
3694 for (; c1
; c1
= c1
->next
)
3696 gfc_add_component (instance
, c1
->name
, &c2
);
3699 c2
->attr
= c1
->attr
;
3701 /* The order of declaration of the type_specs might not be the
3702 same as that of the components. */
3703 if (c1
->attr
.pdt_kind
|| c1
->attr
.pdt_len
)
3705 for (tail
= type_param_spec_list
; tail
; tail
= tail
->next
)
3706 if (strcmp (c1
->name
, tail
->name
) == 0)
3710 /* Deal with type extension by recursively calling this function
3711 to obtain the instance of the extended type. */
3712 if (gfc_current_state () != COMP_DERIVED
3713 && c1
== pdt
->components
3714 && (c1
->ts
.type
== BT_DERIVED
|| c1
->ts
.type
== BT_CLASS
)
3715 && c1
->ts
.u
.derived
&& c1
->ts
.u
.derived
->attr
.pdt_template
3716 && gfc_get_derived_super_type (*sym
) == c2
->ts
.u
.derived
)
3718 gfc_formal_arglist
*f
;
3720 old_param_spec_list
= type_param_spec_list
;
3722 /* Obtain a spec list appropriate to the extended type..*/
3723 actual_param
= gfc_copy_actual_arglist (type_param_spec_list
);
3724 type_param_spec_list
= actual_param
;
3725 for (f
= c1
->ts
.u
.derived
->formal
; f
&& f
->next
; f
= f
->next
)
3726 actual_param
= actual_param
->next
;
3729 gfc_free_actual_arglist (actual_param
->next
);
3730 actual_param
->next
= NULL
;
3733 /* Now obtain the PDT instance for the extended type. */
3734 c2
->param_list
= type_param_spec_list
;
3735 m
= gfc_get_pdt_instance (type_param_spec_list
, &c2
->ts
.u
.derived
,
3737 type_param_spec_list
= old_param_spec_list
;
3739 c2
->ts
.u
.derived
->refs
++;
3740 gfc_set_sym_referenced (c2
->ts
.u
.derived
);
3742 /* Set extension level. */
3743 if (c2
->ts
.u
.derived
->attr
.extension
== 255)
3745 /* Since the extension field is 8 bit wide, we can only have
3746 up to 255 extension levels. */
3747 gfc_error ("Maximum extension level reached with type %qs at %L",
3748 c2
->ts
.u
.derived
->name
,
3749 &c2
->ts
.u
.derived
->declared_at
);
3752 instance
->attr
.extension
= c2
->ts
.u
.derived
->attr
.extension
+ 1;
3757 /* Set the component kind using the parameterized expression. */
3758 if ((c1
->ts
.kind
== 0 || c1
->ts
.type
== BT_CHARACTER
)
3759 && c1
->kind_expr
!= NULL
)
3761 gfc_expr
*e
= gfc_copy_expr (c1
->kind_expr
);
3762 gfc_insert_kind_parameter_exprs (e
);
3763 gfc_simplify_expr (e
, 1);
3764 gfc_extract_int (e
, &c2
->ts
.kind
);
3766 if (gfc_validate_kind (c2
->ts
.type
, c2
->ts
.kind
, true) < 0)
3768 gfc_error ("Kind %d not supported for type %s at %C",
3769 c2
->ts
.kind
, gfc_basic_typename (c2
->ts
.type
));
3774 /* Similarly, set the string length if parameterized. */
3775 if (c1
->ts
.type
== BT_CHARACTER
3776 && c1
->ts
.u
.cl
->length
3777 && gfc_derived_parameter_expr (c1
->ts
.u
.cl
->length
))
3780 e
= gfc_copy_expr (c1
->ts
.u
.cl
->length
);
3781 gfc_insert_kind_parameter_exprs (e
);
3782 gfc_simplify_expr (e
, 1);
3783 c2
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
3784 c2
->ts
.u
.cl
->length
= e
;
3785 c2
->attr
.pdt_string
= 1;
3788 /* Set up either the KIND/LEN initializer, if constant,
3789 or the parameterized expression. Use the template
3790 initializer if one is not already set in this instance. */
3791 if (c2
->attr
.pdt_kind
|| c2
->attr
.pdt_len
)
3793 if (tail
&& tail
->expr
&& gfc_is_constant_expr (tail
->expr
))
3794 c2
->initializer
= gfc_copy_expr (tail
->expr
);
3795 else if (tail
&& tail
->expr
)
3797 c2
->param_list
= gfc_get_actual_arglist ();
3798 c2
->param_list
->name
= tail
->name
;
3799 c2
->param_list
->expr
= gfc_copy_expr (tail
->expr
);
3800 c2
->param_list
->next
= NULL
;
3803 if (!c2
->initializer
&& c1
->initializer
)
3804 c2
->initializer
= gfc_copy_expr (c1
->initializer
);
3807 /* Copy the array spec. */
3808 c2
->as
= gfc_copy_array_spec (c1
->as
);
3809 if (c1
->ts
.type
== BT_CLASS
)
3810 CLASS_DATA (c2
)->as
= gfc_copy_array_spec (CLASS_DATA (c1
)->as
);
3812 /* Determine if an array spec is parameterized. If so, substitute
3813 in the parameter expressions for the bounds and set the pdt_array
3814 attribute. Notice that this attribute must be unconditionally set
3815 if this is an array of parameterized character length. */
3816 if (c1
->as
&& c1
->as
->type
== AS_EXPLICIT
)
3818 bool pdt_array
= false;
3820 /* Are the bounds of the array parameterized? */
3821 for (i
= 0; i
< c1
->as
->rank
; i
++)
3823 if (gfc_derived_parameter_expr (c1
->as
->lower
[i
]))
3825 if (gfc_derived_parameter_expr (c1
->as
->upper
[i
]))
3829 /* If they are, free the expressions for the bounds and
3830 replace them with the template expressions with substitute
3832 for (i
= 0; pdt_array
&& i
< c1
->as
->rank
; i
++)
3835 e
= gfc_copy_expr (c1
->as
->lower
[i
]);
3836 gfc_insert_kind_parameter_exprs (e
);
3837 gfc_simplify_expr (e
, 1);
3838 gfc_free_expr (c2
->as
->lower
[i
]);
3839 c2
->as
->lower
[i
] = e
;
3840 e
= gfc_copy_expr (c1
->as
->upper
[i
]);
3841 gfc_insert_kind_parameter_exprs (e
);
3842 gfc_simplify_expr (e
, 1);
3843 gfc_free_expr (c2
->as
->upper
[i
]);
3844 c2
->as
->upper
[i
] = e
;
3846 c2
->attr
.pdt_array
= pdt_array
? 1 : c2
->attr
.pdt_string
;
3847 if (c1
->initializer
)
3849 c2
->initializer
= gfc_copy_expr (c1
->initializer
);
3850 gfc_insert_kind_parameter_exprs (c2
->initializer
);
3851 gfc_simplify_expr (c2
->initializer
, 1);
3855 /* Recurse into this function for PDT components. */
3856 if ((c1
->ts
.type
== BT_DERIVED
|| c1
->ts
.type
== BT_CLASS
)
3857 && c1
->ts
.u
.derived
&& c1
->ts
.u
.derived
->attr
.pdt_template
)
3859 gfc_actual_arglist
*params
;
3860 /* The component in the template has a list of specification
3861 expressions derived from its declaration. */
3862 params
= gfc_copy_actual_arglist (c1
->param_list
);
3863 actual_param
= params
;
3864 /* Substitute the template parameters with the expressions
3865 from the specification list. */
3866 for (;actual_param
; actual_param
= actual_param
->next
)
3867 gfc_insert_parameter_exprs (actual_param
->expr
,
3868 type_param_spec_list
);
3870 /* Now obtain the PDT instance for the component. */
3871 old_param_spec_list
= type_param_spec_list
;
3872 m
= gfc_get_pdt_instance (params
, &c2
->ts
.u
.derived
, NULL
);
3873 type_param_spec_list
= old_param_spec_list
;
3875 c2
->param_list
= params
;
3876 if (!(c2
->attr
.pointer
|| c2
->attr
.allocatable
))
3877 c2
->initializer
= gfc_default_initializer (&c2
->ts
);
3879 if (c2
->attr
.allocatable
)
3880 instance
->attr
.alloc_comp
= 1;
3884 gfc_commit_symbol (instance
);
3886 *ext_param_list
= type_param_spec_list
;
3891 gfc_free_actual_arglist (type_param_spec_list
);
3896 /* Matches a declaration-type-spec (F03:R502). If successful, sets the ts
3897 structure to the matched specification. This is necessary for FUNCTION and
3898 IMPLICIT statements.
3900 If implicit_flag is nonzero, then we don't check for the optional
3901 kind specification. Not doing so is needed for matching an IMPLICIT
3902 statement correctly. */
3905 gfc_match_decl_type_spec (gfc_typespec
*ts
, int implicit_flag
)
3907 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3908 gfc_symbol
*sym
, *dt_sym
;
3911 bool seen_deferred_kind
, matched_type
;
3912 const char *dt_name
;
3914 decl_type_param_list
= NULL
;
3916 /* A belt and braces check that the typespec is correctly being treated
3917 as a deferred characteristic association. */
3918 seen_deferred_kind
= (gfc_current_state () == COMP_FUNCTION
)
3919 && (gfc_current_block ()->result
->ts
.kind
== -1)
3920 && (ts
->kind
== -1);
3922 if (seen_deferred_kind
)
3925 /* Clear the current binding label, in case one is given. */
3926 curr_binding_label
= NULL
;
3928 if (gfc_match (" byte") == MATCH_YES
)
3930 if (!gfc_notify_std (GFC_STD_GNU
, "BYTE type at %C"))
3933 if (gfc_validate_kind (BT_INTEGER
, 1, true) < 0)
3935 gfc_error ("BYTE type used at %C "
3936 "is not available on the target machine");
3940 ts
->type
= BT_INTEGER
;
3946 m
= gfc_match (" type (");
3947 matched_type
= (m
== MATCH_YES
);
3950 gfc_gobble_whitespace ();
3951 if (gfc_peek_ascii_char () == '*')
3953 if ((m
= gfc_match ("*)")) != MATCH_YES
)
3955 if (gfc_comp_struct (gfc_current_state ()))
3957 gfc_error ("Assumed type at %C is not allowed for components");
3960 if (!gfc_notify_std (GFC_STD_F2018
, "Assumed type at %C"))
3962 ts
->type
= BT_ASSUMED
;
3966 m
= gfc_match ("%n", name
);
3967 matched_type
= (m
== MATCH_YES
);
3970 if ((matched_type
&& strcmp ("integer", name
) == 0)
3971 || (!matched_type
&& gfc_match (" integer") == MATCH_YES
))
3973 ts
->type
= BT_INTEGER
;
3974 ts
->kind
= gfc_default_integer_kind
;
3978 if ((matched_type
&& strcmp ("character", name
) == 0)
3979 || (!matched_type
&& gfc_match (" character") == MATCH_YES
))
3982 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
3983 "intrinsic-type-spec at %C"))
3986 ts
->type
= BT_CHARACTER
;
3987 if (implicit_flag
== 0)
3988 m
= gfc_match_char_spec (ts
);
3992 if (matched_type
&& m
== MATCH_YES
&& gfc_match_char (')') != MATCH_YES
)
3998 if ((matched_type
&& strcmp ("real", name
) == 0)
3999 || (!matched_type
&& gfc_match (" real") == MATCH_YES
))
4002 ts
->kind
= gfc_default_real_kind
;
4007 && (strcmp ("doubleprecision", name
) == 0
4008 || (strcmp ("double", name
) == 0
4009 && gfc_match (" precision") == MATCH_YES
)))
4010 || (!matched_type
&& gfc_match (" double precision") == MATCH_YES
))
4013 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
4014 "intrinsic-type-spec at %C"))
4016 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
4020 ts
->kind
= gfc_default_double_kind
;
4024 if ((matched_type
&& strcmp ("complex", name
) == 0)
4025 || (!matched_type
&& gfc_match (" complex") == MATCH_YES
))
4027 ts
->type
= BT_COMPLEX
;
4028 ts
->kind
= gfc_default_complex_kind
;
4033 && (strcmp ("doublecomplex", name
) == 0
4034 || (strcmp ("double", name
) == 0
4035 && gfc_match (" complex") == MATCH_YES
)))
4036 || (!matched_type
&& gfc_match (" double complex") == MATCH_YES
))
4038 if (!gfc_notify_std (GFC_STD_GNU
, "DOUBLE COMPLEX at %C"))
4042 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
4043 "intrinsic-type-spec at %C"))
4046 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
4049 ts
->type
= BT_COMPLEX
;
4050 ts
->kind
= gfc_default_double_kind
;
4054 if ((matched_type
&& strcmp ("logical", name
) == 0)
4055 || (!matched_type
&& gfc_match (" logical") == MATCH_YES
))
4057 ts
->type
= BT_LOGICAL
;
4058 ts
->kind
= gfc_default_logical_kind
;
4064 m
= gfc_match_actual_arglist (1, &decl_type_param_list
, true);
4065 if (m
== MATCH_ERROR
)
4068 m
= gfc_match_char (')');
4072 m
= match_record_decl (name
);
4074 if (matched_type
|| m
== MATCH_YES
)
4076 ts
->type
= BT_DERIVED
;
4077 /* We accept record/s/ or type(s) where s is a structure, but we
4078 * don't need all the extra derived-type stuff for structures. */
4079 if (gfc_find_symbol (gfc_dt_upper_string (name
), NULL
, 1, &sym
))
4081 gfc_error ("Type name %qs at %C is ambiguous", name
);
4085 if (sym
&& sym
->attr
.flavor
== FL_DERIVED
4086 && sym
->attr
.pdt_template
4087 && gfc_current_state () != COMP_DERIVED
)
4089 m
= gfc_get_pdt_instance (decl_type_param_list
, &sym
, NULL
);
4092 gcc_assert (!sym
->attr
.pdt_template
&& sym
->attr
.pdt_type
);
4093 ts
->u
.derived
= sym
;
4094 strcpy (name
, gfc_dt_lower_string (sym
->name
));
4097 if (sym
&& sym
->attr
.flavor
== FL_STRUCT
)
4099 ts
->u
.derived
= sym
;
4102 /* Actually a derived type. */
4107 /* Match nested STRUCTURE declarations; only valid within another
4108 structure declaration. */
4109 if (flag_dec_structure
4110 && (gfc_current_state () == COMP_STRUCTURE
4111 || gfc_current_state () == COMP_MAP
))
4113 m
= gfc_match (" structure");
4116 m
= gfc_match_structure_decl ();
4119 /* gfc_new_block is updated by match_structure_decl. */
4120 ts
->type
= BT_DERIVED
;
4121 ts
->u
.derived
= gfc_new_block
;
4125 if (m
== MATCH_ERROR
)
4129 /* Match CLASS declarations. */
4130 m
= gfc_match (" class ( * )");
4131 if (m
== MATCH_ERROR
)
4133 else if (m
== MATCH_YES
)
4137 ts
->type
= BT_CLASS
;
4138 gfc_find_symbol ("STAR", gfc_current_ns
, 1, &upe
);
4141 upe
= gfc_new_symbol ("STAR", gfc_current_ns
);
4142 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "STAR");
4144 gfc_set_sym_referenced (upe
);
4146 upe
->ts
.type
= BT_VOID
;
4147 upe
->attr
.unlimited_polymorphic
= 1;
4148 /* This is essential to force the construction of
4149 unlimited polymorphic component class containers. */
4150 upe
->attr
.zero_comp
= 1;
4151 if (!gfc_add_flavor (&upe
->attr
, FL_DERIVED
, NULL
,
4152 &gfc_current_locus
))
4157 st
= gfc_get_tbp_symtree (&gfc_current_ns
->sym_root
, "STAR");
4161 ts
->u
.derived
= upe
;
4165 m
= gfc_match (" class (");
4168 m
= gfc_match ("%n", name
);
4174 ts
->type
= BT_CLASS
;
4176 if (!gfc_notify_std (GFC_STD_F2003
, "CLASS statement at %C"))
4179 m
= gfc_match_actual_arglist (1, &decl_type_param_list
, true);
4180 if (m
== MATCH_ERROR
)
4183 m
= gfc_match_char (')');
4188 /* Defer association of the derived type until the end of the
4189 specification block. However, if the derived type can be
4190 found, add it to the typespec. */
4191 if (gfc_matching_function
)
4193 ts
->u
.derived
= NULL
;
4194 if (gfc_current_state () != COMP_INTERFACE
4195 && !gfc_find_symbol (name
, NULL
, 1, &sym
) && sym
)
4197 sym
= gfc_find_dt_in_generic (sym
);
4198 ts
->u
.derived
= sym
;
4203 /* Search for the name but allow the components to be defined later. If
4204 type = -1, this typespec has been seen in a function declaration but
4205 the type could not be accessed at that point. The actual derived type is
4206 stored in a symtree with the first letter of the name capitalized; the
4207 symtree with the all lower-case name contains the associated
4208 generic function. */
4209 dt_name
= gfc_dt_upper_string (name
);
4214 gfc_get_ha_symbol (name
, &sym
);
4215 if (sym
->generic
&& gfc_find_symbol (dt_name
, NULL
, 0, &dt_sym
))
4217 gfc_error ("Type name %qs at %C is ambiguous", name
);
4220 if (sym
->generic
&& !dt_sym
)
4221 dt_sym
= gfc_find_dt_in_generic (sym
);
4223 /* Host associated PDTs can get confused with their constructors
4224 because they ar instantiated in the template's namespace. */
4227 if (gfc_find_symbol (dt_name
, NULL
, 1, &dt_sym
))
4229 gfc_error ("Type name %qs at %C is ambiguous", name
);
4232 if (dt_sym
&& !dt_sym
->attr
.pdt_type
)
4236 else if (ts
->kind
== -1)
4238 int iface
= gfc_state_stack
->previous
->state
!= COMP_INTERFACE
4239 || gfc_current_ns
->has_import_set
;
4240 gfc_find_symbol (name
, NULL
, iface
, &sym
);
4241 if (sym
&& sym
->generic
&& gfc_find_symbol (dt_name
, NULL
, 1, &dt_sym
))
4243 gfc_error ("Type name %qs at %C is ambiguous", name
);
4246 if (sym
&& sym
->generic
&& !dt_sym
)
4247 dt_sym
= gfc_find_dt_in_generic (sym
);
4254 if ((sym
->attr
.flavor
!= FL_UNKNOWN
&& sym
->attr
.flavor
!= FL_STRUCT
4255 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.generic
))
4256 || sym
->attr
.subroutine
)
4258 gfc_error ("Type name %qs at %C conflicts with previously declared "
4259 "entity at %L, which has the same name", name
,
4264 if (sym
&& sym
->attr
.flavor
== FL_DERIVED
4265 && sym
->attr
.pdt_template
4266 && gfc_current_state () != COMP_DERIVED
)
4268 m
= gfc_get_pdt_instance (decl_type_param_list
, &sym
, NULL
);
4271 gcc_assert (!sym
->attr
.pdt_template
&& sym
->attr
.pdt_type
);
4272 ts
->u
.derived
= sym
;
4273 strcpy (name
, gfc_dt_lower_string (sym
->name
));
4276 gfc_save_symbol_data (sym
);
4277 gfc_set_sym_referenced (sym
);
4278 if (!sym
->attr
.generic
4279 && !gfc_add_generic (&sym
->attr
, sym
->name
, NULL
))
4282 if (!sym
->attr
.function
4283 && !gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
4286 if (dt_sym
&& dt_sym
->attr
.flavor
== FL_DERIVED
4287 && dt_sym
->attr
.pdt_template
4288 && gfc_current_state () != COMP_DERIVED
)
4290 m
= gfc_get_pdt_instance (decl_type_param_list
, &dt_sym
, NULL
);
4293 gcc_assert (!dt_sym
->attr
.pdt_template
&& dt_sym
->attr
.pdt_type
);
4298 gfc_interface
*intr
, *head
;
4300 /* Use upper case to save the actual derived-type symbol. */
4301 gfc_get_symbol (dt_name
, NULL
, &dt_sym
);
4302 dt_sym
->name
= gfc_get_string ("%s", sym
->name
);
4303 head
= sym
->generic
;
4304 intr
= gfc_get_interface ();
4306 intr
->where
= gfc_current_locus
;
4308 sym
->generic
= intr
;
4309 sym
->attr
.if_source
= IFSRC_DECL
;
4312 gfc_save_symbol_data (dt_sym
);
4314 gfc_set_sym_referenced (dt_sym
);
4316 if (dt_sym
->attr
.flavor
!= FL_DERIVED
&& dt_sym
->attr
.flavor
!= FL_STRUCT
4317 && !gfc_add_flavor (&dt_sym
->attr
, FL_DERIVED
, sym
->name
, NULL
))
4320 ts
->u
.derived
= dt_sym
;
4326 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
4327 "intrinsic-type-spec at %C"))
4330 /* For all types except double, derived and character, look for an
4331 optional kind specifier. MATCH_NO is actually OK at this point. */
4332 if (implicit_flag
== 1)
4334 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
4340 if (gfc_current_form
== FORM_FREE
)
4342 c
= gfc_peek_ascii_char ();
4343 if (!gfc_is_whitespace (c
) && c
!= '*' && c
!= '('
4344 && c
!= ':' && c
!= ',')
4346 if (matched_type
&& c
== ')')
4348 gfc_next_ascii_char ();
4355 m
= gfc_match_kind_spec (ts
, false);
4356 if (m
== MATCH_NO
&& ts
->type
!= BT_CHARACTER
)
4358 m
= gfc_match_old_kind_spec (ts
);
4359 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) == -1)
4363 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
4366 /* Defer association of the KIND expression of function results
4367 until after USE and IMPORT statements. */
4368 if ((gfc_current_state () == COMP_NONE
&& gfc_error_flag_test ())
4369 || gfc_matching_function
)
4373 m
= MATCH_YES
; /* No kind specifier found. */
4379 /* Match an IMPLICIT NONE statement. Actually, this statement is
4380 already matched in parse.c, or we would not end up here in the
4381 first place. So the only thing we need to check, is if there is
4382 trailing garbage. If not, the match is successful. */
4385 gfc_match_implicit_none (void)
4389 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4391 bool external
= false;
4392 locus cur_loc
= gfc_current_locus
;
4394 if (gfc_current_ns
->seen_implicit_none
4395 || gfc_current_ns
->has_implicit_none_export
)
4397 gfc_error ("Duplicate IMPLICIT NONE statement at %C");
4401 gfc_gobble_whitespace ();
4402 c
= gfc_peek_ascii_char ();
4405 (void) gfc_next_ascii_char ();
4406 if (!gfc_notify_std (GFC_STD_F2018
, "IMPORT NONE with spec list at %C"))
4409 gfc_gobble_whitespace ();
4410 if (gfc_peek_ascii_char () == ')')
4412 (void) gfc_next_ascii_char ();
4418 m
= gfc_match (" %n", name
);
4422 if (strcmp (name
, "type") == 0)
4424 else if (strcmp (name
, "external") == 0)
4429 gfc_gobble_whitespace ();
4430 c
= gfc_next_ascii_char ();
4441 if (gfc_match_eos () != MATCH_YES
)
4444 gfc_set_implicit_none (type
, external
, &cur_loc
);
4450 /* Match the letter range(s) of an IMPLICIT statement. */
4453 match_implicit_range (void)
4459 cur_loc
= gfc_current_locus
;
4461 gfc_gobble_whitespace ();
4462 c
= gfc_next_ascii_char ();
4465 gfc_error ("Missing character range in IMPLICIT at %C");
4472 gfc_gobble_whitespace ();
4473 c1
= gfc_next_ascii_char ();
4477 gfc_gobble_whitespace ();
4478 c
= gfc_next_ascii_char ();
4483 inner
= 0; /* Fall through. */
4490 gfc_gobble_whitespace ();
4491 c2
= gfc_next_ascii_char ();
4495 gfc_gobble_whitespace ();
4496 c
= gfc_next_ascii_char ();
4498 if ((c
!= ',') && (c
!= ')'))
4511 gfc_error ("Letters must be in alphabetic order in "
4512 "IMPLICIT statement at %C");
4516 /* See if we can add the newly matched range to the pending
4517 implicits from this IMPLICIT statement. We do not check for
4518 conflicts with whatever earlier IMPLICIT statements may have
4519 set. This is done when we've successfully finished matching
4521 if (!gfc_add_new_implicit_range (c1
, c2
))
4528 gfc_syntax_error (ST_IMPLICIT
);
4530 gfc_current_locus
= cur_loc
;
4535 /* Match an IMPLICIT statement, storing the types for
4536 gfc_set_implicit() if the statement is accepted by the parser.
4537 There is a strange looking, but legal syntactic construction
4538 possible. It looks like:
4540 IMPLICIT INTEGER (a-b) (c-d)
4542 This is legal if "a-b" is a constant expression that happens to
4543 equal one of the legal kinds for integers. The real problem
4544 happens with an implicit specification that looks like:
4546 IMPLICIT INTEGER (a-b)
4548 In this case, a typespec matcher that is "greedy" (as most of the
4549 matchers are) gobbles the character range as a kindspec, leaving
4550 nothing left. We therefore have to go a bit more slowly in the
4551 matching process by inhibiting the kindspec checking during
4552 typespec matching and checking for a kind later. */
4555 gfc_match_implicit (void)
4562 if (gfc_current_ns
->seen_implicit_none
)
4564 gfc_error ("IMPLICIT statement at %C following an IMPLICIT NONE (type) "
4571 /* We don't allow empty implicit statements. */
4572 if (gfc_match_eos () == MATCH_YES
)
4574 gfc_error ("Empty IMPLICIT statement at %C");
4580 /* First cleanup. */
4581 gfc_clear_new_implicit ();
4583 /* A basic type is mandatory here. */
4584 m
= gfc_match_decl_type_spec (&ts
, 1);
4585 if (m
== MATCH_ERROR
)
4590 cur_loc
= gfc_current_locus
;
4591 m
= match_implicit_range ();
4595 /* We may have <TYPE> (<RANGE>). */
4596 gfc_gobble_whitespace ();
4597 c
= gfc_peek_ascii_char ();
4598 if (c
== ',' || c
== '\n' || c
== ';' || c
== '!')
4600 /* Check for CHARACTER with no length parameter. */
4601 if (ts
.type
== BT_CHARACTER
&& !ts
.u
.cl
)
4603 ts
.kind
= gfc_default_character_kind
;
4604 ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4605 ts
.u
.cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
,
4609 /* Record the Successful match. */
4610 if (!gfc_merge_new_implicit (&ts
))
4613 c
= gfc_next_ascii_char ();
4614 else if (gfc_match_eos () == MATCH_ERROR
)
4619 gfc_current_locus
= cur_loc
;
4622 /* Discard the (incorrectly) matched range. */
4623 gfc_clear_new_implicit ();
4625 /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
4626 if (ts
.type
== BT_CHARACTER
)
4627 m
= gfc_match_char_spec (&ts
);
4630 m
= gfc_match_kind_spec (&ts
, false);
4633 m
= gfc_match_old_kind_spec (&ts
);
4634 if (m
== MATCH_ERROR
)
4640 if (m
== MATCH_ERROR
)
4643 m
= match_implicit_range ();
4644 if (m
== MATCH_ERROR
)
4649 gfc_gobble_whitespace ();
4650 c
= gfc_next_ascii_char ();
4651 if (c
!= ',' && gfc_match_eos () != MATCH_YES
)
4654 if (!gfc_merge_new_implicit (&ts
))
4662 gfc_syntax_error (ST_IMPLICIT
);
4670 gfc_match_import (void)
4672 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4677 if (gfc_current_ns
->proc_name
== NULL
4678 || gfc_current_ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
4680 gfc_error ("IMPORT statement at %C only permitted in "
4681 "an INTERFACE body");
4685 if (gfc_current_ns
->proc_name
->attr
.module_procedure
)
4687 gfc_error ("F2008: C1210 IMPORT statement at %C is not permitted "
4688 "in a module procedure interface body");
4692 if (!gfc_notify_std (GFC_STD_F2003
, "IMPORT statement at %C"))
4695 if (gfc_match_eos () == MATCH_YES
)
4697 /* All host variables should be imported. */
4698 gfc_current_ns
->has_import_set
= 1;
4702 if (gfc_match (" ::") == MATCH_YES
)
4704 if (gfc_match_eos () == MATCH_YES
)
4706 gfc_error ("Expecting list of named entities at %C");
4714 m
= gfc_match (" %n", name
);
4718 if (gfc_current_ns
->parent
!= NULL
4719 && gfc_find_symbol (name
, gfc_current_ns
->parent
, 1, &sym
))
4721 gfc_error ("Type name %qs at %C is ambiguous", name
);
4724 else if (!sym
&& gfc_current_ns
->proc_name
->ns
->parent
!= NULL
4725 && gfc_find_symbol (name
,
4726 gfc_current_ns
->proc_name
->ns
->parent
,
4729 gfc_error ("Type name %qs at %C is ambiguous", name
);
4735 gfc_error ("Cannot IMPORT %qs from host scoping unit "
4736 "at %C - does not exist.", name
);
4740 if (gfc_find_symtree (gfc_current_ns
->sym_root
, name
))
4742 gfc_warning (0, "%qs is already IMPORTed from host scoping unit "
4747 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, name
);
4750 sym
->attr
.imported
= 1;
4752 if (sym
->attr
.generic
&& (sym
= gfc_find_dt_in_generic (sym
)))
4754 /* The actual derived type is stored in a symtree with the first
4755 letter of the name capitalized; the symtree with the all
4756 lower-case name contains the associated generic function. */
4757 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
,
4758 gfc_dt_upper_string (name
));
4761 sym
->attr
.imported
= 1;
4774 if (gfc_match_eos () == MATCH_YES
)
4776 if (gfc_match_char (',') != MATCH_YES
)
4783 gfc_error ("Syntax error in IMPORT statement at %C");
4788 /* A minimal implementation of gfc_match without whitespace, escape
4789 characters or variable arguments. Returns true if the next
4790 characters match the TARGET template exactly. */
4793 match_string_p (const char *target
)
4797 for (p
= target
; *p
; p
++)
4798 if ((char) gfc_next_ascii_char () != *p
)
4803 /* Matches an attribute specification including array specs. If
4804 successful, leaves the variables current_attr and current_as
4805 holding the specification. Also sets the colon_seen variable for
4806 later use by matchers associated with initializations.
4808 This subroutine is a little tricky in the sense that we don't know
4809 if we really have an attr-spec until we hit the double colon.
4810 Until that time, we can only return MATCH_NO. This forces us to
4811 check for duplicate specification at this level. */
4814 match_attr_spec (void)
4816 /* Modifiers that can exist in a type statement. */
4818 { GFC_DECL_BEGIN
= 0, DECL_ALLOCATABLE
= GFC_DECL_BEGIN
,
4819 DECL_IN
= INTENT_IN
, DECL_OUT
= INTENT_OUT
, DECL_INOUT
= INTENT_INOUT
,
4820 DECL_DIMENSION
, DECL_EXTERNAL
,
4821 DECL_INTRINSIC
, DECL_OPTIONAL
,
4822 DECL_PARAMETER
, DECL_POINTER
, DECL_PROTECTED
, DECL_PRIVATE
,
4823 DECL_STATIC
, DECL_AUTOMATIC
,
4824 DECL_PUBLIC
, DECL_SAVE
, DECL_TARGET
, DECL_VALUE
, DECL_VOLATILE
,
4825 DECL_IS_BIND_C
, DECL_CODIMENSION
, DECL_ASYNCHRONOUS
, DECL_CONTIGUOUS
,
4826 DECL_LEN
, DECL_KIND
, DECL_NONE
, GFC_DECL_END
/* Sentinel */
4829 /* GFC_DECL_END is the sentinel, index starts at 0. */
4830 #define NUM_DECL GFC_DECL_END
4832 /* Make sure that values from sym_intent are safe to be used here. */
4833 gcc_assert (INTENT_IN
> 0);
4835 locus start
, seen_at
[NUM_DECL
];
4842 gfc_clear_attr (¤t_attr
);
4843 start
= gfc_current_locus
;
4849 /* See if we get all of the keywords up to the final double colon. */
4850 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
4858 gfc_gobble_whitespace ();
4860 ch
= gfc_next_ascii_char ();
4863 /* This is the successful exit condition for the loop. */
4864 if (gfc_next_ascii_char () == ':')
4869 gfc_gobble_whitespace ();
4870 switch (gfc_peek_ascii_char ())
4873 gfc_next_ascii_char ();
4874 switch (gfc_next_ascii_char ())
4877 if (match_string_p ("locatable"))
4879 /* Matched "allocatable". */
4880 d
= DECL_ALLOCATABLE
;
4885 if (match_string_p ("ynchronous"))
4887 /* Matched "asynchronous". */
4888 d
= DECL_ASYNCHRONOUS
;
4893 if (match_string_p ("tomatic"))
4895 /* Matched "automatic". */
4903 /* Try and match the bind(c). */
4904 m
= gfc_match_bind_c (NULL
, true);
4907 else if (m
== MATCH_ERROR
)
4912 gfc_next_ascii_char ();
4913 if ('o' != gfc_next_ascii_char ())
4915 switch (gfc_next_ascii_char ())
4918 if (match_string_p ("imension"))
4920 d
= DECL_CODIMENSION
;
4925 if (match_string_p ("tiguous"))
4927 d
= DECL_CONTIGUOUS
;
4934 if (match_string_p ("dimension"))
4939 if (match_string_p ("external"))
4944 if (match_string_p ("int"))
4946 ch
= gfc_next_ascii_char ();
4949 if (match_string_p ("nt"))
4951 /* Matched "intent". */
4952 d
= match_intent_spec ();
4953 if (d
== INTENT_UNKNOWN
)
4962 if (match_string_p ("insic"))
4964 /* Matched "intrinsic". */
4972 if (match_string_p ("kind"))
4977 if (match_string_p ("len"))
4982 if (match_string_p ("optional"))
4987 gfc_next_ascii_char ();
4988 switch (gfc_next_ascii_char ())
4991 if (match_string_p ("rameter"))
4993 /* Matched "parameter". */
4999 if (match_string_p ("inter"))
5001 /* Matched "pointer". */
5007 ch
= gfc_next_ascii_char ();
5010 if (match_string_p ("vate"))
5012 /* Matched "private". */
5018 if (match_string_p ("tected"))
5020 /* Matched "protected". */
5027 if (match_string_p ("blic"))
5029 /* Matched "public". */
5037 gfc_next_ascii_char ();
5038 switch (gfc_next_ascii_char ())
5041 if (match_string_p ("ve"))
5043 /* Matched "save". */
5049 if (match_string_p ("atic"))
5051 /* Matched "static". */
5059 if (match_string_p ("target"))
5064 gfc_next_ascii_char ();
5065 ch
= gfc_next_ascii_char ();
5068 if (match_string_p ("lue"))
5070 /* Matched "value". */
5076 if (match_string_p ("latile"))
5078 /* Matched "volatile". */
5086 /* No double colon and no recognizable decl_type, so assume that
5087 we've been looking at something else the whole time. */
5094 /* Check to make sure any parens are paired up correctly. */
5095 if (gfc_match_parens () == MATCH_ERROR
)
5102 seen_at
[d
] = gfc_current_locus
;
5104 if (d
== DECL_DIMENSION
|| d
== DECL_CODIMENSION
)
5106 gfc_array_spec
*as
= NULL
;
5108 m
= gfc_match_array_spec (&as
, d
== DECL_DIMENSION
,
5109 d
== DECL_CODIMENSION
);
5111 if (current_as
== NULL
)
5113 else if (m
== MATCH_YES
)
5115 if (!merge_array_spec (as
, current_as
, false))
5122 if (d
== DECL_CODIMENSION
)
5123 gfc_error ("Missing codimension specification at %C");
5125 gfc_error ("Missing dimension specification at %C");
5129 if (m
== MATCH_ERROR
)
5134 /* Since we've seen a double colon, we have to be looking at an
5135 attr-spec. This means that we can now issue errors. */
5136 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
5141 case DECL_ALLOCATABLE
:
5142 attr
= "ALLOCATABLE";
5144 case DECL_ASYNCHRONOUS
:
5145 attr
= "ASYNCHRONOUS";
5147 case DECL_CODIMENSION
:
5148 attr
= "CODIMENSION";
5150 case DECL_CONTIGUOUS
:
5151 attr
= "CONTIGUOUS";
5153 case DECL_DIMENSION
:
5160 attr
= "INTENT (IN)";
5163 attr
= "INTENT (OUT)";
5166 attr
= "INTENT (IN OUT)";
5168 case DECL_INTRINSIC
:
5180 case DECL_PARAMETER
:
5186 case DECL_PROTECTED
:
5201 case DECL_AUTOMATIC
:
5207 case DECL_IS_BIND_C
:
5217 attr
= NULL
; /* This shouldn't happen. */
5220 gfc_error ("Duplicate %s attribute at %L", attr
, &seen_at
[d
]);
5225 /* Now that we've dealt with duplicate attributes, add the attributes
5226 to the current attribute. */
5227 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
5234 if ((d
== DECL_STATIC
|| d
== DECL_AUTOMATIC
)
5235 && !flag_dec_static
)
5237 gfc_error ("%s at %L is a DEC extension, enable with "
5239 d
== DECL_STATIC
? "STATIC" : "AUTOMATIC", &seen_at
[d
]);
5243 /* Allow SAVE with STATIC, but don't complain. */
5244 if (d
== DECL_STATIC
&& seen
[DECL_SAVE
])
5247 if (gfc_current_state () == COMP_DERIVED
5248 && d
!= DECL_DIMENSION
&& d
!= DECL_CODIMENSION
5249 && d
!= DECL_POINTER
&& d
!= DECL_PRIVATE
5250 && d
!= DECL_PUBLIC
&& d
!= DECL_CONTIGUOUS
&& d
!= DECL_NONE
)
5252 if (d
== DECL_ALLOCATABLE
)
5254 if (!gfc_notify_std (GFC_STD_F2003
, "ALLOCATABLE "
5255 "attribute at %C in a TYPE definition"))
5261 else if (d
== DECL_KIND
)
5263 if (!gfc_notify_std (GFC_STD_F2003
, "KIND "
5264 "attribute at %C in a TYPE definition"))
5269 if (current_ts
.type
!= BT_INTEGER
)
5271 gfc_error ("Component with KIND attribute at %C must be "
5276 if (current_ts
.kind
!= gfc_default_integer_kind
)
5278 gfc_error ("Component with KIND attribute at %C must be "
5279 "default integer kind (%d)",
5280 gfc_default_integer_kind
);
5285 else if (d
== DECL_LEN
)
5287 if (!gfc_notify_std (GFC_STD_F2003
, "LEN "
5288 "attribute at %C in a TYPE definition"))
5293 if (current_ts
.type
!= BT_INTEGER
)
5295 gfc_error ("Component with LEN attribute at %C must be "
5300 if (current_ts
.kind
!= gfc_default_integer_kind
)
5302 gfc_error ("Component with LEN attribute at %C must be "
5303 "default integer kind (%d)",
5304 gfc_default_integer_kind
);
5311 gfc_error ("Attribute at %L is not allowed in a TYPE definition",
5318 if ((d
== DECL_PRIVATE
|| d
== DECL_PUBLIC
)
5319 && gfc_current_state () != COMP_MODULE
)
5321 if (d
== DECL_PRIVATE
)
5325 if (gfc_current_state () == COMP_DERIVED
5326 && gfc_state_stack
->previous
5327 && gfc_state_stack
->previous
->state
== COMP_MODULE
)
5329 if (!gfc_notify_std (GFC_STD_F2003
, "Attribute %s "
5330 "at %L in a TYPE definition", attr
,
5339 gfc_error ("%s attribute at %L is not allowed outside of the "
5340 "specification part of a module", attr
, &seen_at
[d
]);
5346 if (gfc_current_state () != COMP_DERIVED
5347 && (d
== DECL_KIND
|| d
== DECL_LEN
))
5349 gfc_error ("Attribute at %L is not allowed outside a TYPE "
5350 "definition", &seen_at
[d
]);
5357 case DECL_ALLOCATABLE
:
5358 t
= gfc_add_allocatable (¤t_attr
, &seen_at
[d
]);
5361 case DECL_ASYNCHRONOUS
:
5362 if (!gfc_notify_std (GFC_STD_F2003
, "ASYNCHRONOUS attribute at %C"))
5365 t
= gfc_add_asynchronous (¤t_attr
, NULL
, &seen_at
[d
]);
5368 case DECL_CODIMENSION
:
5369 t
= gfc_add_codimension (¤t_attr
, NULL
, &seen_at
[d
]);
5372 case DECL_CONTIGUOUS
:
5373 if (!gfc_notify_std (GFC_STD_F2008
, "CONTIGUOUS attribute at %C"))
5376 t
= gfc_add_contiguous (¤t_attr
, NULL
, &seen_at
[d
]);
5379 case DECL_DIMENSION
:
5380 t
= gfc_add_dimension (¤t_attr
, NULL
, &seen_at
[d
]);
5384 t
= gfc_add_external (¤t_attr
, &seen_at
[d
]);
5388 t
= gfc_add_intent (¤t_attr
, INTENT_IN
, &seen_at
[d
]);
5392 t
= gfc_add_intent (¤t_attr
, INTENT_OUT
, &seen_at
[d
]);
5396 t
= gfc_add_intent (¤t_attr
, INTENT_INOUT
, &seen_at
[d
]);
5399 case DECL_INTRINSIC
:
5400 t
= gfc_add_intrinsic (¤t_attr
, &seen_at
[d
]);
5404 t
= gfc_add_optional (¤t_attr
, &seen_at
[d
]);
5408 t
= gfc_add_kind (¤t_attr
, &seen_at
[d
]);
5412 t
= gfc_add_len (¤t_attr
, &seen_at
[d
]);
5415 case DECL_PARAMETER
:
5416 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, &seen_at
[d
]);
5420 t
= gfc_add_pointer (¤t_attr
, &seen_at
[d
]);
5423 case DECL_PROTECTED
:
5424 if (gfc_current_state () != COMP_MODULE
5425 || (gfc_current_ns
->proc_name
5426 && gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
))
5428 gfc_error ("PROTECTED at %C only allowed in specification "
5429 "part of a module");
5434 if (!gfc_notify_std (GFC_STD_F2003
, "PROTECTED attribute at %C"))
5437 t
= gfc_add_protected (¤t_attr
, NULL
, &seen_at
[d
]);
5441 t
= gfc_add_access (¤t_attr
, ACCESS_PRIVATE
, NULL
,
5446 t
= gfc_add_access (¤t_attr
, ACCESS_PUBLIC
, NULL
,
5452 t
= gfc_add_save (¤t_attr
, SAVE_EXPLICIT
, NULL
, &seen_at
[d
]);
5455 case DECL_AUTOMATIC
:
5456 t
= gfc_add_automatic (¤t_attr
, NULL
, &seen_at
[d
]);
5460 t
= gfc_add_target (¤t_attr
, &seen_at
[d
]);
5463 case DECL_IS_BIND_C
:
5464 t
= gfc_add_is_bind_c(¤t_attr
, NULL
, &seen_at
[d
], 0);
5468 if (!gfc_notify_std (GFC_STD_F2003
, "VALUE attribute at %C"))
5471 t
= gfc_add_value (¤t_attr
, NULL
, &seen_at
[d
]);
5475 if (!gfc_notify_std (GFC_STD_F2003
, "VOLATILE attribute at %C"))
5478 t
= gfc_add_volatile (¤t_attr
, NULL
, &seen_at
[d
]);
5482 gfc_internal_error ("match_attr_spec(): Bad attribute");
5492 /* Since Fortran 2008 module variables implicitly have the SAVE attribute. */
5493 if ((gfc_current_state () == COMP_MODULE
5494 || gfc_current_state () == COMP_SUBMODULE
)
5495 && !current_attr
.save
5496 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
5497 current_attr
.save
= SAVE_IMPLICIT
;
5503 gfc_current_locus
= start
;
5504 gfc_free_array_spec (current_as
);
5511 /* Set the binding label, dest_label, either with the binding label
5512 stored in the given gfc_typespec, ts, or if none was provided, it
5513 will be the symbol name in all lower case, as required by the draft
5514 (J3/04-007, section 15.4.1). If a binding label was given and
5515 there is more than one argument (num_idents), it is an error. */
5518 set_binding_label (const char **dest_label
, const char *sym_name
,
5521 if (num_idents
> 1 && has_name_equals
)
5523 gfc_error ("Multiple identifiers provided with "
5524 "single NAME= specifier at %C");
5528 if (curr_binding_label
)
5529 /* Binding label given; store in temp holder till have sym. */
5530 *dest_label
= curr_binding_label
;
5533 /* No binding label given, and the NAME= specifier did not exist,
5534 which means there was no NAME="". */
5535 if (sym_name
!= NULL
&& has_name_equals
== 0)
5536 *dest_label
= IDENTIFIER_POINTER (get_identifier (sym_name
));
5543 /* Set the status of the given common block as being BIND(C) or not,
5544 depending on the given parameter, is_bind_c. */
5547 set_com_block_bind_c (gfc_common_head
*com_block
, int is_bind_c
)
5549 com_block
->is_bind_c
= is_bind_c
;
5554 /* Verify that the given gfc_typespec is for a C interoperable type. */
5557 gfc_verify_c_interop (gfc_typespec
*ts
)
5559 if (ts
->type
== BT_DERIVED
&& ts
->u
.derived
!= NULL
)
5560 return (ts
->u
.derived
->ts
.is_c_interop
|| ts
->u
.derived
->attr
.is_bind_c
)
5562 else if (ts
->type
== BT_CLASS
)
5564 else if (ts
->is_c_interop
!= 1 && ts
->type
!= BT_ASSUMED
)
5571 /* Verify that the variables of a given common block, which has been
5572 defined with the attribute specifier bind(c), to be of a C
5573 interoperable type. Errors will be reported here, if
5577 verify_com_block_vars_c_interop (gfc_common_head
*com_block
)
5579 gfc_symbol
*curr_sym
= NULL
;
5582 curr_sym
= com_block
->head
;
5584 /* Make sure we have at least one symbol. */
5585 if (curr_sym
== NULL
)
5588 /* Here we know we have a symbol, so we'll execute this loop
5592 /* The second to last param, 1, says this is in a common block. */
5593 retval
= verify_bind_c_sym (curr_sym
, &(curr_sym
->ts
), 1, com_block
);
5594 curr_sym
= curr_sym
->common_next
;
5595 } while (curr_sym
!= NULL
);
5601 /* Verify that a given BIND(C) symbol is C interoperable. If it is not,
5602 an appropriate error message is reported. */
5605 verify_bind_c_sym (gfc_symbol
*tmp_sym
, gfc_typespec
*ts
,
5606 int is_in_common
, gfc_common_head
*com_block
)
5608 bool bind_c_function
= false;
5611 if (tmp_sym
->attr
.function
&& tmp_sym
->attr
.is_bind_c
)
5612 bind_c_function
= true;
5614 if (tmp_sym
->attr
.function
&& tmp_sym
->result
!= NULL
)
5616 tmp_sym
= tmp_sym
->result
;
5617 /* Make sure it wasn't an implicitly typed result. */
5618 if (tmp_sym
->attr
.implicit_type
&& warn_c_binding_type
)
5620 gfc_warning (OPT_Wc_binding_type
,
5621 "Implicitly declared BIND(C) function %qs at "
5622 "%L may not be C interoperable", tmp_sym
->name
,
5623 &tmp_sym
->declared_at
);
5624 tmp_sym
->ts
.f90_type
= tmp_sym
->ts
.type
;
5625 /* Mark it as C interoperable to prevent duplicate warnings. */
5626 tmp_sym
->ts
.is_c_interop
= 1;
5627 tmp_sym
->attr
.is_c_interop
= 1;
5631 /* Here, we know we have the bind(c) attribute, so if we have
5632 enough type info, then verify that it's a C interop kind.
5633 The info could be in the symbol already, or possibly still in
5634 the given ts (current_ts), so look in both. */
5635 if (tmp_sym
->ts
.type
!= BT_UNKNOWN
|| ts
->type
!= BT_UNKNOWN
)
5637 if (!gfc_verify_c_interop (&(tmp_sym
->ts
)))
5639 /* See if we're dealing with a sym in a common block or not. */
5640 if (is_in_common
== 1 && warn_c_binding_type
)
5642 gfc_warning (OPT_Wc_binding_type
,
5643 "Variable %qs in common block %qs at %L "
5644 "may not be a C interoperable "
5645 "kind though common block %qs is BIND(C)",
5646 tmp_sym
->name
, com_block
->name
,
5647 &(tmp_sym
->declared_at
), com_block
->name
);
5651 if (tmp_sym
->ts
.type
== BT_DERIVED
|| ts
->type
== BT_DERIVED
)
5652 gfc_error ("Type declaration %qs at %L is not C "
5653 "interoperable but it is BIND(C)",
5654 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5655 else if (warn_c_binding_type
)
5656 gfc_warning (OPT_Wc_binding_type
, "Variable %qs at %L "
5657 "may not be a C interoperable "
5658 "kind but it is BIND(C)",
5659 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5663 /* Variables declared w/in a common block can't be bind(c)
5664 since there's no way for C to see these variables, so there's
5665 semantically no reason for the attribute. */
5666 if (is_in_common
== 1 && tmp_sym
->attr
.is_bind_c
== 1)
5668 gfc_error ("Variable %qs in common block %qs at "
5669 "%L cannot be declared with BIND(C) "
5670 "since it is not a global",
5671 tmp_sym
->name
, com_block
->name
,
5672 &(tmp_sym
->declared_at
));
5676 /* Scalar variables that are bind(c) can not have the pointer
5677 or allocatable attributes. */
5678 if (tmp_sym
->attr
.is_bind_c
== 1)
5680 if (tmp_sym
->attr
.pointer
== 1)
5682 gfc_error ("Variable %qs at %L cannot have both the "
5683 "POINTER and BIND(C) attributes",
5684 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5688 if (tmp_sym
->attr
.allocatable
== 1)
5690 gfc_error ("Variable %qs at %L cannot have both the "
5691 "ALLOCATABLE and BIND(C) attributes",
5692 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5698 /* If it is a BIND(C) function, make sure the return value is a
5699 scalar value. The previous tests in this function made sure
5700 the type is interoperable. */
5701 if (bind_c_function
&& tmp_sym
->as
!= NULL
)
5702 gfc_error ("Return type of BIND(C) function %qs at %L cannot "
5703 "be an array", tmp_sym
->name
, &(tmp_sym
->declared_at
));
5705 /* BIND(C) functions can not return a character string. */
5706 if (bind_c_function
&& tmp_sym
->ts
.type
== BT_CHARACTER
)
5707 if (tmp_sym
->ts
.u
.cl
== NULL
|| tmp_sym
->ts
.u
.cl
->length
== NULL
5708 || tmp_sym
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
5709 || mpz_cmp_si (tmp_sym
->ts
.u
.cl
->length
->value
.integer
, 1) != 0)
5710 gfc_error ("Return type of BIND(C) function %qs of character "
5711 "type at %L must have length 1", tmp_sym
->name
,
5712 &(tmp_sym
->declared_at
));
5715 /* See if the symbol has been marked as private. If it has, make sure
5716 there is no binding label and warn the user if there is one. */
5717 if (tmp_sym
->attr
.access
== ACCESS_PRIVATE
5718 && tmp_sym
->binding_label
)
5719 /* Use gfc_warning_now because we won't say that the symbol fails
5720 just because of this. */
5721 gfc_warning_now (0, "Symbol %qs at %L is marked PRIVATE but has been "
5722 "given the binding label %qs", tmp_sym
->name
,
5723 &(tmp_sym
->declared_at
), tmp_sym
->binding_label
);
5729 /* Set the appropriate fields for a symbol that's been declared as
5730 BIND(C) (the is_bind_c flag and the binding label), and verify that
5731 the type is C interoperable. Errors are reported by the functions
5732 used to set/test these fields. */
5735 set_verify_bind_c_sym (gfc_symbol
*tmp_sym
, int num_idents
)
5739 /* TODO: Do we need to make sure the vars aren't marked private? */
5741 /* Set the is_bind_c bit in symbol_attribute. */
5742 gfc_add_is_bind_c (&(tmp_sym
->attr
), tmp_sym
->name
, &gfc_current_locus
, 0);
5744 if (!set_binding_label (&tmp_sym
->binding_label
, tmp_sym
->name
, num_idents
))
5751 /* Set the fields marking the given common block as BIND(C), including
5752 a binding label, and report any errors encountered. */
5755 set_verify_bind_c_com_block (gfc_common_head
*com_block
, int num_idents
)
5759 /* destLabel, common name, typespec (which may have binding label). */
5760 if (!set_binding_label (&com_block
->binding_label
, com_block
->name
,
5764 /* Set the given common block (com_block) to being bind(c) (1). */
5765 set_com_block_bind_c (com_block
, 1);
5771 /* Retrieve the list of one or more identifiers that the given bind(c)
5772 attribute applies to. */
5775 get_bind_c_idents (void)
5777 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5779 gfc_symbol
*tmp_sym
= NULL
;
5781 gfc_common_head
*com_block
= NULL
;
5783 if (gfc_match_name (name
) == MATCH_YES
)
5785 found_id
= MATCH_YES
;
5786 gfc_get_ha_symbol (name
, &tmp_sym
);
5788 else if (match_common_name (name
) == MATCH_YES
)
5790 found_id
= MATCH_YES
;
5791 com_block
= gfc_get_common (name
, 0);
5795 gfc_error ("Need either entity or common block name for "
5796 "attribute specification statement at %C");
5800 /* Save the current identifier and look for more. */
5803 /* Increment the number of identifiers found for this spec stmt. */
5806 /* Make sure we have a sym or com block, and verify that it can
5807 be bind(c). Set the appropriate field(s) and look for more
5809 if (tmp_sym
!= NULL
|| com_block
!= NULL
)
5811 if (tmp_sym
!= NULL
)
5813 if (!set_verify_bind_c_sym (tmp_sym
, num_idents
))
5818 if (!set_verify_bind_c_com_block (com_block
, num_idents
))
5822 /* Look to see if we have another identifier. */
5824 if (gfc_match_eos () == MATCH_YES
)
5825 found_id
= MATCH_NO
;
5826 else if (gfc_match_char (',') != MATCH_YES
)
5827 found_id
= MATCH_NO
;
5828 else if (gfc_match_name (name
) == MATCH_YES
)
5830 found_id
= MATCH_YES
;
5831 gfc_get_ha_symbol (name
, &tmp_sym
);
5833 else if (match_common_name (name
) == MATCH_YES
)
5835 found_id
= MATCH_YES
;
5836 com_block
= gfc_get_common (name
, 0);
5840 gfc_error ("Missing entity or common block name for "
5841 "attribute specification statement at %C");
5847 gfc_internal_error ("Missing symbol");
5849 } while (found_id
== MATCH_YES
);
5851 /* if we get here we were successful */
5856 /* Try and match a BIND(C) attribute specification statement. */
5859 gfc_match_bind_c_stmt (void)
5861 match found_match
= MATCH_NO
;
5866 /* This may not be necessary. */
5868 /* Clear the temporary binding label holder. */
5869 curr_binding_label
= NULL
;
5871 /* Look for the bind(c). */
5872 found_match
= gfc_match_bind_c (NULL
, true);
5874 if (found_match
== MATCH_YES
)
5876 if (!gfc_notify_std (GFC_STD_F2003
, "BIND(C) statement at %C"))
5879 /* Look for the :: now, but it is not required. */
5882 /* Get the identifier(s) that needs to be updated. This may need to
5883 change to hand the flag(s) for the attr specified so all identifiers
5884 found can have all appropriate parts updated (assuming that the same
5885 spec stmt can have multiple attrs, such as both bind(c) and
5887 if (!get_bind_c_idents ())
5888 /* Error message should have printed already. */
5896 /* Match a data declaration statement. */
5899 gfc_match_data_decl (void)
5905 type_param_spec_list
= NULL
;
5906 decl_type_param_list
= NULL
;
5908 num_idents_on_line
= 0;
5910 m
= gfc_match_decl_type_spec (¤t_ts
, 0);
5914 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
5915 && !gfc_comp_struct (gfc_current_state ()))
5917 sym
= gfc_use_derived (current_ts
.u
.derived
);
5925 current_ts
.u
.derived
= sym
;
5928 m
= match_attr_spec ();
5929 if (m
== MATCH_ERROR
)
5935 if (current_ts
.type
== BT_CLASS
5936 && current_ts
.u
.derived
->attr
.unlimited_polymorphic
)
5939 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
5940 && current_ts
.u
.derived
->components
== NULL
5941 && !current_ts
.u
.derived
->attr
.zero_comp
)
5944 if (current_attr
.pointer
&& gfc_comp_struct (gfc_current_state ()))
5947 if (current_attr
.allocatable
&& gfc_current_state () == COMP_DERIVED
)
5950 gfc_find_symbol (current_ts
.u
.derived
->name
,
5951 current_ts
.u
.derived
->ns
, 1, &sym
);
5953 /* Any symbol that we find had better be a type definition
5954 which has its components defined, or be a structure definition
5955 actively being parsed. */
5956 if (sym
!= NULL
&& gfc_fl_struct (sym
->attr
.flavor
)
5957 && (current_ts
.u
.derived
->components
!= NULL
5958 || current_ts
.u
.derived
->attr
.zero_comp
5959 || current_ts
.u
.derived
== gfc_new_block
))
5962 gfc_error ("Derived type at %C has not been previously defined "
5963 "and so cannot appear in a derived type definition");
5969 /* If we have an old-style character declaration, and no new-style
5970 attribute specifications, then there a comma is optional between
5971 the type specification and the variable list. */
5972 if (m
== MATCH_NO
&& current_ts
.type
== BT_CHARACTER
&& old_char_selector
)
5973 gfc_match_char (',');
5975 /* Give the types/attributes to symbols that follow. Give the element
5976 a number so that repeat character length expressions can be copied. */
5980 num_idents_on_line
++;
5981 m
= variable_decl (elem
++);
5982 if (m
== MATCH_ERROR
)
5987 if (gfc_match_eos () == MATCH_YES
)
5989 if (gfc_match_char (',') != MATCH_YES
)
5993 if (!gfc_error_flag_test ())
5995 /* An anonymous structure declaration is unambiguous; if we matched one
5996 according to gfc_match_structure_decl, we need to return MATCH_YES
5997 here to avoid confusing the remaining matchers, even if there was an
5998 error during variable_decl. We must flush any such errors. Note this
5999 causes the parser to gracefully continue parsing the remaining input
6000 as a structure body, which likely follows. */
6001 if (current_ts
.type
== BT_DERIVED
&& current_ts
.u
.derived
6002 && gfc_fl_struct (current_ts
.u
.derived
->attr
.flavor
))
6004 gfc_error_now ("Syntax error in anonymous structure declaration"
6006 /* Skip the bad variable_decl and line up for the start of the
6008 gfc_error_recovery ();
6013 gfc_error ("Syntax error in data declaration at %C");
6018 gfc_free_data_all (gfc_current_ns
);
6021 if (saved_kind_expr
)
6022 gfc_free_expr (saved_kind_expr
);
6023 if (type_param_spec_list
)
6024 gfc_free_actual_arglist (type_param_spec_list
);
6025 if (decl_type_param_list
)
6026 gfc_free_actual_arglist (decl_type_param_list
);
6027 saved_kind_expr
= NULL
;
6028 gfc_free_array_spec (current_as
);
6034 /* Match a prefix associated with a function or subroutine
6035 declaration. If the typespec pointer is nonnull, then a typespec
6036 can be matched. Note that if nothing matches, MATCH_YES is
6037 returned (the null string was matched). */
6040 gfc_match_prefix (gfc_typespec
*ts
)
6046 gfc_clear_attr (¤t_attr
);
6048 seen_impure
= false;
6050 gcc_assert (!gfc_matching_prefix
);
6051 gfc_matching_prefix
= true;
6055 found_prefix
= false;
6057 /* MODULE is a prefix like PURE, ELEMENTAL, etc., having a
6058 corresponding attribute seems natural and distinguishes these
6059 procedures from procedure types of PROC_MODULE, which these are
6061 if (gfc_match ("module% ") == MATCH_YES
)
6063 if (!gfc_notify_std (GFC_STD_F2008
, "MODULE prefix at %C"))
6066 current_attr
.module_procedure
= 1;
6067 found_prefix
= true;
6070 if (!seen_type
&& ts
!= NULL
6071 && gfc_match_decl_type_spec (ts
, 0) == MATCH_YES
6072 && gfc_match_space () == MATCH_YES
)
6076 found_prefix
= true;
6079 if (gfc_match ("elemental% ") == MATCH_YES
)
6081 if (!gfc_add_elemental (¤t_attr
, NULL
))
6084 found_prefix
= true;
6087 if (gfc_match ("pure% ") == MATCH_YES
)
6089 if (!gfc_add_pure (¤t_attr
, NULL
))
6092 found_prefix
= true;
6095 if (gfc_match ("recursive% ") == MATCH_YES
)
6097 if (!gfc_add_recursive (¤t_attr
, NULL
))
6100 found_prefix
= true;
6103 /* IMPURE is a somewhat special case, as it needs not set an actual
6104 attribute but rather only prevents ELEMENTAL routines from being
6105 automatically PURE. */
6106 if (gfc_match ("impure% ") == MATCH_YES
)
6108 if (!gfc_notify_std (GFC_STD_F2008
, "IMPURE procedure at %C"))
6112 found_prefix
= true;
6115 while (found_prefix
);
6117 /* IMPURE and PURE must not both appear, of course. */
6118 if (seen_impure
&& current_attr
.pure
)
6120 gfc_error ("PURE and IMPURE must not appear both at %C");
6124 /* If IMPURE it not seen but the procedure is ELEMENTAL, mark it as PURE. */
6125 if (!seen_impure
&& current_attr
.elemental
&& !current_attr
.pure
)
6127 if (!gfc_add_pure (¤t_attr
, NULL
))
6131 /* At this point, the next item is not a prefix. */
6132 gcc_assert (gfc_matching_prefix
);
6134 gfc_matching_prefix
= false;
6138 gcc_assert (gfc_matching_prefix
);
6139 gfc_matching_prefix
= false;
6144 /* Copy attributes matched by gfc_match_prefix() to attributes on a symbol. */
6147 copy_prefix (symbol_attribute
*dest
, locus
*where
)
6149 if (dest
->module_procedure
)
6151 if (current_attr
.elemental
)
6152 dest
->elemental
= 1;
6154 if (current_attr
.pure
)
6157 if (current_attr
.recursive
)
6158 dest
->recursive
= 1;
6160 /* Module procedures are unusual in that the 'dest' is copied from
6161 the interface declaration. However, this is an oportunity to
6162 check that the submodule declaration is compliant with the
6164 if (dest
->elemental
&& !current_attr
.elemental
)
6166 gfc_error ("ELEMENTAL prefix in MODULE PROCEDURE interface is "
6167 "missing at %L", where
);
6171 if (dest
->pure
&& !current_attr
.pure
)
6173 gfc_error ("PURE prefix in MODULE PROCEDURE interface is "
6174 "missing at %L", where
);
6178 if (dest
->recursive
&& !current_attr
.recursive
)
6180 gfc_error ("RECURSIVE prefix in MODULE PROCEDURE interface is "
6181 "missing at %L", where
);
6188 if (current_attr
.elemental
&& !gfc_add_elemental (dest
, where
))
6191 if (current_attr
.pure
&& !gfc_add_pure (dest
, where
))
6194 if (current_attr
.recursive
&& !gfc_add_recursive (dest
, where
))
6201 /* Match a formal argument list or, if typeparam is true, a
6202 type_param_name_list. */
6205 gfc_match_formal_arglist (gfc_symbol
*progname
, int st_flag
,
6206 int null_flag
, bool typeparam
)
6208 gfc_formal_arglist
*head
, *tail
, *p
, *q
;
6209 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6212 gfc_formal_arglist
*formal
= NULL
;
6216 /* Keep the interface formal argument list and null it so that the
6217 matching for the new declaration can be done. The numbers and
6218 names of the arguments are checked here. The interface formal
6219 arguments are retained in formal_arglist and the characteristics
6220 are compared in resolve.c(resolve_fl_procedure). See the remark
6221 in get_proc_name about the eventual need to copy the formal_arglist
6222 and populate the formal namespace of the interface symbol. */
6223 if (progname
->attr
.module_procedure
6224 && progname
->attr
.host_assoc
)
6226 formal
= progname
->formal
;
6227 progname
->formal
= NULL
;
6230 if (gfc_match_char ('(') != MATCH_YES
)
6237 if (gfc_match_char (')') == MATCH_YES
)
6242 if (gfc_match_char ('*') == MATCH_YES
)
6245 if (!typeparam
&& !gfc_notify_std (GFC_STD_F95_OBS
,
6246 "Alternate-return argument at %C"))
6252 gfc_error_now ("A parameter name is required at %C");
6256 m
= gfc_match_name (name
);
6260 gfc_error_now ("A parameter name is required at %C");
6264 if (!typeparam
&& gfc_get_symbol (name
, NULL
, &sym
))
6267 && gfc_get_symbol (name
, progname
->f2k_derived
, &sym
))
6271 p
= gfc_get_formal_arglist ();
6283 /* We don't add the VARIABLE flavor because the name could be a
6284 dummy procedure. We don't apply these attributes to formal
6285 arguments of statement functions. */
6286 if (sym
!= NULL
&& !st_flag
6287 && (!gfc_add_dummy(&sym
->attr
, sym
->name
, NULL
)
6288 || !gfc_missing_attr (&sym
->attr
, NULL
)))
6294 /* The name of a program unit can be in a different namespace,
6295 so check for it explicitly. After the statement is accepted,
6296 the name is checked for especially in gfc_get_symbol(). */
6297 if (gfc_new_block
!= NULL
&& sym
!= NULL
&& !typeparam
6298 && strcmp (sym
->name
, gfc_new_block
->name
) == 0)
6300 gfc_error ("Name %qs at %C is the name of the procedure",
6306 if (gfc_match_char (')') == MATCH_YES
)
6309 m
= gfc_match_char (',');
6313 gfc_error_now ("Expected parameter list in type declaration "
6316 gfc_error ("Unexpected junk in formal argument list at %C");
6322 /* Check for duplicate symbols in the formal argument list. */
6325 for (p
= head
; p
->next
; p
= p
->next
)
6330 for (q
= p
->next
; q
; q
= q
->next
)
6331 if (p
->sym
== q
->sym
)
6334 gfc_error_now ("Duplicate name %qs in parameter "
6335 "list at %C", p
->sym
->name
);
6337 gfc_error ("Duplicate symbol %qs in formal argument "
6338 "list at %C", p
->sym
->name
);
6346 if (!gfc_add_explicit_interface (progname
, IFSRC_DECL
, head
, NULL
))
6352 /* gfc_error_now used in following and return with MATCH_YES because
6353 doing otherwise results in a cascade of extraneous errors and in
6354 some cases an ICE in symbol.c(gfc_release_symbol). */
6355 if (progname
->attr
.module_procedure
&& progname
->attr
.host_assoc
)
6357 bool arg_count_mismatch
= false;
6359 if (!formal
&& head
)
6360 arg_count_mismatch
= true;
6362 /* Abbreviated module procedure declaration is not meant to have any
6363 formal arguments! */
6364 if (!progname
->abr_modproc_decl
&& formal
&& !head
)
6365 arg_count_mismatch
= true;
6367 for (p
= formal
, q
= head
; p
&& q
; p
= p
->next
, q
= q
->next
)
6369 if ((p
->next
!= NULL
&& q
->next
== NULL
)
6370 || (p
->next
== NULL
&& q
->next
!= NULL
))
6371 arg_count_mismatch
= true;
6372 else if ((p
->sym
== NULL
&& q
->sym
== NULL
)
6373 || strcmp (p
->sym
->name
, q
->sym
->name
) == 0)
6376 gfc_error_now ("Mismatch in MODULE PROCEDURE formal "
6377 "argument names (%s/%s) at %C",
6378 p
->sym
->name
, q
->sym
->name
);
6381 if (arg_count_mismatch
)
6382 gfc_error_now ("Mismatch in number of MODULE PROCEDURE "
6383 "formal arguments at %C");
6389 gfc_free_formal_arglist (head
);
6394 /* Match a RESULT specification following a function declaration or
6395 ENTRY statement. Also matches the end-of-statement. */
6398 match_result (gfc_symbol
*function
, gfc_symbol
**result
)
6400 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6404 if (gfc_match (" result (") != MATCH_YES
)
6407 m
= gfc_match_name (name
);
6411 /* Get the right paren, and that's it because there could be the
6412 bind(c) attribute after the result clause. */
6413 if (gfc_match_char (')') != MATCH_YES
)
6415 /* TODO: should report the missing right paren here. */
6419 if (strcmp (function
->name
, name
) == 0)
6421 gfc_error ("RESULT variable at %C must be different than function name");
6425 if (gfc_get_symbol (name
, NULL
, &r
))
6428 if (!gfc_add_result (&r
->attr
, r
->name
, NULL
))
6437 /* Match a function suffix, which could be a combination of a result
6438 clause and BIND(C), either one, or neither. The draft does not
6439 require them to come in a specific order. */
6442 gfc_match_suffix (gfc_symbol
*sym
, gfc_symbol
**result
)
6444 match is_bind_c
; /* Found bind(c). */
6445 match is_result
; /* Found result clause. */
6446 match found_match
; /* Status of whether we've found a good match. */
6447 char peek_char
; /* Character we're going to peek at. */
6448 bool allow_binding_name
;
6450 /* Initialize to having found nothing. */
6451 found_match
= MATCH_NO
;
6452 is_bind_c
= MATCH_NO
;
6453 is_result
= MATCH_NO
;
6455 /* Get the next char to narrow between result and bind(c). */
6456 gfc_gobble_whitespace ();
6457 peek_char
= gfc_peek_ascii_char ();
6459 /* C binding names are not allowed for internal procedures. */
6460 if (gfc_current_state () == COMP_CONTAINS
6461 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
6462 allow_binding_name
= false;
6464 allow_binding_name
= true;
6469 /* Look for result clause. */
6470 is_result
= match_result (sym
, result
);
6471 if (is_result
== MATCH_YES
)
6473 /* Now see if there is a bind(c) after it. */
6474 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
6475 /* We've found the result clause and possibly bind(c). */
6476 found_match
= MATCH_YES
;
6479 /* This should only be MATCH_ERROR. */
6480 found_match
= is_result
;
6483 /* Look for bind(c) first. */
6484 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
6485 if (is_bind_c
== MATCH_YES
)
6487 /* Now see if a result clause followed it. */
6488 is_result
= match_result (sym
, result
);
6489 found_match
= MATCH_YES
;
6493 /* Should only be a MATCH_ERROR if we get here after seeing 'b'. */
6494 found_match
= MATCH_ERROR
;
6498 gfc_error ("Unexpected junk after function declaration at %C");
6499 found_match
= MATCH_ERROR
;
6503 if (is_bind_c
== MATCH_YES
)
6505 /* Fortran 2008 draft allows BIND(C) for internal procedures. */
6506 if (gfc_current_state () == COMP_CONTAINS
6507 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
6508 && !gfc_notify_std (GFC_STD_F2008
, "BIND(C) attribute "
6509 "at %L may not be specified for an internal "
6510 "procedure", &gfc_current_locus
))
6513 if (!gfc_add_is_bind_c (&(sym
->attr
), sym
->name
, &gfc_current_locus
, 1))
6521 /* Procedure pointer return value without RESULT statement:
6522 Add "hidden" result variable named "ppr@". */
6525 add_hidden_procptr_result (gfc_symbol
*sym
)
6529 if (gfc_notification_std (GFC_STD_F2003
) == ERROR
)
6532 /* First usage case: PROCEDURE and EXTERNAL statements. */
6533 case1
= gfc_current_state () == COMP_FUNCTION
&& gfc_current_block ()
6534 && strcmp (gfc_current_block ()->name
, sym
->name
) == 0
6535 && sym
->attr
.external
;
6536 /* Second usage case: INTERFACE statements. */
6537 case2
= gfc_current_state () == COMP_INTERFACE
&& gfc_state_stack
->previous
6538 && gfc_state_stack
->previous
->state
== COMP_FUNCTION
6539 && strcmp (gfc_state_stack
->previous
->sym
->name
, sym
->name
) == 0;
6545 gfc_get_sym_tree ("ppr@", gfc_current_ns
, &stree
, false);
6549 gfc_get_sym_tree ("ppr@", gfc_current_ns
->parent
, &stree
, false);
6550 st2
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "ppr@");
6551 st2
->n
.sym
= stree
->n
.sym
;
6552 stree
->n
.sym
->refs
++;
6554 sym
->result
= stree
->n
.sym
;
6556 sym
->result
->attr
.proc_pointer
= sym
->attr
.proc_pointer
;
6557 sym
->result
->attr
.pointer
= sym
->attr
.pointer
;
6558 sym
->result
->attr
.external
= sym
->attr
.external
;
6559 sym
->result
->attr
.referenced
= sym
->attr
.referenced
;
6560 sym
->result
->ts
= sym
->ts
;
6561 sym
->attr
.proc_pointer
= 0;
6562 sym
->attr
.pointer
= 0;
6563 sym
->attr
.external
= 0;
6564 if (sym
->result
->attr
.external
&& sym
->result
->attr
.pointer
)
6566 sym
->result
->attr
.pointer
= 0;
6567 sym
->result
->attr
.proc_pointer
= 1;
6570 return gfc_add_result (&sym
->result
->attr
, sym
->result
->name
, NULL
);
6572 /* POINTER after PROCEDURE/EXTERNAL/INTERFACE statement. */
6573 else if (sym
->attr
.function
&& !sym
->attr
.external
&& sym
->attr
.pointer
6574 && sym
->result
&& sym
->result
!= sym
&& sym
->result
->attr
.external
6575 && sym
== gfc_current_ns
->proc_name
6576 && sym
== sym
->result
->ns
->proc_name
6577 && strcmp ("ppr@", sym
->result
->name
) == 0)
6579 sym
->result
->attr
.proc_pointer
= 1;
6580 sym
->attr
.pointer
= 0;
6588 /* Match the interface for a PROCEDURE declaration,
6589 including brackets (R1212). */
6592 match_procedure_interface (gfc_symbol
**proc_if
)
6596 locus old_loc
, entry_loc
;
6597 gfc_namespace
*old_ns
= gfc_current_ns
;
6598 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6600 old_loc
= entry_loc
= gfc_current_locus
;
6601 gfc_clear_ts (¤t_ts
);
6603 if (gfc_match (" (") != MATCH_YES
)
6605 gfc_current_locus
= entry_loc
;
6609 /* Get the type spec. for the procedure interface. */
6610 old_loc
= gfc_current_locus
;
6611 m
= gfc_match_decl_type_spec (¤t_ts
, 0);
6612 gfc_gobble_whitespace ();
6613 if (m
== MATCH_YES
|| (m
== MATCH_NO
&& gfc_peek_ascii_char () == ')'))
6616 if (m
== MATCH_ERROR
)
6619 /* Procedure interface is itself a procedure. */
6620 gfc_current_locus
= old_loc
;
6621 m
= gfc_match_name (name
);
6623 /* First look to see if it is already accessible in the current
6624 namespace because it is use associated or contained. */
6626 if (gfc_find_sym_tree (name
, NULL
, 0, &st
))
6629 /* If it is still not found, then try the parent namespace, if it
6630 exists and create the symbol there if it is still not found. */
6631 if (gfc_current_ns
->parent
)
6632 gfc_current_ns
= gfc_current_ns
->parent
;
6633 if (st
== NULL
&& gfc_get_ha_sym_tree (name
, &st
))
6636 gfc_current_ns
= old_ns
;
6637 *proc_if
= st
->n
.sym
;
6642 /* Resolve interface if possible. That way, attr.procedure is only set
6643 if it is declared by a later procedure-declaration-stmt, which is
6644 invalid per F08:C1216 (cf. resolve_procedure_interface). */
6645 while ((*proc_if
)->ts
.interface
6646 && *proc_if
!= (*proc_if
)->ts
.interface
)
6647 *proc_if
= (*proc_if
)->ts
.interface
;
6649 if ((*proc_if
)->attr
.flavor
== FL_UNKNOWN
6650 && (*proc_if
)->ts
.type
== BT_UNKNOWN
6651 && !gfc_add_flavor (&(*proc_if
)->attr
, FL_PROCEDURE
,
6652 (*proc_if
)->name
, NULL
))
6657 if (gfc_match (" )") != MATCH_YES
)
6659 gfc_current_locus
= entry_loc
;
6667 /* Match a PROCEDURE declaration (R1211). */
6670 match_procedure_decl (void)
6673 gfc_symbol
*sym
, *proc_if
= NULL
;
6675 gfc_expr
*initializer
= NULL
;
6677 /* Parse interface (with brackets). */
6678 m
= match_procedure_interface (&proc_if
);
6682 /* Parse attributes (with colons). */
6683 m
= match_attr_spec();
6684 if (m
== MATCH_ERROR
)
6687 if (proc_if
&& proc_if
->attr
.is_bind_c
&& !current_attr
.is_bind_c
)
6689 current_attr
.is_bind_c
= 1;
6690 has_name_equals
= 0;
6691 curr_binding_label
= NULL
;
6694 /* Get procedure symbols. */
6697 m
= gfc_match_symbol (&sym
, 0);
6700 else if (m
== MATCH_ERROR
)
6703 /* Add current_attr to the symbol attributes. */
6704 if (!gfc_copy_attr (&sym
->attr
, ¤t_attr
, NULL
))
6707 if (sym
->attr
.is_bind_c
)
6709 /* Check for C1218. */
6710 if (!proc_if
|| !proc_if
->attr
.is_bind_c
)
6712 gfc_error ("BIND(C) attribute at %C requires "
6713 "an interface with BIND(C)");
6716 /* Check for C1217. */
6717 if (has_name_equals
&& sym
->attr
.pointer
)
6719 gfc_error ("BIND(C) procedure with NAME may not have "
6720 "POINTER attribute at %C");
6723 if (has_name_equals
&& sym
->attr
.dummy
)
6725 gfc_error ("Dummy procedure at %C may not have "
6726 "BIND(C) attribute with NAME");
6729 /* Set binding label for BIND(C). */
6730 if (!set_binding_label (&sym
->binding_label
, sym
->name
, num
))
6734 if (!gfc_add_external (&sym
->attr
, NULL
))
6737 if (add_hidden_procptr_result (sym
))
6740 if (!gfc_add_proc (&sym
->attr
, sym
->name
, NULL
))
6743 /* Set interface. */
6744 if (proc_if
!= NULL
)
6746 if (sym
->ts
.type
!= BT_UNKNOWN
)
6748 gfc_error ("Procedure %qs at %L already has basic type of %s",
6749 sym
->name
, &gfc_current_locus
,
6750 gfc_basic_typename (sym
->ts
.type
));
6753 sym
->ts
.interface
= proc_if
;
6754 sym
->attr
.untyped
= 1;
6755 sym
->attr
.if_source
= IFSRC_IFBODY
;
6757 else if (current_ts
.type
!= BT_UNKNOWN
)
6759 if (!gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
6761 sym
->ts
.interface
= gfc_new_symbol ("", gfc_current_ns
);
6762 sym
->ts
.interface
->ts
= current_ts
;
6763 sym
->ts
.interface
->attr
.flavor
= FL_PROCEDURE
;
6764 sym
->ts
.interface
->attr
.function
= 1;
6765 sym
->attr
.function
= 1;
6766 sym
->attr
.if_source
= IFSRC_UNKNOWN
;
6769 if (gfc_match (" =>") == MATCH_YES
)
6771 if (!current_attr
.pointer
)
6773 gfc_error ("Initialization at %C isn't for a pointer variable");
6778 m
= match_pointer_init (&initializer
, 1);
6782 if (!add_init_expr_to_sym (sym
->name
, &initializer
, &gfc_current_locus
))
6787 if (gfc_match_eos () == MATCH_YES
)
6789 if (gfc_match_char (',') != MATCH_YES
)
6794 gfc_error ("Syntax error in PROCEDURE statement at %C");
6798 /* Free stuff up and return. */
6799 gfc_free_expr (initializer
);
6805 match_binding_attributes (gfc_typebound_proc
* ba
, bool generic
, bool ppc
);
6808 /* Match a procedure pointer component declaration (R445). */
6811 match_ppc_decl (void)
6814 gfc_symbol
*proc_if
= NULL
;
6818 gfc_expr
*initializer
= NULL
;
6819 gfc_typebound_proc
* tb
;
6820 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6822 /* Parse interface (with brackets). */
6823 m
= match_procedure_interface (&proc_if
);
6827 /* Parse attributes. */
6828 tb
= XCNEW (gfc_typebound_proc
);
6829 tb
->where
= gfc_current_locus
;
6830 m
= match_binding_attributes (tb
, false, true);
6831 if (m
== MATCH_ERROR
)
6834 gfc_clear_attr (¤t_attr
);
6835 current_attr
.procedure
= 1;
6836 current_attr
.proc_pointer
= 1;
6837 current_attr
.access
= tb
->access
;
6838 current_attr
.flavor
= FL_PROCEDURE
;
6840 /* Match the colons (required). */
6841 if (gfc_match (" ::") != MATCH_YES
)
6843 gfc_error ("Expected %<::%> after binding-attributes at %C");
6847 /* Check for C450. */
6848 if (!tb
->nopass
&& proc_if
== NULL
)
6850 gfc_error("NOPASS or explicit interface required at %C");
6854 if (!gfc_notify_std (GFC_STD_F2003
, "Procedure pointer component at %C"))
6857 /* Match PPC names. */
6861 m
= gfc_match_name (name
);
6864 else if (m
== MATCH_ERROR
)
6867 if (!gfc_add_component (gfc_current_block(), name
, &c
))
6870 /* Add current_attr to the symbol attributes. */
6871 if (!gfc_copy_attr (&c
->attr
, ¤t_attr
, NULL
))
6874 if (!gfc_add_external (&c
->attr
, NULL
))
6877 if (!gfc_add_proc (&c
->attr
, name
, NULL
))
6884 c
->tb
= XCNEW (gfc_typebound_proc
);
6885 c
->tb
->where
= gfc_current_locus
;
6889 /* Set interface. */
6890 if (proc_if
!= NULL
)
6892 c
->ts
.interface
= proc_if
;
6893 c
->attr
.untyped
= 1;
6894 c
->attr
.if_source
= IFSRC_IFBODY
;
6896 else if (ts
.type
!= BT_UNKNOWN
)
6899 c
->ts
.interface
= gfc_new_symbol ("", gfc_current_ns
);
6900 c
->ts
.interface
->result
= c
->ts
.interface
;
6901 c
->ts
.interface
->ts
= ts
;
6902 c
->ts
.interface
->attr
.flavor
= FL_PROCEDURE
;
6903 c
->ts
.interface
->attr
.function
= 1;
6904 c
->attr
.function
= 1;
6905 c
->attr
.if_source
= IFSRC_UNKNOWN
;
6908 if (gfc_match (" =>") == MATCH_YES
)
6910 m
= match_pointer_init (&initializer
, 1);
6913 gfc_free_expr (initializer
);
6916 c
->initializer
= initializer
;
6919 if (gfc_match_eos () == MATCH_YES
)
6921 if (gfc_match_char (',') != MATCH_YES
)
6926 gfc_error ("Syntax error in procedure pointer component at %C");
6931 /* Match a PROCEDURE declaration inside an interface (R1206). */
6934 match_procedure_in_interface (void)
6938 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6941 if (current_interface
.type
== INTERFACE_NAMELESS
6942 || current_interface
.type
== INTERFACE_ABSTRACT
)
6944 gfc_error ("PROCEDURE at %C must be in a generic interface");
6948 /* Check if the F2008 optional double colon appears. */
6949 gfc_gobble_whitespace ();
6950 old_locus
= gfc_current_locus
;
6951 if (gfc_match ("::") == MATCH_YES
)
6953 if (!gfc_notify_std (GFC_STD_F2008
, "double colon in "
6954 "MODULE PROCEDURE statement at %L", &old_locus
))
6958 gfc_current_locus
= old_locus
;
6962 m
= gfc_match_name (name
);
6965 else if (m
== MATCH_ERROR
)
6967 if (gfc_get_symbol (name
, gfc_current_ns
->parent
, &sym
))
6970 if (!gfc_add_interface (sym
))
6973 if (gfc_match_eos () == MATCH_YES
)
6975 if (gfc_match_char (',') != MATCH_YES
)
6982 gfc_error ("Syntax error in PROCEDURE statement at %C");
6987 /* General matcher for PROCEDURE declarations. */
6989 static match
match_procedure_in_type (void);
6992 gfc_match_procedure (void)
6996 switch (gfc_current_state ())
7001 case COMP_SUBMODULE
:
7002 case COMP_SUBROUTINE
:
7005 m
= match_procedure_decl ();
7007 case COMP_INTERFACE
:
7008 m
= match_procedure_in_interface ();
7011 m
= match_ppc_decl ();
7013 case COMP_DERIVED_CONTAINS
:
7014 m
= match_procedure_in_type ();
7023 if (!gfc_notify_std (GFC_STD_F2003
, "PROCEDURE statement at %C"))
7030 /* Warn if a matched procedure has the same name as an intrinsic; this is
7031 simply a wrapper around gfc_warn_intrinsic_shadow that interprets the current
7032 parser-state-stack to find out whether we're in a module. */
7035 do_warn_intrinsic_shadow (const gfc_symbol
* sym
, bool func
)
7039 in_module
= (gfc_state_stack
->previous
7040 && (gfc_state_stack
->previous
->state
== COMP_MODULE
7041 || gfc_state_stack
->previous
->state
== COMP_SUBMODULE
));
7043 gfc_warn_intrinsic_shadow (sym
, in_module
, func
);
7047 /* Match a function declaration. */
7050 gfc_match_function_decl (void)
7052 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7053 gfc_symbol
*sym
, *result
;
7057 match found_match
; /* Status returned by match func. */
7059 if (gfc_current_state () != COMP_NONE
7060 && gfc_current_state () != COMP_INTERFACE
7061 && gfc_current_state () != COMP_CONTAINS
)
7064 gfc_clear_ts (¤t_ts
);
7066 old_loc
= gfc_current_locus
;
7068 m
= gfc_match_prefix (¤t_ts
);
7071 gfc_current_locus
= old_loc
;
7075 if (gfc_match ("function% %n", name
) != MATCH_YES
)
7077 gfc_current_locus
= old_loc
;
7081 if (get_proc_name (name
, &sym
, false))
7084 if (add_hidden_procptr_result (sym
))
7087 if (current_attr
.module_procedure
)
7088 sym
->attr
.module_procedure
= 1;
7090 gfc_new_block
= sym
;
7092 m
= gfc_match_formal_arglist (sym
, 0, 0);
7095 gfc_error ("Expected formal argument list in function "
7096 "definition at %C");
7100 else if (m
== MATCH_ERROR
)
7105 /* According to the draft, the bind(c) and result clause can
7106 come in either order after the formal_arg_list (i.e., either
7107 can be first, both can exist together or by themselves or neither
7108 one). Therefore, the match_result can't match the end of the
7109 string, and check for the bind(c) or result clause in either order. */
7110 found_match
= gfc_match_eos ();
7112 /* Make sure that it isn't already declared as BIND(C). If it is, it
7113 must have been marked BIND(C) with a BIND(C) attribute and that is
7114 not allowed for procedures. */
7115 if (sym
->attr
.is_bind_c
== 1)
7117 sym
->attr
.is_bind_c
= 0;
7118 if (sym
->old_symbol
!= NULL
)
7119 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7120 "variables or common blocks",
7121 &(sym
->old_symbol
->declared_at
));
7123 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7124 "variables or common blocks", &gfc_current_locus
);
7127 if (found_match
!= MATCH_YES
)
7129 /* If we haven't found the end-of-statement, look for a suffix. */
7130 suffix_match
= gfc_match_suffix (sym
, &result
);
7131 if (suffix_match
== MATCH_YES
)
7132 /* Need to get the eos now. */
7133 found_match
= gfc_match_eos ();
7135 found_match
= suffix_match
;
7138 if(found_match
!= MATCH_YES
)
7142 /* Make changes to the symbol. */
7145 if (!gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
7148 if (!gfc_missing_attr (&sym
->attr
, NULL
))
7151 if (!copy_prefix (&sym
->attr
, &sym
->declared_at
))
7153 if(!sym
->attr
.module_procedure
)
7159 /* Delay matching the function characteristics until after the
7160 specification block by signalling kind=-1. */
7161 sym
->declared_at
= old_loc
;
7162 if (current_ts
.type
!= BT_UNKNOWN
)
7163 current_ts
.kind
= -1;
7165 current_ts
.kind
= 0;
7169 if (current_ts
.type
!= BT_UNKNOWN
7170 && !gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
7176 if (current_ts
.type
!= BT_UNKNOWN
7177 && !gfc_add_type (result
, ¤t_ts
, &gfc_current_locus
))
7179 sym
->result
= result
;
7182 /* Warn if this procedure has the same name as an intrinsic. */
7183 do_warn_intrinsic_shadow (sym
, true);
7189 gfc_current_locus
= old_loc
;
7194 /* This is mostly a copy of parse.c(add_global_procedure) but modified to
7195 pass the name of the entry, rather than the gfc_current_block name, and
7196 to return false upon finding an existing global entry. */
7199 add_global_entry (const char *name
, const char *binding_label
, bool sub
,
7203 enum gfc_symbol_type type
;
7205 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
7207 /* Only in Fortran 2003: For procedures with a binding label also the Fortran
7208 name is a global identifier. */
7209 if (!binding_label
|| gfc_notification_std (GFC_STD_F2008
))
7211 s
= gfc_get_gsymbol (name
);
7213 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= type
))
7215 gfc_global_used (s
, where
);
7224 s
->ns
= gfc_current_ns
;
7228 /* Don't add the symbol multiple times. */
7230 && (!gfc_notification_std (GFC_STD_F2008
)
7231 || strcmp (name
, binding_label
) != 0))
7233 s
= gfc_get_gsymbol (binding_label
);
7235 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= type
))
7237 gfc_global_used (s
, where
);
7244 s
->binding_label
= binding_label
;
7247 s
->ns
= gfc_current_ns
;
7255 /* Match an ENTRY statement. */
7258 gfc_match_entry (void)
7263 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7264 gfc_compile_state state
;
7268 bool module_procedure
;
7272 m
= gfc_match_name (name
);
7276 if (!gfc_notify_std (GFC_STD_F2008_OBS
, "ENTRY statement at %C"))
7279 state
= gfc_current_state ();
7280 if (state
!= COMP_SUBROUTINE
&& state
!= COMP_FUNCTION
)
7285 gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
7288 gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
7290 case COMP_SUBMODULE
:
7291 gfc_error ("ENTRY statement at %C cannot appear within a SUBMODULE");
7293 case COMP_BLOCK_DATA
:
7294 gfc_error ("ENTRY statement at %C cannot appear within "
7297 case COMP_INTERFACE
:
7298 gfc_error ("ENTRY statement at %C cannot appear within "
7301 case COMP_STRUCTURE
:
7302 gfc_error ("ENTRY statement at %C cannot appear within "
7303 "a STRUCTURE block");
7306 gfc_error ("ENTRY statement at %C cannot appear within "
7307 "a DERIVED TYPE block");
7310 gfc_error ("ENTRY statement at %C cannot appear within "
7311 "an IF-THEN block");
7314 case COMP_DO_CONCURRENT
:
7315 gfc_error ("ENTRY statement at %C cannot appear within "
7319 gfc_error ("ENTRY statement at %C cannot appear within "
7323 gfc_error ("ENTRY statement at %C cannot appear within "
7327 gfc_error ("ENTRY statement at %C cannot appear within "
7331 gfc_error ("ENTRY statement at %C cannot appear within "
7332 "a contained subprogram");
7335 gfc_error ("Unexpected ENTRY statement at %C");
7340 if ((state
== COMP_SUBROUTINE
|| state
== COMP_FUNCTION
)
7341 && gfc_state_stack
->previous
->state
== COMP_INTERFACE
)
7343 gfc_error ("ENTRY statement at %C cannot appear within an INTERFACE");
7347 module_procedure
= gfc_current_ns
->parent
!= NULL
7348 && gfc_current_ns
->parent
->proc_name
7349 && gfc_current_ns
->parent
->proc_name
->attr
.flavor
7352 if (gfc_current_ns
->parent
!= NULL
7353 && gfc_current_ns
->parent
->proc_name
7354 && !module_procedure
)
7356 gfc_error("ENTRY statement at %C cannot appear in a "
7357 "contained procedure");
7361 /* Module function entries need special care in get_proc_name
7362 because previous references within the function will have
7363 created symbols attached to the current namespace. */
7364 if (get_proc_name (name
, &entry
,
7365 gfc_current_ns
->parent
!= NULL
7366 && module_procedure
))
7369 proc
= gfc_current_block ();
7371 /* Make sure that it isn't already declared as BIND(C). If it is, it
7372 must have been marked BIND(C) with a BIND(C) attribute and that is
7373 not allowed for procedures. */
7374 if (entry
->attr
.is_bind_c
== 1)
7376 entry
->attr
.is_bind_c
= 0;
7377 if (entry
->old_symbol
!= NULL
)
7378 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7379 "variables or common blocks",
7380 &(entry
->old_symbol
->declared_at
));
7382 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7383 "variables or common blocks", &gfc_current_locus
);
7386 /* Check what next non-whitespace character is so we can tell if there
7387 is the required parens if we have a BIND(C). */
7388 old_loc
= gfc_current_locus
;
7389 gfc_gobble_whitespace ();
7390 peek_char
= gfc_peek_ascii_char ();
7392 if (state
== COMP_SUBROUTINE
)
7394 m
= gfc_match_formal_arglist (entry
, 0, 1);
7398 /* Call gfc_match_bind_c with allow_binding_name = true as ENTRY can
7399 never be an internal procedure. */
7400 is_bind_c
= gfc_match_bind_c (entry
, true);
7401 if (is_bind_c
== MATCH_ERROR
)
7403 if (is_bind_c
== MATCH_YES
)
7405 if (peek_char
!= '(')
7407 gfc_error ("Missing required parentheses before BIND(C) at %C");
7410 if (!gfc_add_is_bind_c (&(entry
->attr
), entry
->name
,
7411 &(entry
->declared_at
), 1))
7415 if (!gfc_current_ns
->parent
7416 && !add_global_entry (name
, entry
->binding_label
, true,
7420 /* An entry in a subroutine. */
7421 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
7422 || !gfc_add_subroutine (&entry
->attr
, entry
->name
, NULL
))
7427 /* An entry in a function.
7428 We need to take special care because writing
7433 ENTRY f() RESULT (r)
7435 ENTRY f RESULT (r). */
7436 if (gfc_match_eos () == MATCH_YES
)
7438 gfc_current_locus
= old_loc
;
7439 /* Match the empty argument list, and add the interface to
7441 m
= gfc_match_formal_arglist (entry
, 0, 1);
7444 m
= gfc_match_formal_arglist (entry
, 0, 0);
7451 if (gfc_match_eos () == MATCH_YES
)
7453 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
7454 || !gfc_add_function (&entry
->attr
, entry
->name
, NULL
))
7457 entry
->result
= entry
;
7461 m
= gfc_match_suffix (entry
, &result
);
7463 gfc_syntax_error (ST_ENTRY
);
7469 if (!gfc_add_result (&result
->attr
, result
->name
, NULL
)
7470 || !gfc_add_entry (&entry
->attr
, result
->name
, NULL
)
7471 || !gfc_add_function (&entry
->attr
, result
->name
, NULL
))
7473 entry
->result
= result
;
7477 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
7478 || !gfc_add_function (&entry
->attr
, entry
->name
, NULL
))
7480 entry
->result
= entry
;
7484 if (!gfc_current_ns
->parent
7485 && !add_global_entry (name
, entry
->binding_label
, false,
7490 if (gfc_match_eos () != MATCH_YES
)
7492 gfc_syntax_error (ST_ENTRY
);
7496 entry
->attr
.recursive
= proc
->attr
.recursive
;
7497 entry
->attr
.elemental
= proc
->attr
.elemental
;
7498 entry
->attr
.pure
= proc
->attr
.pure
;
7500 el
= gfc_get_entry_list ();
7502 el
->next
= gfc_current_ns
->entries
;
7503 gfc_current_ns
->entries
= el
;
7505 el
->id
= el
->next
->id
+ 1;
7509 new_st
.op
= EXEC_ENTRY
;
7510 new_st
.ext
.entry
= el
;
7516 /* Match a subroutine statement, including optional prefixes. */
7519 gfc_match_subroutine (void)
7521 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7526 bool allow_binding_name
;
7528 if (gfc_current_state () != COMP_NONE
7529 && gfc_current_state () != COMP_INTERFACE
7530 && gfc_current_state () != COMP_CONTAINS
)
7533 m
= gfc_match_prefix (NULL
);
7537 m
= gfc_match ("subroutine% %n", name
);
7541 if (get_proc_name (name
, &sym
, false))
7544 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
7545 the symbol existed before. */
7546 sym
->declared_at
= gfc_current_locus
;
7548 if (current_attr
.module_procedure
)
7549 sym
->attr
.module_procedure
= 1;
7551 if (add_hidden_procptr_result (sym
))
7554 gfc_new_block
= sym
;
7556 /* Check what next non-whitespace character is so we can tell if there
7557 is the required parens if we have a BIND(C). */
7558 gfc_gobble_whitespace ();
7559 peek_char
= gfc_peek_ascii_char ();
7561 if (!gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
))
7564 if (gfc_match_formal_arglist (sym
, 0, 1) != MATCH_YES
)
7567 /* Make sure that it isn't already declared as BIND(C). If it is, it
7568 must have been marked BIND(C) with a BIND(C) attribute and that is
7569 not allowed for procedures. */
7570 if (sym
->attr
.is_bind_c
== 1)
7572 sym
->attr
.is_bind_c
= 0;
7573 if (sym
->old_symbol
!= NULL
)
7574 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7575 "variables or common blocks",
7576 &(sym
->old_symbol
->declared_at
));
7578 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7579 "variables or common blocks", &gfc_current_locus
);
7582 /* C binding names are not allowed for internal procedures. */
7583 if (gfc_current_state () == COMP_CONTAINS
7584 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
7585 allow_binding_name
= false;
7587 allow_binding_name
= true;
7589 /* Here, we are just checking if it has the bind(c) attribute, and if
7590 so, then we need to make sure it's all correct. If it doesn't,
7591 we still need to continue matching the rest of the subroutine line. */
7592 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
7593 if (is_bind_c
== MATCH_ERROR
)
7595 /* There was an attempt at the bind(c), but it was wrong. An
7596 error message should have been printed w/in the gfc_match_bind_c
7597 so here we'll just return the MATCH_ERROR. */
7601 if (is_bind_c
== MATCH_YES
)
7603 /* The following is allowed in the Fortran 2008 draft. */
7604 if (gfc_current_state () == COMP_CONTAINS
7605 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
7606 && !gfc_notify_std (GFC_STD_F2008
, "BIND(C) attribute "
7607 "at %L may not be specified for an internal "
7608 "procedure", &gfc_current_locus
))
7611 if (peek_char
!= '(')
7613 gfc_error ("Missing required parentheses before BIND(C) at %C");
7616 if (!gfc_add_is_bind_c (&(sym
->attr
), sym
->name
,
7617 &(sym
->declared_at
), 1))
7621 if (gfc_match_eos () != MATCH_YES
)
7623 gfc_syntax_error (ST_SUBROUTINE
);
7627 if (!copy_prefix (&sym
->attr
, &sym
->declared_at
))
7629 if(!sym
->attr
.module_procedure
)
7635 /* Warn if it has the same name as an intrinsic. */
7636 do_warn_intrinsic_shadow (sym
, false);
7642 /* Check that the NAME identifier in a BIND attribute or statement
7643 is conform to C identifier rules. */
7646 check_bind_name_identifier (char **name
)
7648 char *n
= *name
, *p
;
7650 /* Remove leading spaces. */
7654 /* On an empty string, free memory and set name to NULL. */
7662 /* Remove trailing spaces. */
7663 p
= n
+ strlen(n
) - 1;
7667 /* Insert the identifier into the symbol table. */
7672 /* Now check that identifier is valid under C rules. */
7675 gfc_error ("Invalid C identifier in NAME= specifier at %C");
7680 if (!(ISALNUM (*p
) || *p
== '_' || *p
== '$'))
7682 gfc_error ("Invalid C identifier in NAME= specifier at %C");
7690 /* Match a BIND(C) specifier, with the optional 'name=' specifier if
7691 given, and set the binding label in either the given symbol (if not
7692 NULL), or in the current_ts. The symbol may be NULL because we may
7693 encounter the BIND(C) before the declaration itself. Return
7694 MATCH_NO if what we're looking at isn't a BIND(C) specifier,
7695 MATCH_ERROR if it is a BIND(C) clause but an error was encountered,
7696 or MATCH_YES if the specifier was correct and the binding label and
7697 bind(c) fields were set correctly for the given symbol or the
7698 current_ts. If allow_binding_name is false, no binding name may be
7702 gfc_match_bind_c (gfc_symbol
*sym
, bool allow_binding_name
)
7704 char *binding_label
= NULL
;
7707 /* Initialize the flag that specifies whether we encountered a NAME=
7708 specifier or not. */
7709 has_name_equals
= 0;
7711 /* This much we have to be able to match, in this order, if
7712 there is a bind(c) label. */
7713 if (gfc_match (" bind ( c ") != MATCH_YES
)
7716 /* Now see if there is a binding label, or if we've reached the
7717 end of the bind(c) attribute without one. */
7718 if (gfc_match_char (',') == MATCH_YES
)
7720 if (gfc_match (" name = ") != MATCH_YES
)
7722 gfc_error ("Syntax error in NAME= specifier for binding label "
7724 /* should give an error message here */
7728 has_name_equals
= 1;
7730 if (gfc_match_init_expr (&e
) != MATCH_YES
)
7736 if (!gfc_simplify_expr(e
, 0))
7738 gfc_error ("NAME= specifier at %C should be a constant expression");
7743 if (e
->expr_type
!= EXPR_CONSTANT
|| e
->ts
.type
!= BT_CHARACTER
7744 || e
->ts
.kind
!= gfc_default_character_kind
|| e
->rank
!= 0)
7746 gfc_error ("NAME= specifier at %C should be a scalar of "
7747 "default character kind");
7752 // Get a C string from the Fortran string constant
7753 binding_label
= gfc_widechar_to_char (e
->value
.character
.string
,
7754 e
->value
.character
.length
);
7757 // Check that it is valid (old gfc_match_name_C)
7758 if (check_bind_name_identifier (&binding_label
) != MATCH_YES
)
7762 /* Get the required right paren. */
7763 if (gfc_match_char (')') != MATCH_YES
)
7765 gfc_error ("Missing closing paren for binding label at %C");
7769 if (has_name_equals
&& !allow_binding_name
)
7771 gfc_error ("No binding name is allowed in BIND(C) at %C");
7775 if (has_name_equals
&& sym
!= NULL
&& sym
->attr
.dummy
)
7777 gfc_error ("For dummy procedure %s, no binding name is "
7778 "allowed in BIND(C) at %C", sym
->name
);
7783 /* Save the binding label to the symbol. If sym is null, we're
7784 probably matching the typespec attributes of a declaration and
7785 haven't gotten the name yet, and therefore, no symbol yet. */
7789 sym
->binding_label
= binding_label
;
7791 curr_binding_label
= binding_label
;
7793 else if (allow_binding_name
)
7795 /* No binding label, but if symbol isn't null, we
7796 can set the label for it here.
7797 If name="" or allow_binding_name is false, no C binding name is
7799 if (sym
!= NULL
&& sym
->name
!= NULL
&& has_name_equals
== 0)
7800 sym
->binding_label
= IDENTIFIER_POINTER (get_identifier (sym
->name
));
7803 if (has_name_equals
&& gfc_current_state () == COMP_INTERFACE
7804 && current_interface
.type
== INTERFACE_ABSTRACT
)
7806 gfc_error ("NAME not allowed on BIND(C) for ABSTRACT INTERFACE at %C");
7814 /* Return nonzero if we're currently compiling a contained procedure. */
7817 contained_procedure (void)
7819 gfc_state_data
*s
= gfc_state_stack
;
7821 if ((s
->state
== COMP_SUBROUTINE
|| s
->state
== COMP_FUNCTION
)
7822 && s
->previous
!= NULL
&& s
->previous
->state
== COMP_CONTAINS
)
7828 /* Set the kind of each enumerator. The kind is selected such that it is
7829 interoperable with the corresponding C enumeration type, making
7830 sure that -fshort-enums is honored. */
7835 enumerator_history
*current_history
= NULL
;
7839 if (max_enum
== NULL
|| enum_history
== NULL
)
7842 if (!flag_short_enums
)
7848 kind
= gfc_integer_kinds
[i
++].kind
;
7850 while (kind
< gfc_c_int_kind
7851 && gfc_check_integer_range (max_enum
->initializer
->value
.integer
,
7854 current_history
= enum_history
;
7855 while (current_history
!= NULL
)
7857 current_history
->sym
->ts
.kind
= kind
;
7858 current_history
= current_history
->next
;
7863 /* Match any of the various end-block statements. Returns the type of
7864 END to the caller. The END INTERFACE, END IF, END DO, END SELECT
7865 and END BLOCK statements cannot be replaced by a single END statement. */
7868 gfc_match_end (gfc_statement
*st
)
7870 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7871 gfc_compile_state state
;
7873 const char *block_name
;
7877 gfc_namespace
*parent_ns
, *ns
, *prev_ns
;
7878 gfc_namespace
**nsp
;
7879 bool abreviated_modproc_decl
= false;
7880 bool got_matching_end
= false;
7882 old_loc
= gfc_current_locus
;
7883 if (gfc_match ("end") != MATCH_YES
)
7886 state
= gfc_current_state ();
7887 block_name
= gfc_current_block () == NULL
7888 ? NULL
: gfc_current_block ()->name
;
7892 case COMP_ASSOCIATE
:
7894 if (gfc_str_startswith (block_name
, "block@"))
7899 case COMP_DERIVED_CONTAINS
:
7900 state
= gfc_state_stack
->previous
->state
;
7901 block_name
= gfc_state_stack
->previous
->sym
== NULL
7902 ? NULL
: gfc_state_stack
->previous
->sym
->name
;
7903 abreviated_modproc_decl
= gfc_state_stack
->previous
->sym
7904 && gfc_state_stack
->previous
->sym
->abr_modproc_decl
;
7911 if (!abreviated_modproc_decl
)
7912 abreviated_modproc_decl
= gfc_current_block ()
7913 && gfc_current_block ()->abr_modproc_decl
;
7919 *st
= ST_END_PROGRAM
;
7920 target
= " program";
7924 case COMP_SUBROUTINE
:
7925 *st
= ST_END_SUBROUTINE
;
7926 if (!abreviated_modproc_decl
)
7927 target
= " subroutine";
7929 target
= " procedure";
7930 eos_ok
= !contained_procedure ();
7934 *st
= ST_END_FUNCTION
;
7935 if (!abreviated_modproc_decl
)
7936 target
= " function";
7938 target
= " procedure";
7939 eos_ok
= !contained_procedure ();
7942 case COMP_BLOCK_DATA
:
7943 *st
= ST_END_BLOCK_DATA
;
7944 target
= " block data";
7949 *st
= ST_END_MODULE
;
7954 case COMP_SUBMODULE
:
7955 *st
= ST_END_SUBMODULE
;
7956 target
= " submodule";
7960 case COMP_INTERFACE
:
7961 *st
= ST_END_INTERFACE
;
7962 target
= " interface";
7978 case COMP_STRUCTURE
:
7979 *st
= ST_END_STRUCTURE
;
7980 target
= " structure";
7985 case COMP_DERIVED_CONTAINS
:
7991 case COMP_ASSOCIATE
:
7992 *st
= ST_END_ASSOCIATE
;
7993 target
= " associate";
8010 case COMP_DO_CONCURRENT
:
8017 *st
= ST_END_CRITICAL
;
8018 target
= " critical";
8023 case COMP_SELECT_TYPE
:
8024 *st
= ST_END_SELECT
;
8030 *st
= ST_END_FORALL
;
8045 last_initializer
= NULL
;
8047 gfc_free_enum_history ();
8051 gfc_error ("Unexpected END statement at %C");
8055 old_loc
= gfc_current_locus
;
8056 if (gfc_match_eos () == MATCH_YES
)
8058 if (!eos_ok
&& (*st
== ST_END_SUBROUTINE
|| *st
== ST_END_FUNCTION
))
8060 if (!gfc_notify_std (GFC_STD_F2008
, "END statement "
8061 "instead of %s statement at %L",
8062 abreviated_modproc_decl
? "END PROCEDURE"
8063 : gfc_ascii_statement(*st
), &old_loc
))
8068 /* We would have required END [something]. */
8069 gfc_error ("%s statement expected at %L",
8070 gfc_ascii_statement (*st
), &old_loc
);
8077 /* Verify that we've got the sort of end-block that we're expecting. */
8078 if (gfc_match (target
) != MATCH_YES
)
8080 gfc_error ("Expecting %s statement at %L", abreviated_modproc_decl
8081 ? "END PROCEDURE" : gfc_ascii_statement(*st
), &old_loc
);
8085 got_matching_end
= true;
8087 old_loc
= gfc_current_locus
;
8088 /* If we're at the end, make sure a block name wasn't required. */
8089 if (gfc_match_eos () == MATCH_YES
)
8092 if (*st
!= ST_ENDDO
&& *st
!= ST_ENDIF
&& *st
!= ST_END_SELECT
8093 && *st
!= ST_END_FORALL
&& *st
!= ST_END_WHERE
&& *st
!= ST_END_BLOCK
8094 && *st
!= ST_END_ASSOCIATE
&& *st
!= ST_END_CRITICAL
)
8100 gfc_error ("Expected block name of %qs in %s statement at %L",
8101 block_name
, gfc_ascii_statement (*st
), &old_loc
);
8106 /* END INTERFACE has a special handler for its several possible endings. */
8107 if (*st
== ST_END_INTERFACE
)
8108 return gfc_match_end_interface ();
8110 /* We haven't hit the end of statement, so what is left must be an
8112 m
= gfc_match_space ();
8114 m
= gfc_match_name (name
);
8117 gfc_error ("Expected terminating name at %C");
8121 if (block_name
== NULL
)
8124 /* We have to pick out the declared submodule name from the composite
8125 required by F2008:11.2.3 para 2, which ends in the declared name. */
8126 if (state
== COMP_SUBMODULE
)
8127 block_name
= strchr (block_name
, '.') + 1;
8129 if (strcmp (name
, block_name
) != 0 && strcmp (block_name
, "ppr@") != 0)
8131 gfc_error ("Expected label %qs for %s statement at %C", block_name
,
8132 gfc_ascii_statement (*st
));
8135 /* Procedure pointer as function result. */
8136 else if (strcmp (block_name
, "ppr@") == 0
8137 && strcmp (name
, gfc_current_block ()->ns
->proc_name
->name
) != 0)
8139 gfc_error ("Expected label %qs for %s statement at %C",
8140 gfc_current_block ()->ns
->proc_name
->name
,
8141 gfc_ascii_statement (*st
));
8145 if (gfc_match_eos () == MATCH_YES
)
8149 gfc_syntax_error (*st
);
8152 gfc_current_locus
= old_loc
;
8154 /* If we are missing an END BLOCK, we created a half-ready namespace.
8155 Remove it from the parent namespace's sibling list. */
8157 while (state
== COMP_BLOCK
&& !got_matching_end
)
8159 parent_ns
= gfc_current_ns
->parent
;
8161 nsp
= &(gfc_state_stack
->previous
->tail
->ext
.block
.ns
);
8167 if (ns
== gfc_current_ns
)
8169 if (prev_ns
== NULL
)
8172 prev_ns
->sibling
= ns
->sibling
;
8178 gfc_free_namespace (gfc_current_ns
);
8179 gfc_current_ns
= parent_ns
;
8180 gfc_state_stack
= gfc_state_stack
->previous
;
8181 state
= gfc_current_state ();
8189 /***************** Attribute declaration statements ****************/
8191 /* Set the attribute of a single variable. */
8196 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8199 /* Workaround -Wmaybe-uninitialized false positive during
8200 profiledbootstrap by initializing them. */
8201 gfc_symbol
*sym
= NULL
;
8207 m
= gfc_match_name (name
);
8211 if (find_special (name
, &sym
, false))
8214 if (!check_function_name (name
))
8220 var_locus
= gfc_current_locus
;
8222 /* Deal with possible array specification for certain attributes. */
8223 if (current_attr
.dimension
8224 || current_attr
.codimension
8225 || current_attr
.allocatable
8226 || current_attr
.pointer
8227 || current_attr
.target
)
8229 m
= gfc_match_array_spec (&as
, !current_attr
.codimension
,
8230 !current_attr
.dimension
8231 && !current_attr
.pointer
8232 && !current_attr
.target
);
8233 if (m
== MATCH_ERROR
)
8236 if (current_attr
.dimension
&& m
== MATCH_NO
)
8238 gfc_error ("Missing array specification at %L in DIMENSION "
8239 "statement", &var_locus
);
8244 if (current_attr
.dimension
&& sym
->value
)
8246 gfc_error ("Dimensions specified for %s at %L after its "
8247 "initialization", sym
->name
, &var_locus
);
8252 if (current_attr
.codimension
&& m
== MATCH_NO
)
8254 gfc_error ("Missing array specification at %L in CODIMENSION "
8255 "statement", &var_locus
);
8260 if ((current_attr
.allocatable
|| current_attr
.pointer
)
8261 && (m
== MATCH_YES
) && (as
->type
!= AS_DEFERRED
))
8263 gfc_error ("Array specification must be deferred at %L", &var_locus
);
8269 /* Update symbol table. DIMENSION attribute is set in
8270 gfc_set_array_spec(). For CLASS variables, this must be applied
8271 to the first component, or '_data' field. */
8272 if (sym
->ts
.type
== BT_CLASS
&& sym
->ts
.u
.derived
->attr
.is_class
)
8274 if (!gfc_copy_attr (&CLASS_DATA(sym
)->attr
, ¤t_attr
, &var_locus
))
8282 if (current_attr
.dimension
== 0 && current_attr
.codimension
== 0
8283 && !gfc_copy_attr (&sym
->attr
, ¤t_attr
, &var_locus
))
8290 if (sym
->ts
.type
== BT_CLASS
8291 && !gfc_build_class_symbol (&sym
->ts
, &sym
->attr
, &sym
->as
))
8297 if (!gfc_set_array_spec (sym
, as
, &var_locus
))
8303 if (sym
->attr
.cray_pointee
&& sym
->as
!= NULL
)
8305 /* Fix the array spec. */
8306 m
= gfc_mod_pointee_as (sym
->as
);
8307 if (m
== MATCH_ERROR
)
8311 if (!gfc_add_attribute (&sym
->attr
, &var_locus
))
8317 if ((current_attr
.external
|| current_attr
.intrinsic
)
8318 && sym
->attr
.flavor
!= FL_PROCEDURE
8319 && !gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, NULL
))
8325 add_hidden_procptr_result (sym
);
8330 gfc_free_array_spec (as
);
8335 /* Generic attribute declaration subroutine. Used for attributes that
8336 just have a list of names. */
8343 /* Gobble the optional double colon, by simply ignoring the result
8353 if (gfc_match_eos () == MATCH_YES
)
8359 if (gfc_match_char (',') != MATCH_YES
)
8361 gfc_error ("Unexpected character in variable list at %C");
8371 /* This routine matches Cray Pointer declarations of the form:
8372 pointer ( <pointer>, <pointee> )
8374 pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...
8375 The pointer, if already declared, should be an integer. Otherwise, we
8376 set it as BT_INTEGER with kind gfc_index_integer_kind. The pointee may
8377 be either a scalar, or an array declaration. No space is allocated for
8378 the pointee. For the statement
8379 pointer (ipt, ar(10))
8380 any subsequent uses of ar will be translated (in C-notation) as
8381 ar(i) => ((<type> *) ipt)(i)
8382 After gimplification, pointee variable will disappear in the code. */
8385 cray_pointer_decl (void)
8388 gfc_array_spec
*as
= NULL
;
8389 gfc_symbol
*cptr
; /* Pointer symbol. */
8390 gfc_symbol
*cpte
; /* Pointee symbol. */
8396 if (gfc_match_char ('(') != MATCH_YES
)
8398 gfc_error ("Expected %<(%> at %C");
8402 /* Match pointer. */
8403 var_locus
= gfc_current_locus
;
8404 gfc_clear_attr (¤t_attr
);
8405 gfc_add_cray_pointer (¤t_attr
, &var_locus
);
8406 current_ts
.type
= BT_INTEGER
;
8407 current_ts
.kind
= gfc_index_integer_kind
;
8409 m
= gfc_match_symbol (&cptr
, 0);
8412 gfc_error ("Expected variable name at %C");
8416 if (!gfc_add_cray_pointer (&cptr
->attr
, &var_locus
))
8419 gfc_set_sym_referenced (cptr
);
8421 if (cptr
->ts
.type
== BT_UNKNOWN
) /* Override the type, if necessary. */
8423 cptr
->ts
.type
= BT_INTEGER
;
8424 cptr
->ts
.kind
= gfc_index_integer_kind
;
8426 else if (cptr
->ts
.type
!= BT_INTEGER
)
8428 gfc_error ("Cray pointer at %C must be an integer");
8431 else if (cptr
->ts
.kind
< gfc_index_integer_kind
)
8432 gfc_warning (0, "Cray pointer at %C has %d bytes of precision;"
8433 " memory addresses require %d bytes",
8434 cptr
->ts
.kind
, gfc_index_integer_kind
);
8436 if (gfc_match_char (',') != MATCH_YES
)
8438 gfc_error ("Expected \",\" at %C");
8442 /* Match Pointee. */
8443 var_locus
= gfc_current_locus
;
8444 gfc_clear_attr (¤t_attr
);
8445 gfc_add_cray_pointee (¤t_attr
, &var_locus
);
8446 current_ts
.type
= BT_UNKNOWN
;
8447 current_ts
.kind
= 0;
8449 m
= gfc_match_symbol (&cpte
, 0);
8452 gfc_error ("Expected variable name at %C");
8456 /* Check for an optional array spec. */
8457 m
= gfc_match_array_spec (&as
, true, false);
8458 if (m
== MATCH_ERROR
)
8460 gfc_free_array_spec (as
);
8463 else if (m
== MATCH_NO
)
8465 gfc_free_array_spec (as
);
8469 if (!gfc_add_cray_pointee (&cpte
->attr
, &var_locus
))
8472 gfc_set_sym_referenced (cpte
);
8474 if (cpte
->as
== NULL
)
8476 if (!gfc_set_array_spec (cpte
, as
, &var_locus
))
8477 gfc_internal_error ("Couldn't set Cray pointee array spec.");
8479 else if (as
!= NULL
)
8481 gfc_error ("Duplicate array spec for Cray pointee at %C");
8482 gfc_free_array_spec (as
);
8488 if (cpte
->as
!= NULL
)
8490 /* Fix array spec. */
8491 m
= gfc_mod_pointee_as (cpte
->as
);
8492 if (m
== MATCH_ERROR
)
8496 /* Point the Pointee at the Pointer. */
8497 cpte
->cp_pointer
= cptr
;
8499 if (gfc_match_char (')') != MATCH_YES
)
8501 gfc_error ("Expected \")\" at %C");
8504 m
= gfc_match_char (',');
8506 done
= true; /* Stop searching for more declarations. */
8510 if (m
== MATCH_ERROR
/* Failed when trying to find ',' above. */
8511 || gfc_match_eos () != MATCH_YES
)
8513 gfc_error ("Expected %<,%> or end of statement at %C");
8521 gfc_match_external (void)
8524 gfc_clear_attr (¤t_attr
);
8525 current_attr
.external
= 1;
8527 return attr_decl ();
8532 gfc_match_intent (void)
8536 /* This is not allowed within a BLOCK construct! */
8537 if (gfc_current_state () == COMP_BLOCK
)
8539 gfc_error ("INTENT is not allowed inside of BLOCK at %C");
8543 intent
= match_intent_spec ();
8544 if (intent
== INTENT_UNKNOWN
)
8547 gfc_clear_attr (¤t_attr
);
8548 current_attr
.intent
= intent
;
8550 return attr_decl ();
8555 gfc_match_intrinsic (void)
8558 gfc_clear_attr (¤t_attr
);
8559 current_attr
.intrinsic
= 1;
8561 return attr_decl ();
8566 gfc_match_optional (void)
8568 /* This is not allowed within a BLOCK construct! */
8569 if (gfc_current_state () == COMP_BLOCK
)
8571 gfc_error ("OPTIONAL is not allowed inside of BLOCK at %C");
8575 gfc_clear_attr (¤t_attr
);
8576 current_attr
.optional
= 1;
8578 return attr_decl ();
8583 gfc_match_pointer (void)
8585 gfc_gobble_whitespace ();
8586 if (gfc_peek_ascii_char () == '(')
8588 if (!flag_cray_pointer
)
8590 gfc_error ("Cray pointer declaration at %C requires -fcray-pointer "
8594 return cray_pointer_decl ();
8598 gfc_clear_attr (¤t_attr
);
8599 current_attr
.pointer
= 1;
8601 return attr_decl ();
8607 gfc_match_allocatable (void)
8609 gfc_clear_attr (¤t_attr
);
8610 current_attr
.allocatable
= 1;
8612 return attr_decl ();
8617 gfc_match_codimension (void)
8619 gfc_clear_attr (¤t_attr
);
8620 current_attr
.codimension
= 1;
8622 return attr_decl ();
8627 gfc_match_contiguous (void)
8629 if (!gfc_notify_std (GFC_STD_F2008
, "CONTIGUOUS statement at %C"))
8632 gfc_clear_attr (¤t_attr
);
8633 current_attr
.contiguous
= 1;
8635 return attr_decl ();
8640 gfc_match_dimension (void)
8642 gfc_clear_attr (¤t_attr
);
8643 current_attr
.dimension
= 1;
8645 return attr_decl ();
8650 gfc_match_target (void)
8652 gfc_clear_attr (¤t_attr
);
8653 current_attr
.target
= 1;
8655 return attr_decl ();
8659 /* Match the list of entities being specified in a PUBLIC or PRIVATE
8663 access_attr_decl (gfc_statement st
)
8665 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8666 interface_type type
;
8668 gfc_symbol
*sym
, *dt_sym
;
8669 gfc_intrinsic_op op
;
8672 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
8677 m
= gfc_match_generic_spec (&type
, name
, &op
);
8680 if (m
== MATCH_ERROR
)
8685 case INTERFACE_NAMELESS
:
8686 case INTERFACE_ABSTRACT
:
8689 case INTERFACE_GENERIC
:
8690 case INTERFACE_DTIO
:
8692 if (gfc_get_symbol (name
, NULL
, &sym
))
8695 if (type
== INTERFACE_DTIO
8696 && gfc_current_ns
->proc_name
8697 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
8698 && sym
->attr
.flavor
== FL_UNKNOWN
)
8699 sym
->attr
.flavor
= FL_PROCEDURE
;
8701 if (!gfc_add_access (&sym
->attr
,
8703 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
,
8707 if (sym
->attr
.generic
&& (dt_sym
= gfc_find_dt_in_generic (sym
))
8708 && !gfc_add_access (&dt_sym
->attr
,
8710 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
,
8716 case INTERFACE_INTRINSIC_OP
:
8717 if (gfc_current_ns
->operator_access
[op
] == ACCESS_UNKNOWN
)
8719 gfc_intrinsic_op other_op
;
8721 gfc_current_ns
->operator_access
[op
] =
8722 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
8724 /* Handle the case if there is another op with the same
8725 function, for INTRINSIC_EQ vs. INTRINSIC_EQ_OS and so on. */
8726 other_op
= gfc_equivalent_op (op
);
8728 if (other_op
!= INTRINSIC_NONE
)
8729 gfc_current_ns
->operator_access
[other_op
] =
8730 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
8735 gfc_error ("Access specification of the %s operator at %C has "
8736 "already been specified", gfc_op2string (op
));
8742 case INTERFACE_USER_OP
:
8743 uop
= gfc_get_uop (name
);
8745 if (uop
->access
== ACCESS_UNKNOWN
)
8747 uop
->access
= (st
== ST_PUBLIC
)
8748 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
8752 gfc_error ("Access specification of the .%s. operator at %C "
8753 "has already been specified", sym
->name
);
8760 if (gfc_match_char (',') == MATCH_NO
)
8764 if (gfc_match_eos () != MATCH_YES
)
8769 gfc_syntax_error (st
);
8777 gfc_match_protected (void)
8782 if (!gfc_current_ns
->proc_name
8783 || gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
8785 gfc_error ("PROTECTED at %C only allowed in specification "
8786 "part of a module");
8791 if (!gfc_notify_std (GFC_STD_F2003
, "PROTECTED statement at %C"))
8794 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
8799 if (gfc_match_eos () == MATCH_YES
)
8804 m
= gfc_match_symbol (&sym
, 0);
8808 if (!gfc_add_protected (&sym
->attr
, sym
->name
, &gfc_current_locus
))
8820 if (gfc_match_eos () == MATCH_YES
)
8822 if (gfc_match_char (',') != MATCH_YES
)
8829 gfc_error ("Syntax error in PROTECTED statement at %C");
8834 /* The PRIVATE statement is a bit weird in that it can be an attribute
8835 declaration, but also works as a standalone statement inside of a
8836 type declaration or a module. */
8839 gfc_match_private (gfc_statement
*st
)
8842 if (gfc_match ("private") != MATCH_YES
)
8845 if (gfc_current_state () != COMP_MODULE
8846 && !(gfc_current_state () == COMP_DERIVED
8847 && gfc_state_stack
->previous
8848 && gfc_state_stack
->previous
->state
== COMP_MODULE
)
8849 && !(gfc_current_state () == COMP_DERIVED_CONTAINS
8850 && gfc_state_stack
->previous
&& gfc_state_stack
->previous
->previous
8851 && gfc_state_stack
->previous
->previous
->state
== COMP_MODULE
))
8853 gfc_error ("PRIVATE statement at %C is only allowed in the "
8854 "specification part of a module");
8858 if (gfc_current_state () == COMP_DERIVED
)
8860 if (gfc_match_eos () == MATCH_YES
)
8866 gfc_syntax_error (ST_PRIVATE
);
8870 if (gfc_match_eos () == MATCH_YES
)
8877 return access_attr_decl (ST_PRIVATE
);
8882 gfc_match_public (gfc_statement
*st
)
8885 if (gfc_match ("public") != MATCH_YES
)
8888 if (gfc_current_state () != COMP_MODULE
)
8890 gfc_error ("PUBLIC statement at %C is only allowed in the "
8891 "specification part of a module");
8895 if (gfc_match_eos () == MATCH_YES
)
8902 return access_attr_decl (ST_PUBLIC
);
8906 /* Workhorse for gfc_match_parameter. */
8916 m
= gfc_match_symbol (&sym
, 0);
8918 gfc_error ("Expected variable name at %C in PARAMETER statement");
8923 if (gfc_match_char ('=') == MATCH_NO
)
8925 gfc_error ("Expected = sign in PARAMETER statement at %C");
8929 m
= gfc_match_init_expr (&init
);
8931 gfc_error ("Expected expression at %C in PARAMETER statement");
8935 if (sym
->ts
.type
== BT_UNKNOWN
8936 && !gfc_set_default_type (sym
, 1, NULL
))
8942 if (!gfc_check_assign_symbol (sym
, NULL
, init
)
8943 || !gfc_add_flavor (&sym
->attr
, FL_PARAMETER
, sym
->name
, NULL
))
8951 gfc_error ("Initializing already initialized variable at %C");
8956 t
= add_init_expr_to_sym (sym
->name
, &init
, &gfc_current_locus
);
8957 return (t
) ? MATCH_YES
: MATCH_ERROR
;
8960 gfc_free_expr (init
);
8965 /* Match a parameter statement, with the weird syntax that these have. */
8968 gfc_match_parameter (void)
8970 const char *term
= " )%t";
8973 if (gfc_match_char ('(') == MATCH_NO
)
8975 /* With legacy PARAMETER statements, don't expect a terminating ')'. */
8976 if (!gfc_notify_std (GFC_STD_LEGACY
, "PARAMETER without '()' at %C"))
8987 if (gfc_match (term
) == MATCH_YES
)
8990 if (gfc_match_char (',') != MATCH_YES
)
8992 gfc_error ("Unexpected characters in PARAMETER statement at %C");
9003 gfc_match_automatic (void)
9007 bool seen_symbol
= false;
9009 if (!flag_dec_static
)
9011 gfc_error ("%s at %C is a DEC extension, enable with "
9022 m
= gfc_match_symbol (&sym
, 0);
9032 if (!gfc_add_automatic (&sym
->attr
, sym
->name
, &gfc_current_locus
))
9038 if (gfc_match_eos () == MATCH_YES
)
9040 if (gfc_match_char (',') != MATCH_YES
)
9046 gfc_error ("Expected entity-list in AUTOMATIC statement at %C");
9053 gfc_error ("Syntax error in AUTOMATIC statement at %C");
9059 gfc_match_static (void)
9063 bool seen_symbol
= false;
9065 if (!flag_dec_static
)
9067 gfc_error ("%s at %C is a DEC extension, enable with "
9077 m
= gfc_match_symbol (&sym
, 0);
9087 if (!gfc_add_save (&sym
->attr
, SAVE_EXPLICIT
, sym
->name
,
9088 &gfc_current_locus
))
9094 if (gfc_match_eos () == MATCH_YES
)
9096 if (gfc_match_char (',') != MATCH_YES
)
9102 gfc_error ("Expected entity-list in STATIC statement at %C");
9109 gfc_error ("Syntax error in STATIC statement at %C");
9114 /* Save statements have a special syntax. */
9117 gfc_match_save (void)
9119 char n
[GFC_MAX_SYMBOL_LEN
+1];
9124 if (gfc_match_eos () == MATCH_YES
)
9126 if (gfc_current_ns
->seen_save
)
9128 if (!gfc_notify_std (GFC_STD_LEGACY
, "Blanket SAVE statement at %C "
9129 "follows previous SAVE statement"))
9133 gfc_current_ns
->save_all
= gfc_current_ns
->seen_save
= 1;
9137 if (gfc_current_ns
->save_all
)
9139 if (!gfc_notify_std (GFC_STD_LEGACY
, "SAVE statement at %C follows "
9140 "blanket SAVE statement"))
9148 m
= gfc_match_symbol (&sym
, 0);
9152 if (!gfc_add_save (&sym
->attr
, SAVE_EXPLICIT
, sym
->name
,
9153 &gfc_current_locus
))
9164 m
= gfc_match (" / %n /", &n
);
9165 if (m
== MATCH_ERROR
)
9170 c
= gfc_get_common (n
, 0);
9173 gfc_current_ns
->seen_save
= 1;
9176 if (gfc_match_eos () == MATCH_YES
)
9178 if (gfc_match_char (',') != MATCH_YES
)
9185 gfc_error ("Syntax error in SAVE statement at %C");
9191 gfc_match_value (void)
9196 /* This is not allowed within a BLOCK construct! */
9197 if (gfc_current_state () == COMP_BLOCK
)
9199 gfc_error ("VALUE is not allowed inside of BLOCK at %C");
9203 if (!gfc_notify_std (GFC_STD_F2003
, "VALUE statement at %C"))
9206 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
9211 if (gfc_match_eos () == MATCH_YES
)
9216 m
= gfc_match_symbol (&sym
, 0);
9220 if (!gfc_add_value (&sym
->attr
, sym
->name
, &gfc_current_locus
))
9232 if (gfc_match_eos () == MATCH_YES
)
9234 if (gfc_match_char (',') != MATCH_YES
)
9241 gfc_error ("Syntax error in VALUE statement at %C");
9247 gfc_match_volatile (void)
9253 if (!gfc_notify_std (GFC_STD_F2003
, "VOLATILE statement at %C"))
9256 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
9261 if (gfc_match_eos () == MATCH_YES
)
9266 /* VOLATILE is special because it can be added to host-associated
9267 symbols locally. Except for coarrays. */
9268 m
= gfc_match_symbol (&sym
, 1);
9272 name
= XCNEWVAR (char, strlen (sym
->name
) + 1);
9273 strcpy (name
, sym
->name
);
9274 if (!check_function_name (name
))
9276 /* F2008, C560+C561. VOLATILE for host-/use-associated variable or
9277 for variable in a BLOCK which is defined outside of the BLOCK. */
9278 if (sym
->ns
!= gfc_current_ns
&& sym
->attr
.codimension
)
9280 gfc_error ("Specifying VOLATILE for coarray variable %qs at "
9281 "%C, which is use-/host-associated", sym
->name
);
9284 if (!gfc_add_volatile (&sym
->attr
, sym
->name
, &gfc_current_locus
))
9296 if (gfc_match_eos () == MATCH_YES
)
9298 if (gfc_match_char (',') != MATCH_YES
)
9305 gfc_error ("Syntax error in VOLATILE statement at %C");
9311 gfc_match_asynchronous (void)
9317 if (!gfc_notify_std (GFC_STD_F2003
, "ASYNCHRONOUS statement at %C"))
9320 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
9325 if (gfc_match_eos () == MATCH_YES
)
9330 /* ASYNCHRONOUS is special because it can be added to host-associated
9332 m
= gfc_match_symbol (&sym
, 1);
9336 name
= XCNEWVAR (char, strlen (sym
->name
) + 1);
9337 strcpy (name
, sym
->name
);
9338 if (!check_function_name (name
))
9340 if (!gfc_add_asynchronous (&sym
->attr
, sym
->name
, &gfc_current_locus
))
9352 if (gfc_match_eos () == MATCH_YES
)
9354 if (gfc_match_char (',') != MATCH_YES
)
9361 gfc_error ("Syntax error in ASYNCHRONOUS statement at %C");
9366 /* Match a module procedure statement in a submodule. */
9369 gfc_match_submod_proc (void)
9371 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9372 gfc_symbol
*sym
, *fsym
;
9374 gfc_formal_arglist
*formal
, *head
, *tail
;
9376 if (gfc_current_state () != COMP_CONTAINS
9377 || !(gfc_state_stack
->previous
9378 && (gfc_state_stack
->previous
->state
== COMP_SUBMODULE
9379 || gfc_state_stack
->previous
->state
== COMP_MODULE
)))
9382 m
= gfc_match (" module% procedure% %n", name
);
9386 if (!gfc_notify_std (GFC_STD_F2008
, "MODULE PROCEDURE declaration "
9390 if (get_proc_name (name
, &sym
, false))
9393 /* Make sure that the result field is appropriately filled, even though
9394 the result symbol will be replaced later on. */
9395 if (sym
->tlink
&& sym
->tlink
->attr
.function
)
9397 if (sym
->tlink
->result
9398 && sym
->tlink
->result
!= sym
->tlink
)
9399 sym
->result
= sym
->tlink
->result
;
9404 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
9405 the symbol existed before. */
9406 sym
->declared_at
= gfc_current_locus
;
9408 if (!sym
->attr
.module_procedure
)
9411 /* Signal match_end to expect "end procedure". */
9412 sym
->abr_modproc_decl
= 1;
9414 /* Change from IFSRC_IFBODY coming from the interface declaration. */
9415 sym
->attr
.if_source
= IFSRC_DECL
;
9417 gfc_new_block
= sym
;
9419 /* Make a new formal arglist with the symbols in the procedure
9422 for (formal
= sym
->formal
; formal
&& formal
->sym
; formal
= formal
->next
)
9424 if (formal
== sym
->formal
)
9425 head
= tail
= gfc_get_formal_arglist ();
9428 tail
->next
= gfc_get_formal_arglist ();
9432 if (gfc_copy_dummy_sym (&fsym
, formal
->sym
, 0))
9436 gfc_set_sym_referenced (fsym
);
9439 /* The dummy symbols get cleaned up, when the formal_namespace of the
9440 interface declaration is cleared. This allows us to add the
9441 explicit interface as is done for other type of procedure. */
9442 if (!gfc_add_explicit_interface (sym
, IFSRC_DECL
, head
,
9443 &gfc_current_locus
))
9446 if (gfc_match_eos () != MATCH_YES
)
9448 gfc_syntax_error (ST_MODULE_PROC
);
9455 gfc_free_formal_arglist (head
);
9460 /* Match a module procedure statement. Note that we have to modify
9461 symbols in the parent's namespace because the current one was there
9462 to receive symbols that are in an interface's formal argument list. */
9465 gfc_match_modproc (void)
9467 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9471 gfc_namespace
*module_ns
;
9472 gfc_interface
*old_interface_head
, *interface
;
9474 if (gfc_state_stack
->state
!= COMP_INTERFACE
9475 || gfc_state_stack
->previous
== NULL
9476 || current_interface
.type
== INTERFACE_NAMELESS
9477 || current_interface
.type
== INTERFACE_ABSTRACT
)
9479 gfc_error ("MODULE PROCEDURE at %C must be in a generic module "
9484 module_ns
= gfc_current_ns
->parent
;
9485 for (; module_ns
; module_ns
= module_ns
->parent
)
9486 if (module_ns
->proc_name
->attr
.flavor
== FL_MODULE
9487 || module_ns
->proc_name
->attr
.flavor
== FL_PROGRAM
9488 || (module_ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
9489 && !module_ns
->proc_name
->attr
.contained
))
9492 if (module_ns
== NULL
)
9495 /* Store the current state of the interface. We will need it if we
9496 end up with a syntax error and need to recover. */
9497 old_interface_head
= gfc_current_interface_head ();
9499 /* Check if the F2008 optional double colon appears. */
9500 gfc_gobble_whitespace ();
9501 old_locus
= gfc_current_locus
;
9502 if (gfc_match ("::") == MATCH_YES
)
9504 if (!gfc_notify_std (GFC_STD_F2008
, "double colon in "
9505 "MODULE PROCEDURE statement at %L", &old_locus
))
9509 gfc_current_locus
= old_locus
;
9514 old_locus
= gfc_current_locus
;
9516 m
= gfc_match_name (name
);
9522 /* Check for syntax error before starting to add symbols to the
9523 current namespace. */
9524 if (gfc_match_eos () == MATCH_YES
)
9527 if (!last
&& gfc_match_char (',') != MATCH_YES
)
9530 /* Now we're sure the syntax is valid, we process this item
9532 if (gfc_get_symbol (name
, module_ns
, &sym
))
9535 if (sym
->attr
.intrinsic
)
9537 gfc_error ("Intrinsic procedure at %L cannot be a MODULE "
9538 "PROCEDURE", &old_locus
);
9542 if (sym
->attr
.proc
!= PROC_MODULE
9543 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
9546 if (!gfc_add_interface (sym
))
9549 sym
->attr
.mod_proc
= 1;
9550 sym
->declared_at
= old_locus
;
9559 /* Restore the previous state of the interface. */
9560 interface
= gfc_current_interface_head ();
9561 gfc_set_current_interface_head (old_interface_head
);
9563 /* Free the new interfaces. */
9564 while (interface
!= old_interface_head
)
9566 gfc_interface
*i
= interface
->next
;
9571 /* And issue a syntax error. */
9572 gfc_syntax_error (ST_MODULE_PROC
);
9577 /* Check a derived type that is being extended. */
9580 check_extended_derived_type (char *name
)
9582 gfc_symbol
*extended
;
9584 if (gfc_find_symbol (name
, gfc_current_ns
, 1, &extended
))
9586 gfc_error ("Ambiguous symbol in TYPE definition at %C");
9590 extended
= gfc_find_dt_in_generic (extended
);
9595 gfc_error ("Symbol %qs at %C has not been previously defined", name
);
9599 if (extended
->attr
.flavor
!= FL_DERIVED
)
9601 gfc_error ("%qs in EXTENDS expression at %C is not a "
9602 "derived type", name
);
9606 if (extended
->attr
.is_bind_c
)
9608 gfc_error ("%qs cannot be extended at %C because it "
9609 "is BIND(C)", extended
->name
);
9613 if (extended
->attr
.sequence
)
9615 gfc_error ("%qs cannot be extended at %C because it "
9616 "is a SEQUENCE type", extended
->name
);
9624 /* Match the optional attribute specifiers for a type declaration.
9625 Return MATCH_ERROR if an error is encountered in one of the handled
9626 attributes (public, private, bind(c)), MATCH_NO if what's found is
9627 not a handled attribute, and MATCH_YES otherwise. TODO: More error
9628 checking on attribute conflicts needs to be done. */
9631 gfc_get_type_attr_spec (symbol_attribute
*attr
, char *name
)
9633 /* See if the derived type is marked as private. */
9634 if (gfc_match (" , private") == MATCH_YES
)
9636 if (gfc_current_state () != COMP_MODULE
)
9638 gfc_error ("Derived type at %C can only be PRIVATE in the "
9639 "specification part of a module");
9643 if (!gfc_add_access (attr
, ACCESS_PRIVATE
, NULL
, NULL
))
9646 else if (gfc_match (" , public") == MATCH_YES
)
9648 if (gfc_current_state () != COMP_MODULE
)
9650 gfc_error ("Derived type at %C can only be PUBLIC in the "
9651 "specification part of a module");
9655 if (!gfc_add_access (attr
, ACCESS_PUBLIC
, NULL
, NULL
))
9658 else if (gfc_match (" , bind ( c )") == MATCH_YES
)
9660 /* If the type is defined to be bind(c) it then needs to make
9661 sure that all fields are interoperable. This will
9662 need to be a semantic check on the finished derived type.
9663 See 15.2.3 (lines 9-12) of F2003 draft. */
9664 if (!gfc_add_is_bind_c (attr
, NULL
, &gfc_current_locus
, 0))
9667 /* TODO: attr conflicts need to be checked, probably in symbol.c. */
9669 else if (gfc_match (" , abstract") == MATCH_YES
)
9671 if (!gfc_notify_std (GFC_STD_F2003
, "ABSTRACT type at %C"))
9674 if (!gfc_add_abstract (attr
, &gfc_current_locus
))
9677 else if (name
&& gfc_match (" , extends ( %n )", name
) == MATCH_YES
)
9679 if (!gfc_add_extension (attr
, &gfc_current_locus
))
9685 /* If we get here, something matched. */
9690 /* Common function for type declaration blocks similar to derived types, such
9691 as STRUCTURES and MAPs. Unlike derived types, a structure type
9692 does NOT have a generic symbol matching the name given by the user.
9693 STRUCTUREs can share names with variables and PARAMETERs so we must allow
9694 for the creation of an independent symbol.
9695 Other parameters are a message to prefix errors with, the name of the new
9696 type to be created, and the flavor to add to the resulting symbol. */
9699 get_struct_decl (const char *name
, sym_flavor fl
, locus
*decl
,
9700 gfc_symbol
**result
)
9705 gcc_assert (name
[0] == (char) TOUPPER (name
[0]));
9710 where
= gfc_current_locus
;
9712 if (gfc_get_symbol (name
, NULL
, &sym
))
9717 gfc_internal_error ("Failed to create structure type '%s' at %C", name
);
9721 if (sym
->components
!= NULL
|| sym
->attr
.zero_comp
)
9723 gfc_error ("Type definition of %qs at %C was already defined at %L",
9724 sym
->name
, &sym
->declared_at
);
9728 sym
->declared_at
= where
;
9730 if (sym
->attr
.flavor
!= fl
9731 && !gfc_add_flavor (&sym
->attr
, fl
, sym
->name
, NULL
))
9734 if (!sym
->hash_value
)
9735 /* Set the hash for the compound name for this type. */
9736 sym
->hash_value
= gfc_hash_value (sym
);
9738 /* Normally the type is expected to have been completely parsed by the time
9739 a field declaration with this type is seen. For unions, maps, and nested
9740 structure declarations, we need to indicate that it is okay that we
9741 haven't seen any components yet. This will be updated after the structure
9743 sym
->attr
.zero_comp
= 0;
9745 /* Structures always act like derived-types with the SEQUENCE attribute */
9746 gfc_add_sequence (&sym
->attr
, sym
->name
, NULL
);
9748 if (result
) *result
= sym
;
9754 /* Match the opening of a MAP block. Like a struct within a union in C;
9755 behaves identical to STRUCTURE blocks. */
9758 gfc_match_map (void)
9760 /* Counter used to give unique internal names to map structures. */
9761 static unsigned int gfc_map_id
= 0;
9762 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9766 old_loc
= gfc_current_locus
;
9768 if (gfc_match_eos () != MATCH_YES
)
9770 gfc_error ("Junk after MAP statement at %C");
9771 gfc_current_locus
= old_loc
;
9775 /* Map blocks are anonymous so we make up unique names for the symbol table
9776 which are invalid Fortran identifiers. */
9777 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "MM$%u", gfc_map_id
++);
9779 if (!get_struct_decl (name
, FL_STRUCT
, &old_loc
, &sym
))
9782 gfc_new_block
= sym
;
9788 /* Match the opening of a UNION block. */
9791 gfc_match_union (void)
9793 /* Counter used to give unique internal names to union types. */
9794 static unsigned int gfc_union_id
= 0;
9795 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9799 old_loc
= gfc_current_locus
;
9801 if (gfc_match_eos () != MATCH_YES
)
9803 gfc_error ("Junk after UNION statement at %C");
9804 gfc_current_locus
= old_loc
;
9808 /* Unions are anonymous so we make up unique names for the symbol table
9809 which are invalid Fortran identifiers. */
9810 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "UU$%u", gfc_union_id
++);
9812 if (!get_struct_decl (name
, FL_UNION
, &old_loc
, &sym
))
9815 gfc_new_block
= sym
;
9821 /* Match the beginning of a STRUCTURE declaration. This is similar to
9822 matching the beginning of a derived type declaration with a few
9823 twists. The resulting type symbol has no access control or other
9824 interesting attributes. */
9827 gfc_match_structure_decl (void)
9829 /* Counter used to give unique internal names to anonymous structures. */
9830 static unsigned int gfc_structure_id
= 0;
9831 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9836 if (!flag_dec_structure
)
9838 gfc_error ("%s at %C is a DEC extension, enable with "
9839 "%<-fdec-structure%>",
9846 m
= gfc_match (" /%n/", name
);
9849 /* Non-nested structure declarations require a structure name. */
9850 if (!gfc_comp_struct (gfc_current_state ()))
9852 gfc_error ("Structure name expected in non-nested structure "
9853 "declaration at %C");
9856 /* This is an anonymous structure; make up a unique name for it
9857 (upper-case letters never make it to symbol names from the source).
9858 The important thing is initializing the type variable
9859 and setting gfc_new_symbol, which is immediately used by
9860 parse_structure () and variable_decl () to add components of
9862 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "SS$%u", gfc_structure_id
++);
9865 where
= gfc_current_locus
;
9866 /* No field list allowed after non-nested structure declaration. */
9867 if (!gfc_comp_struct (gfc_current_state ())
9868 && gfc_match_eos () != MATCH_YES
)
9870 gfc_error ("Junk after non-nested STRUCTURE statement at %C");
9874 /* Make sure the name is not the name of an intrinsic type. */
9875 if (gfc_is_intrinsic_typename (name
))
9877 gfc_error ("Structure name %qs at %C cannot be the same as an"
9878 " intrinsic type", name
);
9882 /* Store the actual type symbol for the structure with an upper-case first
9883 letter (an invalid Fortran identifier). */
9885 if (!get_struct_decl (gfc_dt_upper_string (name
), FL_STRUCT
, &where
, &sym
))
9888 gfc_new_block
= sym
;
9893 /* This function does some work to determine which matcher should be used to
9894 * match a statement beginning with "TYPE". This is used to disambiguate TYPE
9895 * as an alias for PRINT from derived type declarations, TYPE IS statements,
9896 * and [parameterized] derived type declarations. */
9899 gfc_match_type (gfc_statement
*st
)
9901 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9905 /* Requires -fdec. */
9909 m
= gfc_match ("type");
9912 /* If we already have an error in the buffer, it is probably from failing to
9913 * match a derived type data declaration. Let it happen. */
9914 else if (gfc_error_flag_test ())
9917 old_loc
= gfc_current_locus
;
9920 /* If we see an attribute list before anything else it's definitely a derived
9921 * type declaration. */
9922 if (gfc_match (" ,") == MATCH_YES
|| gfc_match (" ::") == MATCH_YES
)
9925 /* By now "TYPE" has already been matched. If we do not see a name, this may
9926 * be something like "TYPE *" or "TYPE <fmt>". */
9927 m
= gfc_match_name (name
);
9930 /* Let print match if it can, otherwise throw an error from
9931 * gfc_match_derived_decl. */
9932 gfc_current_locus
= old_loc
;
9933 if (gfc_match_print () == MATCH_YES
)
9941 /* Check for EOS. */
9942 if (gfc_match_eos () == MATCH_YES
)
9944 /* By now we have "TYPE <name> <EOS>". Check first if the name is an
9945 * intrinsic typename - if so let gfc_match_derived_decl dump an error.
9946 * Otherwise if gfc_match_derived_decl fails it's probably an existing
9947 * symbol which can be printed. */
9948 gfc_current_locus
= old_loc
;
9949 m
= gfc_match_derived_decl ();
9950 if (gfc_is_intrinsic_typename (name
) || m
== MATCH_YES
)
9952 *st
= ST_DERIVED_DECL
;
9958 /* Here we have "TYPE <name>". Check for <TYPE IS (> or a PDT declaration
9959 like <type name(parameter)>. */
9960 gfc_gobble_whitespace ();
9961 bool paren
= gfc_peek_ascii_char () == '(';
9964 if (strcmp ("is", name
) == 0)
9971 /* Treat TYPE... like PRINT... */
9972 gfc_current_locus
= old_loc
;
9974 return gfc_match_print ();
9977 gfc_current_locus
= old_loc
;
9978 *st
= ST_DERIVED_DECL
;
9979 return gfc_match_derived_decl ();
9982 gfc_current_locus
= old_loc
;
9984 return gfc_match_type_is ();
9988 /* Match the beginning of a derived type declaration. If a type name
9989 was the result of a function, then it is possible to have a symbol
9990 already to be known as a derived type yet have no components. */
9993 gfc_match_derived_decl (void)
9995 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9996 char parent
[GFC_MAX_SYMBOL_LEN
+ 1];
9997 symbol_attribute attr
;
9998 gfc_symbol
*sym
, *gensym
;
9999 gfc_symbol
*extended
;
10001 match is_type_attr_spec
= MATCH_NO
;
10002 bool seen_attr
= false;
10003 gfc_interface
*intr
= NULL
, *head
;
10004 bool parameterized_type
= false;
10005 bool seen_colons
= false;
10007 if (gfc_comp_struct (gfc_current_state ()))
10012 gfc_clear_attr (&attr
);
10017 is_type_attr_spec
= gfc_get_type_attr_spec (&attr
, parent
);
10018 if (is_type_attr_spec
== MATCH_ERROR
)
10019 return MATCH_ERROR
;
10020 if (is_type_attr_spec
== MATCH_YES
)
10022 } while (is_type_attr_spec
== MATCH_YES
);
10024 /* Deal with derived type extensions. The extension attribute has
10025 been added to 'attr' but now the parent type must be found and
10028 extended
= check_extended_derived_type (parent
);
10030 if (parent
[0] && !extended
)
10031 return MATCH_ERROR
;
10033 m
= gfc_match (" ::");
10034 if (m
== MATCH_YES
)
10036 seen_colons
= true;
10038 else if (seen_attr
)
10040 gfc_error ("Expected :: in TYPE definition at %C");
10041 return MATCH_ERROR
;
10044 m
= gfc_match (" %n ", name
);
10045 if (m
!= MATCH_YES
)
10048 /* Make sure that we don't identify TYPE IS (...) as a parameterized
10049 derived type named 'is'.
10050 TODO Expand the check, when 'name' = "is" by matching " (tname) "
10051 and checking if this is a(n intrinsic) typename. his picks up
10052 misplaced TYPE IS statements such as in select_type_1.f03. */
10053 if (gfc_peek_ascii_char () == '(')
10055 if (gfc_current_state () == COMP_SELECT_TYPE
10056 || (!seen_colons
&& !strcmp (name
, "is")))
10058 parameterized_type
= true;
10061 m
= gfc_match_eos ();
10062 if (m
!= MATCH_YES
&& !parameterized_type
)
10065 /* Make sure the name is not the name of an intrinsic type. */
10066 if (gfc_is_intrinsic_typename (name
))
10068 gfc_error ("Type name %qs at %C cannot be the same as an intrinsic "
10070 return MATCH_ERROR
;
10073 if (gfc_get_symbol (name
, NULL
, &gensym
))
10074 return MATCH_ERROR
;
10076 if (!gensym
->attr
.generic
&& gensym
->ts
.type
!= BT_UNKNOWN
)
10078 if (gensym
->ts
.u
.derived
)
10079 gfc_error ("Derived type name %qs at %C already has a basic type "
10080 "of %s", gensym
->name
, gfc_typename (&gensym
->ts
));
10082 gfc_error ("Derived type name %qs at %C already has a basic type",
10084 return MATCH_ERROR
;
10087 if (!gensym
->attr
.generic
10088 && !gfc_add_generic (&gensym
->attr
, gensym
->name
, NULL
))
10089 return MATCH_ERROR
;
10091 if (!gensym
->attr
.function
10092 && !gfc_add_function (&gensym
->attr
, gensym
->name
, NULL
))
10093 return MATCH_ERROR
;
10095 sym
= gfc_find_dt_in_generic (gensym
);
10097 if (sym
&& (sym
->components
!= NULL
|| sym
->attr
.zero_comp
))
10099 gfc_error ("Derived type definition of %qs at %C has already been "
10100 "defined", sym
->name
);
10101 return MATCH_ERROR
;
10106 /* Use upper case to save the actual derived-type symbol. */
10107 gfc_get_symbol (gfc_dt_upper_string (gensym
->name
), NULL
, &sym
);
10108 sym
->name
= gfc_get_string ("%s", gensym
->name
);
10109 head
= gensym
->generic
;
10110 intr
= gfc_get_interface ();
10112 intr
->where
= gfc_current_locus
;
10113 intr
->sym
->declared_at
= gfc_current_locus
;
10115 gensym
->generic
= intr
;
10116 gensym
->attr
.if_source
= IFSRC_DECL
;
10119 /* The symbol may already have the derived attribute without the
10120 components. The ways this can happen is via a function
10121 definition, an INTRINSIC statement or a subtype in another
10122 derived type that is a pointer. The first part of the AND clause
10123 is true if the symbol is not the return value of a function. */
10124 if (sym
->attr
.flavor
!= FL_DERIVED
10125 && !gfc_add_flavor (&sym
->attr
, FL_DERIVED
, sym
->name
, NULL
))
10126 return MATCH_ERROR
;
10128 if (attr
.access
!= ACCESS_UNKNOWN
10129 && !gfc_add_access (&sym
->attr
, attr
.access
, sym
->name
, NULL
))
10130 return MATCH_ERROR
;
10131 else if (sym
->attr
.access
== ACCESS_UNKNOWN
10132 && gensym
->attr
.access
!= ACCESS_UNKNOWN
10133 && !gfc_add_access (&sym
->attr
, gensym
->attr
.access
,
10135 return MATCH_ERROR
;
10137 if (sym
->attr
.access
!= ACCESS_UNKNOWN
10138 && gensym
->attr
.access
== ACCESS_UNKNOWN
)
10139 gensym
->attr
.access
= sym
->attr
.access
;
10141 /* See if the derived type was labeled as bind(c). */
10142 if (attr
.is_bind_c
!= 0)
10143 sym
->attr
.is_bind_c
= attr
.is_bind_c
;
10145 /* Construct the f2k_derived namespace if it is not yet there. */
10146 if (!sym
->f2k_derived
)
10147 sym
->f2k_derived
= gfc_get_namespace (NULL
, 0);
10149 if (parameterized_type
)
10151 /* Ignore error or mismatches by going to the end of the statement
10152 in order to avoid the component declarations causing problems. */
10153 m
= gfc_match_formal_arglist (sym
, 0, 0, true);
10154 if (m
!= MATCH_YES
)
10155 gfc_error_recovery ();
10156 m
= gfc_match_eos ();
10157 if (m
!= MATCH_YES
)
10159 gfc_error_recovery ();
10160 gfc_error_now ("Garbage after PARAMETERIZED TYPE declaration at %C");
10162 sym
->attr
.pdt_template
= 1;
10165 if (extended
&& !sym
->components
)
10168 gfc_formal_arglist
*f
, *g
, *h
;
10170 /* Add the extended derived type as the first component. */
10171 gfc_add_component (sym
, parent
, &p
);
10173 gfc_set_sym_referenced (extended
);
10175 p
->ts
.type
= BT_DERIVED
;
10176 p
->ts
.u
.derived
= extended
;
10177 p
->initializer
= gfc_default_initializer (&p
->ts
);
10179 /* Set extension level. */
10180 if (extended
->attr
.extension
== 255)
10182 /* Since the extension field is 8 bit wide, we can only have
10183 up to 255 extension levels. */
10184 gfc_error ("Maximum extension level reached with type %qs at %L",
10185 extended
->name
, &extended
->declared_at
);
10186 return MATCH_ERROR
;
10188 sym
->attr
.extension
= extended
->attr
.extension
+ 1;
10190 /* Provide the links between the extended type and its extension. */
10191 if (!extended
->f2k_derived
)
10192 extended
->f2k_derived
= gfc_get_namespace (NULL
, 0);
10194 /* Copy the extended type-param-name-list from the extended type,
10195 append those of the extension and add the whole lot to the
10197 if (extended
->attr
.pdt_template
)
10200 sym
->attr
.pdt_template
= 1;
10201 for (f
= extended
->formal
; f
; f
= f
->next
)
10203 if (f
== extended
->formal
)
10205 g
= gfc_get_formal_arglist ();
10210 g
->next
= gfc_get_formal_arglist ();
10215 g
->next
= sym
->formal
;
10220 if (!sym
->hash_value
)
10221 /* Set the hash for the compound name for this type. */
10222 sym
->hash_value
= gfc_hash_value (sym
);
10224 /* Take over the ABSTRACT attribute. */
10225 sym
->attr
.abstract
= attr
.abstract
;
10227 gfc_new_block
= sym
;
10233 /* Cray Pointees can be declared as:
10234 pointer (ipt, a (n,m,...,*)) */
10237 gfc_mod_pointee_as (gfc_array_spec
*as
)
10239 as
->cray_pointee
= true; /* This will be useful to know later. */
10240 if (as
->type
== AS_ASSUMED_SIZE
)
10241 as
->cp_was_assumed
= true;
10242 else if (as
->type
== AS_ASSUMED_SHAPE
)
10244 gfc_error ("Cray Pointee at %C cannot be assumed shape array");
10245 return MATCH_ERROR
;
10251 /* Match the enum definition statement, here we are trying to match
10252 the first line of enum definition statement.
10253 Returns MATCH_YES if match is found. */
10256 gfc_match_enum (void)
10260 m
= gfc_match_eos ();
10261 if (m
!= MATCH_YES
)
10264 if (!gfc_notify_std (GFC_STD_F2003
, "ENUM and ENUMERATOR at %C"))
10265 return MATCH_ERROR
;
10271 /* Returns an initializer whose value is one higher than the value of the
10272 LAST_INITIALIZER argument. If the argument is NULL, the
10273 initializers value will be set to zero. The initializer's kind
10274 will be set to gfc_c_int_kind.
10276 If -fshort-enums is given, the appropriate kind will be selected
10277 later after all enumerators have been parsed. A warning is issued
10278 here if an initializer exceeds gfc_c_int_kind. */
10281 enum_initializer (gfc_expr
*last_initializer
, locus where
)
10284 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_c_int_kind
, &where
);
10286 mpz_init (result
->value
.integer
);
10288 if (last_initializer
!= NULL
)
10290 mpz_add_ui (result
->value
.integer
, last_initializer
->value
.integer
, 1);
10291 result
->where
= last_initializer
->where
;
10293 if (gfc_check_integer_range (result
->value
.integer
,
10294 gfc_c_int_kind
) != ARITH_OK
)
10296 gfc_error ("Enumerator exceeds the C integer type at %C");
10302 /* Control comes here, if it's the very first enumerator and no
10303 initializer has been given. It will be initialized to zero. */
10304 mpz_set_si (result
->value
.integer
, 0);
10311 /* Match a variable name with an optional initializer. When this
10312 subroutine is called, a variable is expected to be parsed next.
10313 Depending on what is happening at the moment, updates either the
10314 symbol table or the current interface. */
10317 enumerator_decl (void)
10319 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10320 gfc_expr
*initializer
;
10321 gfc_array_spec
*as
= NULL
;
10328 initializer
= NULL
;
10329 old_locus
= gfc_current_locus
;
10331 /* When we get here, we've just matched a list of attributes and
10332 maybe a type and a double colon. The next thing we expect to see
10333 is the name of the symbol. */
10334 m
= gfc_match_name (name
);
10335 if (m
!= MATCH_YES
)
10338 var_locus
= gfc_current_locus
;
10340 /* OK, we've successfully matched the declaration. Now put the
10341 symbol in the current namespace. If we fail to create the symbol,
10343 if (!build_sym (name
, NULL
, false, &as
, &var_locus
))
10349 /* The double colon must be present in order to have initializers.
10350 Otherwise the statement is ambiguous with an assignment statement. */
10353 if (gfc_match_char ('=') == MATCH_YES
)
10355 m
= gfc_match_init_expr (&initializer
);
10358 gfc_error ("Expected an initialization expression at %C");
10362 if (m
!= MATCH_YES
)
10367 /* If we do not have an initializer, the initialization value of the
10368 previous enumerator (stored in last_initializer) is incremented
10369 by 1 and is used to initialize the current enumerator. */
10370 if (initializer
== NULL
)
10371 initializer
= enum_initializer (last_initializer
, old_locus
);
10373 if (initializer
== NULL
|| initializer
->ts
.type
!= BT_INTEGER
)
10375 gfc_error ("ENUMERATOR %L not initialized with integer expression",
10381 /* Store this current initializer, for the next enumerator variable
10382 to be parsed. add_init_expr_to_sym() zeros initializer, so we
10383 use last_initializer below. */
10384 last_initializer
= initializer
;
10385 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
10387 /* Maintain enumerator history. */
10388 gfc_find_symbol (name
, NULL
, 0, &sym
);
10389 create_enum_history (sym
, last_initializer
);
10391 return (t
) ? MATCH_YES
: MATCH_ERROR
;
10394 /* Free stuff up and return. */
10395 gfc_free_expr (initializer
);
10401 /* Match the enumerator definition statement. */
10404 gfc_match_enumerator_def (void)
10409 gfc_clear_ts (¤t_ts
);
10411 m
= gfc_match (" enumerator");
10412 if (m
!= MATCH_YES
)
10415 m
= gfc_match (" :: ");
10416 if (m
== MATCH_ERROR
)
10419 colon_seen
= (m
== MATCH_YES
);
10421 if (gfc_current_state () != COMP_ENUM
)
10423 gfc_error ("ENUM definition statement expected before %C");
10424 gfc_free_enum_history ();
10425 return MATCH_ERROR
;
10428 (¤t_ts
)->type
= BT_INTEGER
;
10429 (¤t_ts
)->kind
= gfc_c_int_kind
;
10431 gfc_clear_attr (¤t_attr
);
10432 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, NULL
);
10441 m
= enumerator_decl ();
10442 if (m
== MATCH_ERROR
)
10444 gfc_free_enum_history ();
10450 if (gfc_match_eos () == MATCH_YES
)
10452 if (gfc_match_char (',') != MATCH_YES
)
10456 if (gfc_current_state () == COMP_ENUM
)
10458 gfc_free_enum_history ();
10459 gfc_error ("Syntax error in ENUMERATOR definition at %C");
10464 gfc_free_array_spec (current_as
);
10471 /* Match binding attributes. */
10474 match_binding_attributes (gfc_typebound_proc
* ba
, bool generic
, bool ppc
)
10476 bool found_passing
= false;
10477 bool seen_ptr
= false;
10478 match m
= MATCH_YES
;
10480 /* Initialize to defaults. Do so even before the MATCH_NO check so that in
10481 this case the defaults are in there. */
10482 ba
->access
= ACCESS_UNKNOWN
;
10483 ba
->pass_arg
= NULL
;
10484 ba
->pass_arg_num
= 0;
10486 ba
->non_overridable
= 0;
10490 /* If we find a comma, we believe there are binding attributes. */
10491 m
= gfc_match_char (',');
10497 /* Access specifier. */
10499 m
= gfc_match (" public");
10500 if (m
== MATCH_ERROR
)
10502 if (m
== MATCH_YES
)
10504 if (ba
->access
!= ACCESS_UNKNOWN
)
10506 gfc_error ("Duplicate access-specifier at %C");
10510 ba
->access
= ACCESS_PUBLIC
;
10514 m
= gfc_match (" private");
10515 if (m
== MATCH_ERROR
)
10517 if (m
== MATCH_YES
)
10519 if (ba
->access
!= ACCESS_UNKNOWN
)
10521 gfc_error ("Duplicate access-specifier at %C");
10525 ba
->access
= ACCESS_PRIVATE
;
10529 /* If inside GENERIC, the following is not allowed. */
10534 m
= gfc_match (" nopass");
10535 if (m
== MATCH_ERROR
)
10537 if (m
== MATCH_YES
)
10541 gfc_error ("Binding attributes already specify passing,"
10542 " illegal NOPASS at %C");
10546 found_passing
= true;
10551 /* PASS possibly including argument. */
10552 m
= gfc_match (" pass");
10553 if (m
== MATCH_ERROR
)
10555 if (m
== MATCH_YES
)
10557 char arg
[GFC_MAX_SYMBOL_LEN
+ 1];
10561 gfc_error ("Binding attributes already specify passing,"
10562 " illegal PASS at %C");
10566 m
= gfc_match (" ( %n )", arg
);
10567 if (m
== MATCH_ERROR
)
10569 if (m
== MATCH_YES
)
10570 ba
->pass_arg
= gfc_get_string ("%s", arg
);
10571 gcc_assert ((m
== MATCH_YES
) == (ba
->pass_arg
!= NULL
));
10573 found_passing
= true;
10580 /* POINTER flag. */
10581 m
= gfc_match (" pointer");
10582 if (m
== MATCH_ERROR
)
10584 if (m
== MATCH_YES
)
10588 gfc_error ("Duplicate POINTER attribute at %C");
10598 /* NON_OVERRIDABLE flag. */
10599 m
= gfc_match (" non_overridable");
10600 if (m
== MATCH_ERROR
)
10602 if (m
== MATCH_YES
)
10604 if (ba
->non_overridable
)
10606 gfc_error ("Duplicate NON_OVERRIDABLE at %C");
10610 ba
->non_overridable
= 1;
10614 /* DEFERRED flag. */
10615 m
= gfc_match (" deferred");
10616 if (m
== MATCH_ERROR
)
10618 if (m
== MATCH_YES
)
10622 gfc_error ("Duplicate DEFERRED at %C");
10633 /* Nothing matching found. */
10635 gfc_error ("Expected access-specifier at %C");
10637 gfc_error ("Expected binding attribute at %C");
10640 while (gfc_match_char (',') == MATCH_YES
);
10642 /* NON_OVERRIDABLE and DEFERRED exclude themselves. */
10643 if (ba
->non_overridable
&& ba
->deferred
)
10645 gfc_error ("NON_OVERRIDABLE and DEFERRED can't both appear at %C");
10652 if (ba
->access
== ACCESS_UNKNOWN
)
10653 ba
->access
= ppc
? gfc_current_block()->component_access
10654 : gfc_typebound_default_access
;
10656 if (ppc
&& !seen_ptr
)
10658 gfc_error ("POINTER attribute is required for procedure pointer component"
10666 return MATCH_ERROR
;
10670 /* Match a PROCEDURE specific binding inside a derived type. */
10673 match_procedure_in_type (void)
10675 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10676 char target_buf
[GFC_MAX_SYMBOL_LEN
+ 1];
10677 char* target
= NULL
, *ifc
= NULL
;
10678 gfc_typebound_proc tb
;
10682 gfc_symtree
* stree
;
10687 /* Check current state. */
10688 gcc_assert (gfc_state_stack
->state
== COMP_DERIVED_CONTAINS
);
10689 block
= gfc_state_stack
->previous
->sym
;
10690 gcc_assert (block
);
10692 /* Try to match PROCEDURE(interface). */
10693 if (gfc_match (" (") == MATCH_YES
)
10695 m
= gfc_match_name (target_buf
);
10696 if (m
== MATCH_ERROR
)
10698 if (m
!= MATCH_YES
)
10700 gfc_error ("Interface-name expected after %<(%> at %C");
10701 return MATCH_ERROR
;
10704 if (gfc_match (" )") != MATCH_YES
)
10706 gfc_error ("%<)%> expected at %C");
10707 return MATCH_ERROR
;
10713 /* Construct the data structure. */
10714 memset (&tb
, 0, sizeof (tb
));
10715 tb
.where
= gfc_current_locus
;
10717 /* Match binding attributes. */
10718 m
= match_binding_attributes (&tb
, false, false);
10719 if (m
== MATCH_ERROR
)
10721 seen_attrs
= (m
== MATCH_YES
);
10723 /* Check that attribute DEFERRED is given if an interface is specified. */
10724 if (tb
.deferred
&& !ifc
)
10726 gfc_error ("Interface must be specified for DEFERRED binding at %C");
10727 return MATCH_ERROR
;
10729 if (ifc
&& !tb
.deferred
)
10731 gfc_error ("PROCEDURE(interface) at %C should be declared DEFERRED");
10732 return MATCH_ERROR
;
10735 /* Match the colons. */
10736 m
= gfc_match (" ::");
10737 if (m
== MATCH_ERROR
)
10739 seen_colons
= (m
== MATCH_YES
);
10740 if (seen_attrs
&& !seen_colons
)
10742 gfc_error ("Expected %<::%> after binding-attributes at %C");
10743 return MATCH_ERROR
;
10746 /* Match the binding names. */
10749 m
= gfc_match_name (name
);
10750 if (m
== MATCH_ERROR
)
10754 gfc_error ("Expected binding name at %C");
10755 return MATCH_ERROR
;
10758 if (num
>1 && !gfc_notify_std (GFC_STD_F2008
, "PROCEDURE list at %C"))
10759 return MATCH_ERROR
;
10761 /* Try to match the '=> target', if it's there. */
10763 m
= gfc_match (" =>");
10764 if (m
== MATCH_ERROR
)
10766 if (m
== MATCH_YES
)
10770 gfc_error ("%<=> target%> is invalid for DEFERRED binding at %C");
10771 return MATCH_ERROR
;
10776 gfc_error ("%<::%> needed in PROCEDURE binding with explicit target"
10778 return MATCH_ERROR
;
10781 m
= gfc_match_name (target_buf
);
10782 if (m
== MATCH_ERROR
)
10786 gfc_error ("Expected binding target after %<=>%> at %C");
10787 return MATCH_ERROR
;
10789 target
= target_buf
;
10792 /* If no target was found, it has the same name as the binding. */
10796 /* Get the namespace to insert the symbols into. */
10797 ns
= block
->f2k_derived
;
10800 /* If the binding is DEFERRED, check that the containing type is ABSTRACT. */
10801 if (tb
.deferred
&& !block
->attr
.abstract
)
10803 gfc_error ("Type %qs containing DEFERRED binding at %C "
10804 "is not ABSTRACT", block
->name
);
10805 return MATCH_ERROR
;
10808 /* See if we already have a binding with this name in the symtree which
10809 would be an error. If a GENERIC already targeted this binding, it may
10810 be already there but then typebound is still NULL. */
10811 stree
= gfc_find_symtree (ns
->tb_sym_root
, name
);
10812 if (stree
&& stree
->n
.tb
)
10814 gfc_error ("There is already a procedure with binding name %qs for "
10815 "the derived type %qs at %C", name
, block
->name
);
10816 return MATCH_ERROR
;
10819 /* Insert it and set attributes. */
10823 stree
= gfc_new_symtree (&ns
->tb_sym_root
, name
);
10824 gcc_assert (stree
);
10826 stree
->n
.tb
= gfc_get_typebound_proc (&tb
);
10828 if (gfc_get_sym_tree (target
, gfc_current_ns
, &stree
->n
.tb
->u
.specific
,
10830 return MATCH_ERROR
;
10831 gfc_set_sym_referenced (stree
->n
.tb
->u
.specific
->n
.sym
);
10832 gfc_add_flavor(&stree
->n
.tb
->u
.specific
->n
.sym
->attr
, FL_PROCEDURE
,
10833 target
, &stree
->n
.tb
->u
.specific
->n
.sym
->declared_at
);
10835 if (gfc_match_eos () == MATCH_YES
)
10837 if (gfc_match_char (',') != MATCH_YES
)
10842 gfc_error ("Syntax error in PROCEDURE statement at %C");
10843 return MATCH_ERROR
;
10847 /* Match a GENERIC procedure binding inside a derived type. */
10850 gfc_match_generic (void)
10852 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10853 char bind_name
[GFC_MAX_SYMBOL_LEN
+ 16]; /* Allow space for OPERATOR(...). */
10855 gfc_typebound_proc tbattr
; /* Used for match_binding_attributes. */
10856 gfc_typebound_proc
* tb
;
10858 interface_type op_type
;
10859 gfc_intrinsic_op op
;
10862 /* Check current state. */
10863 if (gfc_current_state () == COMP_DERIVED
)
10865 gfc_error ("GENERIC at %C must be inside a derived-type CONTAINS");
10866 return MATCH_ERROR
;
10868 if (gfc_current_state () != COMP_DERIVED_CONTAINS
)
10870 block
= gfc_state_stack
->previous
->sym
;
10871 ns
= block
->f2k_derived
;
10872 gcc_assert (block
&& ns
);
10874 memset (&tbattr
, 0, sizeof (tbattr
));
10875 tbattr
.where
= gfc_current_locus
;
10877 /* See if we get an access-specifier. */
10878 m
= match_binding_attributes (&tbattr
, true, false);
10879 if (m
== MATCH_ERROR
)
10882 /* Now the colons, those are required. */
10883 if (gfc_match (" ::") != MATCH_YES
)
10885 gfc_error ("Expected %<::%> at %C");
10889 /* Match the binding name; depending on type (operator / generic) format
10890 it for future error messages into bind_name. */
10892 m
= gfc_match_generic_spec (&op_type
, name
, &op
);
10893 if (m
== MATCH_ERROR
)
10894 return MATCH_ERROR
;
10897 gfc_error ("Expected generic name or operator descriptor at %C");
10903 case INTERFACE_GENERIC
:
10904 case INTERFACE_DTIO
:
10905 snprintf (bind_name
, sizeof (bind_name
), "%s", name
);
10908 case INTERFACE_USER_OP
:
10909 snprintf (bind_name
, sizeof (bind_name
), "OPERATOR(.%s.)", name
);
10912 case INTERFACE_INTRINSIC_OP
:
10913 snprintf (bind_name
, sizeof (bind_name
), "OPERATOR(%s)",
10914 gfc_op2string (op
));
10917 case INTERFACE_NAMELESS
:
10918 gfc_error ("Malformed GENERIC statement at %C");
10923 gcc_unreachable ();
10926 /* Match the required =>. */
10927 if (gfc_match (" =>") != MATCH_YES
)
10929 gfc_error ("Expected %<=>%> at %C");
10933 /* Try to find existing GENERIC binding with this name / for this operator;
10934 if there is something, check that it is another GENERIC and then extend
10935 it rather than building a new node. Otherwise, create it and put it
10936 at the right position. */
10940 case INTERFACE_DTIO
:
10941 case INTERFACE_USER_OP
:
10942 case INTERFACE_GENERIC
:
10944 const bool is_op
= (op_type
== INTERFACE_USER_OP
);
10947 st
= gfc_find_symtree (is_op
? ns
->tb_uop_root
: ns
->tb_sym_root
, name
);
10948 tb
= st
? st
->n
.tb
: NULL
;
10952 case INTERFACE_INTRINSIC_OP
:
10953 tb
= ns
->tb_op
[op
];
10957 gcc_unreachable ();
10962 if (!tb
->is_generic
)
10964 gcc_assert (op_type
== INTERFACE_GENERIC
);
10965 gfc_error ("There's already a non-generic procedure with binding name"
10966 " %qs for the derived type %qs at %C",
10967 bind_name
, block
->name
);
10971 if (tb
->access
!= tbattr
.access
)
10973 gfc_error ("Binding at %C must have the same access as already"
10974 " defined binding %qs", bind_name
);
10980 tb
= gfc_get_typebound_proc (NULL
);
10981 tb
->where
= gfc_current_locus
;
10982 tb
->access
= tbattr
.access
;
10983 tb
->is_generic
= 1;
10984 tb
->u
.generic
= NULL
;
10988 case INTERFACE_DTIO
:
10989 case INTERFACE_GENERIC
:
10990 case INTERFACE_USER_OP
:
10992 const bool is_op
= (op_type
== INTERFACE_USER_OP
);
10993 gfc_symtree
* st
= gfc_get_tbp_symtree (is_op
? &ns
->tb_uop_root
:
10994 &ns
->tb_sym_root
, name
);
11001 case INTERFACE_INTRINSIC_OP
:
11002 ns
->tb_op
[op
] = tb
;
11006 gcc_unreachable ();
11010 /* Now, match all following names as specific targets. */
11013 gfc_symtree
* target_st
;
11014 gfc_tbp_generic
* target
;
11016 m
= gfc_match_name (name
);
11017 if (m
== MATCH_ERROR
)
11021 gfc_error ("Expected specific binding name at %C");
11025 target_st
= gfc_get_tbp_symtree (&ns
->tb_sym_root
, name
);
11027 /* See if this is a duplicate specification. */
11028 for (target
= tb
->u
.generic
; target
; target
= target
->next
)
11029 if (target_st
== target
->specific_st
)
11031 gfc_error ("%qs already defined as specific binding for the"
11032 " generic %qs at %C", name
, bind_name
);
11036 target
= gfc_get_tbp_generic ();
11037 target
->specific_st
= target_st
;
11038 target
->specific
= NULL
;
11039 target
->next
= tb
->u
.generic
;
11040 target
->is_operator
= ((op_type
== INTERFACE_USER_OP
)
11041 || (op_type
== INTERFACE_INTRINSIC_OP
));
11042 tb
->u
.generic
= target
;
11044 while (gfc_match (" ,") == MATCH_YES
);
11046 /* Here should be the end. */
11047 if (gfc_match_eos () != MATCH_YES
)
11049 gfc_error ("Junk after GENERIC binding at %C");
11056 return MATCH_ERROR
;
11060 /* Match a FINAL declaration inside a derived type. */
11063 gfc_match_final_decl (void)
11065 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
11068 gfc_namespace
* module_ns
;
11072 if (gfc_current_form
== FORM_FREE
)
11074 char c
= gfc_peek_ascii_char ();
11075 if (!gfc_is_whitespace (c
) && c
!= ':')
11079 if (gfc_state_stack
->state
!= COMP_DERIVED_CONTAINS
)
11081 if (gfc_current_form
== FORM_FIXED
)
11084 gfc_error ("FINAL declaration at %C must be inside a derived type "
11085 "CONTAINS section");
11086 return MATCH_ERROR
;
11089 block
= gfc_state_stack
->previous
->sym
;
11090 gcc_assert (block
);
11092 if (!gfc_state_stack
->previous
|| !gfc_state_stack
->previous
->previous
11093 || gfc_state_stack
->previous
->previous
->state
!= COMP_MODULE
)
11095 gfc_error ("Derived type declaration with FINAL at %C must be in the"
11096 " specification part of a MODULE");
11097 return MATCH_ERROR
;
11100 module_ns
= gfc_current_ns
;
11101 gcc_assert (module_ns
);
11102 gcc_assert (module_ns
->proc_name
->attr
.flavor
== FL_MODULE
);
11104 /* Match optional ::, don't care about MATCH_YES or MATCH_NO. */
11105 if (gfc_match (" ::") == MATCH_ERROR
)
11106 return MATCH_ERROR
;
11108 /* Match the sequence of procedure names. */
11115 if (first
&& gfc_match_eos () == MATCH_YES
)
11117 gfc_error ("Empty FINAL at %C");
11118 return MATCH_ERROR
;
11121 m
= gfc_match_name (name
);
11124 gfc_error ("Expected module procedure name at %C");
11125 return MATCH_ERROR
;
11127 else if (m
!= MATCH_YES
)
11128 return MATCH_ERROR
;
11130 if (gfc_match_eos () == MATCH_YES
)
11132 if (!last
&& gfc_match_char (',') != MATCH_YES
)
11134 gfc_error ("Expected %<,%> at %C");
11135 return MATCH_ERROR
;
11138 if (gfc_get_symbol (name
, module_ns
, &sym
))
11140 gfc_error ("Unknown procedure name %qs at %C", name
);
11141 return MATCH_ERROR
;
11144 /* Mark the symbol as module procedure. */
11145 if (sym
->attr
.proc
!= PROC_MODULE
11146 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
11147 return MATCH_ERROR
;
11149 /* Check if we already have this symbol in the list, this is an error. */
11150 for (f
= block
->f2k_derived
->finalizers
; f
; f
= f
->next
)
11151 if (f
->proc_sym
== sym
)
11153 gfc_error ("%qs at %C is already defined as FINAL procedure",
11155 return MATCH_ERROR
;
11158 /* Add this symbol to the list of finalizers. */
11159 gcc_assert (block
->f2k_derived
);
11161 f
= XCNEW (gfc_finalizer
);
11163 f
->proc_tree
= NULL
;
11164 f
->where
= gfc_current_locus
;
11165 f
->next
= block
->f2k_derived
->finalizers
;
11166 block
->f2k_derived
->finalizers
= f
;
11176 const ext_attr_t ext_attr_list
[] = {
11177 { "dllimport", EXT_ATTR_DLLIMPORT
, "dllimport" },
11178 { "dllexport", EXT_ATTR_DLLEXPORT
, "dllexport" },
11179 { "cdecl", EXT_ATTR_CDECL
, "cdecl" },
11180 { "stdcall", EXT_ATTR_STDCALL
, "stdcall" },
11181 { "fastcall", EXT_ATTR_FASTCALL
, "fastcall" },
11182 { "no_arg_check", EXT_ATTR_NO_ARG_CHECK
, NULL
},
11183 { NULL
, EXT_ATTR_LAST
, NULL
}
11186 /* Match a !GCC$ ATTRIBUTES statement of the form:
11187 !GCC$ ATTRIBUTES attribute-list :: var-name [, var-name] ...
11188 When we come here, we have already matched the !GCC$ ATTRIBUTES string.
11190 TODO: We should support all GCC attributes using the same syntax for
11191 the attribute list, i.e. the list in C
11192 __attributes(( attribute-list ))
11194 !GCC$ ATTRIBUTES attribute-list ::
11195 Cf. c-parser.c's c_parser_attributes; the data can then directly be
11198 As there is absolutely no risk of confusion, we should never return
11201 gfc_match_gcc_attributes (void)
11203 symbol_attribute attr
;
11204 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
11209 gfc_clear_attr (&attr
);
11214 if (gfc_match_name (name
) != MATCH_YES
)
11215 return MATCH_ERROR
;
11217 for (id
= 0; id
< EXT_ATTR_LAST
; id
++)
11218 if (strcmp (name
, ext_attr_list
[id
].name
) == 0)
11221 if (id
== EXT_ATTR_LAST
)
11223 gfc_error ("Unknown attribute in !GCC$ ATTRIBUTES statement at %C");
11224 return MATCH_ERROR
;
11227 if (!gfc_add_ext_attribute (&attr
, (ext_attr_id_t
)id
, &gfc_current_locus
))
11228 return MATCH_ERROR
;
11230 gfc_gobble_whitespace ();
11231 ch
= gfc_next_ascii_char ();
11234 /* This is the successful exit condition for the loop. */
11235 if (gfc_next_ascii_char () == ':')
11245 if (gfc_match_eos () == MATCH_YES
)
11250 m
= gfc_match_name (name
);
11251 if (m
!= MATCH_YES
)
11254 if (find_special (name
, &sym
, true))
11255 return MATCH_ERROR
;
11257 sym
->attr
.ext_attr
|= attr
.ext_attr
;
11259 if (gfc_match_eos () == MATCH_YES
)
11262 if (gfc_match_char (',') != MATCH_YES
)
11269 gfc_error ("Syntax error in !GCC$ ATTRIBUTES statement at %C");
11270 return MATCH_ERROR
;
11274 /* Match a !GCC$ UNROLL statement of the form:
11277 The parameter n is the number of times we are supposed to unroll.
11279 When we come here, we have already matched the !GCC$ UNROLL string. */
11281 gfc_match_gcc_unroll (void)
11285 if (gfc_match_small_int (&value
) == MATCH_YES
)
11287 if (value
< 0 || value
> USHRT_MAX
)
11289 gfc_error ("%<GCC unroll%> directive requires a"
11290 " non-negative integral constant"
11291 " less than or equal to %u at %C",
11294 return MATCH_ERROR
;
11296 if (gfc_match_eos () == MATCH_YES
)
11298 directive_unroll
= value
== 0 ? 1 : value
;
11303 gfc_error ("Syntax error in !GCC$ UNROLL directive at %C");
11304 return MATCH_ERROR
;
11307 /* Match a !GCC$ builtin (b) attributes simd flags form:
11309 The parameter b is name of a middle-end built-in.
11315 When we come here, we have already matched the !GCC$ builtin string. */
11317 gfc_match_gcc_builtin (void)
11319 char builtin
[GFC_MAX_SYMBOL_LEN
+ 1];
11321 if (gfc_match (" ( %n ) attributes simd", builtin
) != MATCH_YES
)
11322 return MATCH_ERROR
;
11324 gfc_simd_clause clause
= SIMD_NONE
;
11325 if (gfc_match (" ( notinbranch ) ") == MATCH_YES
)
11326 clause
= SIMD_NOTINBRANCH
;
11327 else if (gfc_match (" ( inbranch ) ") == MATCH_YES
)
11328 clause
= SIMD_INBRANCH
;
11330 if (gfc_vectorized_builtins
== NULL
)
11331 gfc_vectorized_builtins
= new hash_map
<nofree_string_hash
, int> ();
11333 char *r
= XNEWVEC (char, strlen (builtin
) + 32);
11334 sprintf (r
, "__builtin_%s", builtin
);
11337 int &value
= gfc_vectorized_builtins
->get_or_insert (r
, &existed
);