1 /* Declaration statement matcher
2 Copyright (C) 2002-2022 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"
33 /* Macros to access allocate memory for gfc_data_variable,
34 gfc_data_value and gfc_data. */
35 #define gfc_get_data_variable() XCNEW (gfc_data_variable)
36 #define gfc_get_data_value() XCNEW (gfc_data_value)
37 #define gfc_get_data() XCNEW (gfc_data)
40 static bool set_binding_label (const char **, const char *, int);
43 /* This flag is set if an old-style length selector is matched
44 during a type-declaration statement. */
46 static int old_char_selector
;
48 /* When variables acquire types and attributes from a declaration
49 statement, they get them from the following static variables. The
50 first part of a declaration sets these variables and the second
51 part copies these into symbol structures. */
53 static gfc_typespec current_ts
;
55 static symbol_attribute current_attr
;
56 static gfc_array_spec
*current_as
;
57 static int colon_seen
;
60 /* The current binding label (if any). */
61 static const char* curr_binding_label
;
62 /* Need to know how many identifiers are on the current data declaration
63 line in case we're given the BIND(C) attribute with a NAME= specifier. */
64 static int num_idents_on_line
;
65 /* Need to know if a NAME= specifier was found during gfc_match_bind_c so we
66 can supply a name if the curr_binding_label is nil and NAME= was not. */
67 static int has_name_equals
= 0;
69 /* Initializer of the previous enumerator. */
71 static gfc_expr
*last_initializer
;
73 /* History of all the enumerators is maintained, so that
74 kind values of all the enumerators could be updated depending
75 upon the maximum initialized value. */
77 typedef struct enumerator_history
80 gfc_expr
*initializer
;
81 struct enumerator_history
*next
;
85 /* Header of enum history chain. */
87 static enumerator_history
*enum_history
= NULL
;
89 /* Pointer of enum history node containing largest initializer. */
91 static enumerator_history
*max_enum
= NULL
;
93 /* gfc_new_block points to the symbol of a newly matched block. */
95 gfc_symbol
*gfc_new_block
;
97 bool gfc_matching_function
;
99 /* Set upon parsing a !GCC$ unroll n directive for use in the next loop. */
100 int directive_unroll
= -1;
102 /* Set upon parsing supported !GCC$ pragmas for use in the next loop. */
103 bool directive_ivdep
= false;
104 bool directive_vector
= false;
105 bool directive_novector
= false;
107 /* Map of middle-end built-ins that should be vectorized. */
108 hash_map
<nofree_string_hash
, int> *gfc_vectorized_builtins
;
110 /* If a kind expression of a component of a parameterized derived type is
111 parameterized, temporarily store the expression here. */
112 static gfc_expr
*saved_kind_expr
= NULL
;
114 /* Used to store the parameter list arising in a PDT declaration and
115 in the typespec of a PDT variable or component. */
116 static gfc_actual_arglist
*decl_type_param_list
;
117 static gfc_actual_arglist
*type_param_spec_list
;
119 /********************* DATA statement subroutines *********************/
121 static bool in_match_data
= false;
124 gfc_in_match_data (void)
126 return in_match_data
;
130 set_in_match_data (bool set_value
)
132 in_match_data
= set_value
;
135 /* Free a gfc_data_variable structure and everything beneath it. */
138 free_variable (gfc_data_variable
*p
)
140 gfc_data_variable
*q
;
145 gfc_free_expr (p
->expr
);
146 gfc_free_iterator (&p
->iter
, 0);
147 free_variable (p
->list
);
153 /* Free a gfc_data_value structure and everything beneath it. */
156 free_value (gfc_data_value
*p
)
163 mpz_clear (p
->repeat
);
164 gfc_free_expr (p
->expr
);
170 /* Free a list of gfc_data structures. */
173 gfc_free_data (gfc_data
*p
)
180 free_variable (p
->var
);
181 free_value (p
->value
);
187 /* Free all data in a namespace. */
190 gfc_free_data_all (gfc_namespace
*ns
)
202 /* Reject data parsed since the last restore point was marked. */
205 gfc_reject_data (gfc_namespace
*ns
)
209 while (ns
->data
&& ns
->data
!= ns
->old_data
)
217 static match
var_element (gfc_data_variable
*);
219 /* Match a list of variables terminated by an iterator and a right
223 var_list (gfc_data_variable
*parent
)
225 gfc_data_variable
*tail
, var
;
228 m
= var_element (&var
);
229 if (m
== MATCH_ERROR
)
234 tail
= gfc_get_data_variable ();
241 if (gfc_match_char (',') != MATCH_YES
)
244 m
= gfc_match_iterator (&parent
->iter
, 1);
247 if (m
== MATCH_ERROR
)
250 m
= var_element (&var
);
251 if (m
== MATCH_ERROR
)
256 tail
->next
= gfc_get_data_variable ();
262 if (gfc_match_char (')') != MATCH_YES
)
267 gfc_syntax_error (ST_DATA
);
272 /* Match a single element in a data variable list, which can be a
273 variable-iterator list. */
276 var_element (gfc_data_variable
*new_var
)
281 memset (new_var
, 0, sizeof (gfc_data_variable
));
283 if (gfc_match_char ('(') == MATCH_YES
)
284 return var_list (new_var
);
286 m
= gfc_match_variable (&new_var
->expr
, 0);
290 if (new_var
->expr
->expr_type
== EXPR_CONSTANT
291 && new_var
->expr
->symtree
== NULL
)
293 gfc_error ("Inquiry parameter cannot appear in a "
294 "data-stmt-object-list at %C");
298 sym
= new_var
->expr
->symtree
->n
.sym
;
300 /* Symbol should already have an associated type. */
301 if (!gfc_check_symbol_typed (sym
, gfc_current_ns
, false, gfc_current_locus
))
304 if (!sym
->attr
.function
&& gfc_current_ns
->parent
305 && gfc_current_ns
->parent
== sym
->ns
)
307 gfc_error ("Host associated variable %qs may not be in the DATA "
308 "statement at %C", sym
->name
);
312 if (gfc_current_state () != COMP_BLOCK_DATA
313 && sym
->attr
.in_common
314 && !gfc_notify_std (GFC_STD_GNU
, "initialization of "
315 "common block variable %qs in DATA statement at %C",
319 if (!gfc_add_data (&sym
->attr
, sym
->name
, &new_var
->expr
->where
))
326 /* Match the top-level list of data variables. */
329 top_var_list (gfc_data
*d
)
331 gfc_data_variable var
, *tail
, *new_var
;
338 m
= var_element (&var
);
341 if (m
== MATCH_ERROR
)
344 new_var
= gfc_get_data_variable ();
347 new_var
->expr
->where
= gfc_current_locus
;
352 tail
->next
= new_var
;
356 if (gfc_match_char ('/') == MATCH_YES
)
358 if (gfc_match_char (',') != MATCH_YES
)
365 gfc_syntax_error (ST_DATA
);
366 gfc_free_data_all (gfc_current_ns
);
372 match_data_constant (gfc_expr
**result
)
374 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
375 gfc_symbol
*sym
, *dt_sym
= NULL
;
380 m
= gfc_match_literal_constant (&expr
, 1);
387 if (m
== MATCH_ERROR
)
390 m
= gfc_match_null (result
);
394 old_loc
= gfc_current_locus
;
396 /* Should this be a structure component, try to match it
397 before matching a name. */
398 m
= gfc_match_rvalue (result
);
399 if (m
== MATCH_ERROR
)
402 if (m
== MATCH_YES
&& (*result
)->expr_type
== EXPR_STRUCTURE
)
404 if (!gfc_simplify_expr (*result
, 0))
408 else if (m
== MATCH_YES
)
410 /* If a parameter inquiry ends up here, symtree is NULL but **result
411 contains the right constant expression. Check here. */
412 if ((*result
)->symtree
== NULL
413 && (*result
)->expr_type
== EXPR_CONSTANT
414 && ((*result
)->ts
.type
== BT_INTEGER
415 || (*result
)->ts
.type
== BT_REAL
))
418 /* F2018:R845 data-stmt-constant is initial-data-target.
419 A data-stmt-constant shall be ... initial-data-target if and
420 only if the corresponding data-stmt-object has the POINTER
421 attribute. ... If data-stmt-constant is initial-data-target
422 the corresponding data statement object shall be
423 data-pointer-initialization compatible (7.5.4.6) with the initial
424 data target; the data statement object is initially associated
426 if ((*result
)->symtree
->n
.sym
->attr
.save
427 && (*result
)->symtree
->n
.sym
->attr
.target
)
429 gfc_free_expr (*result
);
432 gfc_current_locus
= old_loc
;
434 m
= gfc_match_name (name
);
438 if (gfc_find_symbol (name
, NULL
, 1, &sym
))
441 if (sym
&& sym
->attr
.generic
)
442 dt_sym
= gfc_find_dt_in_generic (sym
);
445 || (sym
->attr
.flavor
!= FL_PARAMETER
446 && (!dt_sym
|| !gfc_fl_struct (dt_sym
->attr
.flavor
))))
448 gfc_error ("Symbol %qs must be a PARAMETER in DATA statement at %C",
453 else if (dt_sym
&& gfc_fl_struct (dt_sym
->attr
.flavor
))
454 return gfc_match_structure_constructor (dt_sym
, result
);
456 /* Check to see if the value is an initialization array expression. */
457 if (sym
->value
->expr_type
== EXPR_ARRAY
)
459 gfc_current_locus
= old_loc
;
461 m
= gfc_match_init_expr (result
);
462 if (m
== MATCH_ERROR
)
467 if (!gfc_simplify_expr (*result
, 0))
470 if ((*result
)->expr_type
== EXPR_CONSTANT
)
474 gfc_error ("Invalid initializer %s in Data statement at %C", name
);
480 *result
= gfc_copy_expr (sym
->value
);
485 /* Match a list of values in a DATA statement. The leading '/' has
486 already been seen at this point. */
489 top_val_list (gfc_data
*data
)
491 gfc_data_value
*new_val
, *tail
;
499 m
= match_data_constant (&expr
);
502 if (m
== MATCH_ERROR
)
505 new_val
= gfc_get_data_value ();
506 mpz_init (new_val
->repeat
);
509 data
->value
= new_val
;
511 tail
->next
= new_val
;
515 if (expr
->ts
.type
!= BT_INTEGER
|| gfc_match_char ('*') != MATCH_YES
)
518 mpz_set_ui (tail
->repeat
, 1);
522 mpz_set (tail
->repeat
, expr
->value
.integer
);
523 gfc_free_expr (expr
);
525 m
= match_data_constant (&tail
->expr
);
528 if (m
== MATCH_ERROR
)
532 if (gfc_match_char ('/') == MATCH_YES
)
534 if (gfc_match_char (',') == MATCH_NO
)
541 gfc_syntax_error (ST_DATA
);
542 gfc_free_data_all (gfc_current_ns
);
547 /* Matches an old style initialization. */
550 match_old_style_init (const char *name
)
555 gfc_data
*newdata
, *nd
;
557 /* Set up data structure to hold initializers. */
558 gfc_find_sym_tree (name
, NULL
, 0, &st
);
561 newdata
= gfc_get_data ();
562 newdata
->var
= gfc_get_data_variable ();
563 newdata
->var
->expr
= gfc_get_variable_expr (st
);
564 newdata
->var
->expr
->where
= sym
->declared_at
;
565 newdata
->where
= gfc_current_locus
;
567 /* Match initial value list. This also eats the terminal '/'. */
568 m
= top_val_list (newdata
);
575 /* Check that a BOZ did not creep into an old-style initialization. */
576 for (nd
= newdata
; nd
; nd
= nd
->next
)
578 if (nd
->value
->expr
->ts
.type
== BT_BOZ
579 && gfc_invalid_boz (G_("BOZ at %L cannot appear in an old-style "
580 "initialization"), &nd
->value
->expr
->where
))
583 if (nd
->var
->expr
->ts
.type
!= BT_INTEGER
584 && nd
->var
->expr
->ts
.type
!= BT_REAL
585 && nd
->value
->expr
->ts
.type
== BT_BOZ
)
587 gfc_error (G_("BOZ literal constant near %L cannot be assigned to "
588 "a %qs variable in an old-style initialization"),
589 &nd
->value
->expr
->where
,
590 gfc_typename (&nd
->value
->expr
->ts
));
597 gfc_error ("Initialization at %C is not allowed in a PURE procedure");
601 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
603 /* Mark the variable as having appeared in a data statement. */
604 if (!gfc_add_data (&sym
->attr
, sym
->name
, &sym
->declared_at
))
610 /* Chain in namespace list of DATA initializers. */
611 newdata
->next
= gfc_current_ns
->data
;
612 gfc_current_ns
->data
= newdata
;
618 /* Match the stuff following a DATA statement. If ERROR_FLAG is set,
619 we are matching a DATA statement and are therefore issuing an error
620 if we encounter something unexpected, if not, we're trying to match
621 an old-style initialization expression of the form INTEGER I /2/. */
624 gfc_match_data (void)
632 /* DATA has been matched. In free form source code, the next character
633 needs to be whitespace or '(' from an implied do-loop. Check that
635 c
= gfc_peek_ascii_char ();
636 if (gfc_current_form
== FORM_FREE
&& !gfc_is_whitespace (c
) && c
!= '(')
639 /* Before parsing the rest of a DATA statement, check F2008:c1206. */
640 if ((gfc_current_state () == COMP_FUNCTION
641 || gfc_current_state () == COMP_SUBROUTINE
)
642 && gfc_state_stack
->previous
->state
== COMP_INTERFACE
)
644 gfc_error ("DATA statement at %C cannot appear within an INTERFACE");
648 set_in_match_data (true);
652 new_data
= gfc_get_data ();
653 new_data
->where
= gfc_current_locus
;
655 m
= top_var_list (new_data
);
659 if (new_data
->var
->iter
.var
660 && new_data
->var
->iter
.var
->ts
.type
== BT_INTEGER
661 && new_data
->var
->iter
.var
->symtree
->n
.sym
->attr
.implied_index
== 1
662 && new_data
->var
->list
663 && new_data
->var
->list
->expr
664 && new_data
->var
->list
->expr
->ts
.type
== BT_CHARACTER
665 && new_data
->var
->list
->expr
->ref
666 && new_data
->var
->list
->expr
->ref
->type
== REF_SUBSTRING
)
668 gfc_error ("Invalid substring in data-implied-do at %L in DATA "
669 "statement", &new_data
->var
->list
->expr
->where
);
673 /* Check for an entity with an allocatable component, which is not
675 e
= new_data
->var
->expr
;
681 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
682 if ((ref
->type
== REF_COMPONENT
683 && ref
->u
.c
.component
->attr
.allocatable
)
684 || (ref
->type
== REF_ARRAY
685 && e
->symtree
->n
.sym
->attr
.pointer
!= 1
686 && ref
->u
.ar
.as
&& ref
->u
.ar
.as
->type
== AS_DEFERRED
))
691 gfc_error ("Allocatable component or deferred-shaped array "
692 "near %C in DATA statement");
696 /* F2008:C567 (R536) A data-i-do-object or a variable that appears
697 as a data-stmt-object shall not be an object designator in which
698 a pointer appears other than as the entire rightmost part-ref. */
699 if (!e
->ref
&& e
->ts
.type
== BT_DERIVED
700 && e
->symtree
->n
.sym
->attr
.pointer
)
704 if (e
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
705 && e
->symtree
->n
.sym
->attr
.pointer
706 && ref
->type
== REF_COMPONENT
)
709 for (; ref
; ref
= ref
->next
)
710 if (ref
->type
== REF_COMPONENT
711 && ref
->u
.c
.component
->attr
.pointer
716 m
= top_val_list (new_data
);
720 new_data
->next
= gfc_current_ns
->data
;
721 gfc_current_ns
->data
= new_data
;
723 /* A BOZ literal constant cannot appear in a structure constructor.
724 Check for that here for a data statement value. */
725 if (new_data
->value
->expr
->ts
.type
== BT_DERIVED
726 && new_data
->value
->expr
->value
.constructor
)
729 c
= gfc_constructor_first (new_data
->value
->expr
->value
.constructor
);
730 for (; c
; c
= gfc_constructor_next (c
))
731 if (c
->expr
&& c
->expr
->ts
.type
== BT_BOZ
)
733 gfc_error ("BOZ literal constant at %L cannot appear in a "
734 "structure constructor", &c
->expr
->where
);
739 if (gfc_match_eos () == MATCH_YES
)
742 gfc_match_char (','); /* Optional comma */
745 set_in_match_data (false);
749 gfc_error ("DATA statement at %C is not allowed in a PURE procedure");
752 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
758 gfc_error ("part-ref with pointer attribute near %L is not "
759 "rightmost part-ref of data-stmt-object",
763 set_in_match_data (false);
764 gfc_free_data (new_data
);
769 /************************ Declaration statements *********************/
772 /* Like gfc_match_init_expr, but matches a 'clist' (old-style initialization
773 list). The difference here is the expression is a list of constants
774 and is surrounded by '/'.
775 The typespec ts must match the typespec of the variable which the
776 clist is initializing.
777 The arrayspec tells whether this should match a list of constants
778 corresponding to array elements or a scalar (as == NULL). */
781 match_clist_expr (gfc_expr
**result
, gfc_typespec
*ts
, gfc_array_spec
*as
)
783 gfc_constructor_base array_head
= NULL
;
784 gfc_expr
*expr
= NULL
;
785 match m
= MATCH_ERROR
;
787 mpz_t repeat
, cons_size
, as_size
;
793 /* We have already matched '/' - now look for a constant list, as with
794 top_val_list from decl.c, but append the result to an array. */
795 if (gfc_match ("/") == MATCH_YES
)
797 gfc_error ("Empty old style initializer list at %C");
801 where
= gfc_current_locus
;
802 scalar
= !as
|| !as
->rank
;
804 if (!scalar
&& !spec_size (as
, &as_size
))
806 gfc_error ("Array in initializer list at %L must have an explicit shape",
807 as
->type
== AS_EXPLICIT
? &as
->upper
[0]->where
: &where
);
808 /* Nothing to cleanup yet. */
812 mpz_init_set_ui (repeat
, 0);
816 m
= match_data_constant (&expr
);
818 expr
= NULL
; /* match_data_constant may set expr to garbage */
821 if (m
== MATCH_ERROR
)
824 /* Found r in repeat spec r*c; look for the constant to repeat. */
825 if ( gfc_match_char ('*') == MATCH_YES
)
829 gfc_error ("Repeat spec invalid in scalar initializer at %C");
832 if (expr
->ts
.type
!= BT_INTEGER
)
834 gfc_error ("Repeat spec must be an integer at %C");
837 mpz_set (repeat
, expr
->value
.integer
);
838 gfc_free_expr (expr
);
841 m
= match_data_constant (&expr
);
845 gfc_error ("Expected data constant after repeat spec at %C");
850 /* No repeat spec, we matched the data constant itself. */
852 mpz_set_ui (repeat
, 1);
856 /* Add the constant initializer as many times as repeated. */
857 for (; mpz_cmp_ui (repeat
, 0) > 0; mpz_sub_ui (repeat
, repeat
, 1))
859 /* Make sure types of elements match */
860 if(ts
&& !gfc_compare_types (&expr
->ts
, ts
)
861 && !gfc_convert_type (expr
, ts
, 1))
864 gfc_constructor_append_expr (&array_head
,
865 gfc_copy_expr (expr
), &gfc_current_locus
);
868 gfc_free_expr (expr
);
872 /* For scalar initializers quit after one element. */
875 if(gfc_match_char ('/') != MATCH_YES
)
877 gfc_error ("End of scalar initializer expected at %C");
883 if (gfc_match_char ('/') == MATCH_YES
)
885 if (gfc_match_char (',') == MATCH_NO
)
889 /* If we break early from here out, we encountered an error. */
892 /* Set up expr as an array constructor. */
895 expr
= gfc_get_array_expr (ts
->type
, ts
->kind
, &where
);
897 expr
->value
.constructor
= array_head
;
899 /* Validate sizes. We built expr ourselves, so cons_size will be
900 constant (we fail above for non-constant expressions).
901 We still need to verify that the sizes match. */
902 gcc_assert (gfc_array_size (expr
, &cons_size
));
903 cmp
= mpz_cmp (cons_size
, as_size
);
905 gfc_error ("Not enough elements in array initializer at %C");
907 gfc_error ("Too many elements in array initializer at %C");
908 mpz_clear (cons_size
);
912 /* Set the rank/shape to match the LHS as auto-reshape is implied. */
913 expr
->rank
= as
->rank
;
914 expr
->shape
= gfc_get_shape (as
->rank
);
915 for (int i
= 0; i
< as
->rank
; ++i
)
916 spec_dimen_size (as
, i
, &expr
->shape
[i
]);
919 /* Make sure scalar types match. */
920 else if (!gfc_compare_types (&expr
->ts
, ts
)
921 && !gfc_convert_type (expr
, ts
, 1))
925 expr
->ts
.u
.cl
->length_from_typespec
= 1;
933 gfc_error ("Syntax error in old style initializer list at %C");
937 expr
->value
.constructor
= NULL
;
938 gfc_free_expr (expr
);
939 gfc_constructor_free (array_head
);
949 /* Auxiliary function to merge DIMENSION and CODIMENSION array specs. */
952 merge_array_spec (gfc_array_spec
*from
, gfc_array_spec
*to
, bool copy
)
954 if ((from
->type
== AS_ASSUMED_RANK
&& to
->corank
)
955 || (to
->type
== AS_ASSUMED_RANK
&& from
->corank
))
957 gfc_error ("The assumed-rank array at %C shall not have a codimension");
961 if (to
->rank
== 0 && from
->rank
> 0)
963 to
->rank
= from
->rank
;
964 to
->type
= from
->type
;
965 to
->cray_pointee
= from
->cray_pointee
;
966 to
->cp_was_assumed
= from
->cp_was_assumed
;
968 for (int i
= to
->corank
- 1; i
>= 0; i
--)
970 /* Do not exceed the limits on lower[] and upper[]. gfortran
971 cleans up elsewhere. */
972 int j
= from
->rank
+ i
;
973 if (j
>= GFC_MAX_DIMENSIONS
)
976 to
->lower
[j
] = to
->lower
[i
];
977 to
->upper
[j
] = to
->upper
[i
];
979 for (int i
= 0; i
< from
->rank
; i
++)
983 to
->lower
[i
] = gfc_copy_expr (from
->lower
[i
]);
984 to
->upper
[i
] = gfc_copy_expr (from
->upper
[i
]);
988 to
->lower
[i
] = from
->lower
[i
];
989 to
->upper
[i
] = from
->upper
[i
];
993 else if (to
->corank
== 0 && from
->corank
> 0)
995 to
->corank
= from
->corank
;
996 to
->cotype
= from
->cotype
;
998 for (int i
= 0; i
< from
->corank
; i
++)
1000 /* Do not exceed the limits on lower[] and upper[]. gfortran
1001 cleans up elsewhere. */
1002 int k
= from
->rank
+ i
;
1003 int j
= to
->rank
+ i
;
1004 if (j
>= GFC_MAX_DIMENSIONS
)
1009 to
->lower
[j
] = gfc_copy_expr (from
->lower
[k
]);
1010 to
->upper
[j
] = gfc_copy_expr (from
->upper
[k
]);
1014 to
->lower
[j
] = from
->lower
[k
];
1015 to
->upper
[j
] = from
->upper
[k
];
1020 if (to
->rank
+ to
->corank
> GFC_MAX_DIMENSIONS
)
1022 gfc_error ("Sum of array rank %d and corank %d at %C exceeds maximum "
1023 "allowed dimensions of %d",
1024 to
->rank
, to
->corank
, GFC_MAX_DIMENSIONS
);
1025 to
->corank
= GFC_MAX_DIMENSIONS
- to
->rank
;
1032 /* Match an intent specification. Since this can only happen after an
1033 INTENT word, a legal intent-spec must follow. */
1036 match_intent_spec (void)
1039 if (gfc_match (" ( in out )") == MATCH_YES
)
1040 return INTENT_INOUT
;
1041 if (gfc_match (" ( in )") == MATCH_YES
)
1043 if (gfc_match (" ( out )") == MATCH_YES
)
1046 gfc_error ("Bad INTENT specification at %C");
1047 return INTENT_UNKNOWN
;
1051 /* Matches a character length specification, which is either a
1052 specification expression, '*', or ':'. */
1055 char_len_param_value (gfc_expr
**expr
, bool *deferred
)
1062 if (gfc_match_char ('*') == MATCH_YES
)
1065 if (gfc_match_char (':') == MATCH_YES
)
1067 if (!gfc_notify_std (GFC_STD_F2003
, "deferred type parameter at %C"))
1075 m
= gfc_match_expr (expr
);
1077 if (m
== MATCH_NO
|| m
== MATCH_ERROR
)
1080 if (!gfc_expr_check_typed (*expr
, gfc_current_ns
, false))
1083 /* If gfortran gets an EXPR_OP, try to simplifiy it. This catches things
1084 like CHARACTER(([1])). */
1085 if ((*expr
)->expr_type
== EXPR_OP
)
1086 gfc_simplify_expr (*expr
, 1);
1088 if ((*expr
)->expr_type
== EXPR_FUNCTION
)
1090 if ((*expr
)->ts
.type
== BT_INTEGER
1091 || ((*expr
)->ts
.type
== BT_UNKNOWN
1092 && strcmp((*expr
)->symtree
->name
, "null") != 0))
1097 else if ((*expr
)->expr_type
== EXPR_CONSTANT
)
1099 /* F2008, 4.4.3.1: The length is a type parameter; its kind is
1100 processor dependent and its value is greater than or equal to zero.
1101 F2008, 4.4.3.2: If the character length parameter value evaluates
1102 to a negative value, the length of character entities declared
1105 if ((*expr
)->ts
.type
== BT_INTEGER
)
1107 if (mpz_cmp_si ((*expr
)->value
.integer
, 0) < 0)
1108 mpz_set_si ((*expr
)->value
.integer
, 0);
1113 else if ((*expr
)->expr_type
== EXPR_ARRAY
)
1115 else if ((*expr
)->expr_type
== EXPR_VARIABLE
)
1120 e
= gfc_copy_expr (*expr
);
1122 /* This catches the invalid code "[character(m(2:3)) :: 'x', 'y']",
1123 which causes an ICE if gfc_reduce_init_expr() is called. */
1124 if (e
->ref
&& e
->ref
->type
== REF_ARRAY
1125 && e
->ref
->u
.ar
.type
== AR_UNKNOWN
1126 && e
->ref
->u
.ar
.dimen_type
[0] == DIMEN_RANGE
)
1129 t
= gfc_reduce_init_expr (e
);
1131 if (!t
&& e
->ts
.type
== BT_UNKNOWN
1132 && e
->symtree
->n
.sym
->attr
.untyped
== 1
1133 && (flag_implicit_none
1134 || e
->symtree
->n
.sym
->ns
->seen_implicit_none
== 1
1135 || e
->symtree
->n
.sym
->ns
->parent
->seen_implicit_none
== 1))
1141 if ((e
->ref
&& e
->ref
->type
== REF_ARRAY
1142 && e
->ref
->u
.ar
.type
!= AR_ELEMENT
)
1143 || (!e
->ref
&& e
->expr_type
== EXPR_ARRAY
))
1158 gfc_error ("Scalar INTEGER expression expected at %L", &(*expr
)->where
);
1163 /* A character length is a '*' followed by a literal integer or a
1164 char_len_param_value in parenthesis. */
1167 match_char_length (gfc_expr
**expr
, bool *deferred
, bool obsolescent_check
)
1173 m
= gfc_match_char ('*');
1177 m
= gfc_match_small_literal_int (&length
, NULL
);
1178 if (m
== MATCH_ERROR
)
1183 if (obsolescent_check
1184 && !gfc_notify_std (GFC_STD_F95_OBS
, "Old-style character length at %C"))
1186 *expr
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
, length
);
1190 if (gfc_match_char ('(') == MATCH_NO
)
1193 m
= char_len_param_value (expr
, deferred
);
1194 if (m
!= MATCH_YES
&& gfc_matching_function
)
1196 gfc_undo_symbols ();
1200 if (m
== MATCH_ERROR
)
1205 if (gfc_match_char (')') == MATCH_NO
)
1207 gfc_free_expr (*expr
);
1215 gfc_error ("Syntax error in character length specification at %C");
1220 /* Special subroutine for finding a symbol. Check if the name is found
1221 in the current name space. If not, and we're compiling a function or
1222 subroutine and the parent compilation unit is an interface, then check
1223 to see if the name we've been given is the name of the interface
1224 (located in another namespace). */
1227 find_special (const char *name
, gfc_symbol
**result
, bool allow_subroutine
)
1233 i
= gfc_get_sym_tree (name
, NULL
, &st
, allow_subroutine
);
1236 *result
= st
? st
->n
.sym
: NULL
;
1240 if (gfc_current_state () != COMP_SUBROUTINE
1241 && gfc_current_state () != COMP_FUNCTION
)
1244 s
= gfc_state_stack
->previous
;
1248 if (s
->state
!= COMP_INTERFACE
)
1251 goto end
; /* Nameless interface. */
1253 if (strcmp (name
, s
->sym
->name
) == 0)
1264 /* Special subroutine for getting a symbol node associated with a
1265 procedure name, used in SUBROUTINE and FUNCTION statements. The
1266 symbol is created in the parent using with symtree node in the
1267 child unit pointing to the symbol. If the current namespace has no
1268 parent, then the symbol is just created in the current unit. */
1271 get_proc_name (const char *name
, gfc_symbol
**result
, bool module_fcn_entry
)
1277 /* Module functions have to be left in their own namespace because
1278 they have potentially (almost certainly!) already been referenced.
1279 In this sense, they are rather like external functions. This is
1280 fixed up in resolve.c(resolve_entries), where the symbol name-
1281 space is set to point to the master function, so that the fake
1282 result mechanism can work. */
1283 if (module_fcn_entry
)
1285 /* Present if entry is declared to be a module procedure. */
1286 rc
= gfc_find_symbol (name
, gfc_current_ns
->parent
, 0, result
);
1288 if (*result
== NULL
)
1289 rc
= gfc_get_symbol (name
, NULL
, result
);
1290 else if (!gfc_get_symbol (name
, NULL
, &sym
) && sym
1291 && (*result
)->ts
.type
== BT_UNKNOWN
1292 && sym
->attr
.flavor
== FL_UNKNOWN
)
1293 /* Pick up the typespec for the entry, if declared in the function
1294 body. Note that this symbol is FL_UNKNOWN because it will
1295 only have appeared in a type declaration. The local symtree
1296 is set to point to the module symbol and a unique symtree
1297 to the local version. This latter ensures a correct clearing
1300 /* If the ENTRY proceeds its specification, we need to ensure
1301 that this does not raise a "has no IMPLICIT type" error. */
1302 if (sym
->ts
.type
== BT_UNKNOWN
)
1303 sym
->attr
.untyped
= 1;
1305 (*result
)->ts
= sym
->ts
;
1307 /* Put the symbol in the procedure namespace so that, should
1308 the ENTRY precede its specification, the specification
1310 (*result
)->ns
= gfc_current_ns
;
1312 gfc_find_sym_tree (name
, gfc_current_ns
, 0, &st
);
1313 st
->n
.sym
= *result
;
1314 st
= gfc_get_unique_symtree (gfc_current_ns
);
1320 rc
= gfc_get_symbol (name
, gfc_current_ns
->parent
, result
);
1326 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
1329 if (sym
->attr
.module_procedure
&& sym
->attr
.if_source
== IFSRC_IFBODY
)
1331 /* Create a partially populated interface symbol to carry the
1332 characteristics of the procedure and the result. */
1333 sym
->tlink
= gfc_new_symbol (name
, sym
->ns
);
1334 gfc_add_type (sym
->tlink
, &(sym
->ts
), &gfc_current_locus
);
1335 gfc_copy_attr (&sym
->tlink
->attr
, &sym
->attr
, NULL
);
1336 if (sym
->attr
.dimension
)
1337 sym
->tlink
->as
= gfc_copy_array_spec (sym
->as
);
1339 /* Ideally, at this point, a copy would be made of the formal
1340 arguments and their namespace. However, this does not appear
1341 to be necessary, albeit at the expense of not being able to
1342 use gfc_compare_interfaces directly. */
1344 if (sym
->result
&& sym
->result
!= sym
)
1346 sym
->tlink
->result
= sym
->result
;
1349 else if (sym
->result
)
1351 sym
->tlink
->result
= sym
->tlink
;
1354 else if (sym
&& !sym
->gfc_new
1355 && gfc_current_state () != COMP_INTERFACE
)
1357 /* Trap another encompassed procedure with the same name. All
1358 these conditions are necessary to avoid picking up an entry
1359 whose name clashes with that of the encompassing procedure;
1360 this is handled using gsymbols to register unique, globally
1361 accessible names. */
1362 if (sym
->attr
.flavor
!= 0
1363 && sym
->attr
.proc
!= 0
1364 && (sym
->attr
.subroutine
|| sym
->attr
.function
|| sym
->attr
.entry
)
1365 && sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
1367 gfc_error_now ("Procedure %qs at %C is already defined at %L",
1368 name
, &sym
->declared_at
);
1371 if (sym
->attr
.flavor
!= 0
1372 && sym
->attr
.entry
&& sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
1374 gfc_error_now ("Procedure %qs at %C is already defined at %L",
1375 name
, &sym
->declared_at
);
1379 if (sym
->attr
.external
&& sym
->attr
.procedure
1380 && gfc_current_state () == COMP_CONTAINS
)
1382 gfc_error_now ("Contained procedure %qs at %C clashes with "
1383 "procedure defined at %L",
1384 name
, &sym
->declared_at
);
1388 /* Trap a procedure with a name the same as interface in the
1389 encompassing scope. */
1390 if (sym
->attr
.generic
!= 0
1391 && (sym
->attr
.subroutine
|| sym
->attr
.function
)
1392 && !sym
->attr
.mod_proc
)
1394 gfc_error_now ("Name %qs at %C is already defined"
1395 " as a generic interface at %L",
1396 name
, &sym
->declared_at
);
1400 /* Trap declarations of attributes in encompassing scope. The
1401 signature for this is that ts.kind is nonzero for no-CLASS
1402 entity. For a CLASS entity, ts.kind is zero. */
1403 if ((sym
->ts
.kind
!= 0 || sym
->ts
.type
== BT_CLASS
)
1404 && !sym
->attr
.implicit_type
1405 && sym
->attr
.proc
== 0
1406 && gfc_current_ns
->parent
!= NULL
1407 && sym
->attr
.access
== 0
1408 && !module_fcn_entry
)
1410 gfc_error_now ("Procedure %qs at %C has an explicit interface "
1411 "from a previous declaration", name
);
1416 /* C1246 (R1225) MODULE shall appear only in the function-stmt or
1417 subroutine-stmt of a module subprogram or of a nonabstract interface
1418 body that is declared in the scoping unit of a module or submodule. */
1419 if (sym
->attr
.external
1420 && (sym
->attr
.subroutine
|| sym
->attr
.function
)
1421 && sym
->attr
.if_source
== IFSRC_IFBODY
1422 && !current_attr
.module_procedure
1423 && sym
->attr
.proc
== PROC_MODULE
1424 && gfc_state_stack
->state
== COMP_CONTAINS
)
1426 gfc_error_now ("Procedure %qs defined in interface body at %L "
1427 "clashes with internal procedure defined at %C",
1428 name
, &sym
->declared_at
);
1432 if (sym
&& !sym
->gfc_new
1433 && sym
->attr
.flavor
!= FL_UNKNOWN
1434 && sym
->attr
.referenced
== 0 && sym
->attr
.subroutine
== 1
1435 && gfc_state_stack
->state
== COMP_CONTAINS
1436 && gfc_state_stack
->previous
->state
== COMP_SUBROUTINE
)
1438 gfc_error_now ("Procedure %qs at %C is already defined at %L",
1439 name
, &sym
->declared_at
);
1443 if (gfc_current_ns
->parent
== NULL
|| *result
== NULL
)
1446 /* Module function entries will already have a symtree in
1447 the current namespace but will need one at module level. */
1448 if (module_fcn_entry
)
1450 /* Present if entry is declared to be a module procedure. */
1451 rc
= gfc_find_sym_tree (name
, gfc_current_ns
->parent
, 0, &st
);
1453 st
= gfc_new_symtree (&gfc_current_ns
->parent
->sym_root
, name
);
1456 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, name
);
1461 /* See if the procedure should be a module procedure. */
1463 if (((sym
->ns
->proc_name
!= NULL
1464 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
1465 && sym
->attr
.proc
!= PROC_MODULE
)
1466 || (module_fcn_entry
&& sym
->attr
.proc
!= PROC_MODULE
))
1467 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
1474 /* Verify that the given symbol representing a parameter is C
1475 interoperable, by checking to see if it was marked as such after
1476 its declaration. If the given symbol is not interoperable, a
1477 warning is reported, thus removing the need to return the status to
1478 the calling function. The standard does not require the user use
1479 one of the iso_c_binding named constants to declare an
1480 interoperable parameter, but we can't be sure if the param is C
1481 interop or not if the user doesn't. For example, integer(4) may be
1482 legal Fortran, but doesn't have meaning in C. It may interop with
1483 a number of the C types, which causes a problem because the
1484 compiler can't know which one. This code is almost certainly not
1485 portable, and the user will get what they deserve if the C type
1486 across platforms isn't always interoperable with integer(4). If
1487 the user had used something like integer(c_int) or integer(c_long),
1488 the compiler could have automatically handled the varying sizes
1489 across platforms. */
1492 gfc_verify_c_interop_param (gfc_symbol
*sym
)
1494 int is_c_interop
= 0;
1497 /* We check implicitly typed variables in symbol.c:gfc_set_default_type().
1498 Don't repeat the checks here. */
1499 if (sym
->attr
.implicit_type
)
1502 /* For subroutines or functions that are passed to a BIND(C) procedure,
1503 they're interoperable if they're BIND(C) and their params are all
1505 if (sym
->attr
.flavor
== FL_PROCEDURE
)
1507 if (sym
->attr
.is_bind_c
== 0)
1509 gfc_error_now ("Procedure %qs at %L must have the BIND(C) "
1510 "attribute to be C interoperable", sym
->name
,
1511 &(sym
->declared_at
));
1516 if (sym
->attr
.is_c_interop
== 1)
1517 /* We've already checked this procedure; don't check it again. */
1520 return verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
1525 /* See if we've stored a reference to a procedure that owns sym. */
1526 if (sym
->ns
!= NULL
&& sym
->ns
->proc_name
!= NULL
)
1528 if (sym
->ns
->proc_name
->attr
.is_bind_c
== 1)
1530 is_c_interop
= (gfc_verify_c_interop(&(sym
->ts
)) ? 1 : 0);
1532 if (is_c_interop
!= 1)
1534 /* Make personalized messages to give better feedback. */
1535 if (sym
->ts
.type
== BT_DERIVED
)
1536 gfc_error ("Variable %qs at %L is a dummy argument to the "
1537 "BIND(C) procedure %qs but is not C interoperable "
1538 "because derived type %qs is not C interoperable",
1539 sym
->name
, &(sym
->declared_at
),
1540 sym
->ns
->proc_name
->name
,
1541 sym
->ts
.u
.derived
->name
);
1542 else if (sym
->ts
.type
== BT_CLASS
)
1543 gfc_error ("Variable %qs at %L is a dummy argument to the "
1544 "BIND(C) procedure %qs but is not C interoperable "
1545 "because it is polymorphic",
1546 sym
->name
, &(sym
->declared_at
),
1547 sym
->ns
->proc_name
->name
);
1548 else if (warn_c_binding_type
)
1549 gfc_warning (OPT_Wc_binding_type
,
1550 "Variable %qs at %L is a dummy argument of the "
1551 "BIND(C) procedure %qs but may not be C "
1553 sym
->name
, &(sym
->declared_at
),
1554 sym
->ns
->proc_name
->name
);
1557 /* Per F2018, 18.3.6 (5), pointer + contiguous is not permitted. */
1558 if (sym
->attr
.pointer
&& sym
->attr
.contiguous
)
1559 gfc_error ("Dummy argument %qs at %L may not be a pointer with "
1560 "CONTIGUOUS attribute as procedure %qs is BIND(C)",
1561 sym
->name
, &sym
->declared_at
, sym
->ns
->proc_name
->name
);
1563 /* Per F2018, C1557, pointer/allocatable dummies to a bind(c)
1564 procedure that are default-initialized are not permitted. */
1565 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
1566 && sym
->ts
.type
== BT_DERIVED
1567 && gfc_has_default_initializer (sym
->ts
.u
.derived
))
1569 gfc_error ("Default-initialized %s dummy argument %qs "
1570 "at %L is not permitted in BIND(C) procedure %qs",
1571 (sym
->attr
.pointer
? "pointer" : "allocatable"),
1572 sym
->name
, &sym
->declared_at
,
1573 sym
->ns
->proc_name
->name
);
1577 /* Character strings are only C interoperable if they have a
1578 length of 1. However, as an argument they are also iteroperable
1579 when passed as descriptor (which requires len=: or len=*). */
1580 if (sym
->ts
.type
== BT_CHARACTER
)
1582 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
1584 if (sym
->attr
.allocatable
|| sym
->attr
.pointer
)
1586 /* F2018, 18.3.6 (6). */
1587 if (!sym
->ts
.deferred
)
1589 if (sym
->attr
.allocatable
)
1590 gfc_error ("Allocatable character dummy argument %qs "
1591 "at %L must have deferred length as "
1592 "procedure %qs is BIND(C)", sym
->name
,
1593 &sym
->declared_at
, sym
->ns
->proc_name
->name
);
1595 gfc_error ("Pointer character dummy argument %qs at %L "
1596 "must have deferred length as procedure %qs "
1597 "is BIND(C)", sym
->name
, &sym
->declared_at
,
1598 sym
->ns
->proc_name
->name
);
1601 else if (!gfc_notify_std (GFC_STD_F2018
,
1602 "Deferred-length character dummy "
1603 "argument %qs at %L of procedure "
1604 "%qs with BIND(C) attribute",
1605 sym
->name
, &sym
->declared_at
,
1606 sym
->ns
->proc_name
->name
))
1609 else if (sym
->attr
.value
1610 && (!cl
|| !cl
->length
1611 || cl
->length
->expr_type
!= EXPR_CONSTANT
1612 || mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0))
1614 gfc_error ("Character dummy argument %qs at %L must be "
1615 "of length 1 as it has the VALUE attribute",
1616 sym
->name
, &sym
->declared_at
);
1619 else if (!cl
|| !cl
->length
)
1621 /* Assumed length; F2018, 18.3.6 (5)(2).
1622 Uses the CFI array descriptor - also for scalars and
1623 explicit-size/assumed-size arrays. */
1624 if (!gfc_notify_std (GFC_STD_F2018
,
1625 "Assumed-length character dummy argument "
1626 "%qs at %L of procedure %qs with BIND(C) "
1627 "attribute", sym
->name
, &sym
->declared_at
,
1628 sym
->ns
->proc_name
->name
))
1631 else if (cl
->length
->expr_type
!= EXPR_CONSTANT
1632 || mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
1634 /* F2018, 18.3.6, (5), item 4. */
1635 if (!sym
->attr
.dimension
1636 || sym
->as
->type
== AS_ASSUMED_SIZE
1637 || sym
->as
->type
== AS_EXPLICIT
)
1639 gfc_error ("Character dummy argument %qs at %L must be "
1640 "of constant length of one or assumed length, "
1641 "unless it has assumed shape or assumed rank, "
1642 "as procedure %qs has the BIND(C) attribute",
1643 sym
->name
, &sym
->declared_at
,
1644 sym
->ns
->proc_name
->name
);
1647 /* else: valid only since F2018 - and an assumed-shape/rank
1648 array; however, gfc_notify_std is already called when
1649 those array types are used. Thus, silently accept F200x. */
1653 /* We have to make sure that any param to a bind(c) routine does
1654 not have the allocatable, pointer, or optional attributes,
1655 according to J3/04-007, section 5.1. */
1656 if (sym
->attr
.allocatable
== 1
1657 && !gfc_notify_std (GFC_STD_F2018
, "Variable %qs at %L with "
1658 "ALLOCATABLE attribute in procedure %qs "
1659 "with BIND(C)", sym
->name
,
1660 &(sym
->declared_at
),
1661 sym
->ns
->proc_name
->name
))
1664 if (sym
->attr
.pointer
== 1
1665 && !gfc_notify_std (GFC_STD_F2018
, "Variable %qs at %L with "
1666 "POINTER attribute in procedure %qs "
1667 "with BIND(C)", sym
->name
,
1668 &(sym
->declared_at
),
1669 sym
->ns
->proc_name
->name
))
1672 if (sym
->attr
.optional
== 1 && sym
->attr
.value
)
1674 gfc_error ("Variable %qs at %L cannot have both the OPTIONAL "
1675 "and the VALUE attribute because procedure %qs "
1676 "is BIND(C)", sym
->name
, &(sym
->declared_at
),
1677 sym
->ns
->proc_name
->name
);
1680 else if (sym
->attr
.optional
== 1
1681 && !gfc_notify_std (GFC_STD_F2018
, "Variable %qs "
1682 "at %L with OPTIONAL attribute in "
1683 "procedure %qs which is BIND(C)",
1684 sym
->name
, &(sym
->declared_at
),
1685 sym
->ns
->proc_name
->name
))
1688 /* Make sure that if it has the dimension attribute, that it is
1689 either assumed size or explicit shape. Deferred shape is already
1690 covered by the pointer/allocatable attribute. */
1691 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SHAPE
1692 && !gfc_notify_std (GFC_STD_F2018
, "Assumed-shape array %qs "
1693 "at %L as dummy argument to the BIND(C) "
1694 "procedure %qs at %L", sym
->name
,
1695 &(sym
->declared_at
),
1696 sym
->ns
->proc_name
->name
,
1697 &(sym
->ns
->proc_name
->declared_at
)))
1707 /* Function called by variable_decl() that adds a name to the symbol table. */
1710 build_sym (const char *name
, gfc_charlen
*cl
, bool cl_deferred
,
1711 gfc_array_spec
**as
, locus
*var_locus
)
1713 symbol_attribute attr
;
1718 /* Symbols in a submodule are host associated from the parent module or
1719 submodules. Therefore, they can be overridden by declarations in the
1720 submodule scope. Deal with this by attaching the existing symbol to
1721 a new symtree and recycling the old symtree with a new symbol... */
1722 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
1723 if (st
!= NULL
&& gfc_state_stack
->state
== COMP_SUBMODULE
1724 && st
->n
.sym
!= NULL
1725 && st
->n
.sym
->attr
.host_assoc
&& st
->n
.sym
->attr
.used_in_submodule
)
1727 gfc_symtree
*s
= gfc_get_unique_symtree (gfc_current_ns
);
1728 s
->n
.sym
= st
->n
.sym
;
1729 sym
= gfc_new_symbol (name
, gfc_current_ns
);
1734 gfc_set_sym_referenced (sym
);
1736 /* ...Otherwise generate a new symtree and new symbol. */
1737 else if (gfc_get_symbol (name
, NULL
, &sym
))
1740 /* Check if the name has already been defined as a type. The
1741 first letter of the symtree will be in upper case then. Of
1742 course, this is only necessary if the upper case letter is
1743 actually different. */
1745 upper
= TOUPPER(name
[0]);
1746 if (upper
!= name
[0])
1748 char u_name
[GFC_MAX_SYMBOL_LEN
+ 1];
1751 gcc_assert (strlen(name
) <= GFC_MAX_SYMBOL_LEN
);
1752 strcpy (u_name
, name
);
1755 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, u_name
);
1757 /* STRUCTURE types can alias symbol names */
1758 if (st
!= 0 && st
->n
.sym
->attr
.flavor
!= FL_STRUCT
)
1760 gfc_error ("Symbol %qs at %C also declared as a type at %L", name
,
1761 &st
->n
.sym
->declared_at
);
1766 /* Start updating the symbol table. Add basic type attribute if present. */
1767 if (current_ts
.type
!= BT_UNKNOWN
1768 && (sym
->attr
.implicit_type
== 0
1769 || !gfc_compare_types (&sym
->ts
, ¤t_ts
))
1770 && !gfc_add_type (sym
, ¤t_ts
, var_locus
))
1773 if (sym
->ts
.type
== BT_CHARACTER
)
1776 sym
->ts
.deferred
= cl_deferred
;
1779 /* Add dimension attribute if present. */
1780 if (!gfc_set_array_spec (sym
, *as
, var_locus
))
1784 /* Add attribute to symbol. The copy is so that we can reset the
1785 dimension attribute. */
1786 attr
= current_attr
;
1788 attr
.codimension
= 0;
1790 if (!gfc_copy_attr (&sym
->attr
, &attr
, var_locus
))
1793 /* Finish any work that may need to be done for the binding label,
1794 if it's a bind(c). The bind(c) attr is found before the symbol
1795 is made, and before the symbol name (for data decls), so the
1796 current_ts is holding the binding label, or nothing if the
1797 name= attr wasn't given. Therefore, test here if we're dealing
1798 with a bind(c) and make sure the binding label is set correctly. */
1799 if (sym
->attr
.is_bind_c
== 1)
1801 if (!sym
->binding_label
)
1803 /* Set the binding label and verify that if a NAME= was specified
1804 then only one identifier was in the entity-decl-list. */
1805 if (!set_binding_label (&sym
->binding_label
, sym
->name
,
1806 num_idents_on_line
))
1811 /* See if we know we're in a common block, and if it's a bind(c)
1812 common then we need to make sure we're an interoperable type. */
1813 if (sym
->attr
.in_common
== 1)
1815 /* Test the common block object. */
1816 if (sym
->common_block
!= NULL
&& sym
->common_block
->is_bind_c
== 1
1817 && sym
->ts
.is_c_interop
!= 1)
1819 gfc_error_now ("Variable %qs in common block %qs at %C "
1820 "must be declared with a C interoperable "
1821 "kind since common block %qs is BIND(C)",
1822 sym
->name
, sym
->common_block
->name
,
1823 sym
->common_block
->name
);
1828 sym
->attr
.implied_index
= 0;
1830 /* Use the parameter expressions for a parameterized derived type. */
1831 if ((sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
1832 && sym
->ts
.u
.derived
->attr
.pdt_type
&& type_param_spec_list
)
1833 sym
->param_list
= gfc_copy_actual_arglist (type_param_spec_list
);
1835 if (sym
->ts
.type
== BT_CLASS
)
1836 return gfc_build_class_symbol (&sym
->ts
, &sym
->attr
, &sym
->as
);
1842 /* Set character constant to the given length. The constant will be padded or
1843 truncated. If we're inside an array constructor without a typespec, we
1844 additionally check that all elements have the same length; check_len -1
1845 means no checking. */
1848 gfc_set_constant_character_len (gfc_charlen_t len
, gfc_expr
*expr
,
1849 gfc_charlen_t check_len
)
1854 if (expr
->ts
.type
!= BT_CHARACTER
)
1857 if (expr
->expr_type
!= EXPR_CONSTANT
)
1859 gfc_error_now ("CHARACTER length must be a constant at %L", &expr
->where
);
1863 slen
= expr
->value
.character
.length
;
1866 s
= gfc_get_wide_string (len
+ 1);
1867 memcpy (s
, expr
->value
.character
.string
,
1868 MIN (len
, slen
) * sizeof (gfc_char_t
));
1870 gfc_wide_memset (&s
[slen
], ' ', len
- slen
);
1872 if (warn_character_truncation
&& slen
> len
)
1873 gfc_warning_now (OPT_Wcharacter_truncation
,
1874 "CHARACTER expression at %L is being truncated "
1875 "(%ld/%ld)", &expr
->where
,
1876 (long) slen
, (long) len
);
1878 /* Apply the standard by 'hand' otherwise it gets cleared for
1880 if (check_len
!= -1 && slen
!= check_len
1881 && !(gfc_option
.allow_std
& GFC_STD_GNU
))
1882 gfc_error_now ("The CHARACTER elements of the array constructor "
1883 "at %L must have the same length (%ld/%ld)",
1884 &expr
->where
, (long) slen
,
1888 free (expr
->value
.character
.string
);
1889 expr
->value
.character
.string
= s
;
1890 expr
->value
.character
.length
= len
;
1891 /* If explicit representation was given, clear it
1892 as it is no longer needed after padding. */
1893 if (expr
->representation
.length
)
1895 expr
->representation
.length
= 0;
1896 free (expr
->representation
.string
);
1897 expr
->representation
.string
= NULL
;
1903 /* Function to create and update the enumerator history
1904 using the information passed as arguments.
1905 Pointer "max_enum" is also updated, to point to
1906 enum history node containing largest initializer.
1908 SYM points to the symbol node of enumerator.
1909 INIT points to its enumerator value. */
1912 create_enum_history (gfc_symbol
*sym
, gfc_expr
*init
)
1914 enumerator_history
*new_enum_history
;
1915 gcc_assert (sym
!= NULL
&& init
!= NULL
);
1917 new_enum_history
= XCNEW (enumerator_history
);
1919 new_enum_history
->sym
= sym
;
1920 new_enum_history
->initializer
= init
;
1921 new_enum_history
->next
= NULL
;
1923 if (enum_history
== NULL
)
1925 enum_history
= new_enum_history
;
1926 max_enum
= enum_history
;
1930 new_enum_history
->next
= enum_history
;
1931 enum_history
= new_enum_history
;
1933 if (mpz_cmp (max_enum
->initializer
->value
.integer
,
1934 new_enum_history
->initializer
->value
.integer
) < 0)
1935 max_enum
= new_enum_history
;
1940 /* Function to free enum kind history. */
1943 gfc_free_enum_history (void)
1945 enumerator_history
*current
= enum_history
;
1946 enumerator_history
*next
;
1948 while (current
!= NULL
)
1950 next
= current
->next
;
1955 enum_history
= NULL
;
1959 /* Function called by variable_decl() that adds an initialization
1960 expression to a symbol. */
1963 add_init_expr_to_sym (const char *name
, gfc_expr
**initp
, locus
*var_locus
)
1965 symbol_attribute attr
;
1970 if (find_special (name
, &sym
, false))
1975 /* If this symbol is confirming an implicit parameter type,
1976 then an initialization expression is not allowed. */
1977 if (attr
.flavor
== FL_PARAMETER
&& sym
->value
!= NULL
)
1981 gfc_error ("Initializer not allowed for PARAMETER %qs at %C",
1991 /* An initializer is required for PARAMETER declarations. */
1992 if (attr
.flavor
== FL_PARAMETER
)
1994 gfc_error ("PARAMETER at %L is missing an initializer", var_locus
);
2000 /* If a variable appears in a DATA block, it cannot have an
2004 gfc_error ("Variable %qs at %C with an initializer already "
2005 "appears in a DATA statement", sym
->name
);
2009 /* Check if the assignment can happen. This has to be put off
2010 until later for derived type variables and procedure pointers. */
2011 if (!gfc_bt_struct (sym
->ts
.type
) && !gfc_bt_struct (init
->ts
.type
)
2012 && sym
->ts
.type
!= BT_CLASS
&& init
->ts
.type
!= BT_CLASS
2013 && !sym
->attr
.proc_pointer
2014 && !gfc_check_assign_symbol (sym
, NULL
, init
))
2017 if (sym
->ts
.type
== BT_CHARACTER
&& sym
->ts
.u
.cl
2018 && init
->ts
.type
== BT_CHARACTER
)
2020 /* Update symbol character length according initializer. */
2021 if (!gfc_check_assign_symbol (sym
, NULL
, init
))
2024 if (sym
->ts
.u
.cl
->length
== NULL
)
2027 /* If there are multiple CHARACTER variables declared on the
2028 same line, we don't want them to share the same length. */
2029 sym
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2031 if (sym
->attr
.flavor
== FL_PARAMETER
)
2033 if (init
->expr_type
== EXPR_CONSTANT
)
2035 clen
= init
->value
.character
.length
;
2036 sym
->ts
.u
.cl
->length
2037 = gfc_get_int_expr (gfc_charlen_int_kind
,
2040 else if (init
->expr_type
== EXPR_ARRAY
)
2042 if (init
->ts
.u
.cl
&& init
->ts
.u
.cl
->length
)
2044 const gfc_expr
*length
= init
->ts
.u
.cl
->length
;
2045 if (length
->expr_type
!= EXPR_CONSTANT
)
2047 gfc_error ("Cannot initialize parameter array "
2049 "with variable length elements",
2053 clen
= mpz_get_si (length
->value
.integer
);
2055 else if (init
->value
.constructor
)
2058 c
= gfc_constructor_first (init
->value
.constructor
);
2059 clen
= c
->expr
->value
.character
.length
;
2063 sym
->ts
.u
.cl
->length
2064 = gfc_get_int_expr (gfc_charlen_int_kind
,
2067 else if (init
->ts
.u
.cl
&& init
->ts
.u
.cl
->length
)
2068 sym
->ts
.u
.cl
->length
=
2069 gfc_copy_expr (init
->ts
.u
.cl
->length
);
2072 /* Update initializer character length according symbol. */
2073 else if (sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2075 if (!gfc_specification_expr (sym
->ts
.u
.cl
->length
))
2078 int k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
,
2080 /* resolve_charlen will complain later on if the length
2081 is too large. Just skeep the initialization in that case. */
2082 if (mpz_cmp (sym
->ts
.u
.cl
->length
->value
.integer
,
2083 gfc_integer_kinds
[k
].huge
) <= 0)
2086 = gfc_mpz_get_hwi (sym
->ts
.u
.cl
->length
->value
.integer
);
2088 if (init
->expr_type
== EXPR_CONSTANT
)
2089 gfc_set_constant_character_len (len
, init
, -1);
2090 else if (init
->expr_type
== EXPR_ARRAY
)
2094 /* Build a new charlen to prevent simplification from
2095 deleting the length before it is resolved. */
2096 init
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2097 init
->ts
.u
.cl
->length
2098 = gfc_copy_expr (sym
->ts
.u
.cl
->length
);
2100 for (c
= gfc_constructor_first (init
->value
.constructor
);
2101 c
; c
= gfc_constructor_next (c
))
2102 gfc_set_constant_character_len (len
, c
->expr
, -1);
2108 if (sym
->attr
.flavor
== FL_PARAMETER
&& sym
->attr
.dimension
&& sym
->as
2109 && sym
->as
->rank
&& init
->rank
&& init
->rank
!= sym
->as
->rank
)
2111 gfc_error ("Rank mismatch of array at %L and its initializer "
2112 "(%d/%d)", &sym
->declared_at
, sym
->as
->rank
, init
->rank
);
2116 /* If sym is implied-shape, set its upper bounds from init. */
2117 if (sym
->attr
.flavor
== FL_PARAMETER
&& sym
->attr
.dimension
2118 && sym
->as
->type
== AS_IMPLIED_SHAPE
)
2122 if (init
->rank
== 0)
2124 gfc_error ("Cannot initialize implied-shape array at %L"
2125 " with scalar", &sym
->declared_at
);
2129 /* The shape may be NULL for EXPR_ARRAY, set it. */
2130 if (init
->shape
== NULL
)
2132 gcc_assert (init
->expr_type
== EXPR_ARRAY
);
2133 init
->shape
= gfc_get_shape (1);
2134 if (!gfc_array_size (init
, &init
->shape
[0]))
2135 gfc_internal_error ("gfc_array_size failed");
2138 for (dim
= 0; dim
< sym
->as
->rank
; ++dim
)
2141 gfc_expr
*e
, *lower
;
2143 lower
= sym
->as
->lower
[dim
];
2145 /* If the lower bound is an array element from another
2146 parameterized array, then it is marked with EXPR_VARIABLE and
2147 is an initialization expression. Try to reduce it. */
2148 if (lower
->expr_type
== EXPR_VARIABLE
)
2149 gfc_reduce_init_expr (lower
);
2151 if (lower
->expr_type
== EXPR_CONSTANT
)
2153 /* All dimensions must be without upper bound. */
2154 gcc_assert (!sym
->as
->upper
[dim
]);
2157 e
= gfc_get_constant_expr (BT_INTEGER
, k
, &sym
->declared_at
);
2158 mpz_add (e
->value
.integer
, lower
->value
.integer
,
2160 mpz_sub_ui (e
->value
.integer
, e
->value
.integer
, 1);
2161 sym
->as
->upper
[dim
] = e
;
2165 gfc_error ("Non-constant lower bound in implied-shape"
2166 " declaration at %L", &lower
->where
);
2171 sym
->as
->type
= AS_EXPLICIT
;
2174 /* Ensure that explicit bounds are simplified. */
2175 if (sym
->attr
.flavor
== FL_PARAMETER
&& sym
->attr
.dimension
2176 && sym
->as
->type
== AS_EXPLICIT
)
2178 for (int dim
= 0; dim
< sym
->as
->rank
; ++dim
)
2182 e
= sym
->as
->lower
[dim
];
2183 if (e
->expr_type
!= EXPR_CONSTANT
)
2184 gfc_reduce_init_expr (e
);
2186 e
= sym
->as
->upper
[dim
];
2187 if (e
->expr_type
!= EXPR_CONSTANT
)
2188 gfc_reduce_init_expr (e
);
2192 /* Need to check if the expression we initialized this
2193 to was one of the iso_c_binding named constants. If so,
2194 and we're a parameter (constant), let it be iso_c.
2196 integer(c_int), parameter :: my_int = c_int
2197 integer(my_int) :: my_int_2
2198 If we mark my_int as iso_c (since we can see it's value
2199 is equal to one of the named constants), then my_int_2
2200 will be considered C interoperable. */
2201 if (sym
->ts
.type
!= BT_CHARACTER
&& !gfc_bt_struct (sym
->ts
.type
))
2203 sym
->ts
.is_iso_c
|= init
->ts
.is_iso_c
;
2204 sym
->ts
.is_c_interop
|= init
->ts
.is_c_interop
;
2205 /* attr bits needed for module files. */
2206 sym
->attr
.is_iso_c
|= init
->ts
.is_iso_c
;
2207 sym
->attr
.is_c_interop
|= init
->ts
.is_c_interop
;
2208 if (init
->ts
.is_iso_c
)
2209 sym
->ts
.f90_type
= init
->ts
.f90_type
;
2212 /* Add initializer. Make sure we keep the ranks sane. */
2213 if (sym
->attr
.dimension
&& init
->rank
== 0)
2218 if (sym
->attr
.flavor
== FL_PARAMETER
2219 && gfc_is_constant_expr (init
)
2220 && (init
->expr_type
== EXPR_CONSTANT
2221 || init
->expr_type
== EXPR_STRUCTURE
)
2222 && spec_size (sym
->as
, &size
)
2223 && mpz_cmp_si (size
, 0) > 0)
2225 array
= gfc_get_array_expr (init
->ts
.type
, init
->ts
.kind
,
2227 if (init
->ts
.type
== BT_DERIVED
)
2228 array
->ts
.u
.derived
= init
->ts
.u
.derived
;
2229 for (n
= 0; n
< (int)mpz_get_si (size
); n
++)
2230 gfc_constructor_append_expr (&array
->value
.constructor
,
2233 : gfc_copy_expr (init
),
2236 array
->shape
= gfc_get_shape (sym
->as
->rank
);
2237 for (n
= 0; n
< sym
->as
->rank
; n
++)
2238 spec_dimen_size (sym
->as
, n
, &array
->shape
[n
]);
2243 init
->rank
= sym
->as
->rank
;
2247 if (sym
->attr
.save
== SAVE_NONE
)
2248 sym
->attr
.save
= SAVE_IMPLICIT
;
2256 /* Function called by variable_decl() that adds a name to a structure
2260 build_struct (const char *name
, gfc_charlen
*cl
, gfc_expr
**init
,
2261 gfc_array_spec
**as
)
2266 /* F03:C438/C439. If the current symbol is of the same derived type that we're
2267 constructing, it must have the pointer attribute. */
2268 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
2269 && current_ts
.u
.derived
== gfc_current_block ()
2270 && current_attr
.pointer
== 0)
2272 if (current_attr
.allocatable
2273 && !gfc_notify_std(GFC_STD_F2008
, "Component at %C "
2274 "must have the POINTER attribute"))
2278 else if (current_attr
.allocatable
== 0)
2280 gfc_error ("Component at %C must have the POINTER attribute");
2286 if (current_ts
.type
== BT_CLASS
2287 && !(current_attr
.pointer
|| current_attr
.allocatable
))
2289 gfc_error ("Component %qs with CLASS at %C must be allocatable "
2290 "or pointer", name
);
2294 if (gfc_current_block ()->attr
.pointer
&& (*as
)->rank
!= 0)
2296 if ((*as
)->type
!= AS_DEFERRED
&& (*as
)->type
!= AS_EXPLICIT
)
2298 gfc_error ("Array component of structure at %C must have explicit "
2299 "or deferred shape");
2304 /* If we are in a nested union/map definition, gfc_add_component will not
2305 properly find repeated components because:
2306 (i) gfc_add_component does a flat search, where components of unions
2307 and maps are implicity chained so nested components may conflict.
2308 (ii) Unions and maps are not linked as components of their parent
2309 structures until after they are parsed.
2310 For (i) we use gfc_find_component which searches recursively, and for (ii)
2311 we search each block directly from the parse stack until we find the top
2314 s
= gfc_state_stack
;
2315 if (s
->state
== COMP_UNION
|| s
->state
== COMP_MAP
)
2317 while (s
->state
== COMP_UNION
|| gfc_comp_struct (s
->state
))
2319 c
= gfc_find_component (s
->sym
, name
, true, true, NULL
);
2322 gfc_error_now ("Component %qs at %C already declared at %L",
2326 /* Break after we've searched the entire chain. */
2327 if (s
->state
== COMP_DERIVED
|| s
->state
== COMP_STRUCTURE
)
2333 if (!gfc_add_component (gfc_current_block(), name
, &c
))
2337 if (c
->ts
.type
== BT_CHARACTER
)
2340 if (c
->ts
.type
!= BT_CLASS
&& c
->ts
.type
!= BT_DERIVED
2341 && (c
->ts
.kind
== 0 || c
->ts
.type
== BT_CHARACTER
)
2342 && saved_kind_expr
!= NULL
)
2343 c
->kind_expr
= gfc_copy_expr (saved_kind_expr
);
2345 c
->attr
= current_attr
;
2347 c
->initializer
= *init
;
2354 c
->attr
.codimension
= 1;
2356 c
->attr
.dimension
= 1;
2360 gfc_apply_init (&c
->ts
, &c
->attr
, c
->initializer
);
2362 /* Check array components. */
2363 if (!c
->attr
.dimension
)
2366 if (c
->attr
.pointer
)
2368 if (c
->as
->type
!= AS_DEFERRED
)
2370 gfc_error ("Pointer array component of structure at %C must have a "
2375 else if (c
->attr
.allocatable
)
2377 if (c
->as
->type
!= AS_DEFERRED
)
2379 gfc_error ("Allocatable component of structure at %C must have a "
2386 if (c
->as
->type
!= AS_EXPLICIT
)
2388 gfc_error ("Array component of structure at %C must have an "
2395 if (c
->ts
.type
== BT_CLASS
)
2396 return gfc_build_class_symbol (&c
->ts
, &c
->attr
, &c
->as
);
2398 if (c
->attr
.pdt_kind
|| c
->attr
.pdt_len
)
2401 gfc_find_symbol (c
->name
, gfc_current_block ()->f2k_derived
,
2405 gfc_error ("Type parameter %qs at %C has no corresponding entry "
2406 "in the type parameter name list at %L",
2407 c
->name
, &gfc_current_block ()->declared_at
);
2411 sym
->attr
.pdt_kind
= c
->attr
.pdt_kind
;
2412 sym
->attr
.pdt_len
= c
->attr
.pdt_len
;
2414 sym
->value
= gfc_copy_expr (c
->initializer
);
2415 sym
->attr
.flavor
= FL_VARIABLE
;
2418 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
2419 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_template
2420 && decl_type_param_list
)
2421 c
->param_list
= gfc_copy_actual_arglist (decl_type_param_list
);
2427 /* Match a 'NULL()', and possibly take care of some side effects. */
2430 gfc_match_null (gfc_expr
**result
)
2433 match m
, m2
= MATCH_NO
;
2435 if ((m
= gfc_match (" null ( )")) == MATCH_ERROR
)
2441 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2443 if ((m2
= gfc_match (" null (")) != MATCH_YES
)
2446 old_loc
= gfc_current_locus
;
2447 if ((m2
= gfc_match (" %n ) ", name
)) == MATCH_ERROR
)
2450 && ((m2
= gfc_match (" mold = %n )", name
)) == MATCH_ERROR
))
2454 gfc_current_locus
= old_loc
;
2459 /* The NULL symbol now has to be/become an intrinsic function. */
2460 if (gfc_get_symbol ("null", NULL
, &sym
))
2462 gfc_error ("NULL() initialization at %C is ambiguous");
2466 gfc_intrinsic_symbol (sym
);
2468 if (sym
->attr
.proc
!= PROC_INTRINSIC
2469 && !(sym
->attr
.use_assoc
&& sym
->attr
.intrinsic
)
2470 && (!gfc_add_procedure(&sym
->attr
, PROC_INTRINSIC
, sym
->name
, NULL
)
2471 || !gfc_add_function (&sym
->attr
, sym
->name
, NULL
)))
2474 *result
= gfc_get_null_expr (&gfc_current_locus
);
2476 /* Invalid per F2008, C512. */
2477 if (m2
== MATCH_YES
)
2479 gfc_error ("NULL() initialization at %C may not have MOLD");
2487 /* Match the initialization expr for a data pointer or procedure pointer. */
2490 match_pointer_init (gfc_expr
**init
, int procptr
)
2494 if (gfc_pure (NULL
) && !gfc_comp_struct (gfc_state_stack
->state
))
2496 gfc_error ("Initialization of pointer at %C is not allowed in "
2497 "a PURE procedure");
2500 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
2502 /* Match NULL() initialization. */
2503 m
= gfc_match_null (init
);
2507 /* Match non-NULL initialization. */
2508 gfc_matching_ptr_assignment
= !procptr
;
2509 gfc_matching_procptr_assignment
= procptr
;
2510 m
= gfc_match_rvalue (init
);
2511 gfc_matching_ptr_assignment
= 0;
2512 gfc_matching_procptr_assignment
= 0;
2513 if (m
== MATCH_ERROR
)
2515 else if (m
== MATCH_NO
)
2517 gfc_error ("Error in pointer initialization at %C");
2521 if (!procptr
&& !gfc_resolve_expr (*init
))
2524 if (!gfc_notify_std (GFC_STD_F2008
, "non-NULL pointer "
2525 "initialization at %C"))
2533 check_function_name (char *name
)
2535 /* In functions that have a RESULT variable defined, the function name always
2536 refers to function calls. Therefore, the name is not allowed to appear in
2537 specification statements. When checking this, be careful about
2538 'hidden' procedure pointer results ('ppr@'). */
2540 if (gfc_current_state () == COMP_FUNCTION
)
2542 gfc_symbol
*block
= gfc_current_block ();
2543 if (block
&& block
->result
&& block
->result
!= block
2544 && strcmp (block
->result
->name
, "ppr@") != 0
2545 && strcmp (block
->name
, name
) == 0)
2547 gfc_error ("RESULT variable %qs at %L prohibits FUNCTION name %qs at %C "
2548 "from appearing in a specification statement",
2549 block
->result
->name
, &block
->result
->declared_at
, name
);
2558 /* Match a variable name with an optional initializer. When this
2559 subroutine is called, a variable is expected to be parsed next.
2560 Depending on what is happening at the moment, updates either the
2561 symbol table or the current interface. */
2564 variable_decl (int elem
)
2566 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2567 static unsigned int fill_id
= 0;
2568 gfc_expr
*initializer
, *char_len
;
2570 gfc_array_spec
*cp_as
; /* Extra copy for Cray Pointees. */
2583 /* When we get here, we've just matched a list of attributes and
2584 maybe a type and a double colon. The next thing we expect to see
2585 is the name of the symbol. */
2587 /* If we are parsing a structure with legacy support, we allow the symbol
2588 name to be '%FILL' which gives it an anonymous (inaccessible) name. */
2590 gfc_gobble_whitespace ();
2591 c
= gfc_peek_ascii_char ();
2594 gfc_next_ascii_char (); /* Burn % character. */
2595 m
= gfc_match ("fill");
2598 if (gfc_current_state () != COMP_STRUCTURE
)
2600 if (flag_dec_structure
)
2601 gfc_error ("%qs not allowed outside STRUCTURE at %C", "%FILL");
2603 gfc_error ("%qs at %C is a DEC extension, enable with "
2604 "%<-fdec-structure%>", "%FILL");
2611 gfc_error ("%qs entity cannot have attributes at %C", "%FILL");
2616 /* %FILL components are given invalid fortran names. */
2617 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "%%FILL%u", fill_id
++);
2621 gfc_error ("Invalid character %qc in variable name at %C", c
);
2627 m
= gfc_match_name (name
);
2632 var_locus
= gfc_current_locus
;
2634 /* Now we could see the optional array spec. or character length. */
2635 m
= gfc_match_array_spec (&as
, true, true);
2636 if (m
== MATCH_ERROR
)
2640 as
= gfc_copy_array_spec (current_as
);
2642 && !merge_array_spec (current_as
, as
, true))
2648 if (flag_cray_pointer
)
2649 cp_as
= gfc_copy_array_spec (as
);
2651 /* At this point, we know for sure if the symbol is PARAMETER and can thus
2652 determine (and check) whether it can be implied-shape. If it
2653 was parsed as assumed-size, change it because PARAMETERs cannot
2656 An explicit-shape-array cannot appear under several conditions.
2657 That check is done here as well. */
2660 if (as
->type
== AS_IMPLIED_SHAPE
&& current_attr
.flavor
!= FL_PARAMETER
)
2663 gfc_error ("Non-PARAMETER symbol %qs at %L cannot be implied-shape",
2668 if (as
->type
== AS_ASSUMED_SIZE
&& as
->rank
== 1
2669 && current_attr
.flavor
== FL_PARAMETER
)
2670 as
->type
= AS_IMPLIED_SHAPE
;
2672 if (as
->type
== AS_IMPLIED_SHAPE
2673 && !gfc_notify_std (GFC_STD_F2008
, "Implied-shape array at %L",
2680 gfc_seen_div0
= false;
2682 /* F2018:C830 (R816) An explicit-shape-spec whose bounds are not
2683 constant expressions shall appear only in a subprogram, derived
2684 type definition, BLOCK construct, or interface body. */
2685 if (as
->type
== AS_EXPLICIT
2686 && gfc_current_state () != COMP_BLOCK
2687 && gfc_current_state () != COMP_DERIVED
2688 && gfc_current_state () != COMP_FUNCTION
2689 && gfc_current_state () != COMP_INTERFACE
2690 && gfc_current_state () != COMP_SUBROUTINE
)
2693 bool not_constant
= false;
2695 for (int i
= 0; i
< as
->rank
; i
++)
2697 e
= gfc_copy_expr (as
->lower
[i
]);
2698 if (!gfc_resolve_expr (e
) && gfc_seen_div0
)
2704 gfc_simplify_expr (e
, 0);
2705 if (e
&& (e
->expr_type
!= EXPR_CONSTANT
))
2707 not_constant
= true;
2712 e
= gfc_copy_expr (as
->upper
[i
]);
2713 if (!gfc_resolve_expr (e
) && gfc_seen_div0
)
2719 gfc_simplify_expr (e
, 0);
2720 if (e
&& (e
->expr_type
!= EXPR_CONSTANT
))
2722 not_constant
= true;
2728 if (not_constant
&& e
->ts
.type
!= BT_INTEGER
)
2730 gfc_error ("Explicit array shape at %C must be constant of "
2731 "INTEGER type and not %s type",
2732 gfc_basic_typename (e
->ts
.type
));
2738 gfc_error ("Explicit shaped array with nonconstant bounds at %C");
2743 if (as
->type
== AS_EXPLICIT
)
2745 for (int i
= 0; i
< as
->rank
; i
++)
2749 if (e
->expr_type
!= EXPR_CONSTANT
)
2751 n
= gfc_copy_expr (e
);
2752 if (!gfc_simplify_expr (n
, 1) && gfc_seen_div0
)
2758 if (n
->expr_type
== EXPR_CONSTANT
)
2759 gfc_replace_expr (e
, n
);
2764 if (e
->expr_type
!= EXPR_CONSTANT
)
2766 n
= gfc_copy_expr (e
);
2767 if (!gfc_simplify_expr (n
, 1) && gfc_seen_div0
)
2773 if (n
->expr_type
== EXPR_CONSTANT
)
2774 gfc_replace_expr (e
, n
);
2784 cl_deferred
= false;
2786 if (current_ts
.type
== BT_CHARACTER
)
2788 switch (match_char_length (&char_len
, &cl_deferred
, false))
2791 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2793 cl
->length
= char_len
;
2796 /* Non-constant lengths need to be copied after the first
2797 element. Also copy assumed lengths. */
2800 && (current_ts
.u
.cl
->length
== NULL
2801 || current_ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
2803 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2804 cl
->length
= gfc_copy_expr (current_ts
.u
.cl
->length
);
2807 cl
= current_ts
.u
.cl
;
2809 cl_deferred
= current_ts
.deferred
;
2818 /* The dummy arguments and result of the abreviated form of MODULE
2819 PROCEDUREs, used in SUBMODULES should not be redefined. */
2820 if (gfc_current_ns
->proc_name
2821 && gfc_current_ns
->proc_name
->abr_modproc_decl
)
2823 gfc_find_symbol (name
, gfc_current_ns
, 1, &sym
);
2824 if (sym
!= NULL
&& (sym
->attr
.dummy
|| sym
->attr
.result
))
2827 gfc_error ("%qs at %C is a redefinition of the declaration "
2828 "in the corresponding interface for MODULE "
2829 "PROCEDURE %qs", sym
->name
,
2830 gfc_current_ns
->proc_name
->name
);
2835 /* %FILL components may not have initializers. */
2836 if (startswith (name
, "%FILL") && gfc_match_eos () != MATCH_YES
)
2838 gfc_error ("%qs entity cannot have an initializer at %C", "%FILL");
2843 /* If this symbol has already shown up in a Cray Pointer declaration,
2844 and this is not a component declaration,
2845 then we want to set the type & bail out. */
2846 if (flag_cray_pointer
&& !gfc_comp_struct (gfc_current_state ()))
2848 gfc_find_symbol (name
, gfc_current_ns
, 0, &sym
);
2849 if (sym
!= NULL
&& sym
->attr
.cray_pointee
)
2852 if (!gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
2858 /* Check to see if we have an array specification. */
2861 if (sym
->as
!= NULL
)
2863 gfc_error ("Duplicate array spec for Cray pointee at %C");
2864 gfc_free_array_spec (cp_as
);
2870 if (!gfc_set_array_spec (sym
, cp_as
, &var_locus
))
2871 gfc_internal_error ("Cannot set pointee array spec.");
2873 /* Fix the array spec. */
2874 m
= gfc_mod_pointee_as (sym
->as
);
2875 if (m
== MATCH_ERROR
)
2883 gfc_free_array_spec (cp_as
);
2887 /* Procedure pointer as function result. */
2888 if (gfc_current_state () == COMP_FUNCTION
2889 && strcmp ("ppr@", gfc_current_block ()->name
) == 0
2890 && strcmp (name
, gfc_current_block ()->ns
->proc_name
->name
) == 0)
2891 strcpy (name
, "ppr@");
2893 if (gfc_current_state () == COMP_FUNCTION
2894 && strcmp (name
, gfc_current_block ()->name
) == 0
2895 && gfc_current_block ()->result
2896 && strcmp ("ppr@", gfc_current_block ()->result
->name
) == 0)
2897 strcpy (name
, "ppr@");
2899 /* OK, we've successfully matched the declaration. Now put the
2900 symbol in the current namespace, because it might be used in the
2901 optional initialization expression for this symbol, e.g. this is
2904 integer, parameter :: i = huge(i)
2906 This is only true for parameters or variables of a basic type.
2907 For components of derived types, it is not true, so we don't
2908 create a symbol for those yet. If we fail to create the symbol,
2910 if (!gfc_comp_struct (gfc_current_state ())
2911 && !build_sym (name
, cl
, cl_deferred
, &as
, &var_locus
))
2917 if (!check_function_name (name
))
2923 /* We allow old-style initializations of the form
2924 integer i /2/, j(4) /3*3, 1/
2925 (if no colon has been seen). These are different from data
2926 statements in that initializers are only allowed to apply to the
2927 variable immediately preceding, i.e.
2929 is not allowed. Therefore we have to do some work manually, that
2930 could otherwise be left to the matchers for DATA statements. */
2932 if (!colon_seen
&& gfc_match (" /") == MATCH_YES
)
2934 if (!gfc_notify_std (GFC_STD_GNU
, "Old-style "
2935 "initialization at %C"))
2938 /* Allow old style initializations for components of STRUCTUREs and MAPs
2939 but not components of derived types. */
2940 else if (gfc_current_state () == COMP_DERIVED
)
2942 gfc_error ("Invalid old style initialization for derived type "
2948 /* For structure components, read the initializer as a special
2949 expression and let the rest of this function apply the initializer
2951 else if (gfc_comp_struct (gfc_current_state ()))
2953 m
= match_clist_expr (&initializer
, ¤t_ts
, as
);
2955 gfc_error ("Syntax error in old style initialization of %s at %C",
2961 /* Otherwise we treat the old style initialization just like a
2962 DATA declaration for the current variable. */
2964 return match_old_style_init (name
);
2967 /* The double colon must be present in order to have initializers.
2968 Otherwise the statement is ambiguous with an assignment statement. */
2971 if (gfc_match (" =>") == MATCH_YES
)
2973 if (!current_attr
.pointer
)
2975 gfc_error ("Initialization at %C isn't for a pointer variable");
2980 m
= match_pointer_init (&initializer
, 0);
2984 /* The target of a pointer initialization must have the SAVE
2985 attribute. A variable in PROGRAM, MODULE, or SUBMODULE scope
2986 is implicit SAVEd. Explicitly, set the SAVE_IMPLICIT value. */
2987 if (initializer
->expr_type
== EXPR_VARIABLE
2988 && initializer
->symtree
->n
.sym
->attr
.save
== SAVE_NONE
2989 && (gfc_current_state () == COMP_PROGRAM
2990 || gfc_current_state () == COMP_MODULE
2991 || gfc_current_state () == COMP_SUBMODULE
))
2992 initializer
->symtree
->n
.sym
->attr
.save
= SAVE_IMPLICIT
;
2994 else if (gfc_match_char ('=') == MATCH_YES
)
2996 if (current_attr
.pointer
)
2998 gfc_error ("Pointer initialization at %C requires %<=>%>, "
3004 m
= gfc_match_init_expr (&initializer
);
3007 gfc_error ("Expected an initialization expression at %C");
3011 if (current_attr
.flavor
!= FL_PARAMETER
&& gfc_pure (NULL
)
3012 && !gfc_comp_struct (gfc_state_stack
->state
))
3014 gfc_error ("Initialization of variable at %C is not allowed in "
3015 "a PURE procedure");
3019 if (current_attr
.flavor
!= FL_PARAMETER
3020 && !gfc_comp_struct (gfc_state_stack
->state
))
3021 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
3028 if (initializer
!= NULL
&& current_attr
.allocatable
3029 && gfc_comp_struct (gfc_current_state ()))
3031 gfc_error ("Initialization of allocatable component at %C is not "
3037 if (gfc_current_state () == COMP_DERIVED
3038 && initializer
&& initializer
->ts
.type
== BT_HOLLERITH
)
3040 gfc_error ("Initialization of structure component with a HOLLERITH "
3041 "constant at %L is not allowed", &initializer
->where
);
3046 if (gfc_current_state () == COMP_DERIVED
3047 && gfc_current_block ()->attr
.pdt_template
)
3050 gfc_find_symbol (name
, gfc_current_block ()->f2k_derived
,
3052 if (!param
&& (current_attr
.pdt_kind
|| current_attr
.pdt_len
))
3054 gfc_error ("The component with KIND or LEN attribute at %C does not "
3055 "not appear in the type parameter list at %L",
3056 &gfc_current_block ()->declared_at
);
3060 else if (param
&& !(current_attr
.pdt_kind
|| current_attr
.pdt_len
))
3062 gfc_error ("The component at %C that appears in the type parameter "
3063 "list at %L has neither the KIND nor LEN attribute",
3064 &gfc_current_block ()->declared_at
);
3068 else if (as
&& (current_attr
.pdt_kind
|| current_attr
.pdt_len
))
3070 gfc_error ("The component at %C which is a type parameter must be "
3075 else if (param
&& initializer
)
3077 if (initializer
->ts
.type
== BT_BOZ
)
3079 gfc_error ("BOZ literal constant at %L cannot appear as an "
3080 "initializer", &initializer
->where
);
3084 param
->value
= gfc_copy_expr (initializer
);
3088 /* Before adding a possible initilizer, do a simple check for compatibility
3089 of lhs and rhs types. Assigning a REAL value to a derived type is not a
3091 if (current_ts
.type
== BT_DERIVED
&& initializer
3092 && (gfc_numeric_ts (&initializer
->ts
)
3093 || initializer
->ts
.type
== BT_LOGICAL
3094 || initializer
->ts
.type
== BT_CHARACTER
))
3096 gfc_error ("Incompatible initialization between a derived type "
3097 "entity and an entity with %qs type at %C",
3098 gfc_typename (initializer
));
3104 /* Add the initializer. Note that it is fine if initializer is
3105 NULL here, because we sometimes also need to check if a
3106 declaration *must* have an initialization expression. */
3107 if (!gfc_comp_struct (gfc_current_state ()))
3108 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
3111 if (current_ts
.type
== BT_DERIVED
3112 && !current_attr
.pointer
&& !initializer
)
3113 initializer
= gfc_default_initializer (¤t_ts
);
3114 t
= build_struct (name
, cl
, &initializer
, &as
);
3116 /* If we match a nested structure definition we expect to see the
3117 * body even if the variable declarations blow up, so we need to keep
3118 * the structure declaration around. */
3119 if (gfc_new_block
&& gfc_new_block
->attr
.flavor
== FL_STRUCT
)
3120 gfc_commit_symbol (gfc_new_block
);
3123 m
= (t
) ? MATCH_YES
: MATCH_ERROR
;
3126 /* Free stuff up and return. */
3127 gfc_seen_div0
= false;
3128 gfc_free_expr (initializer
);
3129 gfc_free_array_spec (as
);
3135 /* Match an extended-f77 "TYPESPEC*bytesize"-style kind specification.
3136 This assumes that the byte size is equal to the kind number for
3137 non-COMPLEX types, and equal to twice the kind number for COMPLEX. */
3140 gfc_match_old_kind_spec (gfc_typespec
*ts
)
3145 if (gfc_match_char ('*') != MATCH_YES
)
3148 m
= gfc_match_small_literal_int (&ts
->kind
, NULL
);
3152 original_kind
= ts
->kind
;
3154 /* Massage the kind numbers for complex types. */
3155 if (ts
->type
== BT_COMPLEX
)
3159 gfc_error ("Old-style type declaration %s*%d not supported at %C",
3160 gfc_basic_typename (ts
->type
), original_kind
);
3167 if (ts
->type
== BT_INTEGER
&& ts
->kind
== 4 && flag_integer4_kind
== 8)
3170 if (ts
->type
== BT_REAL
|| ts
->type
== BT_COMPLEX
)
3174 if (flag_real4_kind
== 8)
3176 if (flag_real4_kind
== 10)
3178 if (flag_real4_kind
== 16)
3181 else if (ts
->kind
== 8)
3183 if (flag_real8_kind
== 4)
3185 if (flag_real8_kind
== 10)
3187 if (flag_real8_kind
== 16)
3192 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
3194 gfc_error ("Old-style type declaration %s*%d not supported at %C",
3195 gfc_basic_typename (ts
->type
), original_kind
);
3199 if (!gfc_notify_std (GFC_STD_GNU
,
3200 "Nonstandard type declaration %s*%d at %C",
3201 gfc_basic_typename(ts
->type
), original_kind
))
3208 /* Match a kind specification. Since kinds are generally optional, we
3209 usually return MATCH_NO if something goes wrong. If a "kind="
3210 string is found, then we know we have an error. */
3213 gfc_match_kind_spec (gfc_typespec
*ts
, bool kind_expr_only
)
3223 saved_kind_expr
= NULL
;
3225 where
= loc
= gfc_current_locus
;
3230 if (gfc_match_char ('(') == MATCH_NO
)
3233 /* Also gobbles optional text. */
3234 if (gfc_match (" kind = ") == MATCH_YES
)
3237 loc
= gfc_current_locus
;
3241 n
= gfc_match_init_expr (&e
);
3243 if (gfc_derived_parameter_expr (e
))
3246 saved_kind_expr
= gfc_copy_expr (e
);
3247 goto close_brackets
;
3252 if (gfc_matching_function
)
3254 /* The function kind expression might include use associated or
3255 imported parameters and try again after the specification
3257 if (gfc_match_char (')') != MATCH_YES
)
3259 gfc_error ("Missing right parenthesis at %C");
3265 gfc_undo_symbols ();
3270 /* ....or else, the match is real. */
3272 gfc_error ("Expected initialization expression at %C");
3280 gfc_error ("Expected scalar initialization expression at %C");
3285 if (gfc_extract_int (e
, &ts
->kind
, 1))
3291 /* Before throwing away the expression, let's see if we had a
3292 C interoperable kind (and store the fact). */
3293 if (e
->ts
.is_c_interop
== 1)
3295 /* Mark this as C interoperable if being declared with one
3296 of the named constants from iso_c_binding. */
3297 ts
->is_c_interop
= e
->ts
.is_iso_c
;
3298 ts
->f90_type
= e
->ts
.f90_type
;
3300 ts
->interop_kind
= e
->symtree
->n
.sym
;
3306 /* Ignore errors to this point, if we've gotten here. This means
3307 we ignore the m=MATCH_ERROR from above. */
3308 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
3310 gfc_error ("Kind %d not supported for type %s at %C", ts
->kind
,
3311 gfc_basic_typename (ts
->type
));
3312 gfc_current_locus
= where
;
3316 /* Warn if, e.g., c_int is used for a REAL variable, but not
3317 if, e.g., c_double is used for COMPLEX as the standard
3318 explicitly says that the kind type parameter for complex and real
3319 variable is the same, i.e. c_float == c_float_complex. */
3320 if (ts
->f90_type
!= BT_UNKNOWN
&& ts
->f90_type
!= ts
->type
3321 && !((ts
->f90_type
== BT_REAL
&& ts
->type
== BT_COMPLEX
)
3322 || (ts
->f90_type
== BT_COMPLEX
&& ts
->type
== BT_REAL
)))
3323 gfc_warning_now (0, "C kind type parameter is for type %s but type at %L "
3324 "is %s", gfc_basic_typename (ts
->f90_type
), &where
,
3325 gfc_basic_typename (ts
->type
));
3329 gfc_gobble_whitespace ();
3330 if ((c
= gfc_next_ascii_char ()) != ')'
3331 && (ts
->type
!= BT_CHARACTER
|| c
!= ','))
3333 if (ts
->type
== BT_CHARACTER
)
3334 gfc_error ("Missing right parenthesis or comma at %C");
3336 gfc_error ("Missing right parenthesis at %C");
3340 /* All tests passed. */
3343 if(m
== MATCH_ERROR
)
3344 gfc_current_locus
= where
;
3346 if (ts
->type
== BT_INTEGER
&& ts
->kind
== 4 && flag_integer4_kind
== 8)
3349 if (ts
->type
== BT_REAL
|| ts
->type
== BT_COMPLEX
)
3353 if (flag_real4_kind
== 8)
3355 if (flag_real4_kind
== 10)
3357 if (flag_real4_kind
== 16)
3360 else if (ts
->kind
== 8)
3362 if (flag_real8_kind
== 4)
3364 if (flag_real8_kind
== 10)
3366 if (flag_real8_kind
== 16)
3371 /* Return what we know from the test(s). */
3376 gfc_current_locus
= where
;
3382 match_char_kind (int * kind
, int * is_iso_c
)
3391 where
= gfc_current_locus
;
3393 n
= gfc_match_init_expr (&e
);
3395 if (n
!= MATCH_YES
&& gfc_matching_function
)
3397 /* The expression might include use-associated or imported
3398 parameters and try again after the specification
3401 gfc_undo_symbols ();
3406 gfc_error ("Expected initialization expression at %C");
3412 gfc_error ("Expected scalar initialization expression at %C");
3417 if (gfc_derived_parameter_expr (e
))
3419 saved_kind_expr
= e
;
3424 fail
= gfc_extract_int (e
, kind
, 1);
3425 *is_iso_c
= e
->ts
.is_iso_c
;
3434 /* Ignore errors to this point, if we've gotten here. This means
3435 we ignore the m=MATCH_ERROR from above. */
3436 if (gfc_validate_kind (BT_CHARACTER
, *kind
, true) < 0)
3438 gfc_error ("Kind %d is not supported for CHARACTER at %C", *kind
);
3442 /* All tests passed. */
3445 if (m
== MATCH_ERROR
)
3446 gfc_current_locus
= where
;
3448 /* Return what we know from the test(s). */
3453 gfc_current_locus
= where
;
3458 /* Match the various kind/length specifications in a CHARACTER
3459 declaration. We don't return MATCH_NO. */
3462 gfc_match_char_spec (gfc_typespec
*ts
)
3464 int kind
, seen_length
, is_iso_c
;
3476 /* Try the old-style specification first. */
3477 old_char_selector
= 0;
3479 m
= match_char_length (&len
, &deferred
, true);
3483 old_char_selector
= 1;
3488 m
= gfc_match_char ('(');
3491 m
= MATCH_YES
; /* Character without length is a single char. */
3495 /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ). */
3496 if (gfc_match (" kind =") == MATCH_YES
)
3498 m
= match_char_kind (&kind
, &is_iso_c
);
3500 if (m
== MATCH_ERROR
)
3505 if (gfc_match (" , len =") == MATCH_NO
)
3508 m
= char_len_param_value (&len
, &deferred
);
3511 if (m
== MATCH_ERROR
)
3518 /* Try to match "LEN = <len-param>" or "LEN = <len-param>, KIND = <int>". */
3519 if (gfc_match (" len =") == MATCH_YES
)
3521 m
= char_len_param_value (&len
, &deferred
);
3524 if (m
== MATCH_ERROR
)
3528 if (gfc_match_char (')') == MATCH_YES
)
3531 if (gfc_match (" , kind =") != MATCH_YES
)
3534 if (match_char_kind (&kind
, &is_iso_c
) == MATCH_ERROR
)
3540 /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ). */
3541 m
= char_len_param_value (&len
, &deferred
);
3544 if (m
== MATCH_ERROR
)
3548 m
= gfc_match_char (')');
3552 if (gfc_match_char (',') != MATCH_YES
)
3555 gfc_match (" kind ="); /* Gobble optional text. */
3557 m
= match_char_kind (&kind
, &is_iso_c
);
3558 if (m
== MATCH_ERROR
)
3564 /* Require a right-paren at this point. */
3565 m
= gfc_match_char (')');
3570 gfc_error ("Syntax error in CHARACTER declaration at %C");
3572 gfc_free_expr (len
);
3576 /* Deal with character functions after USE and IMPORT statements. */
3577 if (gfc_matching_function
)
3579 gfc_free_expr (len
);
3580 gfc_undo_symbols ();
3586 gfc_free_expr (len
);
3590 /* Do some final massaging of the length values. */
3591 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
3593 if (seen_length
== 0)
3594 cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
, 1);
3597 /* If gfortran ends up here, then len may be reducible to a constant.
3598 Try to do that here. If it does not reduce, simply assign len to
3599 charlen. A complication occurs with user-defined generic functions,
3600 which are not resolved. Use a private namespace to deal with
3601 generic functions. */
3603 if (len
&& len
->expr_type
!= EXPR_CONSTANT
)
3605 gfc_namespace
*old_ns
;
3608 old_ns
= gfc_current_ns
;
3609 gfc_current_ns
= gfc_get_namespace (NULL
, 0);
3611 e
= gfc_copy_expr (len
);
3612 gfc_reduce_init_expr (e
);
3613 if (e
->expr_type
== EXPR_CONSTANT
)
3615 gfc_replace_expr (len
, e
);
3616 if (mpz_cmp_si (len
->value
.integer
, 0) < 0)
3617 mpz_set_ui (len
->value
.integer
, 0);
3622 gfc_free_namespace (gfc_current_ns
);
3623 gfc_current_ns
= old_ns
;
3630 ts
->kind
= kind
== 0 ? gfc_default_character_kind
: kind
;
3631 ts
->deferred
= deferred
;
3633 /* We have to know if it was a C interoperable kind so we can
3634 do accurate type checking of bind(c) procs, etc. */
3636 /* Mark this as C interoperable if being declared with one
3637 of the named constants from iso_c_binding. */
3638 ts
->is_c_interop
= is_iso_c
;
3639 else if (len
!= NULL
)
3640 /* Here, we might have parsed something such as: character(c_char)
3641 In this case, the parsing code above grabs the c_char when
3642 looking for the length (line 1690, roughly). it's the last
3643 testcase for parsing the kind params of a character variable.
3644 However, it's not actually the length. this seems like it
3646 To see if the user used a C interop kind, test the expr
3647 of the so called length, and see if it's C interoperable. */
3648 ts
->is_c_interop
= len
->ts
.is_iso_c
;
3654 /* Matches a RECORD declaration. */
3657 match_record_decl (char *name
)
3660 old_loc
= gfc_current_locus
;
3663 m
= gfc_match (" record /");
3666 if (!flag_dec_structure
)
3668 gfc_current_locus
= old_loc
;
3669 gfc_error ("RECORD at %C is an extension, enable it with "
3670 "%<-fdec-structure%>");
3673 m
= gfc_match (" %n/", name
);
3678 gfc_current_locus
= old_loc
;
3679 if (flag_dec_structure
3680 && (gfc_match (" record% ") == MATCH_YES
3681 || gfc_match (" record%t") == MATCH_YES
))
3682 gfc_error ("Structure name expected after RECORD at %C");
3690 /* This function uses the gfc_actual_arglist 'type_param_spec_list' as a source
3691 of expressions to substitute into the possibly parameterized expression
3692 'e'. Using a list is inefficient but should not be too bad since the
3693 number of type parameters is not likely to be large. */
3695 insert_parameter_exprs (gfc_expr
* e
, gfc_symbol
* sym ATTRIBUTE_UNUSED
,
3698 gfc_actual_arglist
*param
;
3701 if (e
->expr_type
!= EXPR_VARIABLE
)
3704 gcc_assert (e
->symtree
);
3705 if (e
->symtree
->n
.sym
->attr
.pdt_kind
3706 || (*f
!= 0 && e
->symtree
->n
.sym
->attr
.pdt_len
))
3708 for (param
= type_param_spec_list
; param
; param
= param
->next
)
3709 if (strcmp (e
->symtree
->n
.sym
->name
, param
->name
) == 0)
3714 copy
= gfc_copy_expr (param
->expr
);
3725 gfc_insert_kind_parameter_exprs (gfc_expr
*e
)
3727 return gfc_traverse_expr (e
, NULL
, &insert_parameter_exprs
, 0);
3732 gfc_insert_parameter_exprs (gfc_expr
*e
, gfc_actual_arglist
*param_list
)
3734 gfc_actual_arglist
*old_param_spec_list
= type_param_spec_list
;
3735 type_param_spec_list
= param_list
;
3736 bool res
= gfc_traverse_expr (e
, NULL
, &insert_parameter_exprs
, 1);
3737 type_param_spec_list
= old_param_spec_list
;
3741 /* Determines the instance of a parameterized derived type to be used by
3742 matching determining the values of the kind parameters and using them
3743 in the name of the instance. If the instance exists, it is used, otherwise
3744 a new derived type is created. */
3746 gfc_get_pdt_instance (gfc_actual_arglist
*param_list
, gfc_symbol
**sym
,
3747 gfc_actual_arglist
**ext_param_list
)
3749 /* The PDT template symbol. */
3750 gfc_symbol
*pdt
= *sym
;
3751 /* The symbol for the parameter in the template f2k_namespace. */
3753 /* The hoped for instance of the PDT. */
3754 gfc_symbol
*instance
;
3755 /* The list of parameters appearing in the PDT declaration. */
3756 gfc_formal_arglist
*type_param_name_list
;
3757 /* Used to store the parameter specification list during recursive calls. */
3758 gfc_actual_arglist
*old_param_spec_list
;
3759 /* Pointers to the parameter specification being used. */
3760 gfc_actual_arglist
*actual_param
;
3761 gfc_actual_arglist
*tail
= NULL
;
3762 /* Used to build up the name of the PDT instance. The prefix uses 4
3763 characters and each KIND parameter 2 more. Allow 8 of the latter. */
3764 char name
[GFC_MAX_SYMBOL_LEN
+ 21];
3766 bool name_seen
= (param_list
== NULL
);
3767 bool assumed_seen
= false;
3768 bool deferred_seen
= false;
3769 bool spec_error
= false;
3771 gfc_expr
*kind_expr
;
3772 gfc_component
*c1
, *c2
;
3775 type_param_spec_list
= NULL
;
3777 type_param_name_list
= pdt
->formal
;
3778 actual_param
= param_list
;
3779 sprintf (name
, "Pdt%s", pdt
->name
);
3781 /* Run through the parameter name list and pick up the actual
3782 parameter values or use the default values in the PDT declaration. */
3783 for (; type_param_name_list
;
3784 type_param_name_list
= type_param_name_list
->next
)
3786 if (actual_param
&& actual_param
->spec_type
!= SPEC_EXPLICIT
)
3788 if (actual_param
->spec_type
== SPEC_ASSUMED
)
3789 spec_error
= deferred_seen
;
3791 spec_error
= assumed_seen
;
3795 gfc_error ("The type parameter spec list at %C cannot contain "
3796 "both ASSUMED and DEFERRED parameters");
3801 if (actual_param
&& actual_param
->name
)
3803 param
= type_param_name_list
->sym
;
3805 if (!param
|| !param
->name
)
3808 c1
= gfc_find_component (pdt
, param
->name
, false, true, NULL
);
3809 /* An error should already have been thrown in resolve.c
3810 (resolve_fl_derived0). */
3811 if (!pdt
->attr
.use_assoc
&& !c1
)
3817 if (!actual_param
&& !(c1
&& c1
->initializer
))
3819 gfc_error ("The type parameter spec list at %C does not contain "
3820 "enough parameter expressions");
3823 else if (!actual_param
&& c1
&& c1
->initializer
)
3824 kind_expr
= gfc_copy_expr (c1
->initializer
);
3825 else if (actual_param
&& actual_param
->spec_type
== SPEC_EXPLICIT
)
3826 kind_expr
= gfc_copy_expr (actual_param
->expr
);
3830 actual_param
= param_list
;
3831 for (;actual_param
; actual_param
= actual_param
->next
)
3832 if (actual_param
->name
3833 && strcmp (actual_param
->name
, param
->name
) == 0)
3835 if (actual_param
&& actual_param
->spec_type
== SPEC_EXPLICIT
)
3836 kind_expr
= gfc_copy_expr (actual_param
->expr
);
3839 if (c1
->initializer
)
3840 kind_expr
= gfc_copy_expr (c1
->initializer
);
3841 else if (!(actual_param
&& param
->attr
.pdt_len
))
3843 gfc_error ("The derived parameter %qs at %C does not "
3844 "have a default value", param
->name
);
3850 /* Store the current parameter expressions in a temporary actual
3851 arglist 'list' so that they can be substituted in the corresponding
3852 expressions in the PDT instance. */
3853 if (type_param_spec_list
== NULL
)
3855 type_param_spec_list
= gfc_get_actual_arglist ();
3856 tail
= type_param_spec_list
;
3860 tail
->next
= gfc_get_actual_arglist ();
3863 tail
->name
= param
->name
;
3867 /* Try simplification even for LEN expressions. */
3869 gfc_resolve_expr (kind_expr
);
3870 ok
= gfc_simplify_expr (kind_expr
, 1);
3871 /* Variable expressions seem to default to BT_PROCEDURE.
3872 TODO find out why this is and fix it. */
3873 if (kind_expr
->ts
.type
!= BT_INTEGER
3874 && kind_expr
->ts
.type
!= BT_PROCEDURE
)
3876 gfc_error ("The parameter expression at %C must be of "
3877 "INTEGER type and not %s type",
3878 gfc_basic_typename (kind_expr
->ts
.type
));
3881 if (kind_expr
->ts
.type
== BT_INTEGER
&& !ok
)
3883 gfc_error ("The parameter expression at %C does not "
3884 "simplify to an INTEGER constant");
3888 tail
->expr
= gfc_copy_expr (kind_expr
);
3892 tail
->spec_type
= actual_param
->spec_type
;
3894 if (!param
->attr
.pdt_kind
)
3896 if (!name_seen
&& actual_param
)
3897 actual_param
= actual_param
->next
;
3900 gfc_free_expr (kind_expr
);
3907 && (actual_param
->spec_type
== SPEC_ASSUMED
3908 || actual_param
->spec_type
== SPEC_DEFERRED
))
3910 gfc_error ("The KIND parameter %qs at %C cannot either be "
3911 "ASSUMED or DEFERRED", param
->name
);
3915 if (!kind_expr
|| !gfc_is_constant_expr (kind_expr
))
3917 gfc_error ("The value for the KIND parameter %qs at %C does not "
3918 "reduce to a constant expression", param
->name
);
3922 gfc_extract_int (kind_expr
, &kind_value
);
3923 sprintf (name
+ strlen (name
), "_%d", kind_value
);
3925 if (!name_seen
&& actual_param
)
3926 actual_param
= actual_param
->next
;
3927 gfc_free_expr (kind_expr
);
3930 if (!name_seen
&& actual_param
)
3932 gfc_error ("The type parameter spec list at %C contains too many "
3933 "parameter expressions");
3937 /* Now we search for the PDT instance 'name'. If it doesn't exist, we
3938 build it, using 'pdt' as a template. */
3939 if (gfc_get_symbol (name
, pdt
->ns
, &instance
))
3941 gfc_error ("Parameterized derived type at %C is ambiguous");
3947 if (instance
->attr
.flavor
== FL_DERIVED
3948 && instance
->attr
.pdt_type
)
3952 *ext_param_list
= type_param_spec_list
;
3954 gfc_commit_symbols ();
3958 /* Start building the new instance of the parameterized type. */
3959 gfc_copy_attr (&instance
->attr
, &pdt
->attr
, &pdt
->declared_at
);
3960 instance
->attr
.pdt_template
= 0;
3961 instance
->attr
.pdt_type
= 1;
3962 instance
->declared_at
= gfc_current_locus
;
3964 /* Add the components, replacing the parameters in all expressions
3965 with the expressions for their values in 'type_param_spec_list'. */
3966 c1
= pdt
->components
;
3967 tail
= type_param_spec_list
;
3968 for (; c1
; c1
= c1
->next
)
3970 gfc_add_component (instance
, c1
->name
, &c2
);
3973 c2
->attr
= c1
->attr
;
3975 /* The order of declaration of the type_specs might not be the
3976 same as that of the components. */
3977 if (c1
->attr
.pdt_kind
|| c1
->attr
.pdt_len
)
3979 for (tail
= type_param_spec_list
; tail
; tail
= tail
->next
)
3980 if (strcmp (c1
->name
, tail
->name
) == 0)
3984 /* Deal with type extension by recursively calling this function
3985 to obtain the instance of the extended type. */
3986 if (gfc_current_state () != COMP_DERIVED
3987 && c1
== pdt
->components
3988 && (c1
->ts
.type
== BT_DERIVED
|| c1
->ts
.type
== BT_CLASS
)
3989 && c1
->ts
.u
.derived
&& c1
->ts
.u
.derived
->attr
.pdt_template
3990 && gfc_get_derived_super_type (*sym
) == c2
->ts
.u
.derived
)
3992 gfc_formal_arglist
*f
;
3994 old_param_spec_list
= type_param_spec_list
;
3996 /* Obtain a spec list appropriate to the extended type..*/
3997 actual_param
= gfc_copy_actual_arglist (type_param_spec_list
);
3998 type_param_spec_list
= actual_param
;
3999 for (f
= c1
->ts
.u
.derived
->formal
; f
&& f
->next
; f
= f
->next
)
4000 actual_param
= actual_param
->next
;
4003 gfc_free_actual_arglist (actual_param
->next
);
4004 actual_param
->next
= NULL
;
4007 /* Now obtain the PDT instance for the extended type. */
4008 c2
->param_list
= type_param_spec_list
;
4009 m
= gfc_get_pdt_instance (type_param_spec_list
, &c2
->ts
.u
.derived
,
4011 type_param_spec_list
= old_param_spec_list
;
4013 c2
->ts
.u
.derived
->refs
++;
4014 gfc_set_sym_referenced (c2
->ts
.u
.derived
);
4016 /* Set extension level. */
4017 if (c2
->ts
.u
.derived
->attr
.extension
== 255)
4019 /* Since the extension field is 8 bit wide, we can only have
4020 up to 255 extension levels. */
4021 gfc_error ("Maximum extension level reached with type %qs at %L",
4022 c2
->ts
.u
.derived
->name
,
4023 &c2
->ts
.u
.derived
->declared_at
);
4026 instance
->attr
.extension
= c2
->ts
.u
.derived
->attr
.extension
+ 1;
4031 /* Set the component kind using the parameterized expression. */
4032 if ((c1
->ts
.kind
== 0 || c1
->ts
.type
== BT_CHARACTER
)
4033 && c1
->kind_expr
!= NULL
)
4035 gfc_expr
*e
= gfc_copy_expr (c1
->kind_expr
);
4036 gfc_insert_kind_parameter_exprs (e
);
4037 gfc_simplify_expr (e
, 1);
4038 gfc_extract_int (e
, &c2
->ts
.kind
);
4040 if (gfc_validate_kind (c2
->ts
.type
, c2
->ts
.kind
, true) < 0)
4042 gfc_error ("Kind %d not supported for type %s at %C",
4043 c2
->ts
.kind
, gfc_basic_typename (c2
->ts
.type
));
4048 /* Similarly, set the string length if parameterized. */
4049 if (c1
->ts
.type
== BT_CHARACTER
4050 && c1
->ts
.u
.cl
->length
4051 && gfc_derived_parameter_expr (c1
->ts
.u
.cl
->length
))
4054 e
= gfc_copy_expr (c1
->ts
.u
.cl
->length
);
4055 gfc_insert_kind_parameter_exprs (e
);
4056 gfc_simplify_expr (e
, 1);
4057 c2
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4058 c2
->ts
.u
.cl
->length
= e
;
4059 c2
->attr
.pdt_string
= 1;
4062 /* Set up either the KIND/LEN initializer, if constant,
4063 or the parameterized expression. Use the template
4064 initializer if one is not already set in this instance. */
4065 if (c2
->attr
.pdt_kind
|| c2
->attr
.pdt_len
)
4067 if (tail
&& tail
->expr
&& gfc_is_constant_expr (tail
->expr
))
4068 c2
->initializer
= gfc_copy_expr (tail
->expr
);
4069 else if (tail
&& tail
->expr
)
4071 c2
->param_list
= gfc_get_actual_arglist ();
4072 c2
->param_list
->name
= tail
->name
;
4073 c2
->param_list
->expr
= gfc_copy_expr (tail
->expr
);
4074 c2
->param_list
->next
= NULL
;
4077 if (!c2
->initializer
&& c1
->initializer
)
4078 c2
->initializer
= gfc_copy_expr (c1
->initializer
);
4081 /* Copy the array spec. */
4082 c2
->as
= gfc_copy_array_spec (c1
->as
);
4083 if (c1
->ts
.type
== BT_CLASS
)
4084 CLASS_DATA (c2
)->as
= gfc_copy_array_spec (CLASS_DATA (c1
)->as
);
4086 /* Determine if an array spec is parameterized. If so, substitute
4087 in the parameter expressions for the bounds and set the pdt_array
4088 attribute. Notice that this attribute must be unconditionally set
4089 if this is an array of parameterized character length. */
4090 if (c1
->as
&& c1
->as
->type
== AS_EXPLICIT
)
4092 bool pdt_array
= false;
4094 /* Are the bounds of the array parameterized? */
4095 for (i
= 0; i
< c1
->as
->rank
; i
++)
4097 if (gfc_derived_parameter_expr (c1
->as
->lower
[i
]))
4099 if (gfc_derived_parameter_expr (c1
->as
->upper
[i
]))
4103 /* If they are, free the expressions for the bounds and
4104 replace them with the template expressions with substitute
4106 for (i
= 0; pdt_array
&& i
< c1
->as
->rank
; i
++)
4109 e
= gfc_copy_expr (c1
->as
->lower
[i
]);
4110 gfc_insert_kind_parameter_exprs (e
);
4111 gfc_simplify_expr (e
, 1);
4112 gfc_free_expr (c2
->as
->lower
[i
]);
4113 c2
->as
->lower
[i
] = e
;
4114 e
= gfc_copy_expr (c1
->as
->upper
[i
]);
4115 gfc_insert_kind_parameter_exprs (e
);
4116 gfc_simplify_expr (e
, 1);
4117 gfc_free_expr (c2
->as
->upper
[i
]);
4118 c2
->as
->upper
[i
] = e
;
4120 c2
->attr
.pdt_array
= pdt_array
? 1 : c2
->attr
.pdt_string
;
4121 if (c1
->initializer
)
4123 c2
->initializer
= gfc_copy_expr (c1
->initializer
);
4124 gfc_insert_kind_parameter_exprs (c2
->initializer
);
4125 gfc_simplify_expr (c2
->initializer
, 1);
4129 /* Recurse into this function for PDT components. */
4130 if ((c1
->ts
.type
== BT_DERIVED
|| c1
->ts
.type
== BT_CLASS
)
4131 && c1
->ts
.u
.derived
&& c1
->ts
.u
.derived
->attr
.pdt_template
)
4133 gfc_actual_arglist
*params
;
4134 /* The component in the template has a list of specification
4135 expressions derived from its declaration. */
4136 params
= gfc_copy_actual_arglist (c1
->param_list
);
4137 actual_param
= params
;
4138 /* Substitute the template parameters with the expressions
4139 from the specification list. */
4140 for (;actual_param
; actual_param
= actual_param
->next
)
4141 gfc_insert_parameter_exprs (actual_param
->expr
,
4142 type_param_spec_list
);
4144 /* Now obtain the PDT instance for the component. */
4145 old_param_spec_list
= type_param_spec_list
;
4146 m
= gfc_get_pdt_instance (params
, &c2
->ts
.u
.derived
, NULL
);
4147 type_param_spec_list
= old_param_spec_list
;
4149 c2
->param_list
= params
;
4150 if (!(c2
->attr
.pointer
|| c2
->attr
.allocatable
))
4151 c2
->initializer
= gfc_default_initializer (&c2
->ts
);
4153 if (c2
->attr
.allocatable
)
4154 instance
->attr
.alloc_comp
= 1;
4158 gfc_commit_symbol (instance
);
4160 *ext_param_list
= type_param_spec_list
;
4165 gfc_free_actual_arglist (type_param_spec_list
);
4170 /* Match a legacy nonstandard BYTE type-spec. */
4173 match_byte_typespec (gfc_typespec
*ts
)
4175 if (gfc_match (" byte") == MATCH_YES
)
4177 if (!gfc_notify_std (GFC_STD_GNU
, "BYTE type at %C"))
4180 if (gfc_current_form
== FORM_FREE
)
4182 char c
= gfc_peek_ascii_char ();
4183 if (!gfc_is_whitespace (c
) && c
!= ',')
4187 if (gfc_validate_kind (BT_INTEGER
, 1, true) < 0)
4189 gfc_error ("BYTE type used at %C "
4190 "is not available on the target machine");
4194 ts
->type
= BT_INTEGER
;
4202 /* Matches a declaration-type-spec (F03:R502). If successful, sets the ts
4203 structure to the matched specification. This is necessary for FUNCTION and
4204 IMPLICIT statements.
4206 If implicit_flag is nonzero, then we don't check for the optional
4207 kind specification. Not doing so is needed for matching an IMPLICIT
4208 statement correctly. */
4211 gfc_match_decl_type_spec (gfc_typespec
*ts
, int implicit_flag
)
4213 /* Provide sufficient space to hold "pdtsymbol". */
4214 char *name
= XALLOCAVEC (char, GFC_MAX_SYMBOL_LEN
+ 1);
4215 gfc_symbol
*sym
, *dt_sym
;
4218 bool seen_deferred_kind
, matched_type
;
4219 const char *dt_name
;
4221 decl_type_param_list
= NULL
;
4223 /* A belt and braces check that the typespec is correctly being treated
4224 as a deferred characteristic association. */
4225 seen_deferred_kind
= (gfc_current_state () == COMP_FUNCTION
)
4226 && (gfc_current_block ()->result
->ts
.kind
== -1)
4227 && (ts
->kind
== -1);
4229 if (seen_deferred_kind
)
4232 /* Clear the current binding label, in case one is given. */
4233 curr_binding_label
= NULL
;
4235 /* Match BYTE type-spec. */
4236 m
= match_byte_typespec (ts
);
4240 m
= gfc_match (" type (");
4241 matched_type
= (m
== MATCH_YES
);
4244 gfc_gobble_whitespace ();
4245 if (gfc_peek_ascii_char () == '*')
4247 if ((m
= gfc_match ("* ) ")) != MATCH_YES
)
4249 if (gfc_comp_struct (gfc_current_state ()))
4251 gfc_error ("Assumed type at %C is not allowed for components");
4254 if (!gfc_notify_std (GFC_STD_F2018
, "Assumed type at %C"))
4256 ts
->type
= BT_ASSUMED
;
4260 m
= gfc_match ("%n", name
);
4261 matched_type
= (m
== MATCH_YES
);
4264 if ((matched_type
&& strcmp ("integer", name
) == 0)
4265 || (!matched_type
&& gfc_match (" integer") == MATCH_YES
))
4267 ts
->type
= BT_INTEGER
;
4268 ts
->kind
= gfc_default_integer_kind
;
4272 if ((matched_type
&& strcmp ("character", name
) == 0)
4273 || (!matched_type
&& gfc_match (" character") == MATCH_YES
))
4276 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
4277 "intrinsic-type-spec at %C"))
4280 ts
->type
= BT_CHARACTER
;
4281 if (implicit_flag
== 0)
4282 m
= gfc_match_char_spec (ts
);
4286 if (matched_type
&& m
== MATCH_YES
&& gfc_match_char (')') != MATCH_YES
)
4288 gfc_error ("Malformed type-spec at %C");
4295 if ((matched_type
&& strcmp ("real", name
) == 0)
4296 || (!matched_type
&& gfc_match (" real") == MATCH_YES
))
4299 ts
->kind
= gfc_default_real_kind
;
4304 && (strcmp ("doubleprecision", name
) == 0
4305 || (strcmp ("double", name
) == 0
4306 && gfc_match (" precision") == MATCH_YES
)))
4307 || (!matched_type
&& gfc_match (" double precision") == MATCH_YES
))
4310 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
4311 "intrinsic-type-spec at %C"))
4314 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
4316 gfc_error ("Malformed type-spec at %C");
4321 ts
->kind
= gfc_default_double_kind
;
4325 if ((matched_type
&& strcmp ("complex", name
) == 0)
4326 || (!matched_type
&& gfc_match (" complex") == MATCH_YES
))
4328 ts
->type
= BT_COMPLEX
;
4329 ts
->kind
= gfc_default_complex_kind
;
4334 && (strcmp ("doublecomplex", name
) == 0
4335 || (strcmp ("double", name
) == 0
4336 && gfc_match (" complex") == MATCH_YES
)))
4337 || (!matched_type
&& gfc_match (" double complex") == MATCH_YES
))
4339 if (!gfc_notify_std (GFC_STD_GNU
, "DOUBLE COMPLEX at %C"))
4343 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
4344 "intrinsic-type-spec at %C"))
4347 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
4349 gfc_error ("Malformed type-spec at %C");
4353 ts
->type
= BT_COMPLEX
;
4354 ts
->kind
= gfc_default_double_kind
;
4358 if ((matched_type
&& strcmp ("logical", name
) == 0)
4359 || (!matched_type
&& gfc_match (" logical") == MATCH_YES
))
4361 ts
->type
= BT_LOGICAL
;
4362 ts
->kind
= gfc_default_logical_kind
;
4368 m
= gfc_match_actual_arglist (1, &decl_type_param_list
, true);
4369 if (m
== MATCH_ERROR
)
4372 gfc_gobble_whitespace ();
4373 if (gfc_peek_ascii_char () != ')')
4375 gfc_error ("Malformed type-spec at %C");
4378 m
= gfc_match_char (')'); /* Burn closing ')'. */
4382 m
= match_record_decl (name
);
4384 if (matched_type
|| m
== MATCH_YES
)
4386 ts
->type
= BT_DERIVED
;
4387 /* We accept record/s/ or type(s) where s is a structure, but we
4388 * don't need all the extra derived-type stuff for structures. */
4389 if (gfc_find_symbol (gfc_dt_upper_string (name
), NULL
, 1, &sym
))
4391 gfc_error ("Type name %qs at %C is ambiguous", name
);
4395 if (sym
&& sym
->attr
.flavor
== FL_DERIVED
4396 && sym
->attr
.pdt_template
4397 && gfc_current_state () != COMP_DERIVED
)
4399 m
= gfc_get_pdt_instance (decl_type_param_list
, &sym
, NULL
);
4402 gcc_assert (!sym
->attr
.pdt_template
&& sym
->attr
.pdt_type
);
4403 ts
->u
.derived
= sym
;
4404 const char* lower
= gfc_dt_lower_string (sym
->name
);
4405 size_t len
= strlen (lower
);
4406 /* Reallocate with sufficient size. */
4407 if (len
> GFC_MAX_SYMBOL_LEN
)
4408 name
= XALLOCAVEC (char, len
+ 1);
4409 memcpy (name
, lower
, len
);
4413 if (sym
&& sym
->attr
.flavor
== FL_STRUCT
)
4415 ts
->u
.derived
= sym
;
4418 /* Actually a derived type. */
4423 /* Match nested STRUCTURE declarations; only valid within another
4424 structure declaration. */
4425 if (flag_dec_structure
4426 && (gfc_current_state () == COMP_STRUCTURE
4427 || gfc_current_state () == COMP_MAP
))
4429 m
= gfc_match (" structure");
4432 m
= gfc_match_structure_decl ();
4435 /* gfc_new_block is updated by match_structure_decl. */
4436 ts
->type
= BT_DERIVED
;
4437 ts
->u
.derived
= gfc_new_block
;
4441 if (m
== MATCH_ERROR
)
4445 /* Match CLASS declarations. */
4446 m
= gfc_match (" class ( * )");
4447 if (m
== MATCH_ERROR
)
4449 else if (m
== MATCH_YES
)
4453 ts
->type
= BT_CLASS
;
4454 gfc_find_symbol ("STAR", gfc_current_ns
, 1, &upe
);
4457 upe
= gfc_new_symbol ("STAR", gfc_current_ns
);
4458 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "STAR");
4460 gfc_set_sym_referenced (upe
);
4462 upe
->ts
.type
= BT_VOID
;
4463 upe
->attr
.unlimited_polymorphic
= 1;
4464 /* This is essential to force the construction of
4465 unlimited polymorphic component class containers. */
4466 upe
->attr
.zero_comp
= 1;
4467 if (!gfc_add_flavor (&upe
->attr
, FL_DERIVED
, NULL
,
4468 &gfc_current_locus
))
4473 st
= gfc_get_tbp_symtree (&gfc_current_ns
->sym_root
, "STAR");
4477 ts
->u
.derived
= upe
;
4481 m
= gfc_match (" class (");
4484 m
= gfc_match ("%n", name
);
4490 ts
->type
= BT_CLASS
;
4492 if (!gfc_notify_std (GFC_STD_F2003
, "CLASS statement at %C"))
4495 m
= gfc_match_actual_arglist (1, &decl_type_param_list
, true);
4496 if (m
== MATCH_ERROR
)
4499 m
= gfc_match_char (')');
4504 /* Defer association of the derived type until the end of the
4505 specification block. However, if the derived type can be
4506 found, add it to the typespec. */
4507 if (gfc_matching_function
)
4509 ts
->u
.derived
= NULL
;
4510 if (gfc_current_state () != COMP_INTERFACE
4511 && !gfc_find_symbol (name
, NULL
, 1, &sym
) && sym
)
4513 sym
= gfc_find_dt_in_generic (sym
);
4514 ts
->u
.derived
= sym
;
4519 /* Search for the name but allow the components to be defined later. If
4520 type = -1, this typespec has been seen in a function declaration but
4521 the type could not be accessed at that point. The actual derived type is
4522 stored in a symtree with the first letter of the name capitalized; the
4523 symtree with the all lower-case name contains the associated
4524 generic function. */
4525 dt_name
= gfc_dt_upper_string (name
);
4530 gfc_get_ha_symbol (name
, &sym
);
4531 if (sym
->generic
&& gfc_find_symbol (dt_name
, NULL
, 0, &dt_sym
))
4533 gfc_error ("Type name %qs at %C is ambiguous", name
);
4536 if (sym
->generic
&& !dt_sym
)
4537 dt_sym
= gfc_find_dt_in_generic (sym
);
4539 /* Host associated PDTs can get confused with their constructors
4540 because they ar instantiated in the template's namespace. */
4543 if (gfc_find_symbol (dt_name
, NULL
, 1, &dt_sym
))
4545 gfc_error ("Type name %qs at %C is ambiguous", name
);
4548 if (dt_sym
&& !dt_sym
->attr
.pdt_type
)
4552 else if (ts
->kind
== -1)
4554 int iface
= gfc_state_stack
->previous
->state
!= COMP_INTERFACE
4555 || gfc_current_ns
->has_import_set
;
4556 gfc_find_symbol (name
, NULL
, iface
, &sym
);
4557 if (sym
&& sym
->generic
&& gfc_find_symbol (dt_name
, NULL
, 1, &dt_sym
))
4559 gfc_error ("Type name %qs at %C is ambiguous", name
);
4562 if (sym
&& sym
->generic
&& !dt_sym
)
4563 dt_sym
= gfc_find_dt_in_generic (sym
);
4570 if ((sym
->attr
.flavor
!= FL_UNKNOWN
&& sym
->attr
.flavor
!= FL_STRUCT
4571 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.generic
))
4572 || sym
->attr
.subroutine
)
4574 gfc_error ("Type name %qs at %C conflicts with previously declared "
4575 "entity at %L, which has the same name", name
,
4580 if (sym
&& sym
->attr
.flavor
== FL_DERIVED
4581 && sym
->attr
.pdt_template
4582 && gfc_current_state () != COMP_DERIVED
)
4584 m
= gfc_get_pdt_instance (decl_type_param_list
, &sym
, NULL
);
4587 gcc_assert (!sym
->attr
.pdt_template
&& sym
->attr
.pdt_type
);
4588 ts
->u
.derived
= sym
;
4589 strcpy (name
, gfc_dt_lower_string (sym
->name
));
4592 gfc_save_symbol_data (sym
);
4593 gfc_set_sym_referenced (sym
);
4594 if (!sym
->attr
.generic
4595 && !gfc_add_generic (&sym
->attr
, sym
->name
, NULL
))
4598 if (!sym
->attr
.function
4599 && !gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
4602 if (dt_sym
&& dt_sym
->attr
.flavor
== FL_DERIVED
4603 && dt_sym
->attr
.pdt_template
4604 && gfc_current_state () != COMP_DERIVED
)
4606 m
= gfc_get_pdt_instance (decl_type_param_list
, &dt_sym
, NULL
);
4609 gcc_assert (!dt_sym
->attr
.pdt_template
&& dt_sym
->attr
.pdt_type
);
4614 gfc_interface
*intr
, *head
;
4616 /* Use upper case to save the actual derived-type symbol. */
4617 gfc_get_symbol (dt_name
, NULL
, &dt_sym
);
4618 dt_sym
->name
= gfc_get_string ("%s", sym
->name
);
4619 head
= sym
->generic
;
4620 intr
= gfc_get_interface ();
4622 intr
->where
= gfc_current_locus
;
4624 sym
->generic
= intr
;
4625 sym
->attr
.if_source
= IFSRC_DECL
;
4628 gfc_save_symbol_data (dt_sym
);
4630 gfc_set_sym_referenced (dt_sym
);
4632 if (dt_sym
->attr
.flavor
!= FL_DERIVED
&& dt_sym
->attr
.flavor
!= FL_STRUCT
4633 && !gfc_add_flavor (&dt_sym
->attr
, FL_DERIVED
, sym
->name
, NULL
))
4636 ts
->u
.derived
= dt_sym
;
4642 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
4643 "intrinsic-type-spec at %C"))
4646 /* For all types except double, derived and character, look for an
4647 optional kind specifier. MATCH_NO is actually OK at this point. */
4648 if (implicit_flag
== 1)
4650 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
4656 if (gfc_current_form
== FORM_FREE
)
4658 c
= gfc_peek_ascii_char ();
4659 if (!gfc_is_whitespace (c
) && c
!= '*' && c
!= '('
4660 && c
!= ':' && c
!= ',')
4662 if (matched_type
&& c
== ')')
4664 gfc_next_ascii_char ();
4667 gfc_error ("Malformed type-spec at %C");
4672 m
= gfc_match_kind_spec (ts
, false);
4673 if (m
== MATCH_NO
&& ts
->type
!= BT_CHARACTER
)
4675 m
= gfc_match_old_kind_spec (ts
);
4676 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) == -1)
4680 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
4682 gfc_error ("Malformed type-spec at %C");
4686 /* Defer association of the KIND expression of function results
4687 until after USE and IMPORT statements. */
4688 if ((gfc_current_state () == COMP_NONE
&& gfc_error_flag_test ())
4689 || gfc_matching_function
)
4693 m
= MATCH_YES
; /* No kind specifier found. */
4699 /* Match an IMPLICIT NONE statement. Actually, this statement is
4700 already matched in parse.c, or we would not end up here in the
4701 first place. So the only thing we need to check, is if there is
4702 trailing garbage. If not, the match is successful. */
4705 gfc_match_implicit_none (void)
4709 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4711 bool external
= false;
4712 locus cur_loc
= gfc_current_locus
;
4714 if (gfc_current_ns
->seen_implicit_none
4715 || gfc_current_ns
->has_implicit_none_export
)
4717 gfc_error ("Duplicate IMPLICIT NONE statement at %C");
4721 gfc_gobble_whitespace ();
4722 c
= gfc_peek_ascii_char ();
4725 (void) gfc_next_ascii_char ();
4726 if (!gfc_notify_std (GFC_STD_F2018
, "IMPLICIT NONE with spec list at %C"))
4729 gfc_gobble_whitespace ();
4730 if (gfc_peek_ascii_char () == ')')
4732 (void) gfc_next_ascii_char ();
4738 m
= gfc_match (" %n", name
);
4742 if (strcmp (name
, "type") == 0)
4744 else if (strcmp (name
, "external") == 0)
4749 gfc_gobble_whitespace ();
4750 c
= gfc_next_ascii_char ();
4761 if (gfc_match_eos () != MATCH_YES
)
4764 gfc_set_implicit_none (type
, external
, &cur_loc
);
4770 /* Match the letter range(s) of an IMPLICIT statement. */
4773 match_implicit_range (void)
4779 cur_loc
= gfc_current_locus
;
4781 gfc_gobble_whitespace ();
4782 c
= gfc_next_ascii_char ();
4785 gfc_error ("Missing character range in IMPLICIT at %C");
4792 gfc_gobble_whitespace ();
4793 c1
= gfc_next_ascii_char ();
4797 gfc_gobble_whitespace ();
4798 c
= gfc_next_ascii_char ();
4803 inner
= 0; /* Fall through. */
4810 gfc_gobble_whitespace ();
4811 c2
= gfc_next_ascii_char ();
4815 gfc_gobble_whitespace ();
4816 c
= gfc_next_ascii_char ();
4818 if ((c
!= ',') && (c
!= ')'))
4831 gfc_error ("Letters must be in alphabetic order in "
4832 "IMPLICIT statement at %C");
4836 /* See if we can add the newly matched range to the pending
4837 implicits from this IMPLICIT statement. We do not check for
4838 conflicts with whatever earlier IMPLICIT statements may have
4839 set. This is done when we've successfully finished matching
4841 if (!gfc_add_new_implicit_range (c1
, c2
))
4848 gfc_syntax_error (ST_IMPLICIT
);
4850 gfc_current_locus
= cur_loc
;
4855 /* Match an IMPLICIT statement, storing the types for
4856 gfc_set_implicit() if the statement is accepted by the parser.
4857 There is a strange looking, but legal syntactic construction
4858 possible. It looks like:
4860 IMPLICIT INTEGER (a-b) (c-d)
4862 This is legal if "a-b" is a constant expression that happens to
4863 equal one of the legal kinds for integers. The real problem
4864 happens with an implicit specification that looks like:
4866 IMPLICIT INTEGER (a-b)
4868 In this case, a typespec matcher that is "greedy" (as most of the
4869 matchers are) gobbles the character range as a kindspec, leaving
4870 nothing left. We therefore have to go a bit more slowly in the
4871 matching process by inhibiting the kindspec checking during
4872 typespec matching and checking for a kind later. */
4875 gfc_match_implicit (void)
4882 if (gfc_current_ns
->seen_implicit_none
)
4884 gfc_error ("IMPLICIT statement at %C following an IMPLICIT NONE (type) "
4891 /* We don't allow empty implicit statements. */
4892 if (gfc_match_eos () == MATCH_YES
)
4894 gfc_error ("Empty IMPLICIT statement at %C");
4900 /* First cleanup. */
4901 gfc_clear_new_implicit ();
4903 /* A basic type is mandatory here. */
4904 m
= gfc_match_decl_type_spec (&ts
, 1);
4905 if (m
== MATCH_ERROR
)
4910 cur_loc
= gfc_current_locus
;
4911 m
= match_implicit_range ();
4915 /* We may have <TYPE> (<RANGE>). */
4916 gfc_gobble_whitespace ();
4917 c
= gfc_peek_ascii_char ();
4918 if (c
== ',' || c
== '\n' || c
== ';' || c
== '!')
4920 /* Check for CHARACTER with no length parameter. */
4921 if (ts
.type
== BT_CHARACTER
&& !ts
.u
.cl
)
4923 ts
.kind
= gfc_default_character_kind
;
4924 ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4925 ts
.u
.cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
,
4929 /* Record the Successful match. */
4930 if (!gfc_merge_new_implicit (&ts
))
4933 c
= gfc_next_ascii_char ();
4934 else if (gfc_match_eos () == MATCH_ERROR
)
4939 gfc_current_locus
= cur_loc
;
4942 /* Discard the (incorrectly) matched range. */
4943 gfc_clear_new_implicit ();
4945 /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
4946 if (ts
.type
== BT_CHARACTER
)
4947 m
= gfc_match_char_spec (&ts
);
4948 else if (gfc_numeric_ts(&ts
) || ts
.type
== BT_LOGICAL
)
4950 m
= gfc_match_kind_spec (&ts
, false);
4953 m
= gfc_match_old_kind_spec (&ts
);
4954 if (m
== MATCH_ERROR
)
4960 if (m
== MATCH_ERROR
)
4963 m
= match_implicit_range ();
4964 if (m
== MATCH_ERROR
)
4969 gfc_gobble_whitespace ();
4970 c
= gfc_next_ascii_char ();
4971 if (c
!= ',' && gfc_match_eos () != MATCH_YES
)
4974 if (!gfc_merge_new_implicit (&ts
))
4982 gfc_syntax_error (ST_IMPLICIT
);
4990 gfc_match_import (void)
4992 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4997 if (gfc_current_ns
->proc_name
== NULL
4998 || gfc_current_ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
5000 gfc_error ("IMPORT statement at %C only permitted in "
5001 "an INTERFACE body");
5005 if (gfc_current_ns
->proc_name
->attr
.module_procedure
)
5007 gfc_error ("F2008: C1210 IMPORT statement at %C is not permitted "
5008 "in a module procedure interface body");
5012 if (!gfc_notify_std (GFC_STD_F2003
, "IMPORT statement at %C"))
5015 if (gfc_match_eos () == MATCH_YES
)
5017 /* All host variables should be imported. */
5018 gfc_current_ns
->has_import_set
= 1;
5022 if (gfc_match (" ::") == MATCH_YES
)
5024 if (gfc_match_eos () == MATCH_YES
)
5026 gfc_error ("Expecting list of named entities at %C");
5034 m
= gfc_match (" %n", name
);
5038 if (gfc_current_ns
->parent
!= NULL
5039 && gfc_find_symbol (name
, gfc_current_ns
->parent
, 1, &sym
))
5041 gfc_error ("Type name %qs at %C is ambiguous", name
);
5044 else if (!sym
&& gfc_current_ns
->proc_name
->ns
->parent
!= NULL
5045 && gfc_find_symbol (name
,
5046 gfc_current_ns
->proc_name
->ns
->parent
,
5049 gfc_error ("Type name %qs at %C is ambiguous", name
);
5055 gfc_error ("Cannot IMPORT %qs from host scoping unit "
5056 "at %C - does not exist.", name
);
5060 if (gfc_find_symtree (gfc_current_ns
->sym_root
, name
))
5062 gfc_warning (0, "%qs is already IMPORTed from host scoping unit "
5067 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, name
);
5070 sym
->attr
.imported
= 1;
5072 if (sym
->attr
.generic
&& (sym
= gfc_find_dt_in_generic (sym
)))
5074 /* The actual derived type is stored in a symtree with the first
5075 letter of the name capitalized; the symtree with the all
5076 lower-case name contains the associated generic function. */
5077 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
,
5078 gfc_dt_upper_string (name
));
5081 sym
->attr
.imported
= 1;
5094 if (gfc_match_eos () == MATCH_YES
)
5096 if (gfc_match_char (',') != MATCH_YES
)
5103 gfc_error ("Syntax error in IMPORT statement at %C");
5108 /* A minimal implementation of gfc_match without whitespace, escape
5109 characters or variable arguments. Returns true if the next
5110 characters match the TARGET template exactly. */
5113 match_string_p (const char *target
)
5117 for (p
= target
; *p
; p
++)
5118 if ((char) gfc_next_ascii_char () != *p
)
5123 /* Matches an attribute specification including array specs. If
5124 successful, leaves the variables current_attr and current_as
5125 holding the specification. Also sets the colon_seen variable for
5126 later use by matchers associated with initializations.
5128 This subroutine is a little tricky in the sense that we don't know
5129 if we really have an attr-spec until we hit the double colon.
5130 Until that time, we can only return MATCH_NO. This forces us to
5131 check for duplicate specification at this level. */
5134 match_attr_spec (void)
5136 /* Modifiers that can exist in a type statement. */
5138 { GFC_DECL_BEGIN
= 0, DECL_ALLOCATABLE
= GFC_DECL_BEGIN
,
5139 DECL_IN
= INTENT_IN
, DECL_OUT
= INTENT_OUT
, DECL_INOUT
= INTENT_INOUT
,
5140 DECL_DIMENSION
, DECL_EXTERNAL
,
5141 DECL_INTRINSIC
, DECL_OPTIONAL
,
5142 DECL_PARAMETER
, DECL_POINTER
, DECL_PROTECTED
, DECL_PRIVATE
,
5143 DECL_STATIC
, DECL_AUTOMATIC
,
5144 DECL_PUBLIC
, DECL_SAVE
, DECL_TARGET
, DECL_VALUE
, DECL_VOLATILE
,
5145 DECL_IS_BIND_C
, DECL_CODIMENSION
, DECL_ASYNCHRONOUS
, DECL_CONTIGUOUS
,
5146 DECL_LEN
, DECL_KIND
, DECL_NONE
, GFC_DECL_END
/* Sentinel */
5149 /* GFC_DECL_END is the sentinel, index starts at 0. */
5150 #define NUM_DECL GFC_DECL_END
5152 /* Make sure that values from sym_intent are safe to be used here. */
5153 gcc_assert (INTENT_IN
> 0);
5155 locus start
, seen_at
[NUM_DECL
];
5162 gfc_clear_attr (¤t_attr
);
5163 start
= gfc_current_locus
;
5169 /* See if we get all of the keywords up to the final double colon. */
5170 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
5178 gfc_gobble_whitespace ();
5180 ch
= gfc_next_ascii_char ();
5183 /* This is the successful exit condition for the loop. */
5184 if (gfc_next_ascii_char () == ':')
5189 gfc_gobble_whitespace ();
5190 switch (gfc_peek_ascii_char ())
5193 gfc_next_ascii_char ();
5194 switch (gfc_next_ascii_char ())
5197 if (match_string_p ("locatable"))
5199 /* Matched "allocatable". */
5200 d
= DECL_ALLOCATABLE
;
5205 if (match_string_p ("ynchronous"))
5207 /* Matched "asynchronous". */
5208 d
= DECL_ASYNCHRONOUS
;
5213 if (match_string_p ("tomatic"))
5215 /* Matched "automatic". */
5223 /* Try and match the bind(c). */
5224 m
= gfc_match_bind_c (NULL
, true);
5227 else if (m
== MATCH_ERROR
)
5232 gfc_next_ascii_char ();
5233 if ('o' != gfc_next_ascii_char ())
5235 switch (gfc_next_ascii_char ())
5238 if (match_string_p ("imension"))
5240 d
= DECL_CODIMENSION
;
5245 if (match_string_p ("tiguous"))
5247 d
= DECL_CONTIGUOUS
;
5254 if (match_string_p ("dimension"))
5259 if (match_string_p ("external"))
5264 if (match_string_p ("int"))
5266 ch
= gfc_next_ascii_char ();
5269 if (match_string_p ("nt"))
5271 /* Matched "intent". */
5272 d
= match_intent_spec ();
5273 if (d
== INTENT_UNKNOWN
)
5282 if (match_string_p ("insic"))
5284 /* Matched "intrinsic". */
5292 if (match_string_p ("kind"))
5297 if (match_string_p ("len"))
5302 if (match_string_p ("optional"))
5307 gfc_next_ascii_char ();
5308 switch (gfc_next_ascii_char ())
5311 if (match_string_p ("rameter"))
5313 /* Matched "parameter". */
5319 if (match_string_p ("inter"))
5321 /* Matched "pointer". */
5327 ch
= gfc_next_ascii_char ();
5330 if (match_string_p ("vate"))
5332 /* Matched "private". */
5338 if (match_string_p ("tected"))
5340 /* Matched "protected". */
5347 if (match_string_p ("blic"))
5349 /* Matched "public". */
5357 gfc_next_ascii_char ();
5358 switch (gfc_next_ascii_char ())
5361 if (match_string_p ("ve"))
5363 /* Matched "save". */
5369 if (match_string_p ("atic"))
5371 /* Matched "static". */
5379 if (match_string_p ("target"))
5384 gfc_next_ascii_char ();
5385 ch
= gfc_next_ascii_char ();
5388 if (match_string_p ("lue"))
5390 /* Matched "value". */
5396 if (match_string_p ("latile"))
5398 /* Matched "volatile". */
5406 /* No double colon and no recognizable decl_type, so assume that
5407 we've been looking at something else the whole time. */
5414 /* Check to make sure any parens are paired up correctly. */
5415 if (gfc_match_parens () == MATCH_ERROR
)
5422 seen_at
[d
] = gfc_current_locus
;
5424 if (d
== DECL_DIMENSION
|| d
== DECL_CODIMENSION
)
5426 gfc_array_spec
*as
= NULL
;
5428 m
= gfc_match_array_spec (&as
, d
== DECL_DIMENSION
,
5429 d
== DECL_CODIMENSION
);
5431 if (current_as
== NULL
)
5433 else if (m
== MATCH_YES
)
5435 if (!merge_array_spec (as
, current_as
, false))
5442 if (d
== DECL_CODIMENSION
)
5443 gfc_error ("Missing codimension specification at %C");
5445 gfc_error ("Missing dimension specification at %C");
5449 if (m
== MATCH_ERROR
)
5454 /* Since we've seen a double colon, we have to be looking at an
5455 attr-spec. This means that we can now issue errors. */
5456 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
5461 case DECL_ALLOCATABLE
:
5462 attr
= "ALLOCATABLE";
5464 case DECL_ASYNCHRONOUS
:
5465 attr
= "ASYNCHRONOUS";
5467 case DECL_CODIMENSION
:
5468 attr
= "CODIMENSION";
5470 case DECL_CONTIGUOUS
:
5471 attr
= "CONTIGUOUS";
5473 case DECL_DIMENSION
:
5480 attr
= "INTENT (IN)";
5483 attr
= "INTENT (OUT)";
5486 attr
= "INTENT (IN OUT)";
5488 case DECL_INTRINSIC
:
5500 case DECL_PARAMETER
:
5506 case DECL_PROTECTED
:
5521 case DECL_AUTOMATIC
:
5527 case DECL_IS_BIND_C
:
5537 attr
= NULL
; /* This shouldn't happen. */
5540 gfc_error ("Duplicate %s attribute at %L", attr
, &seen_at
[d
]);
5545 /* Now that we've dealt with duplicate attributes, add the attributes
5546 to the current attribute. */
5547 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
5554 if ((d
== DECL_STATIC
|| d
== DECL_AUTOMATIC
)
5555 && !flag_dec_static
)
5557 gfc_error ("%s at %L is a DEC extension, enable with "
5559 d
== DECL_STATIC
? "STATIC" : "AUTOMATIC", &seen_at
[d
]);
5563 /* Allow SAVE with STATIC, but don't complain. */
5564 if (d
== DECL_STATIC
&& seen
[DECL_SAVE
])
5567 if (gfc_comp_struct (gfc_current_state ())
5568 && d
!= DECL_DIMENSION
&& d
!= DECL_CODIMENSION
5569 && d
!= DECL_POINTER
&& d
!= DECL_PRIVATE
5570 && d
!= DECL_PUBLIC
&& d
!= DECL_CONTIGUOUS
&& d
!= DECL_NONE
)
5572 bool is_derived
= gfc_current_state () == COMP_DERIVED
;
5573 if (d
== DECL_ALLOCATABLE
)
5575 if (!gfc_notify_std (GFC_STD_F2003
, is_derived
5576 ? G_("ALLOCATABLE attribute at %C in a "
5578 : G_("ALLOCATABLE attribute at %C in a "
5579 "STRUCTURE definition")))
5585 else if (d
== DECL_KIND
)
5587 if (!gfc_notify_std (GFC_STD_F2003
, is_derived
5588 ? G_("KIND attribute at %C in a "
5590 : G_("KIND attribute at %C in a "
5591 "STRUCTURE definition")))
5596 if (current_ts
.type
!= BT_INTEGER
)
5598 gfc_error ("Component with KIND attribute at %C must be "
5604 else if (d
== DECL_LEN
)
5606 if (!gfc_notify_std (GFC_STD_F2003
, is_derived
5607 ? G_("LEN attribute at %C in a "
5609 : G_("LEN attribute at %C in a "
5610 "STRUCTURE definition")))
5615 if (current_ts
.type
!= BT_INTEGER
)
5617 gfc_error ("Component with LEN attribute at %C must be "
5625 gfc_error (is_derived
? G_("Attribute at %L is not allowed in a "
5627 : G_("Attribute at %L is not allowed in a "
5628 "STRUCTURE definition"), &seen_at
[d
]);
5634 if ((d
== DECL_PRIVATE
|| d
== DECL_PUBLIC
)
5635 && gfc_current_state () != COMP_MODULE
)
5637 if (d
== DECL_PRIVATE
)
5641 if (gfc_current_state () == COMP_DERIVED
5642 && gfc_state_stack
->previous
5643 && gfc_state_stack
->previous
->state
== COMP_MODULE
)
5645 if (!gfc_notify_std (GFC_STD_F2003
, "Attribute %s "
5646 "at %L in a TYPE definition", attr
,
5655 gfc_error ("%s attribute at %L is not allowed outside of the "
5656 "specification part of a module", attr
, &seen_at
[d
]);
5662 if (gfc_current_state () != COMP_DERIVED
5663 && (d
== DECL_KIND
|| d
== DECL_LEN
))
5665 gfc_error ("Attribute at %L is not allowed outside a TYPE "
5666 "definition", &seen_at
[d
]);
5673 case DECL_ALLOCATABLE
:
5674 t
= gfc_add_allocatable (¤t_attr
, &seen_at
[d
]);
5677 case DECL_ASYNCHRONOUS
:
5678 if (!gfc_notify_std (GFC_STD_F2003
, "ASYNCHRONOUS attribute at %C"))
5681 t
= gfc_add_asynchronous (¤t_attr
, NULL
, &seen_at
[d
]);
5684 case DECL_CODIMENSION
:
5685 t
= gfc_add_codimension (¤t_attr
, NULL
, &seen_at
[d
]);
5688 case DECL_CONTIGUOUS
:
5689 if (!gfc_notify_std (GFC_STD_F2008
, "CONTIGUOUS attribute at %C"))
5692 t
= gfc_add_contiguous (¤t_attr
, NULL
, &seen_at
[d
]);
5695 case DECL_DIMENSION
:
5696 t
= gfc_add_dimension (¤t_attr
, NULL
, &seen_at
[d
]);
5700 t
= gfc_add_external (¤t_attr
, &seen_at
[d
]);
5704 t
= gfc_add_intent (¤t_attr
, INTENT_IN
, &seen_at
[d
]);
5708 t
= gfc_add_intent (¤t_attr
, INTENT_OUT
, &seen_at
[d
]);
5712 t
= gfc_add_intent (¤t_attr
, INTENT_INOUT
, &seen_at
[d
]);
5715 case DECL_INTRINSIC
:
5716 t
= gfc_add_intrinsic (¤t_attr
, &seen_at
[d
]);
5720 t
= gfc_add_optional (¤t_attr
, &seen_at
[d
]);
5724 t
= gfc_add_kind (¤t_attr
, &seen_at
[d
]);
5728 t
= gfc_add_len (¤t_attr
, &seen_at
[d
]);
5731 case DECL_PARAMETER
:
5732 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, &seen_at
[d
]);
5736 t
= gfc_add_pointer (¤t_attr
, &seen_at
[d
]);
5739 case DECL_PROTECTED
:
5740 if (gfc_current_state () != COMP_MODULE
5741 || (gfc_current_ns
->proc_name
5742 && gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
))
5744 gfc_error ("PROTECTED at %C only allowed in specification "
5745 "part of a module");
5750 if (!gfc_notify_std (GFC_STD_F2003
, "PROTECTED attribute at %C"))
5753 t
= gfc_add_protected (¤t_attr
, NULL
, &seen_at
[d
]);
5757 t
= gfc_add_access (¤t_attr
, ACCESS_PRIVATE
, NULL
,
5762 t
= gfc_add_access (¤t_attr
, ACCESS_PUBLIC
, NULL
,
5768 t
= gfc_add_save (¤t_attr
, SAVE_EXPLICIT
, NULL
, &seen_at
[d
]);
5771 case DECL_AUTOMATIC
:
5772 t
= gfc_add_automatic (¤t_attr
, NULL
, &seen_at
[d
]);
5776 t
= gfc_add_target (¤t_attr
, &seen_at
[d
]);
5779 case DECL_IS_BIND_C
:
5780 t
= gfc_add_is_bind_c(¤t_attr
, NULL
, &seen_at
[d
], 0);
5784 if (!gfc_notify_std (GFC_STD_F2003
, "VALUE attribute at %C"))
5787 t
= gfc_add_value (¤t_attr
, NULL
, &seen_at
[d
]);
5791 if (!gfc_notify_std (GFC_STD_F2003
, "VOLATILE attribute at %C"))
5794 t
= gfc_add_volatile (¤t_attr
, NULL
, &seen_at
[d
]);
5798 gfc_internal_error ("match_attr_spec(): Bad attribute");
5808 /* Since Fortran 2008 module variables implicitly have the SAVE attribute. */
5809 if ((gfc_current_state () == COMP_MODULE
5810 || gfc_current_state () == COMP_SUBMODULE
)
5811 && !current_attr
.save
5812 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
5813 current_attr
.save
= SAVE_IMPLICIT
;
5819 gfc_current_locus
= start
;
5820 gfc_free_array_spec (current_as
);
5827 /* Set the binding label, dest_label, either with the binding label
5828 stored in the given gfc_typespec, ts, or if none was provided, it
5829 will be the symbol name in all lower case, as required by the draft
5830 (J3/04-007, section 15.4.1). If a binding label was given and
5831 there is more than one argument (num_idents), it is an error. */
5834 set_binding_label (const char **dest_label
, const char *sym_name
,
5837 if (num_idents
> 1 && has_name_equals
)
5839 gfc_error ("Multiple identifiers provided with "
5840 "single NAME= specifier at %C");
5844 if (curr_binding_label
)
5845 /* Binding label given; store in temp holder till have sym. */
5846 *dest_label
= curr_binding_label
;
5849 /* No binding label given, and the NAME= specifier did not exist,
5850 which means there was no NAME="". */
5851 if (sym_name
!= NULL
&& has_name_equals
== 0)
5852 *dest_label
= IDENTIFIER_POINTER (get_identifier (sym_name
));
5859 /* Set the status of the given common block as being BIND(C) or not,
5860 depending on the given parameter, is_bind_c. */
5863 set_com_block_bind_c (gfc_common_head
*com_block
, int is_bind_c
)
5865 com_block
->is_bind_c
= is_bind_c
;
5870 /* Verify that the given gfc_typespec is for a C interoperable type. */
5873 gfc_verify_c_interop (gfc_typespec
*ts
)
5875 if (ts
->type
== BT_DERIVED
&& ts
->u
.derived
!= NULL
)
5876 return (ts
->u
.derived
->ts
.is_c_interop
|| ts
->u
.derived
->attr
.is_bind_c
)
5878 else if (ts
->type
== BT_CLASS
)
5880 else if (ts
->is_c_interop
!= 1 && ts
->type
!= BT_ASSUMED
)
5887 /* Verify that the variables of a given common block, which has been
5888 defined with the attribute specifier bind(c), to be of a C
5889 interoperable type. Errors will be reported here, if
5893 verify_com_block_vars_c_interop (gfc_common_head
*com_block
)
5895 gfc_symbol
*curr_sym
= NULL
;
5898 curr_sym
= com_block
->head
;
5900 /* Make sure we have at least one symbol. */
5901 if (curr_sym
== NULL
)
5904 /* Here we know we have a symbol, so we'll execute this loop
5908 /* The second to last param, 1, says this is in a common block. */
5909 retval
= verify_bind_c_sym (curr_sym
, &(curr_sym
->ts
), 1, com_block
);
5910 curr_sym
= curr_sym
->common_next
;
5911 } while (curr_sym
!= NULL
);
5917 /* Verify that a given BIND(C) symbol is C interoperable. If it is not,
5918 an appropriate error message is reported. */
5921 verify_bind_c_sym (gfc_symbol
*tmp_sym
, gfc_typespec
*ts
,
5922 int is_in_common
, gfc_common_head
*com_block
)
5924 bool bind_c_function
= false;
5927 if (tmp_sym
->attr
.function
&& tmp_sym
->attr
.is_bind_c
)
5928 bind_c_function
= true;
5930 if (tmp_sym
->attr
.function
&& tmp_sym
->result
!= NULL
)
5932 tmp_sym
= tmp_sym
->result
;
5933 /* Make sure it wasn't an implicitly typed result. */
5934 if (tmp_sym
->attr
.implicit_type
&& warn_c_binding_type
)
5936 gfc_warning (OPT_Wc_binding_type
,
5937 "Implicitly declared BIND(C) function %qs at "
5938 "%L may not be C interoperable", tmp_sym
->name
,
5939 &tmp_sym
->declared_at
);
5940 tmp_sym
->ts
.f90_type
= tmp_sym
->ts
.type
;
5941 /* Mark it as C interoperable to prevent duplicate warnings. */
5942 tmp_sym
->ts
.is_c_interop
= 1;
5943 tmp_sym
->attr
.is_c_interop
= 1;
5947 /* Here, we know we have the bind(c) attribute, so if we have
5948 enough type info, then verify that it's a C interop kind.
5949 The info could be in the symbol already, or possibly still in
5950 the given ts (current_ts), so look in both. */
5951 if (tmp_sym
->ts
.type
!= BT_UNKNOWN
|| ts
->type
!= BT_UNKNOWN
)
5953 if (!gfc_verify_c_interop (&(tmp_sym
->ts
)))
5955 /* See if we're dealing with a sym in a common block or not. */
5956 if (is_in_common
== 1 && warn_c_binding_type
)
5958 gfc_warning (OPT_Wc_binding_type
,
5959 "Variable %qs in common block %qs at %L "
5960 "may not be a C interoperable "
5961 "kind though common block %qs is BIND(C)",
5962 tmp_sym
->name
, com_block
->name
,
5963 &(tmp_sym
->declared_at
), com_block
->name
);
5967 if (tmp_sym
->ts
.type
== BT_DERIVED
|| ts
->type
== BT_DERIVED
)
5968 gfc_error ("Type declaration %qs at %L is not C "
5969 "interoperable but it is BIND(C)",
5970 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5971 else if (warn_c_binding_type
)
5972 gfc_warning (OPT_Wc_binding_type
, "Variable %qs at %L "
5973 "may not be a C interoperable "
5974 "kind but it is BIND(C)",
5975 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5979 /* Variables declared w/in a common block can't be bind(c)
5980 since there's no way for C to see these variables, so there's
5981 semantically no reason for the attribute. */
5982 if (is_in_common
== 1 && tmp_sym
->attr
.is_bind_c
== 1)
5984 gfc_error ("Variable %qs in common block %qs at "
5985 "%L cannot be declared with BIND(C) "
5986 "since it is not a global",
5987 tmp_sym
->name
, com_block
->name
,
5988 &(tmp_sym
->declared_at
));
5992 /* Scalar variables that are bind(c) cannot have the pointer
5993 or allocatable attributes. */
5994 if (tmp_sym
->attr
.is_bind_c
== 1)
5996 if (tmp_sym
->attr
.pointer
== 1)
5998 gfc_error ("Variable %qs at %L cannot have both the "
5999 "POINTER and BIND(C) attributes",
6000 tmp_sym
->name
, &(tmp_sym
->declared_at
));
6004 if (tmp_sym
->attr
.allocatable
== 1)
6006 gfc_error ("Variable %qs at %L cannot have both the "
6007 "ALLOCATABLE and BIND(C) attributes",
6008 tmp_sym
->name
, &(tmp_sym
->declared_at
));
6014 /* If it is a BIND(C) function, make sure the return value is a
6015 scalar value. The previous tests in this function made sure
6016 the type is interoperable. */
6017 if (bind_c_function
&& tmp_sym
->as
!= NULL
)
6018 gfc_error ("Return type of BIND(C) function %qs at %L cannot "
6019 "be an array", tmp_sym
->name
, &(tmp_sym
->declared_at
));
6021 /* BIND(C) functions cannot return a character string. */
6022 if (bind_c_function
&& tmp_sym
->ts
.type
== BT_CHARACTER
)
6023 if (tmp_sym
->ts
.u
.cl
== NULL
|| tmp_sym
->ts
.u
.cl
->length
== NULL
6024 || tmp_sym
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
6025 || mpz_cmp_si (tmp_sym
->ts
.u
.cl
->length
->value
.integer
, 1) != 0)
6026 gfc_error ("Return type of BIND(C) function %qs of character "
6027 "type at %L must have length 1", tmp_sym
->name
,
6028 &(tmp_sym
->declared_at
));
6031 /* See if the symbol has been marked as private. If it has, make sure
6032 there is no binding label and warn the user if there is one. */
6033 if (tmp_sym
->attr
.access
== ACCESS_PRIVATE
6034 && tmp_sym
->binding_label
)
6035 /* Use gfc_warning_now because we won't say that the symbol fails
6036 just because of this. */
6037 gfc_warning_now (0, "Symbol %qs at %L is marked PRIVATE but has been "
6038 "given the binding label %qs", tmp_sym
->name
,
6039 &(tmp_sym
->declared_at
), tmp_sym
->binding_label
);
6045 /* Set the appropriate fields for a symbol that's been declared as
6046 BIND(C) (the is_bind_c flag and the binding label), and verify that
6047 the type is C interoperable. Errors are reported by the functions
6048 used to set/test these fields. */
6051 set_verify_bind_c_sym (gfc_symbol
*tmp_sym
, int num_idents
)
6055 /* TODO: Do we need to make sure the vars aren't marked private? */
6057 /* Set the is_bind_c bit in symbol_attribute. */
6058 gfc_add_is_bind_c (&(tmp_sym
->attr
), tmp_sym
->name
, &gfc_current_locus
, 0);
6060 if (!set_binding_label (&tmp_sym
->binding_label
, tmp_sym
->name
, num_idents
))
6067 /* Set the fields marking the given common block as BIND(C), including
6068 a binding label, and report any errors encountered. */
6071 set_verify_bind_c_com_block (gfc_common_head
*com_block
, int num_idents
)
6075 /* destLabel, common name, typespec (which may have binding label). */
6076 if (!set_binding_label (&com_block
->binding_label
, com_block
->name
,
6080 /* Set the given common block (com_block) to being bind(c) (1). */
6081 set_com_block_bind_c (com_block
, 1);
6087 /* Retrieve the list of one or more identifiers that the given bind(c)
6088 attribute applies to. */
6091 get_bind_c_idents (void)
6093 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6095 gfc_symbol
*tmp_sym
= NULL
;
6097 gfc_common_head
*com_block
= NULL
;
6099 if (gfc_match_name (name
) == MATCH_YES
)
6101 found_id
= MATCH_YES
;
6102 gfc_get_ha_symbol (name
, &tmp_sym
);
6104 else if (gfc_match_common_name (name
) == MATCH_YES
)
6106 found_id
= MATCH_YES
;
6107 com_block
= gfc_get_common (name
, 0);
6111 gfc_error ("Need either entity or common block name for "
6112 "attribute specification statement at %C");
6116 /* Save the current identifier and look for more. */
6119 /* Increment the number of identifiers found for this spec stmt. */
6122 /* Make sure we have a sym or com block, and verify that it can
6123 be bind(c). Set the appropriate field(s) and look for more
6125 if (tmp_sym
!= NULL
|| com_block
!= NULL
)
6127 if (tmp_sym
!= NULL
)
6129 if (!set_verify_bind_c_sym (tmp_sym
, num_idents
))
6134 if (!set_verify_bind_c_com_block (com_block
, num_idents
))
6138 /* Look to see if we have another identifier. */
6140 if (gfc_match_eos () == MATCH_YES
)
6141 found_id
= MATCH_NO
;
6142 else if (gfc_match_char (',') != MATCH_YES
)
6143 found_id
= MATCH_NO
;
6144 else if (gfc_match_name (name
) == MATCH_YES
)
6146 found_id
= MATCH_YES
;
6147 gfc_get_ha_symbol (name
, &tmp_sym
);
6149 else if (gfc_match_common_name (name
) == MATCH_YES
)
6151 found_id
= MATCH_YES
;
6152 com_block
= gfc_get_common (name
, 0);
6156 gfc_error ("Missing entity or common block name for "
6157 "attribute specification statement at %C");
6163 gfc_internal_error ("Missing symbol");
6165 } while (found_id
== MATCH_YES
);
6167 /* if we get here we were successful */
6172 /* Try and match a BIND(C) attribute specification statement. */
6175 gfc_match_bind_c_stmt (void)
6177 match found_match
= MATCH_NO
;
6182 /* This may not be necessary. */
6184 /* Clear the temporary binding label holder. */
6185 curr_binding_label
= NULL
;
6187 /* Look for the bind(c). */
6188 found_match
= gfc_match_bind_c (NULL
, true);
6190 if (found_match
== MATCH_YES
)
6192 if (!gfc_notify_std (GFC_STD_F2003
, "BIND(C) statement at %C"))
6195 /* Look for the :: now, but it is not required. */
6198 /* Get the identifier(s) that needs to be updated. This may need to
6199 change to hand the flag(s) for the attr specified so all identifiers
6200 found can have all appropriate parts updated (assuming that the same
6201 spec stmt can have multiple attrs, such as both bind(c) and
6203 if (!get_bind_c_idents ())
6204 /* Error message should have printed already. */
6212 /* Match a data declaration statement. */
6215 gfc_match_data_decl (void)
6221 type_param_spec_list
= NULL
;
6222 decl_type_param_list
= NULL
;
6224 num_idents_on_line
= 0;
6226 m
= gfc_match_decl_type_spec (¤t_ts
, 0);
6230 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
6231 && !gfc_comp_struct (gfc_current_state ()))
6233 sym
= gfc_use_derived (current_ts
.u
.derived
);
6241 current_ts
.u
.derived
= sym
;
6244 m
= match_attr_spec ();
6245 if (m
== MATCH_ERROR
)
6251 if (current_ts
.type
== BT_CLASS
6252 && current_ts
.u
.derived
->attr
.unlimited_polymorphic
)
6255 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
6256 && current_ts
.u
.derived
->components
== NULL
6257 && !current_ts
.u
.derived
->attr
.zero_comp
)
6260 if (current_attr
.pointer
&& gfc_comp_struct (gfc_current_state ()))
6263 if (current_attr
.allocatable
&& gfc_current_state () == COMP_DERIVED
)
6266 gfc_find_symbol (current_ts
.u
.derived
->name
,
6267 current_ts
.u
.derived
->ns
, 1, &sym
);
6269 /* Any symbol that we find had better be a type definition
6270 which has its components defined, or be a structure definition
6271 actively being parsed. */
6272 if (sym
!= NULL
&& gfc_fl_struct (sym
->attr
.flavor
)
6273 && (current_ts
.u
.derived
->components
!= NULL
6274 || current_ts
.u
.derived
->attr
.zero_comp
6275 || current_ts
.u
.derived
== gfc_new_block
))
6278 gfc_error ("Derived type at %C has not been previously defined "
6279 "and so cannot appear in a derived type definition");
6285 /* If we have an old-style character declaration, and no new-style
6286 attribute specifications, then there a comma is optional between
6287 the type specification and the variable list. */
6288 if (m
== MATCH_NO
&& current_ts
.type
== BT_CHARACTER
&& old_char_selector
)
6289 gfc_match_char (',');
6291 /* Give the types/attributes to symbols that follow. Give the element
6292 a number so that repeat character length expressions can be copied. */
6296 num_idents_on_line
++;
6297 m
= variable_decl (elem
++);
6298 if (m
== MATCH_ERROR
)
6303 if (gfc_match_eos () == MATCH_YES
)
6305 if (gfc_match_char (',') != MATCH_YES
)
6309 if (!gfc_error_flag_test ())
6311 /* An anonymous structure declaration is unambiguous; if we matched one
6312 according to gfc_match_structure_decl, we need to return MATCH_YES
6313 here to avoid confusing the remaining matchers, even if there was an
6314 error during variable_decl. We must flush any such errors. Note this
6315 causes the parser to gracefully continue parsing the remaining input
6316 as a structure body, which likely follows. */
6317 if (current_ts
.type
== BT_DERIVED
&& current_ts
.u
.derived
6318 && gfc_fl_struct (current_ts
.u
.derived
->attr
.flavor
))
6320 gfc_error_now ("Syntax error in anonymous structure declaration"
6322 /* Skip the bad variable_decl and line up for the start of the
6324 gfc_error_recovery ();
6329 gfc_error ("Syntax error in data declaration at %C");
6334 gfc_free_data_all (gfc_current_ns
);
6337 if (saved_kind_expr
)
6338 gfc_free_expr (saved_kind_expr
);
6339 if (type_param_spec_list
)
6340 gfc_free_actual_arglist (type_param_spec_list
);
6341 if (decl_type_param_list
)
6342 gfc_free_actual_arglist (decl_type_param_list
);
6343 saved_kind_expr
= NULL
;
6344 gfc_free_array_spec (current_as
);
6350 in_module_or_interface(void)
6352 if (gfc_current_state () == COMP_MODULE
6353 || gfc_current_state () == COMP_SUBMODULE
6354 || gfc_current_state () == COMP_INTERFACE
)
6357 if (gfc_state_stack
->state
== COMP_CONTAINS
6358 || gfc_state_stack
->state
== COMP_FUNCTION
6359 || gfc_state_stack
->state
== COMP_SUBROUTINE
)
6362 for (p
= gfc_state_stack
->previous
; p
; p
= p
->previous
)
6364 if (p
->state
== COMP_MODULE
|| p
->state
== COMP_SUBMODULE
6365 || p
->state
== COMP_INTERFACE
)
6372 /* Match a prefix associated with a function or subroutine
6373 declaration. If the typespec pointer is nonnull, then a typespec
6374 can be matched. Note that if nothing matches, MATCH_YES is
6375 returned (the null string was matched). */
6378 gfc_match_prefix (gfc_typespec
*ts
)
6384 gfc_clear_attr (¤t_attr
);
6386 seen_impure
= false;
6388 gcc_assert (!gfc_matching_prefix
);
6389 gfc_matching_prefix
= true;
6393 found_prefix
= false;
6395 /* MODULE is a prefix like PURE, ELEMENTAL, etc., having a
6396 corresponding attribute seems natural and distinguishes these
6397 procedures from procedure types of PROC_MODULE, which these are
6399 if (gfc_match ("module% ") == MATCH_YES
)
6401 if (!gfc_notify_std (GFC_STD_F2008
, "MODULE prefix at %C"))
6404 if (!in_module_or_interface ())
6406 gfc_error ("MODULE prefix at %C found outside of a module, "
6407 "submodule, or interface");
6411 current_attr
.module_procedure
= 1;
6412 found_prefix
= true;
6415 if (!seen_type
&& ts
!= NULL
)
6418 m
= gfc_match_decl_type_spec (ts
, 0);
6419 if (m
== MATCH_ERROR
)
6421 if (m
== MATCH_YES
&& gfc_match_space () == MATCH_YES
)
6424 found_prefix
= true;
6428 if (gfc_match ("elemental% ") == MATCH_YES
)
6430 if (!gfc_add_elemental (¤t_attr
, NULL
))
6433 found_prefix
= true;
6436 if (gfc_match ("pure% ") == MATCH_YES
)
6438 if (!gfc_add_pure (¤t_attr
, NULL
))
6441 found_prefix
= true;
6444 if (gfc_match ("recursive% ") == MATCH_YES
)
6446 if (!gfc_add_recursive (¤t_attr
, NULL
))
6449 found_prefix
= true;
6452 /* IMPURE is a somewhat special case, as it needs not set an actual
6453 attribute but rather only prevents ELEMENTAL routines from being
6454 automatically PURE. */
6455 if (gfc_match ("impure% ") == MATCH_YES
)
6457 if (!gfc_notify_std (GFC_STD_F2008
, "IMPURE procedure at %C"))
6461 found_prefix
= true;
6464 while (found_prefix
);
6466 /* IMPURE and PURE must not both appear, of course. */
6467 if (seen_impure
&& current_attr
.pure
)
6469 gfc_error ("PURE and IMPURE must not appear both at %C");
6473 /* If IMPURE it not seen but the procedure is ELEMENTAL, mark it as PURE. */
6474 if (!seen_impure
&& current_attr
.elemental
&& !current_attr
.pure
)
6476 if (!gfc_add_pure (¤t_attr
, NULL
))
6480 /* At this point, the next item is not a prefix. */
6481 gcc_assert (gfc_matching_prefix
);
6483 gfc_matching_prefix
= false;
6487 gcc_assert (gfc_matching_prefix
);
6488 gfc_matching_prefix
= false;
6493 /* Copy attributes matched by gfc_match_prefix() to attributes on a symbol. */
6496 copy_prefix (symbol_attribute
*dest
, locus
*where
)
6498 if (dest
->module_procedure
)
6500 if (current_attr
.elemental
)
6501 dest
->elemental
= 1;
6503 if (current_attr
.pure
)
6506 if (current_attr
.recursive
)
6507 dest
->recursive
= 1;
6509 /* Module procedures are unusual in that the 'dest' is copied from
6510 the interface declaration. However, this is an oportunity to
6511 check that the submodule declaration is compliant with the
6513 if (dest
->elemental
&& !current_attr
.elemental
)
6515 gfc_error ("ELEMENTAL prefix in MODULE PROCEDURE interface is "
6516 "missing at %L", where
);
6520 if (dest
->pure
&& !current_attr
.pure
)
6522 gfc_error ("PURE prefix in MODULE PROCEDURE interface is "
6523 "missing at %L", where
);
6527 if (dest
->recursive
&& !current_attr
.recursive
)
6529 gfc_error ("RECURSIVE prefix in MODULE PROCEDURE interface is "
6530 "missing at %L", where
);
6537 if (current_attr
.elemental
&& !gfc_add_elemental (dest
, where
))
6540 if (current_attr
.pure
&& !gfc_add_pure (dest
, where
))
6543 if (current_attr
.recursive
&& !gfc_add_recursive (dest
, where
))
6550 /* Match a formal argument list or, if typeparam is true, a
6551 type_param_name_list. */
6554 gfc_match_formal_arglist (gfc_symbol
*progname
, int st_flag
,
6555 int null_flag
, bool typeparam
)
6557 gfc_formal_arglist
*head
, *tail
, *p
, *q
;
6558 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6561 gfc_formal_arglist
*formal
= NULL
;
6565 /* Keep the interface formal argument list and null it so that the
6566 matching for the new declaration can be done. The numbers and
6567 names of the arguments are checked here. The interface formal
6568 arguments are retained in formal_arglist and the characteristics
6569 are compared in resolve.c(resolve_fl_procedure). See the remark
6570 in get_proc_name about the eventual need to copy the formal_arglist
6571 and populate the formal namespace of the interface symbol. */
6572 if (progname
->attr
.module_procedure
6573 && progname
->attr
.host_assoc
)
6575 formal
= progname
->formal
;
6576 progname
->formal
= NULL
;
6579 if (gfc_match_char ('(') != MATCH_YES
)
6586 if (gfc_match_char (')') == MATCH_YES
)
6590 gfc_error_now ("A type parameter list is required at %C");
6600 if (gfc_match_char ('*') == MATCH_YES
)
6603 if (!typeparam
&& !gfc_notify_std (GFC_STD_F95_OBS
,
6604 "Alternate-return argument at %C"))
6610 gfc_error_now ("A parameter name is required at %C");
6614 m
= gfc_match_name (name
);
6618 gfc_error_now ("A parameter name is required at %C");
6622 if (!typeparam
&& gfc_get_symbol (name
, NULL
, &sym
))
6625 && gfc_get_symbol (name
, progname
->f2k_derived
, &sym
))
6629 p
= gfc_get_formal_arglist ();
6641 /* We don't add the VARIABLE flavor because the name could be a
6642 dummy procedure. We don't apply these attributes to formal
6643 arguments of statement functions. */
6644 if (sym
!= NULL
&& !st_flag
6645 && (!gfc_add_dummy(&sym
->attr
, sym
->name
, NULL
)
6646 || !gfc_missing_attr (&sym
->attr
, NULL
)))
6652 /* The name of a program unit can be in a different namespace,
6653 so check for it explicitly. After the statement is accepted,
6654 the name is checked for especially in gfc_get_symbol(). */
6655 if (gfc_new_block
!= NULL
&& sym
!= NULL
&& !typeparam
6656 && strcmp (sym
->name
, gfc_new_block
->name
) == 0)
6658 gfc_error ("Name %qs at %C is the name of the procedure",
6664 if (gfc_match_char (')') == MATCH_YES
)
6667 m
= gfc_match_char (',');
6671 gfc_error_now ("Expected parameter list in type declaration "
6674 gfc_error ("Unexpected junk in formal argument list at %C");
6680 /* Check for duplicate symbols in the formal argument list. */
6683 for (p
= head
; p
->next
; p
= p
->next
)
6688 for (q
= p
->next
; q
; q
= q
->next
)
6689 if (p
->sym
== q
->sym
)
6692 gfc_error_now ("Duplicate name %qs in parameter "
6693 "list at %C", p
->sym
->name
);
6695 gfc_error ("Duplicate symbol %qs in formal argument "
6696 "list at %C", p
->sym
->name
);
6704 if (!gfc_add_explicit_interface (progname
, IFSRC_DECL
, head
, NULL
))
6710 /* gfc_error_now used in following and return with MATCH_YES because
6711 doing otherwise results in a cascade of extraneous errors and in
6712 some cases an ICE in symbol.c(gfc_release_symbol). */
6713 if (progname
->attr
.module_procedure
&& progname
->attr
.host_assoc
)
6715 bool arg_count_mismatch
= false;
6717 if (!formal
&& head
)
6718 arg_count_mismatch
= true;
6720 /* Abbreviated module procedure declaration is not meant to have any
6721 formal arguments! */
6722 if (!progname
->abr_modproc_decl
&& formal
&& !head
)
6723 arg_count_mismatch
= true;
6725 for (p
= formal
, q
= head
; p
&& q
; p
= p
->next
, q
= q
->next
)
6727 if ((p
->next
!= NULL
&& q
->next
== NULL
)
6728 || (p
->next
== NULL
&& q
->next
!= NULL
))
6729 arg_count_mismatch
= true;
6730 else if ((p
->sym
== NULL
&& q
->sym
== NULL
)
6731 || strcmp (p
->sym
->name
, q
->sym
->name
) == 0)
6734 gfc_error_now ("Mismatch in MODULE PROCEDURE formal "
6735 "argument names (%s/%s) at %C",
6736 p
->sym
->name
, q
->sym
->name
);
6739 if (arg_count_mismatch
)
6740 gfc_error_now ("Mismatch in number of MODULE PROCEDURE "
6741 "formal arguments at %C");
6747 gfc_free_formal_arglist (head
);
6752 /* Match a RESULT specification following a function declaration or
6753 ENTRY statement. Also matches the end-of-statement. */
6756 match_result (gfc_symbol
*function
, gfc_symbol
**result
)
6758 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6762 if (gfc_match (" result (") != MATCH_YES
)
6765 m
= gfc_match_name (name
);
6769 /* Get the right paren, and that's it because there could be the
6770 bind(c) attribute after the result clause. */
6771 if (gfc_match_char (')') != MATCH_YES
)
6773 /* TODO: should report the missing right paren here. */
6777 if (strcmp (function
->name
, name
) == 0)
6779 gfc_error ("RESULT variable at %C must be different than function name");
6783 if (gfc_get_symbol (name
, NULL
, &r
))
6786 if (!gfc_add_result (&r
->attr
, r
->name
, NULL
))
6795 /* Match a function suffix, which could be a combination of a result
6796 clause and BIND(C), either one, or neither. The draft does not
6797 require them to come in a specific order. */
6800 gfc_match_suffix (gfc_symbol
*sym
, gfc_symbol
**result
)
6802 match is_bind_c
; /* Found bind(c). */
6803 match is_result
; /* Found result clause. */
6804 match found_match
; /* Status of whether we've found a good match. */
6805 char peek_char
; /* Character we're going to peek at. */
6806 bool allow_binding_name
;
6808 /* Initialize to having found nothing. */
6809 found_match
= MATCH_NO
;
6810 is_bind_c
= MATCH_NO
;
6811 is_result
= MATCH_NO
;
6813 /* Get the next char to narrow between result and bind(c). */
6814 gfc_gobble_whitespace ();
6815 peek_char
= gfc_peek_ascii_char ();
6817 /* C binding names are not allowed for internal procedures. */
6818 if (gfc_current_state () == COMP_CONTAINS
6819 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
6820 allow_binding_name
= false;
6822 allow_binding_name
= true;
6827 /* Look for result clause. */
6828 is_result
= match_result (sym
, result
);
6829 if (is_result
== MATCH_YES
)
6831 /* Now see if there is a bind(c) after it. */
6832 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
6833 /* We've found the result clause and possibly bind(c). */
6834 found_match
= MATCH_YES
;
6837 /* This should only be MATCH_ERROR. */
6838 found_match
= is_result
;
6841 /* Look for bind(c) first. */
6842 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
6843 if (is_bind_c
== MATCH_YES
)
6845 /* Now see if a result clause followed it. */
6846 is_result
= match_result (sym
, result
);
6847 found_match
= MATCH_YES
;
6851 /* Should only be a MATCH_ERROR if we get here after seeing 'b'. */
6852 found_match
= MATCH_ERROR
;
6856 gfc_error ("Unexpected junk after function declaration at %C");
6857 found_match
= MATCH_ERROR
;
6861 if (is_bind_c
== MATCH_YES
)
6863 /* Fortran 2008 draft allows BIND(C) for internal procedures. */
6864 if (gfc_current_state () == COMP_CONTAINS
6865 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
6866 && !gfc_notify_std (GFC_STD_F2008
, "BIND(C) attribute "
6867 "at %L may not be specified for an internal "
6868 "procedure", &gfc_current_locus
))
6871 if (!gfc_add_is_bind_c (&(sym
->attr
), sym
->name
, &gfc_current_locus
, 1))
6879 /* Procedure pointer return value without RESULT statement:
6880 Add "hidden" result variable named "ppr@". */
6883 add_hidden_procptr_result (gfc_symbol
*sym
)
6887 if (gfc_notification_std (GFC_STD_F2003
) == ERROR
)
6890 /* First usage case: PROCEDURE and EXTERNAL statements. */
6891 case1
= gfc_current_state () == COMP_FUNCTION
&& gfc_current_block ()
6892 && strcmp (gfc_current_block ()->name
, sym
->name
) == 0
6893 && sym
->attr
.external
;
6894 /* Second usage case: INTERFACE statements. */
6895 case2
= gfc_current_state () == COMP_INTERFACE
&& gfc_state_stack
->previous
6896 && gfc_state_stack
->previous
->state
== COMP_FUNCTION
6897 && strcmp (gfc_state_stack
->previous
->sym
->name
, sym
->name
) == 0;
6903 gfc_get_sym_tree ("ppr@", gfc_current_ns
, &stree
, false);
6907 gfc_get_sym_tree ("ppr@", gfc_current_ns
->parent
, &stree
, false);
6908 st2
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "ppr@");
6909 st2
->n
.sym
= stree
->n
.sym
;
6910 stree
->n
.sym
->refs
++;
6912 sym
->result
= stree
->n
.sym
;
6914 sym
->result
->attr
.proc_pointer
= sym
->attr
.proc_pointer
;
6915 sym
->result
->attr
.pointer
= sym
->attr
.pointer
;
6916 sym
->result
->attr
.external
= sym
->attr
.external
;
6917 sym
->result
->attr
.referenced
= sym
->attr
.referenced
;
6918 sym
->result
->ts
= sym
->ts
;
6919 sym
->attr
.proc_pointer
= 0;
6920 sym
->attr
.pointer
= 0;
6921 sym
->attr
.external
= 0;
6922 if (sym
->result
->attr
.external
&& sym
->result
->attr
.pointer
)
6924 sym
->result
->attr
.pointer
= 0;
6925 sym
->result
->attr
.proc_pointer
= 1;
6928 return gfc_add_result (&sym
->result
->attr
, sym
->result
->name
, NULL
);
6930 /* POINTER after PROCEDURE/EXTERNAL/INTERFACE statement. */
6931 else if (sym
->attr
.function
&& !sym
->attr
.external
&& sym
->attr
.pointer
6932 && sym
->result
&& sym
->result
!= sym
&& sym
->result
->attr
.external
6933 && sym
== gfc_current_ns
->proc_name
6934 && sym
== sym
->result
->ns
->proc_name
6935 && strcmp ("ppr@", sym
->result
->name
) == 0)
6937 sym
->result
->attr
.proc_pointer
= 1;
6938 sym
->attr
.pointer
= 0;
6946 /* Match the interface for a PROCEDURE declaration,
6947 including brackets (R1212). */
6950 match_procedure_interface (gfc_symbol
**proc_if
)
6954 locus old_loc
, entry_loc
;
6955 gfc_namespace
*old_ns
= gfc_current_ns
;
6956 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6958 old_loc
= entry_loc
= gfc_current_locus
;
6959 gfc_clear_ts (¤t_ts
);
6961 if (gfc_match (" (") != MATCH_YES
)
6963 gfc_current_locus
= entry_loc
;
6967 /* Get the type spec. for the procedure interface. */
6968 old_loc
= gfc_current_locus
;
6969 m
= gfc_match_decl_type_spec (¤t_ts
, 0);
6970 gfc_gobble_whitespace ();
6971 if (m
== MATCH_YES
|| (m
== MATCH_NO
&& gfc_peek_ascii_char () == ')'))
6974 if (m
== MATCH_ERROR
)
6977 /* Procedure interface is itself a procedure. */
6978 gfc_current_locus
= old_loc
;
6979 m
= gfc_match_name (name
);
6981 /* First look to see if it is already accessible in the current
6982 namespace because it is use associated or contained. */
6984 if (gfc_find_sym_tree (name
, NULL
, 0, &st
))
6987 /* If it is still not found, then try the parent namespace, if it
6988 exists and create the symbol there if it is still not found. */
6989 if (gfc_current_ns
->parent
)
6990 gfc_current_ns
= gfc_current_ns
->parent
;
6991 if (st
== NULL
&& gfc_get_ha_sym_tree (name
, &st
))
6994 gfc_current_ns
= old_ns
;
6995 *proc_if
= st
->n
.sym
;
7000 /* Resolve interface if possible. That way, attr.procedure is only set
7001 if it is declared by a later procedure-declaration-stmt, which is
7002 invalid per F08:C1216 (cf. resolve_procedure_interface). */
7003 while ((*proc_if
)->ts
.interface
7004 && *proc_if
!= (*proc_if
)->ts
.interface
)
7005 *proc_if
= (*proc_if
)->ts
.interface
;
7007 if ((*proc_if
)->attr
.flavor
== FL_UNKNOWN
7008 && (*proc_if
)->ts
.type
== BT_UNKNOWN
7009 && !gfc_add_flavor (&(*proc_if
)->attr
, FL_PROCEDURE
,
7010 (*proc_if
)->name
, NULL
))
7015 if (gfc_match (" )") != MATCH_YES
)
7017 gfc_current_locus
= entry_loc
;
7025 /* Match a PROCEDURE declaration (R1211). */
7028 match_procedure_decl (void)
7031 gfc_symbol
*sym
, *proc_if
= NULL
;
7033 gfc_expr
*initializer
= NULL
;
7035 /* Parse interface (with brackets). */
7036 m
= match_procedure_interface (&proc_if
);
7040 /* Parse attributes (with colons). */
7041 m
= match_attr_spec();
7042 if (m
== MATCH_ERROR
)
7045 if (proc_if
&& proc_if
->attr
.is_bind_c
&& !current_attr
.is_bind_c
)
7047 current_attr
.is_bind_c
= 1;
7048 has_name_equals
= 0;
7049 curr_binding_label
= NULL
;
7052 /* Get procedure symbols. */
7055 m
= gfc_match_symbol (&sym
, 0);
7058 else if (m
== MATCH_ERROR
)
7061 /* Add current_attr to the symbol attributes. */
7062 if (!gfc_copy_attr (&sym
->attr
, ¤t_attr
, NULL
))
7065 if (sym
->attr
.is_bind_c
)
7067 /* Check for C1218. */
7068 if (!proc_if
|| !proc_if
->attr
.is_bind_c
)
7070 gfc_error ("BIND(C) attribute at %C requires "
7071 "an interface with BIND(C)");
7074 /* Check for C1217. */
7075 if (has_name_equals
&& sym
->attr
.pointer
)
7077 gfc_error ("BIND(C) procedure with NAME may not have "
7078 "POINTER attribute at %C");
7081 if (has_name_equals
&& sym
->attr
.dummy
)
7083 gfc_error ("Dummy procedure at %C may not have "
7084 "BIND(C) attribute with NAME");
7087 /* Set binding label for BIND(C). */
7088 if (!set_binding_label (&sym
->binding_label
, sym
->name
, num
))
7092 if (!gfc_add_external (&sym
->attr
, NULL
))
7095 if (add_hidden_procptr_result (sym
))
7098 if (!gfc_add_proc (&sym
->attr
, sym
->name
, NULL
))
7101 /* Set interface. */
7102 if (proc_if
!= NULL
)
7104 if (sym
->ts
.type
!= BT_UNKNOWN
)
7106 gfc_error ("Procedure %qs at %L already has basic type of %s",
7107 sym
->name
, &gfc_current_locus
,
7108 gfc_basic_typename (sym
->ts
.type
));
7111 sym
->ts
.interface
= proc_if
;
7112 sym
->attr
.untyped
= 1;
7113 sym
->attr
.if_source
= IFSRC_IFBODY
;
7115 else if (current_ts
.type
!= BT_UNKNOWN
)
7117 if (!gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
7119 sym
->ts
.interface
= gfc_new_symbol ("", gfc_current_ns
);
7120 sym
->ts
.interface
->ts
= current_ts
;
7121 sym
->ts
.interface
->attr
.flavor
= FL_PROCEDURE
;
7122 sym
->ts
.interface
->attr
.function
= 1;
7123 sym
->attr
.function
= 1;
7124 sym
->attr
.if_source
= IFSRC_UNKNOWN
;
7127 if (gfc_match (" =>") == MATCH_YES
)
7129 if (!current_attr
.pointer
)
7131 gfc_error ("Initialization at %C isn't for a pointer variable");
7136 m
= match_pointer_init (&initializer
, 1);
7140 if (!add_init_expr_to_sym (sym
->name
, &initializer
, &gfc_current_locus
))
7145 if (gfc_match_eos () == MATCH_YES
)
7147 if (gfc_match_char (',') != MATCH_YES
)
7152 gfc_error ("Syntax error in PROCEDURE statement at %C");
7156 /* Free stuff up and return. */
7157 gfc_free_expr (initializer
);
7163 match_binding_attributes (gfc_typebound_proc
* ba
, bool generic
, bool ppc
);
7166 /* Match a procedure pointer component declaration (R445). */
7169 match_ppc_decl (void)
7172 gfc_symbol
*proc_if
= NULL
;
7176 gfc_expr
*initializer
= NULL
;
7177 gfc_typebound_proc
* tb
;
7178 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7180 /* Parse interface (with brackets). */
7181 m
= match_procedure_interface (&proc_if
);
7185 /* Parse attributes. */
7186 tb
= XCNEW (gfc_typebound_proc
);
7187 tb
->where
= gfc_current_locus
;
7188 m
= match_binding_attributes (tb
, false, true);
7189 if (m
== MATCH_ERROR
)
7192 gfc_clear_attr (¤t_attr
);
7193 current_attr
.procedure
= 1;
7194 current_attr
.proc_pointer
= 1;
7195 current_attr
.access
= tb
->access
;
7196 current_attr
.flavor
= FL_PROCEDURE
;
7198 /* Match the colons (required). */
7199 if (gfc_match (" ::") != MATCH_YES
)
7201 gfc_error ("Expected %<::%> after binding-attributes at %C");
7205 /* Check for C450. */
7206 if (!tb
->nopass
&& proc_if
== NULL
)
7208 gfc_error("NOPASS or explicit interface required at %C");
7212 if (!gfc_notify_std (GFC_STD_F2003
, "Procedure pointer component at %C"))
7215 /* Match PPC names. */
7219 m
= gfc_match_name (name
);
7222 else if (m
== MATCH_ERROR
)
7225 if (!gfc_add_component (gfc_current_block(), name
, &c
))
7228 /* Add current_attr to the symbol attributes. */
7229 if (!gfc_copy_attr (&c
->attr
, ¤t_attr
, NULL
))
7232 if (!gfc_add_external (&c
->attr
, NULL
))
7235 if (!gfc_add_proc (&c
->attr
, name
, NULL
))
7242 c
->tb
= XCNEW (gfc_typebound_proc
);
7243 c
->tb
->where
= gfc_current_locus
;
7247 /* Set interface. */
7248 if (proc_if
!= NULL
)
7250 c
->ts
.interface
= proc_if
;
7251 c
->attr
.untyped
= 1;
7252 c
->attr
.if_source
= IFSRC_IFBODY
;
7254 else if (ts
.type
!= BT_UNKNOWN
)
7257 c
->ts
.interface
= gfc_new_symbol ("", gfc_current_ns
);
7258 c
->ts
.interface
->result
= c
->ts
.interface
;
7259 c
->ts
.interface
->ts
= ts
;
7260 c
->ts
.interface
->attr
.flavor
= FL_PROCEDURE
;
7261 c
->ts
.interface
->attr
.function
= 1;
7262 c
->attr
.function
= 1;
7263 c
->attr
.if_source
= IFSRC_UNKNOWN
;
7266 if (gfc_match (" =>") == MATCH_YES
)
7268 m
= match_pointer_init (&initializer
, 1);
7271 gfc_free_expr (initializer
);
7274 c
->initializer
= initializer
;
7277 if (gfc_match_eos () == MATCH_YES
)
7279 if (gfc_match_char (',') != MATCH_YES
)
7284 gfc_error ("Syntax error in procedure pointer component at %C");
7289 /* Match a PROCEDURE declaration inside an interface (R1206). */
7292 match_procedure_in_interface (void)
7296 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7299 if (current_interface
.type
== INTERFACE_NAMELESS
7300 || current_interface
.type
== INTERFACE_ABSTRACT
)
7302 gfc_error ("PROCEDURE at %C must be in a generic interface");
7306 /* Check if the F2008 optional double colon appears. */
7307 gfc_gobble_whitespace ();
7308 old_locus
= gfc_current_locus
;
7309 if (gfc_match ("::") == MATCH_YES
)
7311 if (!gfc_notify_std (GFC_STD_F2008
, "double colon in "
7312 "MODULE PROCEDURE statement at %L", &old_locus
))
7316 gfc_current_locus
= old_locus
;
7320 m
= gfc_match_name (name
);
7323 else if (m
== MATCH_ERROR
)
7325 if (gfc_get_symbol (name
, gfc_current_ns
->parent
, &sym
))
7328 if (!gfc_add_interface (sym
))
7331 if (gfc_match_eos () == MATCH_YES
)
7333 if (gfc_match_char (',') != MATCH_YES
)
7340 gfc_error ("Syntax error in PROCEDURE statement at %C");
7345 /* General matcher for PROCEDURE declarations. */
7347 static match
match_procedure_in_type (void);
7350 gfc_match_procedure (void)
7354 switch (gfc_current_state ())
7359 case COMP_SUBMODULE
:
7360 case COMP_SUBROUTINE
:
7363 m
= match_procedure_decl ();
7365 case COMP_INTERFACE
:
7366 m
= match_procedure_in_interface ();
7369 m
= match_ppc_decl ();
7371 case COMP_DERIVED_CONTAINS
:
7372 m
= match_procedure_in_type ();
7381 if (!gfc_notify_std (GFC_STD_F2003
, "PROCEDURE statement at %C"))
7388 /* Warn if a matched procedure has the same name as an intrinsic; this is
7389 simply a wrapper around gfc_warn_intrinsic_shadow that interprets the current
7390 parser-state-stack to find out whether we're in a module. */
7393 do_warn_intrinsic_shadow (const gfc_symbol
* sym
, bool func
)
7397 in_module
= (gfc_state_stack
->previous
7398 && (gfc_state_stack
->previous
->state
== COMP_MODULE
7399 || gfc_state_stack
->previous
->state
== COMP_SUBMODULE
));
7401 gfc_warn_intrinsic_shadow (sym
, in_module
, func
);
7405 /* Match a function declaration. */
7408 gfc_match_function_decl (void)
7410 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7411 gfc_symbol
*sym
, *result
;
7415 match found_match
; /* Status returned by match func. */
7417 if (gfc_current_state () != COMP_NONE
7418 && gfc_current_state () != COMP_INTERFACE
7419 && gfc_current_state () != COMP_CONTAINS
)
7422 gfc_clear_ts (¤t_ts
);
7424 old_loc
= gfc_current_locus
;
7426 m
= gfc_match_prefix (¤t_ts
);
7429 gfc_current_locus
= old_loc
;
7433 if (gfc_match ("function% %n", name
) != MATCH_YES
)
7435 gfc_current_locus
= old_loc
;
7439 if (get_proc_name (name
, &sym
, false))
7442 if (add_hidden_procptr_result (sym
))
7445 if (current_attr
.module_procedure
)
7446 sym
->attr
.module_procedure
= 1;
7448 gfc_new_block
= sym
;
7450 m
= gfc_match_formal_arglist (sym
, 0, 0);
7453 gfc_error ("Expected formal argument list in function "
7454 "definition at %C");
7458 else if (m
== MATCH_ERROR
)
7463 /* According to the draft, the bind(c) and result clause can
7464 come in either order after the formal_arg_list (i.e., either
7465 can be first, both can exist together or by themselves or neither
7466 one). Therefore, the match_result can't match the end of the
7467 string, and check for the bind(c) or result clause in either order. */
7468 found_match
= gfc_match_eos ();
7470 /* Make sure that it isn't already declared as BIND(C). If it is, it
7471 must have been marked BIND(C) with a BIND(C) attribute and that is
7472 not allowed for procedures. */
7473 if (sym
->attr
.is_bind_c
== 1)
7475 sym
->attr
.is_bind_c
= 0;
7477 if (gfc_state_stack
->previous
7478 && gfc_state_stack
->previous
->state
!= COMP_SUBMODULE
)
7481 loc
= sym
->old_symbol
!= NULL
7482 ? sym
->old_symbol
->declared_at
: gfc_current_locus
;
7483 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7484 "variables or common blocks", &loc
);
7488 if (found_match
!= MATCH_YES
)
7490 /* If we haven't found the end-of-statement, look for a suffix. */
7491 suffix_match
= gfc_match_suffix (sym
, &result
);
7492 if (suffix_match
== MATCH_YES
)
7493 /* Need to get the eos now. */
7494 found_match
= gfc_match_eos ();
7496 found_match
= suffix_match
;
7499 /* F2018 C1550 (R1526) If MODULE appears in the prefix of a module
7500 subprogram and a binding label is specified, it shall be the
7501 same as the binding label specified in the corresponding module
7502 procedure interface body. */
7503 if (sym
->attr
.is_bind_c
&& sym
->attr
.module_procedure
&& sym
->old_symbol
7504 && strcmp (sym
->name
, sym
->old_symbol
->name
) == 0
7505 && sym
->binding_label
&& sym
->old_symbol
->binding_label
7506 && strcmp (sym
->binding_label
, sym
->old_symbol
->binding_label
) != 0)
7508 const char *null
= "NULL", *s1
, *s2
;
7509 s1
= sym
->binding_label
;
7511 s2
= sym
->old_symbol
->binding_label
;
7513 gfc_error ("Mismatch in BIND(C) names (%qs/%qs) at %C", s1
, s2
);
7514 sym
->refs
++; /* Needed to avoid an ICE in gfc_release_symbol */
7518 if(found_match
!= MATCH_YES
)
7522 /* Make changes to the symbol. */
7525 if (!gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
7528 if (!gfc_missing_attr (&sym
->attr
, NULL
))
7531 if (!copy_prefix (&sym
->attr
, &sym
->declared_at
))
7533 if(!sym
->attr
.module_procedure
)
7539 /* Delay matching the function characteristics until after the
7540 specification block by signalling kind=-1. */
7541 sym
->declared_at
= old_loc
;
7542 if (current_ts
.type
!= BT_UNKNOWN
)
7543 current_ts
.kind
= -1;
7545 current_ts
.kind
= 0;
7549 if (current_ts
.type
!= BT_UNKNOWN
7550 && !gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
7556 if (current_ts
.type
!= BT_UNKNOWN
7557 && !gfc_add_type (result
, ¤t_ts
, &gfc_current_locus
))
7559 sym
->result
= result
;
7562 /* Warn if this procedure has the same name as an intrinsic. */
7563 do_warn_intrinsic_shadow (sym
, true);
7569 gfc_current_locus
= old_loc
;
7574 /* This is mostly a copy of parse.c(add_global_procedure) but modified to
7575 pass the name of the entry, rather than the gfc_current_block name, and
7576 to return false upon finding an existing global entry. */
7579 add_global_entry (const char *name
, const char *binding_label
, bool sub
,
7583 enum gfc_symbol_type type
;
7585 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
7587 /* Only in Fortran 2003: For procedures with a binding label also the Fortran
7588 name is a global identifier. */
7589 if (!binding_label
|| gfc_notification_std (GFC_STD_F2008
))
7591 s
= gfc_get_gsymbol (name
, false);
7593 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= type
))
7595 gfc_global_used (s
, where
);
7604 s
->ns
= gfc_current_ns
;
7608 /* Don't add the symbol multiple times. */
7610 && (!gfc_notification_std (GFC_STD_F2008
)
7611 || strcmp (name
, binding_label
) != 0))
7613 s
= gfc_get_gsymbol (binding_label
, true);
7615 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= type
))
7617 gfc_global_used (s
, where
);
7624 s
->binding_label
= binding_label
;
7627 s
->ns
= gfc_current_ns
;
7635 /* Match an ENTRY statement. */
7638 gfc_match_entry (void)
7643 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7644 gfc_compile_state state
;
7648 bool module_procedure
;
7652 m
= gfc_match_name (name
);
7656 if (!gfc_notify_std (GFC_STD_F2008_OBS
, "ENTRY statement at %C"))
7659 state
= gfc_current_state ();
7660 if (state
!= COMP_SUBROUTINE
&& state
!= COMP_FUNCTION
)
7665 gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
7668 gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
7670 case COMP_SUBMODULE
:
7671 gfc_error ("ENTRY statement at %C cannot appear within a SUBMODULE");
7673 case COMP_BLOCK_DATA
:
7674 gfc_error ("ENTRY statement at %C cannot appear within "
7677 case COMP_INTERFACE
:
7678 gfc_error ("ENTRY statement at %C cannot appear within "
7681 case COMP_STRUCTURE
:
7682 gfc_error ("ENTRY statement at %C cannot appear within "
7683 "a STRUCTURE block");
7686 gfc_error ("ENTRY statement at %C cannot appear within "
7687 "a DERIVED TYPE block");
7690 gfc_error ("ENTRY statement at %C cannot appear within "
7691 "an IF-THEN block");
7694 case COMP_DO_CONCURRENT
:
7695 gfc_error ("ENTRY statement at %C cannot appear within "
7699 gfc_error ("ENTRY statement at %C cannot appear within "
7703 gfc_error ("ENTRY statement at %C cannot appear within "
7707 gfc_error ("ENTRY statement at %C cannot appear within "
7711 gfc_error ("ENTRY statement at %C cannot appear within "
7712 "a contained subprogram");
7715 gfc_error ("Unexpected ENTRY statement at %C");
7720 if ((state
== COMP_SUBROUTINE
|| state
== COMP_FUNCTION
)
7721 && gfc_state_stack
->previous
->state
== COMP_INTERFACE
)
7723 gfc_error ("ENTRY statement at %C cannot appear within an INTERFACE");
7727 module_procedure
= gfc_current_ns
->parent
!= NULL
7728 && gfc_current_ns
->parent
->proc_name
7729 && gfc_current_ns
->parent
->proc_name
->attr
.flavor
7732 if (gfc_current_ns
->parent
!= NULL
7733 && gfc_current_ns
->parent
->proc_name
7734 && !module_procedure
)
7736 gfc_error("ENTRY statement at %C cannot appear in a "
7737 "contained procedure");
7741 /* Module function entries need special care in get_proc_name
7742 because previous references within the function will have
7743 created symbols attached to the current namespace. */
7744 if (get_proc_name (name
, &entry
,
7745 gfc_current_ns
->parent
!= NULL
7746 && module_procedure
))
7749 proc
= gfc_current_block ();
7751 /* Make sure that it isn't already declared as BIND(C). If it is, it
7752 must have been marked BIND(C) with a BIND(C) attribute and that is
7753 not allowed for procedures. */
7754 if (entry
->attr
.is_bind_c
== 1)
7758 entry
->attr
.is_bind_c
= 0;
7760 loc
= entry
->old_symbol
!= NULL
7761 ? entry
->old_symbol
->declared_at
: gfc_current_locus
;
7762 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7763 "variables or common blocks", &loc
);
7766 /* Check what next non-whitespace character is so we can tell if there
7767 is the required parens if we have a BIND(C). */
7768 old_loc
= gfc_current_locus
;
7769 gfc_gobble_whitespace ();
7770 peek_char
= gfc_peek_ascii_char ();
7772 if (state
== COMP_SUBROUTINE
)
7774 m
= gfc_match_formal_arglist (entry
, 0, 1);
7778 /* Call gfc_match_bind_c with allow_binding_name = true as ENTRY can
7779 never be an internal procedure. */
7780 is_bind_c
= gfc_match_bind_c (entry
, true);
7781 if (is_bind_c
== MATCH_ERROR
)
7783 if (is_bind_c
== MATCH_YES
)
7785 if (peek_char
!= '(')
7787 gfc_error ("Missing required parentheses before BIND(C) at %C");
7791 if (!gfc_add_is_bind_c (&(entry
->attr
), entry
->name
,
7792 &(entry
->declared_at
), 1))
7797 if (!gfc_current_ns
->parent
7798 && !add_global_entry (name
, entry
->binding_label
, true,
7802 /* An entry in a subroutine. */
7803 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
7804 || !gfc_add_subroutine (&entry
->attr
, entry
->name
, NULL
))
7809 /* An entry in a function.
7810 We need to take special care because writing
7815 ENTRY f() RESULT (r)
7817 ENTRY f RESULT (r). */
7818 if (gfc_match_eos () == MATCH_YES
)
7820 gfc_current_locus
= old_loc
;
7821 /* Match the empty argument list, and add the interface to
7823 m
= gfc_match_formal_arglist (entry
, 0, 1);
7826 m
= gfc_match_formal_arglist (entry
, 0, 0);
7833 if (gfc_match_eos () == MATCH_YES
)
7835 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
7836 || !gfc_add_function (&entry
->attr
, entry
->name
, NULL
))
7839 entry
->result
= entry
;
7843 m
= gfc_match_suffix (entry
, &result
);
7845 gfc_syntax_error (ST_ENTRY
);
7851 if (!gfc_add_result (&result
->attr
, result
->name
, NULL
)
7852 || !gfc_add_entry (&entry
->attr
, result
->name
, NULL
)
7853 || !gfc_add_function (&entry
->attr
, result
->name
, NULL
))
7855 entry
->result
= result
;
7859 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
7860 || !gfc_add_function (&entry
->attr
, entry
->name
, NULL
))
7862 entry
->result
= entry
;
7866 if (!gfc_current_ns
->parent
7867 && !add_global_entry (name
, entry
->binding_label
, false,
7872 if (gfc_match_eos () != MATCH_YES
)
7874 gfc_syntax_error (ST_ENTRY
);
7878 /* F2018:C1546 An elemental procedure shall not have the BIND attribute. */
7879 if (proc
->attr
.elemental
&& entry
->attr
.is_bind_c
)
7881 gfc_error ("ENTRY statement at %L with BIND(C) prohibited in an "
7882 "elemental procedure", &entry
->declared_at
);
7886 entry
->attr
.recursive
= proc
->attr
.recursive
;
7887 entry
->attr
.elemental
= proc
->attr
.elemental
;
7888 entry
->attr
.pure
= proc
->attr
.pure
;
7890 el
= gfc_get_entry_list ();
7892 el
->next
= gfc_current_ns
->entries
;
7893 gfc_current_ns
->entries
= el
;
7895 el
->id
= el
->next
->id
+ 1;
7899 new_st
.op
= EXEC_ENTRY
;
7900 new_st
.ext
.entry
= el
;
7906 /* Match a subroutine statement, including optional prefixes. */
7909 gfc_match_subroutine (void)
7911 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7916 bool allow_binding_name
;
7919 if (gfc_current_state () != COMP_NONE
7920 && gfc_current_state () != COMP_INTERFACE
7921 && gfc_current_state () != COMP_CONTAINS
)
7924 m
= gfc_match_prefix (NULL
);
7928 m
= gfc_match ("subroutine% %n", name
);
7932 if (get_proc_name (name
, &sym
, false))
7935 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
7936 the symbol existed before. */
7937 sym
->declared_at
= gfc_current_locus
;
7939 if (current_attr
.module_procedure
)
7940 sym
->attr
.module_procedure
= 1;
7942 if (add_hidden_procptr_result (sym
))
7945 gfc_new_block
= sym
;
7947 /* Check what next non-whitespace character is so we can tell if there
7948 is the required parens if we have a BIND(C). */
7949 gfc_gobble_whitespace ();
7950 peek_char
= gfc_peek_ascii_char ();
7952 if (!gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
))
7955 if (gfc_match_formal_arglist (sym
, 0, 1) != MATCH_YES
)
7958 /* Make sure that it isn't already declared as BIND(C). If it is, it
7959 must have been marked BIND(C) with a BIND(C) attribute and that is
7960 not allowed for procedures. */
7961 if (sym
->attr
.is_bind_c
== 1)
7963 sym
->attr
.is_bind_c
= 0;
7965 if (gfc_state_stack
->previous
7966 && gfc_state_stack
->previous
->state
!= COMP_SUBMODULE
)
7969 loc
= sym
->old_symbol
!= NULL
7970 ? sym
->old_symbol
->declared_at
: gfc_current_locus
;
7971 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7972 "variables or common blocks", &loc
);
7976 /* C binding names are not allowed for internal procedures. */
7977 if (gfc_current_state () == COMP_CONTAINS
7978 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
7979 allow_binding_name
= false;
7981 allow_binding_name
= true;
7983 /* Here, we are just checking if it has the bind(c) attribute, and if
7984 so, then we need to make sure it's all correct. If it doesn't,
7985 we still need to continue matching the rest of the subroutine line. */
7986 gfc_gobble_whitespace ();
7987 loc
= gfc_current_locus
;
7988 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
7989 if (is_bind_c
== MATCH_ERROR
)
7991 /* There was an attempt at the bind(c), but it was wrong. An
7992 error message should have been printed w/in the gfc_match_bind_c
7993 so here we'll just return the MATCH_ERROR. */
7997 if (is_bind_c
== MATCH_YES
)
7999 gfc_formal_arglist
*arg
;
8001 /* The following is allowed in the Fortran 2008 draft. */
8002 if (gfc_current_state () == COMP_CONTAINS
8003 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
8004 && !gfc_notify_std (GFC_STD_F2008
, "BIND(C) attribute "
8005 "at %L may not be specified for an internal "
8006 "procedure", &gfc_current_locus
))
8009 if (peek_char
!= '(')
8011 gfc_error ("Missing required parentheses before BIND(C) at %C");
8015 /* F2018 C1550 (R1526) If MODULE appears in the prefix of a module
8016 subprogram and a binding label is specified, it shall be the
8017 same as the binding label specified in the corresponding module
8018 procedure interface body. */
8019 if (sym
->attr
.module_procedure
&& sym
->old_symbol
8020 && strcmp (sym
->name
, sym
->old_symbol
->name
) == 0
8021 && sym
->binding_label
&& sym
->old_symbol
->binding_label
8022 && strcmp (sym
->binding_label
, sym
->old_symbol
->binding_label
) != 0)
8024 const char *null
= "NULL", *s1
, *s2
;
8025 s1
= sym
->binding_label
;
8027 s2
= sym
->old_symbol
->binding_label
;
8029 gfc_error ("Mismatch in BIND(C) names (%qs/%qs) at %C", s1
, s2
);
8030 sym
->refs
++; /* Needed to avoid an ICE in gfc_release_symbol */
8034 /* Scan the dummy arguments for an alternate return. */
8035 for (arg
= sym
->formal
; arg
; arg
= arg
->next
)
8038 gfc_error ("Alternate return dummy argument cannot appear in a "
8039 "SUBROUTINE with the BIND(C) attribute at %L", &loc
);
8043 if (!gfc_add_is_bind_c (&(sym
->attr
), sym
->name
, &(sym
->declared_at
), 1))
8047 if (gfc_match_eos () != MATCH_YES
)
8049 gfc_syntax_error (ST_SUBROUTINE
);
8053 if (!copy_prefix (&sym
->attr
, &sym
->declared_at
))
8055 if(!sym
->attr
.module_procedure
)
8061 /* Warn if it has the same name as an intrinsic. */
8062 do_warn_intrinsic_shadow (sym
, false);
8068 /* Check that the NAME identifier in a BIND attribute or statement
8069 is conform to C identifier rules. */
8072 check_bind_name_identifier (char **name
)
8074 char *n
= *name
, *p
;
8076 /* Remove leading spaces. */
8080 /* On an empty string, free memory and set name to NULL. */
8088 /* Remove trailing spaces. */
8089 p
= n
+ strlen(n
) - 1;
8093 /* Insert the identifier into the symbol table. */
8098 /* Now check that identifier is valid under C rules. */
8101 gfc_error ("Invalid C identifier in NAME= specifier at %C");
8106 if (!(ISALNUM (*p
) || *p
== '_' || *p
== '$'))
8108 gfc_error ("Invalid C identifier in NAME= specifier at %C");
8116 /* Match a BIND(C) specifier, with the optional 'name=' specifier if
8117 given, and set the binding label in either the given symbol (if not
8118 NULL), or in the current_ts. The symbol may be NULL because we may
8119 encounter the BIND(C) before the declaration itself. Return
8120 MATCH_NO if what we're looking at isn't a BIND(C) specifier,
8121 MATCH_ERROR if it is a BIND(C) clause but an error was encountered,
8122 or MATCH_YES if the specifier was correct and the binding label and
8123 bind(c) fields were set correctly for the given symbol or the
8124 current_ts. If allow_binding_name is false, no binding name may be
8128 gfc_match_bind_c (gfc_symbol
*sym
, bool allow_binding_name
)
8130 char *binding_label
= NULL
;
8133 /* Initialize the flag that specifies whether we encountered a NAME=
8134 specifier or not. */
8135 has_name_equals
= 0;
8137 /* This much we have to be able to match, in this order, if
8138 there is a bind(c) label. */
8139 if (gfc_match (" bind ( c ") != MATCH_YES
)
8142 /* Now see if there is a binding label, or if we've reached the
8143 end of the bind(c) attribute without one. */
8144 if (gfc_match_char (',') == MATCH_YES
)
8146 if (gfc_match (" name = ") != MATCH_YES
)
8148 gfc_error ("Syntax error in NAME= specifier for binding label "
8150 /* should give an error message here */
8154 has_name_equals
= 1;
8156 if (gfc_match_init_expr (&e
) != MATCH_YES
)
8162 if (!gfc_simplify_expr(e
, 0))
8164 gfc_error ("NAME= specifier at %C should be a constant expression");
8169 if (e
->expr_type
!= EXPR_CONSTANT
|| e
->ts
.type
!= BT_CHARACTER
8170 || e
->ts
.kind
!= gfc_default_character_kind
|| e
->rank
!= 0)
8172 gfc_error ("NAME= specifier at %C should be a scalar of "
8173 "default character kind");
8178 // Get a C string from the Fortran string constant
8179 binding_label
= gfc_widechar_to_char (e
->value
.character
.string
,
8180 e
->value
.character
.length
);
8183 // Check that it is valid (old gfc_match_name_C)
8184 if (check_bind_name_identifier (&binding_label
) != MATCH_YES
)
8188 /* Get the required right paren. */
8189 if (gfc_match_char (')') != MATCH_YES
)
8191 gfc_error ("Missing closing paren for binding label at %C");
8195 if (has_name_equals
&& !allow_binding_name
)
8197 gfc_error ("No binding name is allowed in BIND(C) at %C");
8201 if (has_name_equals
&& sym
!= NULL
&& sym
->attr
.dummy
)
8203 gfc_error ("For dummy procedure %s, no binding name is "
8204 "allowed in BIND(C) at %C", sym
->name
);
8209 /* Save the binding label to the symbol. If sym is null, we're
8210 probably matching the typespec attributes of a declaration and
8211 haven't gotten the name yet, and therefore, no symbol yet. */
8215 sym
->binding_label
= binding_label
;
8217 curr_binding_label
= binding_label
;
8219 else if (allow_binding_name
)
8221 /* No binding label, but if symbol isn't null, we
8222 can set the label for it here.
8223 If name="" or allow_binding_name is false, no C binding name is
8225 if (sym
!= NULL
&& sym
->name
!= NULL
&& has_name_equals
== 0)
8226 sym
->binding_label
= IDENTIFIER_POINTER (get_identifier (sym
->name
));
8229 if (has_name_equals
&& gfc_current_state () == COMP_INTERFACE
8230 && current_interface
.type
== INTERFACE_ABSTRACT
)
8232 gfc_error ("NAME not allowed on BIND(C) for ABSTRACT INTERFACE at %C");
8240 /* Return nonzero if we're currently compiling a contained procedure. */
8243 contained_procedure (void)
8245 gfc_state_data
*s
= gfc_state_stack
;
8247 if ((s
->state
== COMP_SUBROUTINE
|| s
->state
== COMP_FUNCTION
)
8248 && s
->previous
!= NULL
&& s
->previous
->state
== COMP_CONTAINS
)
8254 /* Set the kind of each enumerator. The kind is selected such that it is
8255 interoperable with the corresponding C enumeration type, making
8256 sure that -fshort-enums is honored. */
8261 enumerator_history
*current_history
= NULL
;
8265 if (max_enum
== NULL
|| enum_history
== NULL
)
8268 if (!flag_short_enums
)
8274 kind
= gfc_integer_kinds
[i
++].kind
;
8276 while (kind
< gfc_c_int_kind
8277 && gfc_check_integer_range (max_enum
->initializer
->value
.integer
,
8280 current_history
= enum_history
;
8281 while (current_history
!= NULL
)
8283 current_history
->sym
->ts
.kind
= kind
;
8284 current_history
= current_history
->next
;
8289 /* Match any of the various end-block statements. Returns the type of
8290 END to the caller. The END INTERFACE, END IF, END DO, END SELECT
8291 and END BLOCK statements cannot be replaced by a single END statement. */
8294 gfc_match_end (gfc_statement
*st
)
8296 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8297 gfc_compile_state state
;
8299 const char *block_name
;
8303 gfc_namespace
*parent_ns
, *ns
, *prev_ns
;
8304 gfc_namespace
**nsp
;
8305 bool abreviated_modproc_decl
= false;
8306 bool got_matching_end
= false;
8308 old_loc
= gfc_current_locus
;
8309 if (gfc_match ("end") != MATCH_YES
)
8312 state
= gfc_current_state ();
8313 block_name
= gfc_current_block () == NULL
8314 ? NULL
: gfc_current_block ()->name
;
8318 case COMP_ASSOCIATE
:
8320 if (startswith (block_name
, "block@"))
8325 case COMP_DERIVED_CONTAINS
:
8326 state
= gfc_state_stack
->previous
->state
;
8327 block_name
= gfc_state_stack
->previous
->sym
== NULL
8328 ? NULL
: gfc_state_stack
->previous
->sym
->name
;
8329 abreviated_modproc_decl
= gfc_state_stack
->previous
->sym
8330 && gfc_state_stack
->previous
->sym
->abr_modproc_decl
;
8337 if (!abreviated_modproc_decl
)
8338 abreviated_modproc_decl
= gfc_current_block ()
8339 && gfc_current_block ()->abr_modproc_decl
;
8345 *st
= ST_END_PROGRAM
;
8346 target
= " program";
8350 case COMP_SUBROUTINE
:
8351 *st
= ST_END_SUBROUTINE
;
8352 if (!abreviated_modproc_decl
)
8353 target
= " subroutine";
8355 target
= " procedure";
8356 eos_ok
= !contained_procedure ();
8360 *st
= ST_END_FUNCTION
;
8361 if (!abreviated_modproc_decl
)
8362 target
= " function";
8364 target
= " procedure";
8365 eos_ok
= !contained_procedure ();
8368 case COMP_BLOCK_DATA
:
8369 *st
= ST_END_BLOCK_DATA
;
8370 target
= " block data";
8375 *st
= ST_END_MODULE
;
8380 case COMP_SUBMODULE
:
8381 *st
= ST_END_SUBMODULE
;
8382 target
= " submodule";
8386 case COMP_INTERFACE
:
8387 *st
= ST_END_INTERFACE
;
8388 target
= " interface";
8404 case COMP_STRUCTURE
:
8405 *st
= ST_END_STRUCTURE
;
8406 target
= " structure";
8411 case COMP_DERIVED_CONTAINS
:
8417 case COMP_ASSOCIATE
:
8418 *st
= ST_END_ASSOCIATE
;
8419 target
= " associate";
8424 case COMP_OMP_STRICTLY_STRUCTURED_BLOCK
:
8437 case COMP_DO_CONCURRENT
:
8444 *st
= ST_END_CRITICAL
;
8445 target
= " critical";
8450 case COMP_SELECT_TYPE
:
8451 case COMP_SELECT_RANK
:
8452 *st
= ST_END_SELECT
;
8458 *st
= ST_END_FORALL
;
8473 last_initializer
= NULL
;
8475 gfc_free_enum_history ();
8479 gfc_error ("Unexpected END statement at %C");
8483 old_loc
= gfc_current_locus
;
8484 if (gfc_match_eos () == MATCH_YES
)
8486 if (!eos_ok
&& (*st
== ST_END_SUBROUTINE
|| *st
== ST_END_FUNCTION
))
8488 if (!gfc_notify_std (GFC_STD_F2008
, "END statement "
8489 "instead of %s statement at %L",
8490 abreviated_modproc_decl
? "END PROCEDURE"
8491 : gfc_ascii_statement(*st
), &old_loc
))
8496 /* We would have required END [something]. */
8497 gfc_error ("%s statement expected at %L",
8498 gfc_ascii_statement (*st
), &old_loc
);
8505 /* Verify that we've got the sort of end-block that we're expecting. */
8506 if (gfc_match (target
) != MATCH_YES
)
8508 gfc_error ("Expecting %s statement at %L", abreviated_modproc_decl
8509 ? "END PROCEDURE" : gfc_ascii_statement(*st
), &old_loc
);
8513 got_matching_end
= true;
8515 old_loc
= gfc_current_locus
;
8516 /* If we're at the end, make sure a block name wasn't required. */
8517 if (gfc_match_eos () == MATCH_YES
)
8520 if (*st
!= ST_ENDDO
&& *st
!= ST_ENDIF
&& *st
!= ST_END_SELECT
8521 && *st
!= ST_END_FORALL
&& *st
!= ST_END_WHERE
&& *st
!= ST_END_BLOCK
8522 && *st
!= ST_END_ASSOCIATE
&& *st
!= ST_END_CRITICAL
)
8528 gfc_error ("Expected block name of %qs in %s statement at %L",
8529 block_name
, gfc_ascii_statement (*st
), &old_loc
);
8534 /* END INTERFACE has a special handler for its several possible endings. */
8535 if (*st
== ST_END_INTERFACE
)
8536 return gfc_match_end_interface ();
8538 /* We haven't hit the end of statement, so what is left must be an
8540 m
= gfc_match_space ();
8542 m
= gfc_match_name (name
);
8545 gfc_error ("Expected terminating name at %C");
8549 if (block_name
== NULL
)
8552 /* We have to pick out the declared submodule name from the composite
8553 required by F2008:11.2.3 para 2, which ends in the declared name. */
8554 if (state
== COMP_SUBMODULE
)
8555 block_name
= strchr (block_name
, '.') + 1;
8557 if (strcmp (name
, block_name
) != 0 && strcmp (block_name
, "ppr@") != 0)
8559 gfc_error ("Expected label %qs for %s statement at %C", block_name
,
8560 gfc_ascii_statement (*st
));
8563 /* Procedure pointer as function result. */
8564 else if (strcmp (block_name
, "ppr@") == 0
8565 && strcmp (name
, gfc_current_block ()->ns
->proc_name
->name
) != 0)
8567 gfc_error ("Expected label %qs for %s statement at %C",
8568 gfc_current_block ()->ns
->proc_name
->name
,
8569 gfc_ascii_statement (*st
));
8573 if (gfc_match_eos () == MATCH_YES
)
8577 gfc_syntax_error (*st
);
8580 gfc_current_locus
= old_loc
;
8582 /* If we are missing an END BLOCK, we created a half-ready namespace.
8583 Remove it from the parent namespace's sibling list. */
8585 while (state
== COMP_BLOCK
&& !got_matching_end
)
8587 parent_ns
= gfc_current_ns
->parent
;
8589 nsp
= &(gfc_state_stack
->previous
->tail
->ext
.block
.ns
);
8595 if (ns
== gfc_current_ns
)
8597 if (prev_ns
== NULL
)
8600 prev_ns
->sibling
= ns
->sibling
;
8606 gfc_free_namespace (gfc_current_ns
);
8607 gfc_current_ns
= parent_ns
;
8608 gfc_state_stack
= gfc_state_stack
->previous
;
8609 state
= gfc_current_state ();
8617 /***************** Attribute declaration statements ****************/
8619 /* Set the attribute of a single variable. */
8624 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8627 /* Workaround -Wmaybe-uninitialized false positive during
8628 profiledbootstrap by initializing them. */
8629 gfc_symbol
*sym
= NULL
;
8635 m
= gfc_match_name (name
);
8639 if (find_special (name
, &sym
, false))
8642 if (!check_function_name (name
))
8648 var_locus
= gfc_current_locus
;
8650 /* Deal with possible array specification for certain attributes. */
8651 if (current_attr
.dimension
8652 || current_attr
.codimension
8653 || current_attr
.allocatable
8654 || current_attr
.pointer
8655 || current_attr
.target
)
8657 m
= gfc_match_array_spec (&as
, !current_attr
.codimension
,
8658 !current_attr
.dimension
8659 && !current_attr
.pointer
8660 && !current_attr
.target
);
8661 if (m
== MATCH_ERROR
)
8664 if (current_attr
.dimension
&& m
== MATCH_NO
)
8666 gfc_error ("Missing array specification at %L in DIMENSION "
8667 "statement", &var_locus
);
8672 if (current_attr
.dimension
&& sym
->value
)
8674 gfc_error ("Dimensions specified for %s at %L after its "
8675 "initialization", sym
->name
, &var_locus
);
8680 if (current_attr
.codimension
&& m
== MATCH_NO
)
8682 gfc_error ("Missing array specification at %L in CODIMENSION "
8683 "statement", &var_locus
);
8688 if ((current_attr
.allocatable
|| current_attr
.pointer
)
8689 && (m
== MATCH_YES
) && (as
->type
!= AS_DEFERRED
))
8691 gfc_error ("Array specification must be deferred at %L", &var_locus
);
8697 /* Update symbol table. DIMENSION attribute is set in
8698 gfc_set_array_spec(). For CLASS variables, this must be applied
8699 to the first component, or '_data' field. */
8700 if (sym
->ts
.type
== BT_CLASS
&& sym
->ts
.u
.derived
->attr
.is_class
)
8702 /* gfc_set_array_spec sets sym->attr not CLASS_DATA(sym)->attr. Check
8703 for duplicate attribute here. */
8704 if (CLASS_DATA(sym
)->attr
.dimension
== 1 && as
)
8706 gfc_error ("Duplicate DIMENSION attribute at %C");
8711 if (!gfc_copy_attr (&CLASS_DATA(sym
)->attr
, ¤t_attr
, &var_locus
))
8719 if (current_attr
.dimension
== 0 && current_attr
.codimension
== 0
8720 && !gfc_copy_attr (&sym
->attr
, ¤t_attr
, &var_locus
))
8727 if (sym
->ts
.type
== BT_CLASS
8728 && !gfc_build_class_symbol (&sym
->ts
, &sym
->attr
, &sym
->as
))
8734 if (!gfc_set_array_spec (sym
, as
, &var_locus
))
8740 if (sym
->attr
.cray_pointee
&& sym
->as
!= NULL
)
8742 /* Fix the array spec. */
8743 m
= gfc_mod_pointee_as (sym
->as
);
8744 if (m
== MATCH_ERROR
)
8748 if (!gfc_add_attribute (&sym
->attr
, &var_locus
))
8754 if ((current_attr
.external
|| current_attr
.intrinsic
)
8755 && sym
->attr
.flavor
!= FL_PROCEDURE
8756 && !gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, NULL
))
8762 add_hidden_procptr_result (sym
);
8767 gfc_free_array_spec (as
);
8772 /* Generic attribute declaration subroutine. Used for attributes that
8773 just have a list of names. */
8780 /* Gobble the optional double colon, by simply ignoring the result
8790 if (gfc_match_eos () == MATCH_YES
)
8796 if (gfc_match_char (',') != MATCH_YES
)
8798 gfc_error ("Unexpected character in variable list at %C");
8808 /* This routine matches Cray Pointer declarations of the form:
8809 pointer ( <pointer>, <pointee> )
8811 pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...
8812 The pointer, if already declared, should be an integer. Otherwise, we
8813 set it as BT_INTEGER with kind gfc_index_integer_kind. The pointee may
8814 be either a scalar, or an array declaration. No space is allocated for
8815 the pointee. For the statement
8816 pointer (ipt, ar(10))
8817 any subsequent uses of ar will be translated (in C-notation) as
8818 ar(i) => ((<type> *) ipt)(i)
8819 After gimplification, pointee variable will disappear in the code. */
8822 cray_pointer_decl (void)
8825 gfc_array_spec
*as
= NULL
;
8826 gfc_symbol
*cptr
; /* Pointer symbol. */
8827 gfc_symbol
*cpte
; /* Pointee symbol. */
8833 if (gfc_match_char ('(') != MATCH_YES
)
8835 gfc_error ("Expected %<(%> at %C");
8839 /* Match pointer. */
8840 var_locus
= gfc_current_locus
;
8841 gfc_clear_attr (¤t_attr
);
8842 gfc_add_cray_pointer (¤t_attr
, &var_locus
);
8843 current_ts
.type
= BT_INTEGER
;
8844 current_ts
.kind
= gfc_index_integer_kind
;
8846 m
= gfc_match_symbol (&cptr
, 0);
8849 gfc_error ("Expected variable name at %C");
8853 if (!gfc_add_cray_pointer (&cptr
->attr
, &var_locus
))
8856 gfc_set_sym_referenced (cptr
);
8858 if (cptr
->ts
.type
== BT_UNKNOWN
) /* Override the type, if necessary. */
8860 cptr
->ts
.type
= BT_INTEGER
;
8861 cptr
->ts
.kind
= gfc_index_integer_kind
;
8863 else if (cptr
->ts
.type
!= BT_INTEGER
)
8865 gfc_error ("Cray pointer at %C must be an integer");
8868 else if (cptr
->ts
.kind
< gfc_index_integer_kind
)
8869 gfc_warning (0, "Cray pointer at %C has %d bytes of precision;"
8870 " memory addresses require %d bytes",
8871 cptr
->ts
.kind
, gfc_index_integer_kind
);
8873 if (gfc_match_char (',') != MATCH_YES
)
8875 gfc_error ("Expected \",\" at %C");
8879 /* Match Pointee. */
8880 var_locus
= gfc_current_locus
;
8881 gfc_clear_attr (¤t_attr
);
8882 gfc_add_cray_pointee (¤t_attr
, &var_locus
);
8883 current_ts
.type
= BT_UNKNOWN
;
8884 current_ts
.kind
= 0;
8886 m
= gfc_match_symbol (&cpte
, 0);
8889 gfc_error ("Expected variable name at %C");
8893 /* Check for an optional array spec. */
8894 m
= gfc_match_array_spec (&as
, true, false);
8895 if (m
== MATCH_ERROR
)
8897 gfc_free_array_spec (as
);
8900 else if (m
== MATCH_NO
)
8902 gfc_free_array_spec (as
);
8906 if (!gfc_add_cray_pointee (&cpte
->attr
, &var_locus
))
8909 gfc_set_sym_referenced (cpte
);
8911 if (cpte
->as
== NULL
)
8913 if (!gfc_set_array_spec (cpte
, as
, &var_locus
))
8914 gfc_internal_error ("Cannot set Cray pointee array spec.");
8916 else if (as
!= NULL
)
8918 gfc_error ("Duplicate array spec for Cray pointee at %C");
8919 gfc_free_array_spec (as
);
8925 if (cpte
->as
!= NULL
)
8927 /* Fix array spec. */
8928 m
= gfc_mod_pointee_as (cpte
->as
);
8929 if (m
== MATCH_ERROR
)
8933 /* Point the Pointee at the Pointer. */
8934 cpte
->cp_pointer
= cptr
;
8936 if (gfc_match_char (')') != MATCH_YES
)
8938 gfc_error ("Expected \")\" at %C");
8941 m
= gfc_match_char (',');
8943 done
= true; /* Stop searching for more declarations. */
8947 if (m
== MATCH_ERROR
/* Failed when trying to find ',' above. */
8948 || gfc_match_eos () != MATCH_YES
)
8950 gfc_error ("Expected %<,%> or end of statement at %C");
8958 gfc_match_external (void)
8961 gfc_clear_attr (¤t_attr
);
8962 current_attr
.external
= 1;
8964 return attr_decl ();
8969 gfc_match_intent (void)
8973 /* This is not allowed within a BLOCK construct! */
8974 if (gfc_current_state () == COMP_BLOCK
)
8976 gfc_error ("INTENT is not allowed inside of BLOCK at %C");
8980 intent
= match_intent_spec ();
8981 if (intent
== INTENT_UNKNOWN
)
8984 gfc_clear_attr (¤t_attr
);
8985 current_attr
.intent
= intent
;
8987 return attr_decl ();
8992 gfc_match_intrinsic (void)
8995 gfc_clear_attr (¤t_attr
);
8996 current_attr
.intrinsic
= 1;
8998 return attr_decl ();
9003 gfc_match_optional (void)
9005 /* This is not allowed within a BLOCK construct! */
9006 if (gfc_current_state () == COMP_BLOCK
)
9008 gfc_error ("OPTIONAL is not allowed inside of BLOCK at %C");
9012 gfc_clear_attr (¤t_attr
);
9013 current_attr
.optional
= 1;
9015 return attr_decl ();
9020 gfc_match_pointer (void)
9022 gfc_gobble_whitespace ();
9023 if (gfc_peek_ascii_char () == '(')
9025 if (!flag_cray_pointer
)
9027 gfc_error ("Cray pointer declaration at %C requires "
9028 "%<-fcray-pointer%> flag");
9031 return cray_pointer_decl ();
9035 gfc_clear_attr (¤t_attr
);
9036 current_attr
.pointer
= 1;
9038 return attr_decl ();
9044 gfc_match_allocatable (void)
9046 gfc_clear_attr (¤t_attr
);
9047 current_attr
.allocatable
= 1;
9049 return attr_decl ();
9054 gfc_match_codimension (void)
9056 gfc_clear_attr (¤t_attr
);
9057 current_attr
.codimension
= 1;
9059 return attr_decl ();
9064 gfc_match_contiguous (void)
9066 if (!gfc_notify_std (GFC_STD_F2008
, "CONTIGUOUS statement at %C"))
9069 gfc_clear_attr (¤t_attr
);
9070 current_attr
.contiguous
= 1;
9072 return attr_decl ();
9077 gfc_match_dimension (void)
9079 gfc_clear_attr (¤t_attr
);
9080 current_attr
.dimension
= 1;
9082 return attr_decl ();
9087 gfc_match_target (void)
9089 gfc_clear_attr (¤t_attr
);
9090 current_attr
.target
= 1;
9092 return attr_decl ();
9096 /* Match the list of entities being specified in a PUBLIC or PRIVATE
9100 access_attr_decl (gfc_statement st
)
9102 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9103 interface_type type
;
9105 gfc_symbol
*sym
, *dt_sym
;
9106 gfc_intrinsic_op op
;
9108 gfc_access access
= (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
9110 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
9115 m
= gfc_match_generic_spec (&type
, name
, &op
);
9118 if (m
== MATCH_ERROR
)
9123 case INTERFACE_NAMELESS
:
9124 case INTERFACE_ABSTRACT
:
9127 case INTERFACE_GENERIC
:
9128 case INTERFACE_DTIO
:
9130 if (gfc_get_symbol (name
, NULL
, &sym
))
9133 if (type
== INTERFACE_DTIO
9134 && gfc_current_ns
->proc_name
9135 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
9136 && sym
->attr
.flavor
== FL_UNKNOWN
)
9137 sym
->attr
.flavor
= FL_PROCEDURE
;
9139 if (!gfc_add_access (&sym
->attr
, access
, sym
->name
, NULL
))
9142 if (sym
->attr
.generic
&& (dt_sym
= gfc_find_dt_in_generic (sym
))
9143 && !gfc_add_access (&dt_sym
->attr
, access
, sym
->name
, NULL
))
9148 case INTERFACE_INTRINSIC_OP
:
9149 if (gfc_current_ns
->operator_access
[op
] == ACCESS_UNKNOWN
)
9151 gfc_intrinsic_op other_op
;
9153 gfc_current_ns
->operator_access
[op
] = access
;
9155 /* Handle the case if there is another op with the same
9156 function, for INTRINSIC_EQ vs. INTRINSIC_EQ_OS and so on. */
9157 other_op
= gfc_equivalent_op (op
);
9159 if (other_op
!= INTRINSIC_NONE
)
9160 gfc_current_ns
->operator_access
[other_op
] = access
;
9164 gfc_error ("Access specification of the %s operator at %C has "
9165 "already been specified", gfc_op2string (op
));
9171 case INTERFACE_USER_OP
:
9172 uop
= gfc_get_uop (name
);
9174 if (uop
->access
== ACCESS_UNKNOWN
)
9176 uop
->access
= access
;
9180 gfc_error ("Access specification of the .%s. operator at %C "
9181 "has already been specified", uop
->name
);
9188 if (gfc_match_char (',') == MATCH_NO
)
9192 if (gfc_match_eos () != MATCH_YES
)
9197 gfc_syntax_error (st
);
9205 gfc_match_protected (void)
9211 /* PROTECTED has already been seen, but must be followed by whitespace
9213 c
= gfc_peek_ascii_char ();
9214 if (!gfc_is_whitespace (c
) && c
!= ':')
9217 if (!gfc_current_ns
->proc_name
9218 || gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
9220 gfc_error ("PROTECTED at %C only allowed in specification "
9221 "part of a module");
9228 if (!gfc_notify_std (GFC_STD_F2003
, "PROTECTED statement at %C"))
9231 /* PROTECTED has an entity-list. */
9232 if (gfc_match_eos () == MATCH_YES
)
9237 m
= gfc_match_symbol (&sym
, 0);
9241 if (!gfc_add_protected (&sym
->attr
, sym
->name
, &gfc_current_locus
))
9253 if (gfc_match_eos () == MATCH_YES
)
9255 if (gfc_match_char (',') != MATCH_YES
)
9262 gfc_error ("Syntax error in PROTECTED statement at %C");
9267 /* The PRIVATE statement is a bit weird in that it can be an attribute
9268 declaration, but also works as a standalone statement inside of a
9269 type declaration or a module. */
9272 gfc_match_private (gfc_statement
*st
)
9274 gfc_state_data
*prev
;
9276 if (gfc_match ("private") != MATCH_YES
)
9279 /* Try matching PRIVATE without an access-list. */
9280 if (gfc_match_eos () == MATCH_YES
)
9282 prev
= gfc_state_stack
->previous
;
9283 if (gfc_current_state () != COMP_MODULE
9284 && !(gfc_current_state () == COMP_DERIVED
9285 && prev
&& prev
->state
== COMP_MODULE
)
9286 && !(gfc_current_state () == COMP_DERIVED_CONTAINS
9287 && prev
->previous
&& prev
->previous
->state
== COMP_MODULE
))
9289 gfc_error ("PRIVATE statement at %C is only allowed in the "
9290 "specification part of a module");
9298 /* At this point in free-form source code, PRIVATE must be followed
9299 by whitespace or ::. */
9300 if (gfc_current_form
== FORM_FREE
)
9302 char c
= gfc_peek_ascii_char ();
9303 if (!gfc_is_whitespace (c
) && c
!= ':')
9307 prev
= gfc_state_stack
->previous
;
9308 if (gfc_current_state () != COMP_MODULE
9309 && !(gfc_current_state () == COMP_DERIVED
9310 && prev
&& prev
->state
== COMP_MODULE
)
9311 && !(gfc_current_state () == COMP_DERIVED_CONTAINS
9312 && prev
->previous
&& prev
->previous
->state
== COMP_MODULE
))
9314 gfc_error ("PRIVATE statement at %C is only allowed in the "
9315 "specification part of a module");
9320 return access_attr_decl (ST_PRIVATE
);
9325 gfc_match_public (gfc_statement
*st
)
9327 if (gfc_match ("public") != MATCH_YES
)
9330 /* Try matching PUBLIC without an access-list. */
9331 if (gfc_match_eos () == MATCH_YES
)
9333 if (gfc_current_state () != COMP_MODULE
)
9335 gfc_error ("PUBLIC statement at %C is only allowed in the "
9336 "specification part of a module");
9344 /* At this point in free-form source code, PUBLIC must be followed
9345 by whitespace or ::. */
9346 if (gfc_current_form
== FORM_FREE
)
9348 char c
= gfc_peek_ascii_char ();
9349 if (!gfc_is_whitespace (c
) && c
!= ':')
9353 if (gfc_current_state () != COMP_MODULE
)
9355 gfc_error ("PUBLIC statement at %C is only allowed in the "
9356 "specification part of a module");
9361 return access_attr_decl (ST_PUBLIC
);
9365 /* Workhorse for gfc_match_parameter. */
9375 m
= gfc_match_symbol (&sym
, 0);
9377 gfc_error ("Expected variable name at %C in PARAMETER statement");
9382 if (gfc_match_char ('=') == MATCH_NO
)
9384 gfc_error ("Expected = sign in PARAMETER statement at %C");
9388 m
= gfc_match_init_expr (&init
);
9390 gfc_error ("Expected expression at %C in PARAMETER statement");
9394 if (sym
->ts
.type
== BT_UNKNOWN
9395 && !gfc_set_default_type (sym
, 1, NULL
))
9401 if (!gfc_check_assign_symbol (sym
, NULL
, init
)
9402 || !gfc_add_flavor (&sym
->attr
, FL_PARAMETER
, sym
->name
, NULL
))
9410 gfc_error ("Initializing already initialized variable at %C");
9415 t
= add_init_expr_to_sym (sym
->name
, &init
, &gfc_current_locus
);
9416 return (t
) ? MATCH_YES
: MATCH_ERROR
;
9419 gfc_free_expr (init
);
9424 /* Match a parameter statement, with the weird syntax that these have. */
9427 gfc_match_parameter (void)
9429 const char *term
= " )%t";
9432 if (gfc_match_char ('(') == MATCH_NO
)
9434 /* With legacy PARAMETER statements, don't expect a terminating ')'. */
9435 if (!gfc_notify_std (GFC_STD_LEGACY
, "PARAMETER without '()' at %C"))
9446 if (gfc_match (term
) == MATCH_YES
)
9449 if (gfc_match_char (',') != MATCH_YES
)
9451 gfc_error ("Unexpected characters in PARAMETER statement at %C");
9462 gfc_match_automatic (void)
9466 bool seen_symbol
= false;
9468 if (!flag_dec_static
)
9470 gfc_error ("%s at %C is a DEC extension, enable with "
9481 m
= gfc_match_symbol (&sym
, 0);
9491 if (!gfc_add_automatic (&sym
->attr
, sym
->name
, &gfc_current_locus
))
9497 if (gfc_match_eos () == MATCH_YES
)
9499 if (gfc_match_char (',') != MATCH_YES
)
9505 gfc_error ("Expected entity-list in AUTOMATIC statement at %C");
9512 gfc_error ("Syntax error in AUTOMATIC statement at %C");
9518 gfc_match_static (void)
9522 bool seen_symbol
= false;
9524 if (!flag_dec_static
)
9526 gfc_error ("%s at %C is a DEC extension, enable with "
9536 m
= gfc_match_symbol (&sym
, 0);
9546 if (!gfc_add_save (&sym
->attr
, SAVE_EXPLICIT
, sym
->name
,
9547 &gfc_current_locus
))
9553 if (gfc_match_eos () == MATCH_YES
)
9555 if (gfc_match_char (',') != MATCH_YES
)
9561 gfc_error ("Expected entity-list in STATIC statement at %C");
9568 gfc_error ("Syntax error in STATIC statement at %C");
9573 /* Save statements have a special syntax. */
9576 gfc_match_save (void)
9578 char n
[GFC_MAX_SYMBOL_LEN
+1];
9583 if (gfc_match_eos () == MATCH_YES
)
9585 if (gfc_current_ns
->seen_save
)
9587 if (!gfc_notify_std (GFC_STD_LEGACY
, "Blanket SAVE statement at %C "
9588 "follows previous SAVE statement"))
9592 gfc_current_ns
->save_all
= gfc_current_ns
->seen_save
= 1;
9596 if (gfc_current_ns
->save_all
)
9598 if (!gfc_notify_std (GFC_STD_LEGACY
, "SAVE statement at %C follows "
9599 "blanket SAVE statement"))
9607 m
= gfc_match_symbol (&sym
, 0);
9611 if (!gfc_add_save (&sym
->attr
, SAVE_EXPLICIT
, sym
->name
,
9612 &gfc_current_locus
))
9623 m
= gfc_match (" / %n /", &n
);
9624 if (m
== MATCH_ERROR
)
9629 c
= gfc_get_common (n
, 0);
9632 gfc_current_ns
->seen_save
= 1;
9635 if (gfc_match_eos () == MATCH_YES
)
9637 if (gfc_match_char (',') != MATCH_YES
)
9644 if (gfc_current_ns
->seen_save
)
9646 gfc_error ("Syntax error in SAVE statement at %C");
9655 gfc_match_value (void)
9660 /* This is not allowed within a BLOCK construct! */
9661 if (gfc_current_state () == COMP_BLOCK
)
9663 gfc_error ("VALUE is not allowed inside of BLOCK at %C");
9667 if (!gfc_notify_std (GFC_STD_F2003
, "VALUE statement at %C"))
9670 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
9675 if (gfc_match_eos () == MATCH_YES
)
9680 m
= gfc_match_symbol (&sym
, 0);
9684 if (!gfc_add_value (&sym
->attr
, sym
->name
, &gfc_current_locus
))
9696 if (gfc_match_eos () == MATCH_YES
)
9698 if (gfc_match_char (',') != MATCH_YES
)
9705 gfc_error ("Syntax error in VALUE statement at %C");
9711 gfc_match_volatile (void)
9717 if (!gfc_notify_std (GFC_STD_F2003
, "VOLATILE statement at %C"))
9720 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
9725 if (gfc_match_eos () == MATCH_YES
)
9730 /* VOLATILE is special because it can be added to host-associated
9731 symbols locally. Except for coarrays. */
9732 m
= gfc_match_symbol (&sym
, 1);
9736 name
= XCNEWVAR (char, strlen (sym
->name
) + 1);
9737 strcpy (name
, sym
->name
);
9738 if (!check_function_name (name
))
9740 /* F2008, C560+C561. VOLATILE for host-/use-associated variable or
9741 for variable in a BLOCK which is defined outside of the BLOCK. */
9742 if (sym
->ns
!= gfc_current_ns
&& sym
->attr
.codimension
)
9744 gfc_error ("Specifying VOLATILE for coarray variable %qs at "
9745 "%C, which is use-/host-associated", sym
->name
);
9748 if (!gfc_add_volatile (&sym
->attr
, sym
->name
, &gfc_current_locus
))
9760 if (gfc_match_eos () == MATCH_YES
)
9762 if (gfc_match_char (',') != MATCH_YES
)
9769 gfc_error ("Syntax error in VOLATILE statement at %C");
9775 gfc_match_asynchronous (void)
9781 if (!gfc_notify_std (GFC_STD_F2003
, "ASYNCHRONOUS statement at %C"))
9784 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
9789 if (gfc_match_eos () == MATCH_YES
)
9794 /* ASYNCHRONOUS is special because it can be added to host-associated
9796 m
= gfc_match_symbol (&sym
, 1);
9800 name
= XCNEWVAR (char, strlen (sym
->name
) + 1);
9801 strcpy (name
, sym
->name
);
9802 if (!check_function_name (name
))
9804 if (!gfc_add_asynchronous (&sym
->attr
, sym
->name
, &gfc_current_locus
))
9816 if (gfc_match_eos () == MATCH_YES
)
9818 if (gfc_match_char (',') != MATCH_YES
)
9825 gfc_error ("Syntax error in ASYNCHRONOUS statement at %C");
9830 /* Match a module procedure statement in a submodule. */
9833 gfc_match_submod_proc (void)
9835 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9836 gfc_symbol
*sym
, *fsym
;
9838 gfc_formal_arglist
*formal
, *head
, *tail
;
9840 if (gfc_current_state () != COMP_CONTAINS
9841 || !(gfc_state_stack
->previous
9842 && (gfc_state_stack
->previous
->state
== COMP_SUBMODULE
9843 || gfc_state_stack
->previous
->state
== COMP_MODULE
)))
9846 m
= gfc_match (" module% procedure% %n", name
);
9850 if (!gfc_notify_std (GFC_STD_F2008
, "MODULE PROCEDURE declaration "
9854 if (get_proc_name (name
, &sym
, false))
9857 /* Make sure that the result field is appropriately filled. */
9858 if (sym
->tlink
&& sym
->tlink
->attr
.function
)
9860 if (sym
->tlink
->result
&& sym
->tlink
->result
!= sym
->tlink
)
9862 sym
->result
= sym
->tlink
->result
;
9863 if (!sym
->result
->attr
.use_assoc
)
9865 gfc_symtree
*st
= gfc_new_symtree (&gfc_current_ns
->sym_root
,
9867 st
->n
.sym
= sym
->result
;
9868 sym
->result
->refs
++;
9875 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
9876 the symbol existed before. */
9877 sym
->declared_at
= gfc_current_locus
;
9879 if (!sym
->attr
.module_procedure
)
9882 /* Signal match_end to expect "end procedure". */
9883 sym
->abr_modproc_decl
= 1;
9885 /* Change from IFSRC_IFBODY coming from the interface declaration. */
9886 sym
->attr
.if_source
= IFSRC_DECL
;
9888 gfc_new_block
= sym
;
9890 /* Make a new formal arglist with the symbols in the procedure
9893 for (formal
= sym
->formal
; formal
&& formal
->sym
; formal
= formal
->next
)
9895 if (formal
== sym
->formal
)
9896 head
= tail
= gfc_get_formal_arglist ();
9899 tail
->next
= gfc_get_formal_arglist ();
9903 if (gfc_copy_dummy_sym (&fsym
, formal
->sym
, 0))
9907 gfc_set_sym_referenced (fsym
);
9910 /* The dummy symbols get cleaned up, when the formal_namespace of the
9911 interface declaration is cleared. This allows us to add the
9912 explicit interface as is done for other type of procedure. */
9913 if (!gfc_add_explicit_interface (sym
, IFSRC_DECL
, head
,
9914 &gfc_current_locus
))
9917 if (gfc_match_eos () != MATCH_YES
)
9919 /* Unset st->n.sym. Note: in reject_statement (), the symbol changes are
9920 undone, such that the st->n.sym->formal points to the original symbol;
9921 if now this namespace is finalized, the formal namespace is freed,
9922 but it might be still needed in the parent namespace. */
9923 gfc_symtree
*st
= gfc_find_symtree (gfc_current_ns
->sym_root
, sym
->name
);
9925 gfc_free_symbol (sym
->tlink
);
9928 gfc_syntax_error (ST_MODULE_PROC
);
9935 gfc_free_formal_arglist (head
);
9940 /* Match a module procedure statement. Note that we have to modify
9941 symbols in the parent's namespace because the current one was there
9942 to receive symbols that are in an interface's formal argument list. */
9945 gfc_match_modproc (void)
9947 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9951 gfc_namespace
*module_ns
;
9952 gfc_interface
*old_interface_head
, *interface
;
9954 if ((gfc_state_stack
->state
!= COMP_INTERFACE
9955 && gfc_state_stack
->state
!= COMP_CONTAINS
)
9956 || gfc_state_stack
->previous
== NULL
9957 || current_interface
.type
== INTERFACE_NAMELESS
9958 || current_interface
.type
== INTERFACE_ABSTRACT
)
9960 gfc_error ("MODULE PROCEDURE at %C must be in a generic module "
9965 module_ns
= gfc_current_ns
->parent
;
9966 for (; module_ns
; module_ns
= module_ns
->parent
)
9967 if (module_ns
->proc_name
->attr
.flavor
== FL_MODULE
9968 || module_ns
->proc_name
->attr
.flavor
== FL_PROGRAM
9969 || (module_ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
9970 && !module_ns
->proc_name
->attr
.contained
))
9973 if (module_ns
== NULL
)
9976 /* Store the current state of the interface. We will need it if we
9977 end up with a syntax error and need to recover. */
9978 old_interface_head
= gfc_current_interface_head ();
9980 /* Check if the F2008 optional double colon appears. */
9981 gfc_gobble_whitespace ();
9982 old_locus
= gfc_current_locus
;
9983 if (gfc_match ("::") == MATCH_YES
)
9985 if (!gfc_notify_std (GFC_STD_F2008
, "double colon in "
9986 "MODULE PROCEDURE statement at %L", &old_locus
))
9990 gfc_current_locus
= old_locus
;
9995 old_locus
= gfc_current_locus
;
9997 m
= gfc_match_name (name
);
10000 if (m
!= MATCH_YES
)
10001 return MATCH_ERROR
;
10003 /* Check for syntax error before starting to add symbols to the
10004 current namespace. */
10005 if (gfc_match_eos () == MATCH_YES
)
10008 if (!last
&& gfc_match_char (',') != MATCH_YES
)
10011 /* Now we're sure the syntax is valid, we process this item
10013 if (gfc_get_symbol (name
, module_ns
, &sym
))
10014 return MATCH_ERROR
;
10016 if (sym
->attr
.intrinsic
)
10018 gfc_error ("Intrinsic procedure at %L cannot be a MODULE "
10019 "PROCEDURE", &old_locus
);
10020 return MATCH_ERROR
;
10023 if (sym
->attr
.proc
!= PROC_MODULE
10024 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
10025 return MATCH_ERROR
;
10027 if (!gfc_add_interface (sym
))
10028 return MATCH_ERROR
;
10030 sym
->attr
.mod_proc
= 1;
10031 sym
->declared_at
= old_locus
;
10040 /* Restore the previous state of the interface. */
10041 interface
= gfc_current_interface_head ();
10042 gfc_set_current_interface_head (old_interface_head
);
10044 /* Free the new interfaces. */
10045 while (interface
!= old_interface_head
)
10047 gfc_interface
*i
= interface
->next
;
10052 /* And issue a syntax error. */
10053 gfc_syntax_error (ST_MODULE_PROC
);
10054 return MATCH_ERROR
;
10058 /* Check a derived type that is being extended. */
10061 check_extended_derived_type (char *name
)
10063 gfc_symbol
*extended
;
10065 if (gfc_find_symbol (name
, gfc_current_ns
, 1, &extended
))
10067 gfc_error ("Ambiguous symbol in TYPE definition at %C");
10071 extended
= gfc_find_dt_in_generic (extended
);
10076 gfc_error ("Symbol %qs at %C has not been previously defined", name
);
10080 if (extended
->attr
.flavor
!= FL_DERIVED
)
10082 gfc_error ("%qs in EXTENDS expression at %C is not a "
10083 "derived type", name
);
10087 if (extended
->attr
.is_bind_c
)
10089 gfc_error ("%qs cannot be extended at %C because it "
10090 "is BIND(C)", extended
->name
);
10094 if (extended
->attr
.sequence
)
10096 gfc_error ("%qs cannot be extended at %C because it "
10097 "is a SEQUENCE type", extended
->name
);
10105 /* Match the optional attribute specifiers for a type declaration.
10106 Return MATCH_ERROR if an error is encountered in one of the handled
10107 attributes (public, private, bind(c)), MATCH_NO if what's found is
10108 not a handled attribute, and MATCH_YES otherwise. TODO: More error
10109 checking on attribute conflicts needs to be done. */
10112 gfc_get_type_attr_spec (symbol_attribute
*attr
, char *name
)
10114 /* See if the derived type is marked as private. */
10115 if (gfc_match (" , private") == MATCH_YES
)
10117 if (gfc_current_state () != COMP_MODULE
)
10119 gfc_error ("Derived type at %C can only be PRIVATE in the "
10120 "specification part of a module");
10121 return MATCH_ERROR
;
10124 if (!gfc_add_access (attr
, ACCESS_PRIVATE
, NULL
, NULL
))
10125 return MATCH_ERROR
;
10127 else if (gfc_match (" , public") == MATCH_YES
)
10129 if (gfc_current_state () != COMP_MODULE
)
10131 gfc_error ("Derived type at %C can only be PUBLIC in the "
10132 "specification part of a module");
10133 return MATCH_ERROR
;
10136 if (!gfc_add_access (attr
, ACCESS_PUBLIC
, NULL
, NULL
))
10137 return MATCH_ERROR
;
10139 else if (gfc_match (" , bind ( c )") == MATCH_YES
)
10141 /* If the type is defined to be bind(c) it then needs to make
10142 sure that all fields are interoperable. This will
10143 need to be a semantic check on the finished derived type.
10144 See 15.2.3 (lines 9-12) of F2003 draft. */
10145 if (!gfc_add_is_bind_c (attr
, NULL
, &gfc_current_locus
, 0))
10146 return MATCH_ERROR
;
10148 /* TODO: attr conflicts need to be checked, probably in symbol.c. */
10150 else if (gfc_match (" , abstract") == MATCH_YES
)
10152 if (!gfc_notify_std (GFC_STD_F2003
, "ABSTRACT type at %C"))
10153 return MATCH_ERROR
;
10155 if (!gfc_add_abstract (attr
, &gfc_current_locus
))
10156 return MATCH_ERROR
;
10158 else if (name
&& gfc_match (" , extends ( %n )", name
) == MATCH_YES
)
10160 if (!gfc_add_extension (attr
, &gfc_current_locus
))
10161 return MATCH_ERROR
;
10166 /* If we get here, something matched. */
10171 /* Common function for type declaration blocks similar to derived types, such
10172 as STRUCTURES and MAPs. Unlike derived types, a structure type
10173 does NOT have a generic symbol matching the name given by the user.
10174 STRUCTUREs can share names with variables and PARAMETERs so we must allow
10175 for the creation of an independent symbol.
10176 Other parameters are a message to prefix errors with, the name of the new
10177 type to be created, and the flavor to add to the resulting symbol. */
10180 get_struct_decl (const char *name
, sym_flavor fl
, locus
*decl
,
10181 gfc_symbol
**result
)
10186 gcc_assert (name
[0] == (char) TOUPPER (name
[0]));
10191 where
= gfc_current_locus
;
10193 if (gfc_get_symbol (name
, NULL
, &sym
))
10198 gfc_internal_error ("Failed to create structure type '%s' at %C", name
);
10202 if (sym
->components
!= NULL
|| sym
->attr
.zero_comp
)
10204 gfc_error ("Type definition of %qs at %C was already defined at %L",
10205 sym
->name
, &sym
->declared_at
);
10209 sym
->declared_at
= where
;
10211 if (sym
->attr
.flavor
!= fl
10212 && !gfc_add_flavor (&sym
->attr
, fl
, sym
->name
, NULL
))
10215 if (!sym
->hash_value
)
10216 /* Set the hash for the compound name for this type. */
10217 sym
->hash_value
= gfc_hash_value (sym
);
10219 /* Normally the type is expected to have been completely parsed by the time
10220 a field declaration with this type is seen. For unions, maps, and nested
10221 structure declarations, we need to indicate that it is okay that we
10222 haven't seen any components yet. This will be updated after the structure
10223 is fully parsed. */
10224 sym
->attr
.zero_comp
= 0;
10226 /* Structures always act like derived-types with the SEQUENCE attribute */
10227 gfc_add_sequence (&sym
->attr
, sym
->name
, NULL
);
10229 if (result
) *result
= sym
;
10235 /* Match the opening of a MAP block. Like a struct within a union in C;
10236 behaves identical to STRUCTURE blocks. */
10239 gfc_match_map (void)
10241 /* Counter used to give unique internal names to map structures. */
10242 static unsigned int gfc_map_id
= 0;
10243 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10247 old_loc
= gfc_current_locus
;
10249 if (gfc_match_eos () != MATCH_YES
)
10251 gfc_error ("Junk after MAP statement at %C");
10252 gfc_current_locus
= old_loc
;
10253 return MATCH_ERROR
;
10256 /* Map blocks are anonymous so we make up unique names for the symbol table
10257 which are invalid Fortran identifiers. */
10258 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "MM$%u", gfc_map_id
++);
10260 if (!get_struct_decl (name
, FL_STRUCT
, &old_loc
, &sym
))
10261 return MATCH_ERROR
;
10263 gfc_new_block
= sym
;
10269 /* Match the opening of a UNION block. */
10272 gfc_match_union (void)
10274 /* Counter used to give unique internal names to union types. */
10275 static unsigned int gfc_union_id
= 0;
10276 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10280 old_loc
= gfc_current_locus
;
10282 if (gfc_match_eos () != MATCH_YES
)
10284 gfc_error ("Junk after UNION statement at %C");
10285 gfc_current_locus
= old_loc
;
10286 return MATCH_ERROR
;
10289 /* Unions are anonymous so we make up unique names for the symbol table
10290 which are invalid Fortran identifiers. */
10291 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "UU$%u", gfc_union_id
++);
10293 if (!get_struct_decl (name
, FL_UNION
, &old_loc
, &sym
))
10294 return MATCH_ERROR
;
10296 gfc_new_block
= sym
;
10302 /* Match the beginning of a STRUCTURE declaration. This is similar to
10303 matching the beginning of a derived type declaration with a few
10304 twists. The resulting type symbol has no access control or other
10305 interesting attributes. */
10308 gfc_match_structure_decl (void)
10310 /* Counter used to give unique internal names to anonymous structures. */
10311 static unsigned int gfc_structure_id
= 0;
10312 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10317 if (!flag_dec_structure
)
10319 gfc_error ("%s at %C is a DEC extension, enable with "
10320 "%<-fdec-structure%>",
10322 return MATCH_ERROR
;
10327 m
= gfc_match (" /%n/", name
);
10328 if (m
!= MATCH_YES
)
10330 /* Non-nested structure declarations require a structure name. */
10331 if (!gfc_comp_struct (gfc_current_state ()))
10333 gfc_error ("Structure name expected in non-nested structure "
10334 "declaration at %C");
10335 return MATCH_ERROR
;
10337 /* This is an anonymous structure; make up a unique name for it
10338 (upper-case letters never make it to symbol names from the source).
10339 The important thing is initializing the type variable
10340 and setting gfc_new_symbol, which is immediately used by
10341 parse_structure () and variable_decl () to add components of
10343 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "SS$%u", gfc_structure_id
++);
10346 where
= gfc_current_locus
;
10347 /* No field list allowed after non-nested structure declaration. */
10348 if (!gfc_comp_struct (gfc_current_state ())
10349 && gfc_match_eos () != MATCH_YES
)
10351 gfc_error ("Junk after non-nested STRUCTURE statement at %C");
10352 return MATCH_ERROR
;
10355 /* Make sure the name is not the name of an intrinsic type. */
10356 if (gfc_is_intrinsic_typename (name
))
10358 gfc_error ("Structure name %qs at %C cannot be the same as an"
10359 " intrinsic type", name
);
10360 return MATCH_ERROR
;
10363 /* Store the actual type symbol for the structure with an upper-case first
10364 letter (an invalid Fortran identifier). */
10366 if (!get_struct_decl (gfc_dt_upper_string (name
), FL_STRUCT
, &where
, &sym
))
10367 return MATCH_ERROR
;
10369 gfc_new_block
= sym
;
10374 /* This function does some work to determine which matcher should be used to
10375 * match a statement beginning with "TYPE". This is used to disambiguate TYPE
10376 * as an alias for PRINT from derived type declarations, TYPE IS statements,
10377 * and [parameterized] derived type declarations. */
10380 gfc_match_type (gfc_statement
*st
)
10382 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10386 /* Requires -fdec. */
10390 m
= gfc_match ("type");
10391 if (m
!= MATCH_YES
)
10393 /* If we already have an error in the buffer, it is probably from failing to
10394 * match a derived type data declaration. Let it happen. */
10395 else if (gfc_error_flag_test ())
10398 old_loc
= gfc_current_locus
;
10401 /* If we see an attribute list before anything else it's definitely a derived
10402 * type declaration. */
10403 if (gfc_match (" ,") == MATCH_YES
|| gfc_match (" ::") == MATCH_YES
)
10406 /* By now "TYPE" has already been matched. If we do not see a name, this may
10407 * be something like "TYPE *" or "TYPE <fmt>". */
10408 m
= gfc_match_name (name
);
10409 if (m
!= MATCH_YES
)
10411 /* Let print match if it can, otherwise throw an error from
10412 * gfc_match_derived_decl. */
10413 gfc_current_locus
= old_loc
;
10414 if (gfc_match_print () == MATCH_YES
)
10422 /* Check for EOS. */
10423 if (gfc_match_eos () == MATCH_YES
)
10425 /* By now we have "TYPE <name> <EOS>". Check first if the name is an
10426 * intrinsic typename - if so let gfc_match_derived_decl dump an error.
10427 * Otherwise if gfc_match_derived_decl fails it's probably an existing
10428 * symbol which can be printed. */
10429 gfc_current_locus
= old_loc
;
10430 m
= gfc_match_derived_decl ();
10431 if (gfc_is_intrinsic_typename (name
) || m
== MATCH_YES
)
10433 *st
= ST_DERIVED_DECL
;
10439 /* Here we have "TYPE <name>". Check for <TYPE IS (> or a PDT declaration
10440 like <type name(parameter)>. */
10441 gfc_gobble_whitespace ();
10442 bool paren
= gfc_peek_ascii_char () == '(';
10445 if (strcmp ("is", name
) == 0)
10452 /* Treat TYPE... like PRINT... */
10453 gfc_current_locus
= old_loc
;
10455 return gfc_match_print ();
10458 gfc_current_locus
= old_loc
;
10459 *st
= ST_DERIVED_DECL
;
10460 return gfc_match_derived_decl ();
10463 gfc_current_locus
= old_loc
;
10465 return gfc_match_type_is ();
10469 /* Match the beginning of a derived type declaration. If a type name
10470 was the result of a function, then it is possible to have a symbol
10471 already to be known as a derived type yet have no components. */
10474 gfc_match_derived_decl (void)
10476 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10477 char parent
[GFC_MAX_SYMBOL_LEN
+ 1];
10478 symbol_attribute attr
;
10479 gfc_symbol
*sym
, *gensym
;
10480 gfc_symbol
*extended
;
10482 match is_type_attr_spec
= MATCH_NO
;
10483 bool seen_attr
= false;
10484 gfc_interface
*intr
= NULL
, *head
;
10485 bool parameterized_type
= false;
10486 bool seen_colons
= false;
10488 if (gfc_comp_struct (gfc_current_state ()))
10493 gfc_clear_attr (&attr
);
10498 is_type_attr_spec
= gfc_get_type_attr_spec (&attr
, parent
);
10499 if (is_type_attr_spec
== MATCH_ERROR
)
10500 return MATCH_ERROR
;
10501 if (is_type_attr_spec
== MATCH_YES
)
10503 } while (is_type_attr_spec
== MATCH_YES
);
10505 /* Deal with derived type extensions. The extension attribute has
10506 been added to 'attr' but now the parent type must be found and
10509 extended
= check_extended_derived_type (parent
);
10511 if (parent
[0] && !extended
)
10512 return MATCH_ERROR
;
10514 m
= gfc_match (" ::");
10515 if (m
== MATCH_YES
)
10517 seen_colons
= true;
10519 else if (seen_attr
)
10521 gfc_error ("Expected :: in TYPE definition at %C");
10522 return MATCH_ERROR
;
10525 /* In free source form, need to check for TYPE XXX as oppose to TYPEXXX.
10526 But, we need to simply return for TYPE(. */
10527 if (m
== MATCH_NO
&& gfc_current_form
== FORM_FREE
)
10529 char c
= gfc_peek_ascii_char ();
10532 if (!gfc_is_whitespace (c
))
10534 gfc_error ("Mangled derived type definition at %C");
10539 m
= gfc_match (" %n ", name
);
10540 if (m
!= MATCH_YES
)
10543 /* Make sure that we don't identify TYPE IS (...) as a parameterized
10544 derived type named 'is'.
10545 TODO Expand the check, when 'name' = "is" by matching " (tname) "
10546 and checking if this is a(n intrinsic) typename. This picks up
10547 misplaced TYPE IS statements such as in select_type_1.f03. */
10548 if (gfc_peek_ascii_char () == '(')
10550 if (gfc_current_state () == COMP_SELECT_TYPE
10551 || (!seen_colons
&& !strcmp (name
, "is")))
10553 parameterized_type
= true;
10556 m
= gfc_match_eos ();
10557 if (m
!= MATCH_YES
&& !parameterized_type
)
10560 /* Make sure the name is not the name of an intrinsic type. */
10561 if (gfc_is_intrinsic_typename (name
))
10563 gfc_error ("Type name %qs at %C cannot be the same as an intrinsic "
10565 return MATCH_ERROR
;
10568 if (gfc_get_symbol (name
, NULL
, &gensym
))
10569 return MATCH_ERROR
;
10571 if (!gensym
->attr
.generic
&& gensym
->ts
.type
!= BT_UNKNOWN
)
10573 if (gensym
->ts
.u
.derived
)
10574 gfc_error ("Derived type name %qs at %C already has a basic type "
10575 "of %s", gensym
->name
, gfc_typename (&gensym
->ts
));
10577 gfc_error ("Derived type name %qs at %C already has a basic type",
10579 return MATCH_ERROR
;
10582 if (!gensym
->attr
.generic
10583 && !gfc_add_generic (&gensym
->attr
, gensym
->name
, NULL
))
10584 return MATCH_ERROR
;
10586 if (!gensym
->attr
.function
10587 && !gfc_add_function (&gensym
->attr
, gensym
->name
, NULL
))
10588 return MATCH_ERROR
;
10590 if (gensym
->attr
.dummy
)
10592 gfc_error ("Dummy argument %qs at %L cannot be a derived type at %C",
10593 name
, &gensym
->declared_at
);
10594 return MATCH_ERROR
;
10597 sym
= gfc_find_dt_in_generic (gensym
);
10599 if (sym
&& (sym
->components
!= NULL
|| sym
->attr
.zero_comp
))
10601 gfc_error ("Derived type definition of %qs at %C has already been "
10602 "defined", sym
->name
);
10603 return MATCH_ERROR
;
10608 /* Use upper case to save the actual derived-type symbol. */
10609 gfc_get_symbol (gfc_dt_upper_string (gensym
->name
), NULL
, &sym
);
10610 sym
->name
= gfc_get_string ("%s", gensym
->name
);
10611 head
= gensym
->generic
;
10612 intr
= gfc_get_interface ();
10614 intr
->where
= gfc_current_locus
;
10615 intr
->sym
->declared_at
= gfc_current_locus
;
10617 gensym
->generic
= intr
;
10618 gensym
->attr
.if_source
= IFSRC_DECL
;
10621 /* The symbol may already have the derived attribute without the
10622 components. The ways this can happen is via a function
10623 definition, an INTRINSIC statement or a subtype in another
10624 derived type that is a pointer. The first part of the AND clause
10625 is true if the symbol is not the return value of a function. */
10626 if (sym
->attr
.flavor
!= FL_DERIVED
10627 && !gfc_add_flavor (&sym
->attr
, FL_DERIVED
, sym
->name
, NULL
))
10628 return MATCH_ERROR
;
10630 if (attr
.access
!= ACCESS_UNKNOWN
10631 && !gfc_add_access (&sym
->attr
, attr
.access
, sym
->name
, NULL
))
10632 return MATCH_ERROR
;
10633 else if (sym
->attr
.access
== ACCESS_UNKNOWN
10634 && gensym
->attr
.access
!= ACCESS_UNKNOWN
10635 && !gfc_add_access (&sym
->attr
, gensym
->attr
.access
,
10637 return MATCH_ERROR
;
10639 if (sym
->attr
.access
!= ACCESS_UNKNOWN
10640 && gensym
->attr
.access
== ACCESS_UNKNOWN
)
10641 gensym
->attr
.access
= sym
->attr
.access
;
10643 /* See if the derived type was labeled as bind(c). */
10644 if (attr
.is_bind_c
!= 0)
10645 sym
->attr
.is_bind_c
= attr
.is_bind_c
;
10647 /* Construct the f2k_derived namespace if it is not yet there. */
10648 if (!sym
->f2k_derived
)
10649 sym
->f2k_derived
= gfc_get_namespace (NULL
, 0);
10651 if (parameterized_type
)
10653 /* Ignore error or mismatches by going to the end of the statement
10654 in order to avoid the component declarations causing problems. */
10655 m
= gfc_match_formal_arglist (sym
, 0, 0, true);
10656 if (m
!= MATCH_YES
)
10657 gfc_error_recovery ();
10659 sym
->attr
.pdt_template
= 1;
10660 m
= gfc_match_eos ();
10661 if (m
!= MATCH_YES
)
10663 gfc_error_recovery ();
10664 gfc_error_now ("Garbage after PARAMETERIZED TYPE declaration at %C");
10668 if (extended
&& !sym
->components
)
10671 gfc_formal_arglist
*f
, *g
, *h
;
10673 /* Add the extended derived type as the first component. */
10674 gfc_add_component (sym
, parent
, &p
);
10676 gfc_set_sym_referenced (extended
);
10678 p
->ts
.type
= BT_DERIVED
;
10679 p
->ts
.u
.derived
= extended
;
10680 p
->initializer
= gfc_default_initializer (&p
->ts
);
10682 /* Set extension level. */
10683 if (extended
->attr
.extension
== 255)
10685 /* Since the extension field is 8 bit wide, we can only have
10686 up to 255 extension levels. */
10687 gfc_error ("Maximum extension level reached with type %qs at %L",
10688 extended
->name
, &extended
->declared_at
);
10689 return MATCH_ERROR
;
10691 sym
->attr
.extension
= extended
->attr
.extension
+ 1;
10693 /* Provide the links between the extended type and its extension. */
10694 if (!extended
->f2k_derived
)
10695 extended
->f2k_derived
= gfc_get_namespace (NULL
, 0);
10697 /* Copy the extended type-param-name-list from the extended type,
10698 append those of the extension and add the whole lot to the
10700 if (extended
->attr
.pdt_template
)
10703 sym
->attr
.pdt_template
= 1;
10704 for (f
= extended
->formal
; f
; f
= f
->next
)
10706 if (f
== extended
->formal
)
10708 g
= gfc_get_formal_arglist ();
10713 g
->next
= gfc_get_formal_arglist ();
10718 g
->next
= sym
->formal
;
10723 if (!sym
->hash_value
)
10724 /* Set the hash for the compound name for this type. */
10725 sym
->hash_value
= gfc_hash_value (sym
);
10727 /* Take over the ABSTRACT attribute. */
10728 sym
->attr
.abstract
= attr
.abstract
;
10730 gfc_new_block
= sym
;
10736 /* Cray Pointees can be declared as:
10737 pointer (ipt, a (n,m,...,*)) */
10740 gfc_mod_pointee_as (gfc_array_spec
*as
)
10742 as
->cray_pointee
= true; /* This will be useful to know later. */
10743 if (as
->type
== AS_ASSUMED_SIZE
)
10744 as
->cp_was_assumed
= true;
10745 else if (as
->type
== AS_ASSUMED_SHAPE
)
10747 gfc_error ("Cray Pointee at %C cannot be assumed shape array");
10748 return MATCH_ERROR
;
10754 /* Match the enum definition statement, here we are trying to match
10755 the first line of enum definition statement.
10756 Returns MATCH_YES if match is found. */
10759 gfc_match_enum (void)
10763 m
= gfc_match_eos ();
10764 if (m
!= MATCH_YES
)
10767 if (!gfc_notify_std (GFC_STD_F2003
, "ENUM and ENUMERATOR at %C"))
10768 return MATCH_ERROR
;
10774 /* Returns an initializer whose value is one higher than the value of the
10775 LAST_INITIALIZER argument. If the argument is NULL, the
10776 initializers value will be set to zero. The initializer's kind
10777 will be set to gfc_c_int_kind.
10779 If -fshort-enums is given, the appropriate kind will be selected
10780 later after all enumerators have been parsed. A warning is issued
10781 here if an initializer exceeds gfc_c_int_kind. */
10784 enum_initializer (gfc_expr
*last_initializer
, locus where
)
10787 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_c_int_kind
, &where
);
10789 mpz_init (result
->value
.integer
);
10791 if (last_initializer
!= NULL
)
10793 mpz_add_ui (result
->value
.integer
, last_initializer
->value
.integer
, 1);
10794 result
->where
= last_initializer
->where
;
10796 if (gfc_check_integer_range (result
->value
.integer
,
10797 gfc_c_int_kind
) != ARITH_OK
)
10799 gfc_error ("Enumerator exceeds the C integer type at %C");
10805 /* Control comes here, if it's the very first enumerator and no
10806 initializer has been given. It will be initialized to zero. */
10807 mpz_set_si (result
->value
.integer
, 0);
10814 /* Match a variable name with an optional initializer. When this
10815 subroutine is called, a variable is expected to be parsed next.
10816 Depending on what is happening at the moment, updates either the
10817 symbol table or the current interface. */
10820 enumerator_decl (void)
10822 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10823 gfc_expr
*initializer
;
10824 gfc_array_spec
*as
= NULL
;
10831 initializer
= NULL
;
10832 old_locus
= gfc_current_locus
;
10834 /* When we get here, we've just matched a list of attributes and
10835 maybe a type and a double colon. The next thing we expect to see
10836 is the name of the symbol. */
10837 m
= gfc_match_name (name
);
10838 if (m
!= MATCH_YES
)
10841 var_locus
= gfc_current_locus
;
10843 /* OK, we've successfully matched the declaration. Now put the
10844 symbol in the current namespace. If we fail to create the symbol,
10846 if (!build_sym (name
, NULL
, false, &as
, &var_locus
))
10852 /* The double colon must be present in order to have initializers.
10853 Otherwise the statement is ambiguous with an assignment statement. */
10856 if (gfc_match_char ('=') == MATCH_YES
)
10858 m
= gfc_match_init_expr (&initializer
);
10861 gfc_error ("Expected an initialization expression at %C");
10865 if (m
!= MATCH_YES
)
10870 /* If we do not have an initializer, the initialization value of the
10871 previous enumerator (stored in last_initializer) is incremented
10872 by 1 and is used to initialize the current enumerator. */
10873 if (initializer
== NULL
)
10874 initializer
= enum_initializer (last_initializer
, old_locus
);
10876 if (initializer
== NULL
|| initializer
->ts
.type
!= BT_INTEGER
)
10878 gfc_error ("ENUMERATOR %L not initialized with integer expression",
10884 /* Store this current initializer, for the next enumerator variable
10885 to be parsed. add_init_expr_to_sym() zeros initializer, so we
10886 use last_initializer below. */
10887 last_initializer
= initializer
;
10888 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
10890 /* Maintain enumerator history. */
10891 gfc_find_symbol (name
, NULL
, 0, &sym
);
10892 create_enum_history (sym
, last_initializer
);
10894 return (t
) ? MATCH_YES
: MATCH_ERROR
;
10897 /* Free stuff up and return. */
10898 gfc_free_expr (initializer
);
10904 /* Match the enumerator definition statement. */
10907 gfc_match_enumerator_def (void)
10912 gfc_clear_ts (¤t_ts
);
10914 m
= gfc_match (" enumerator");
10915 if (m
!= MATCH_YES
)
10918 m
= gfc_match (" :: ");
10919 if (m
== MATCH_ERROR
)
10922 colon_seen
= (m
== MATCH_YES
);
10924 if (gfc_current_state () != COMP_ENUM
)
10926 gfc_error ("ENUM definition statement expected before %C");
10927 gfc_free_enum_history ();
10928 return MATCH_ERROR
;
10931 (¤t_ts
)->type
= BT_INTEGER
;
10932 (¤t_ts
)->kind
= gfc_c_int_kind
;
10934 gfc_clear_attr (¤t_attr
);
10935 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, NULL
);
10944 m
= enumerator_decl ();
10945 if (m
== MATCH_ERROR
)
10947 gfc_free_enum_history ();
10953 if (gfc_match_eos () == MATCH_YES
)
10955 if (gfc_match_char (',') != MATCH_YES
)
10959 if (gfc_current_state () == COMP_ENUM
)
10961 gfc_free_enum_history ();
10962 gfc_error ("Syntax error in ENUMERATOR definition at %C");
10967 gfc_free_array_spec (current_as
);
10974 /* Match binding attributes. */
10977 match_binding_attributes (gfc_typebound_proc
* ba
, bool generic
, bool ppc
)
10979 bool found_passing
= false;
10980 bool seen_ptr
= false;
10981 match m
= MATCH_YES
;
10983 /* Initialize to defaults. Do so even before the MATCH_NO check so that in
10984 this case the defaults are in there. */
10985 ba
->access
= ACCESS_UNKNOWN
;
10986 ba
->pass_arg
= NULL
;
10987 ba
->pass_arg_num
= 0;
10989 ba
->non_overridable
= 0;
10993 /* If we find a comma, we believe there are binding attributes. */
10994 m
= gfc_match_char (',');
11000 /* Access specifier. */
11002 m
= gfc_match (" public");
11003 if (m
== MATCH_ERROR
)
11005 if (m
== MATCH_YES
)
11007 if (ba
->access
!= ACCESS_UNKNOWN
)
11009 gfc_error ("Duplicate access-specifier at %C");
11013 ba
->access
= ACCESS_PUBLIC
;
11017 m
= gfc_match (" private");
11018 if (m
== MATCH_ERROR
)
11020 if (m
== MATCH_YES
)
11022 if (ba
->access
!= ACCESS_UNKNOWN
)
11024 gfc_error ("Duplicate access-specifier at %C");
11028 ba
->access
= ACCESS_PRIVATE
;
11032 /* If inside GENERIC, the following is not allowed. */
11037 m
= gfc_match (" nopass");
11038 if (m
== MATCH_ERROR
)
11040 if (m
== MATCH_YES
)
11044 gfc_error ("Binding attributes already specify passing,"
11045 " illegal NOPASS at %C");
11049 found_passing
= true;
11054 /* PASS possibly including argument. */
11055 m
= gfc_match (" pass");
11056 if (m
== MATCH_ERROR
)
11058 if (m
== MATCH_YES
)
11060 char arg
[GFC_MAX_SYMBOL_LEN
+ 1];
11064 gfc_error ("Binding attributes already specify passing,"
11065 " illegal PASS at %C");
11069 m
= gfc_match (" ( %n )", arg
);
11070 if (m
== MATCH_ERROR
)
11072 if (m
== MATCH_YES
)
11073 ba
->pass_arg
= gfc_get_string ("%s", arg
);
11074 gcc_assert ((m
== MATCH_YES
) == (ba
->pass_arg
!= NULL
));
11076 found_passing
= true;
11083 /* POINTER flag. */
11084 m
= gfc_match (" pointer");
11085 if (m
== MATCH_ERROR
)
11087 if (m
== MATCH_YES
)
11091 gfc_error ("Duplicate POINTER attribute at %C");
11101 /* NON_OVERRIDABLE flag. */
11102 m
= gfc_match (" non_overridable");
11103 if (m
== MATCH_ERROR
)
11105 if (m
== MATCH_YES
)
11107 if (ba
->non_overridable
)
11109 gfc_error ("Duplicate NON_OVERRIDABLE at %C");
11113 ba
->non_overridable
= 1;
11117 /* DEFERRED flag. */
11118 m
= gfc_match (" deferred");
11119 if (m
== MATCH_ERROR
)
11121 if (m
== MATCH_YES
)
11125 gfc_error ("Duplicate DEFERRED at %C");
11136 /* Nothing matching found. */
11138 gfc_error ("Expected access-specifier at %C");
11140 gfc_error ("Expected binding attribute at %C");
11143 while (gfc_match_char (',') == MATCH_YES
);
11145 /* NON_OVERRIDABLE and DEFERRED exclude themselves. */
11146 if (ba
->non_overridable
&& ba
->deferred
)
11148 gfc_error ("NON_OVERRIDABLE and DEFERRED cannot both appear at %C");
11155 if (ba
->access
== ACCESS_UNKNOWN
)
11156 ba
->access
= ppc
? gfc_current_block()->component_access
11157 : gfc_typebound_default_access
;
11159 if (ppc
&& !seen_ptr
)
11161 gfc_error ("POINTER attribute is required for procedure pointer component"
11169 return MATCH_ERROR
;
11173 /* Match a PROCEDURE specific binding inside a derived type. */
11176 match_procedure_in_type (void)
11178 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
11179 char target_buf
[GFC_MAX_SYMBOL_LEN
+ 1];
11180 char* target
= NULL
, *ifc
= NULL
;
11181 gfc_typebound_proc tb
;
11185 gfc_symtree
* stree
;
11190 /* Check current state. */
11191 gcc_assert (gfc_state_stack
->state
== COMP_DERIVED_CONTAINS
);
11192 block
= gfc_state_stack
->previous
->sym
;
11193 gcc_assert (block
);
11195 /* Try to match PROCEDURE(interface). */
11196 if (gfc_match (" (") == MATCH_YES
)
11198 m
= gfc_match_name (target_buf
);
11199 if (m
== MATCH_ERROR
)
11201 if (m
!= MATCH_YES
)
11203 gfc_error ("Interface-name expected after %<(%> at %C");
11204 return MATCH_ERROR
;
11207 if (gfc_match (" )") != MATCH_YES
)
11209 gfc_error ("%<)%> expected at %C");
11210 return MATCH_ERROR
;
11216 /* Construct the data structure. */
11217 memset (&tb
, 0, sizeof (tb
));
11218 tb
.where
= gfc_current_locus
;
11220 /* Match binding attributes. */
11221 m
= match_binding_attributes (&tb
, false, false);
11222 if (m
== MATCH_ERROR
)
11224 seen_attrs
= (m
== MATCH_YES
);
11226 /* Check that attribute DEFERRED is given if an interface is specified. */
11227 if (tb
.deferred
&& !ifc
)
11229 gfc_error ("Interface must be specified for DEFERRED binding at %C");
11230 return MATCH_ERROR
;
11232 if (ifc
&& !tb
.deferred
)
11234 gfc_error ("PROCEDURE(interface) at %C should be declared DEFERRED");
11235 return MATCH_ERROR
;
11238 /* Match the colons. */
11239 m
= gfc_match (" ::");
11240 if (m
== MATCH_ERROR
)
11242 seen_colons
= (m
== MATCH_YES
);
11243 if (seen_attrs
&& !seen_colons
)
11245 gfc_error ("Expected %<::%> after binding-attributes at %C");
11246 return MATCH_ERROR
;
11249 /* Match the binding names. */
11252 m
= gfc_match_name (name
);
11253 if (m
== MATCH_ERROR
)
11257 gfc_error ("Expected binding name at %C");
11258 return MATCH_ERROR
;
11261 if (num
>1 && !gfc_notify_std (GFC_STD_F2008
, "PROCEDURE list at %C"))
11262 return MATCH_ERROR
;
11264 /* Try to match the '=> target', if it's there. */
11266 m
= gfc_match (" =>");
11267 if (m
== MATCH_ERROR
)
11269 if (m
== MATCH_YES
)
11273 gfc_error ("%<=> target%> is invalid for DEFERRED binding at %C");
11274 return MATCH_ERROR
;
11279 gfc_error ("%<::%> needed in PROCEDURE binding with explicit target"
11281 return MATCH_ERROR
;
11284 m
= gfc_match_name (target_buf
);
11285 if (m
== MATCH_ERROR
)
11289 gfc_error ("Expected binding target after %<=>%> at %C");
11290 return MATCH_ERROR
;
11292 target
= target_buf
;
11295 /* If no target was found, it has the same name as the binding. */
11299 /* Get the namespace to insert the symbols into. */
11300 ns
= block
->f2k_derived
;
11303 /* If the binding is DEFERRED, check that the containing type is ABSTRACT. */
11304 if (tb
.deferred
&& !block
->attr
.abstract
)
11306 gfc_error ("Type %qs containing DEFERRED binding at %C "
11307 "is not ABSTRACT", block
->name
);
11308 return MATCH_ERROR
;
11311 /* See if we already have a binding with this name in the symtree which
11312 would be an error. If a GENERIC already targeted this binding, it may
11313 be already there but then typebound is still NULL. */
11314 stree
= gfc_find_symtree (ns
->tb_sym_root
, name
);
11315 if (stree
&& stree
->n
.tb
)
11317 gfc_error ("There is already a procedure with binding name %qs for "
11318 "the derived type %qs at %C", name
, block
->name
);
11319 return MATCH_ERROR
;
11322 /* Insert it and set attributes. */
11326 stree
= gfc_new_symtree (&ns
->tb_sym_root
, name
);
11327 gcc_assert (stree
);
11329 stree
->n
.tb
= gfc_get_typebound_proc (&tb
);
11331 if (gfc_get_sym_tree (target
, gfc_current_ns
, &stree
->n
.tb
->u
.specific
,
11333 return MATCH_ERROR
;
11334 gfc_set_sym_referenced (stree
->n
.tb
->u
.specific
->n
.sym
);
11335 gfc_add_flavor(&stree
->n
.tb
->u
.specific
->n
.sym
->attr
, FL_PROCEDURE
,
11336 target
, &stree
->n
.tb
->u
.specific
->n
.sym
->declared_at
);
11338 if (gfc_match_eos () == MATCH_YES
)
11340 if (gfc_match_char (',') != MATCH_YES
)
11345 gfc_error ("Syntax error in PROCEDURE statement at %C");
11346 return MATCH_ERROR
;
11350 /* Match a GENERIC procedure binding inside a derived type. */
11353 gfc_match_generic (void)
11355 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
11356 char bind_name
[GFC_MAX_SYMBOL_LEN
+ 16]; /* Allow space for OPERATOR(...). */
11358 gfc_typebound_proc tbattr
; /* Used for match_binding_attributes. */
11359 gfc_typebound_proc
* tb
;
11361 interface_type op_type
;
11362 gfc_intrinsic_op op
;
11365 /* Check current state. */
11366 if (gfc_current_state () == COMP_DERIVED
)
11368 gfc_error ("GENERIC at %C must be inside a derived-type CONTAINS");
11369 return MATCH_ERROR
;
11371 if (gfc_current_state () != COMP_DERIVED_CONTAINS
)
11373 block
= gfc_state_stack
->previous
->sym
;
11374 ns
= block
->f2k_derived
;
11375 gcc_assert (block
&& ns
);
11377 memset (&tbattr
, 0, sizeof (tbattr
));
11378 tbattr
.where
= gfc_current_locus
;
11380 /* See if we get an access-specifier. */
11381 m
= match_binding_attributes (&tbattr
, true, false);
11382 if (m
== MATCH_ERROR
)
11385 /* Now the colons, those are required. */
11386 if (gfc_match (" ::") != MATCH_YES
)
11388 gfc_error ("Expected %<::%> at %C");
11392 /* Match the binding name; depending on type (operator / generic) format
11393 it for future error messages into bind_name. */
11395 m
= gfc_match_generic_spec (&op_type
, name
, &op
);
11396 if (m
== MATCH_ERROR
)
11397 return MATCH_ERROR
;
11400 gfc_error ("Expected generic name or operator descriptor at %C");
11406 case INTERFACE_GENERIC
:
11407 case INTERFACE_DTIO
:
11408 snprintf (bind_name
, sizeof (bind_name
), "%s", name
);
11411 case INTERFACE_USER_OP
:
11412 snprintf (bind_name
, sizeof (bind_name
), "OPERATOR(.%s.)", name
);
11415 case INTERFACE_INTRINSIC_OP
:
11416 snprintf (bind_name
, sizeof (bind_name
), "OPERATOR(%s)",
11417 gfc_op2string (op
));
11420 case INTERFACE_NAMELESS
:
11421 gfc_error ("Malformed GENERIC statement at %C");
11426 gcc_unreachable ();
11429 /* Match the required =>. */
11430 if (gfc_match (" =>") != MATCH_YES
)
11432 gfc_error ("Expected %<=>%> at %C");
11436 /* Try to find existing GENERIC binding with this name / for this operator;
11437 if there is something, check that it is another GENERIC and then extend
11438 it rather than building a new node. Otherwise, create it and put it
11439 at the right position. */
11443 case INTERFACE_DTIO
:
11444 case INTERFACE_USER_OP
:
11445 case INTERFACE_GENERIC
:
11447 const bool is_op
= (op_type
== INTERFACE_USER_OP
);
11450 st
= gfc_find_symtree (is_op
? ns
->tb_uop_root
: ns
->tb_sym_root
, name
);
11451 tb
= st
? st
->n
.tb
: NULL
;
11455 case INTERFACE_INTRINSIC_OP
:
11456 tb
= ns
->tb_op
[op
];
11460 gcc_unreachable ();
11465 if (!tb
->is_generic
)
11467 gcc_assert (op_type
== INTERFACE_GENERIC
);
11468 gfc_error ("There's already a non-generic procedure with binding name"
11469 " %qs for the derived type %qs at %C",
11470 bind_name
, block
->name
);
11474 if (tb
->access
!= tbattr
.access
)
11476 gfc_error ("Binding at %C must have the same access as already"
11477 " defined binding %qs", bind_name
);
11483 tb
= gfc_get_typebound_proc (NULL
);
11484 tb
->where
= gfc_current_locus
;
11485 tb
->access
= tbattr
.access
;
11486 tb
->is_generic
= 1;
11487 tb
->u
.generic
= NULL
;
11491 case INTERFACE_DTIO
:
11492 case INTERFACE_GENERIC
:
11493 case INTERFACE_USER_OP
:
11495 const bool is_op
= (op_type
== INTERFACE_USER_OP
);
11496 gfc_symtree
* st
= gfc_get_tbp_symtree (is_op
? &ns
->tb_uop_root
:
11497 &ns
->tb_sym_root
, name
);
11504 case INTERFACE_INTRINSIC_OP
:
11505 ns
->tb_op
[op
] = tb
;
11509 gcc_unreachable ();
11513 /* Now, match all following names as specific targets. */
11516 gfc_symtree
* target_st
;
11517 gfc_tbp_generic
* target
;
11519 m
= gfc_match_name (name
);
11520 if (m
== MATCH_ERROR
)
11524 gfc_error ("Expected specific binding name at %C");
11528 target_st
= gfc_get_tbp_symtree (&ns
->tb_sym_root
, name
);
11530 /* See if this is a duplicate specification. */
11531 for (target
= tb
->u
.generic
; target
; target
= target
->next
)
11532 if (target_st
== target
->specific_st
)
11534 gfc_error ("%qs already defined as specific binding for the"
11535 " generic %qs at %C", name
, bind_name
);
11539 target
= gfc_get_tbp_generic ();
11540 target
->specific_st
= target_st
;
11541 target
->specific
= NULL
;
11542 target
->next
= tb
->u
.generic
;
11543 target
->is_operator
= ((op_type
== INTERFACE_USER_OP
)
11544 || (op_type
== INTERFACE_INTRINSIC_OP
));
11545 tb
->u
.generic
= target
;
11547 while (gfc_match (" ,") == MATCH_YES
);
11549 /* Here should be the end. */
11550 if (gfc_match_eos () != MATCH_YES
)
11552 gfc_error ("Junk after GENERIC binding at %C");
11559 return MATCH_ERROR
;
11563 /* Match a FINAL declaration inside a derived type. */
11566 gfc_match_final_decl (void)
11568 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
11571 gfc_namespace
* module_ns
;
11575 if (gfc_current_form
== FORM_FREE
)
11577 char c
= gfc_peek_ascii_char ();
11578 if (!gfc_is_whitespace (c
) && c
!= ':')
11582 if (gfc_state_stack
->state
!= COMP_DERIVED_CONTAINS
)
11584 if (gfc_current_form
== FORM_FIXED
)
11587 gfc_error ("FINAL declaration at %C must be inside a derived type "
11588 "CONTAINS section");
11589 return MATCH_ERROR
;
11592 block
= gfc_state_stack
->previous
->sym
;
11593 gcc_assert (block
);
11595 if (!gfc_state_stack
->previous
|| !gfc_state_stack
->previous
->previous
11596 || gfc_state_stack
->previous
->previous
->state
!= COMP_MODULE
)
11598 gfc_error ("Derived type declaration with FINAL at %C must be in the"
11599 " specification part of a MODULE");
11600 return MATCH_ERROR
;
11603 module_ns
= gfc_current_ns
;
11604 gcc_assert (module_ns
);
11605 gcc_assert (module_ns
->proc_name
->attr
.flavor
== FL_MODULE
);
11607 /* Match optional ::, don't care about MATCH_YES or MATCH_NO. */
11608 if (gfc_match (" ::") == MATCH_ERROR
)
11609 return MATCH_ERROR
;
11611 /* Match the sequence of procedure names. */
11618 if (first
&& gfc_match_eos () == MATCH_YES
)
11620 gfc_error ("Empty FINAL at %C");
11621 return MATCH_ERROR
;
11624 m
= gfc_match_name (name
);
11627 gfc_error ("Expected module procedure name at %C");
11628 return MATCH_ERROR
;
11630 else if (m
!= MATCH_YES
)
11631 return MATCH_ERROR
;
11633 if (gfc_match_eos () == MATCH_YES
)
11635 if (!last
&& gfc_match_char (',') != MATCH_YES
)
11637 gfc_error ("Expected %<,%> at %C");
11638 return MATCH_ERROR
;
11641 if (gfc_get_symbol (name
, module_ns
, &sym
))
11643 gfc_error ("Unknown procedure name %qs at %C", name
);
11644 return MATCH_ERROR
;
11647 /* Mark the symbol as module procedure. */
11648 if (sym
->attr
.proc
!= PROC_MODULE
11649 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
11650 return MATCH_ERROR
;
11652 /* Check if we already have this symbol in the list, this is an error. */
11653 for (f
= block
->f2k_derived
->finalizers
; f
; f
= f
->next
)
11654 if (f
->proc_sym
== sym
)
11656 gfc_error ("%qs at %C is already defined as FINAL procedure",
11658 return MATCH_ERROR
;
11661 /* Add this symbol to the list of finalizers. */
11662 gcc_assert (block
->f2k_derived
);
11664 f
= XCNEW (gfc_finalizer
);
11666 f
->proc_tree
= NULL
;
11667 f
->where
= gfc_current_locus
;
11668 f
->next
= block
->f2k_derived
->finalizers
;
11669 block
->f2k_derived
->finalizers
= f
;
11679 const ext_attr_t ext_attr_list
[] = {
11680 { "dllimport", EXT_ATTR_DLLIMPORT
, "dllimport" },
11681 { "dllexport", EXT_ATTR_DLLEXPORT
, "dllexport" },
11682 { "cdecl", EXT_ATTR_CDECL
, "cdecl" },
11683 { "stdcall", EXT_ATTR_STDCALL
, "stdcall" },
11684 { "fastcall", EXT_ATTR_FASTCALL
, "fastcall" },
11685 { "no_arg_check", EXT_ATTR_NO_ARG_CHECK
, NULL
},
11686 { "deprecated", EXT_ATTR_DEPRECATED
, NULL
},
11687 { NULL
, EXT_ATTR_LAST
, NULL
}
11690 /* Match a !GCC$ ATTRIBUTES statement of the form:
11691 !GCC$ ATTRIBUTES attribute-list :: var-name [, var-name] ...
11692 When we come here, we have already matched the !GCC$ ATTRIBUTES string.
11694 TODO: We should support all GCC attributes using the same syntax for
11695 the attribute list, i.e. the list in C
11696 __attributes(( attribute-list ))
11698 !GCC$ ATTRIBUTES attribute-list ::
11699 Cf. c-parser.c's c_parser_attributes; the data can then directly be
11702 As there is absolutely no risk of confusion, we should never return
11705 gfc_match_gcc_attributes (void)
11707 symbol_attribute attr
;
11708 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
11713 gfc_clear_attr (&attr
);
11718 if (gfc_match_name (name
) != MATCH_YES
)
11719 return MATCH_ERROR
;
11721 for (id
= 0; id
< EXT_ATTR_LAST
; id
++)
11722 if (strcmp (name
, ext_attr_list
[id
].name
) == 0)
11725 if (id
== EXT_ATTR_LAST
)
11727 gfc_error ("Unknown attribute in !GCC$ ATTRIBUTES statement at %C");
11728 return MATCH_ERROR
;
11731 if (!gfc_add_ext_attribute (&attr
, (ext_attr_id_t
)id
, &gfc_current_locus
))
11732 return MATCH_ERROR
;
11734 gfc_gobble_whitespace ();
11735 ch
= gfc_next_ascii_char ();
11738 /* This is the successful exit condition for the loop. */
11739 if (gfc_next_ascii_char () == ':')
11749 if (gfc_match_eos () == MATCH_YES
)
11754 m
= gfc_match_name (name
);
11755 if (m
!= MATCH_YES
)
11758 if (find_special (name
, &sym
, true))
11759 return MATCH_ERROR
;
11761 sym
->attr
.ext_attr
|= attr
.ext_attr
;
11763 if (gfc_match_eos () == MATCH_YES
)
11766 if (gfc_match_char (',') != MATCH_YES
)
11773 gfc_error ("Syntax error in !GCC$ ATTRIBUTES statement at %C");
11774 return MATCH_ERROR
;
11778 /* Match a !GCC$ UNROLL statement of the form:
11781 The parameter n is the number of times we are supposed to unroll.
11783 When we come here, we have already matched the !GCC$ UNROLL string. */
11785 gfc_match_gcc_unroll (void)
11789 /* FIXME: use gfc_match_small_literal_int instead, delete small_int */
11790 if (gfc_match_small_int (&value
) == MATCH_YES
)
11792 if (value
< 0 || value
> USHRT_MAX
)
11794 gfc_error ("%<GCC unroll%> directive requires a"
11795 " non-negative integral constant"
11796 " less than or equal to %u at %C",
11799 return MATCH_ERROR
;
11801 if (gfc_match_eos () == MATCH_YES
)
11803 directive_unroll
= value
== 0 ? 1 : value
;
11808 gfc_error ("Syntax error in !GCC$ UNROLL directive at %C");
11809 return MATCH_ERROR
;
11812 /* Match a !GCC$ builtin (b) attributes simd flags if('target') form:
11814 The parameter b is name of a middle-end built-in.
11815 FLAGS is optional and must be one of:
11819 IF('target') is optional and TARGET is a name of a multilib ABI.
11821 When we come here, we have already matched the !GCC$ builtin string. */
11824 gfc_match_gcc_builtin (void)
11826 char builtin
[GFC_MAX_SYMBOL_LEN
+ 1];
11827 char target
[GFC_MAX_SYMBOL_LEN
+ 1];
11829 if (gfc_match (" ( %n ) attributes simd", builtin
) != MATCH_YES
)
11830 return MATCH_ERROR
;
11832 gfc_simd_clause clause
= SIMD_NONE
;
11833 if (gfc_match (" ( notinbranch ) ") == MATCH_YES
)
11834 clause
= SIMD_NOTINBRANCH
;
11835 else if (gfc_match (" ( inbranch ) ") == MATCH_YES
)
11836 clause
= SIMD_INBRANCH
;
11838 if (gfc_match (" if ( '%n' ) ", target
) == MATCH_YES
)
11840 const char *abi
= targetm
.get_multilib_abi_name ();
11841 if (abi
== NULL
|| strcmp (abi
, target
) != 0)
11845 if (gfc_vectorized_builtins
== NULL
)
11846 gfc_vectorized_builtins
= new hash_map
<nofree_string_hash
, int> ();
11848 char *r
= XNEWVEC (char, strlen (builtin
) + 32);
11849 sprintf (r
, "__builtin_%s", builtin
);
11852 int &value
= gfc_vectorized_builtins
->get_or_insert (r
, &existed
);
11860 /* Match an !GCC$ IVDEP statement.
11861 When we come here, we have already matched the !GCC$ IVDEP string. */
11864 gfc_match_gcc_ivdep (void)
11866 if (gfc_match_eos () == MATCH_YES
)
11868 directive_ivdep
= true;
11872 gfc_error ("Syntax error in !GCC$ IVDEP directive at %C");
11873 return MATCH_ERROR
;
11876 /* Match an !GCC$ VECTOR statement.
11877 When we come here, we have already matched the !GCC$ VECTOR string. */
11880 gfc_match_gcc_vector (void)
11882 if (gfc_match_eos () == MATCH_YES
)
11884 directive_vector
= true;
11885 directive_novector
= false;
11889 gfc_error ("Syntax error in !GCC$ VECTOR directive at %C");
11890 return MATCH_ERROR
;
11893 /* Match an !GCC$ NOVECTOR statement.
11894 When we come here, we have already matched the !GCC$ NOVECTOR string. */
11897 gfc_match_gcc_novector (void)
11899 if (gfc_match_eos () == MATCH_YES
)
11901 directive_novector
= true;
11902 directive_vector
= false;
11906 gfc_error ("Syntax error in !GCC$ NOVECTOR directive at %C");
11907 return MATCH_ERROR
;