1 /* Declaration statement matcher
2 Copyright (C) 2002-2021 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 expr
->rank
= as
->rank
;
900 expr
->shape
= gfc_get_shape (expr
->rank
);
902 /* Validate sizes. We built expr ourselves, so cons_size will be
903 constant (we fail above for non-constant expressions).
904 We still need to verify that the sizes match. */
905 gcc_assert (gfc_array_size (expr
, &cons_size
));
906 cmp
= mpz_cmp (cons_size
, as_size
);
908 gfc_error ("Not enough elements in array initializer at %C");
910 gfc_error ("Too many elements in array initializer at %C");
911 mpz_clear (cons_size
);
916 /* Make sure scalar types match. */
917 else if (!gfc_compare_types (&expr
->ts
, ts
)
918 && !gfc_convert_type (expr
, ts
, 1))
922 expr
->ts
.u
.cl
->length_from_typespec
= 1;
930 gfc_error ("Syntax error in old style initializer list at %C");
934 expr
->value
.constructor
= NULL
;
935 gfc_free_expr (expr
);
936 gfc_constructor_free (array_head
);
946 /* Auxiliary function to merge DIMENSION and CODIMENSION array specs. */
949 merge_array_spec (gfc_array_spec
*from
, gfc_array_spec
*to
, bool copy
)
951 if ((from
->type
== AS_ASSUMED_RANK
&& to
->corank
)
952 || (to
->type
== AS_ASSUMED_RANK
&& from
->corank
))
954 gfc_error ("The assumed-rank array at %C shall not have a codimension");
958 if (to
->rank
== 0 && from
->rank
> 0)
960 to
->rank
= from
->rank
;
961 to
->type
= from
->type
;
962 to
->cray_pointee
= from
->cray_pointee
;
963 to
->cp_was_assumed
= from
->cp_was_assumed
;
965 for (int i
= to
->corank
- 1; i
>= 0; i
--)
967 /* Do not exceed the limits on lower[] and upper[]. gfortran
968 cleans up elsewhere. */
969 int j
= from
->rank
+ i
;
970 if (j
>= GFC_MAX_DIMENSIONS
)
973 to
->lower
[j
] = to
->lower
[i
];
974 to
->upper
[j
] = to
->upper
[i
];
976 for (int i
= 0; i
< from
->rank
; i
++)
980 to
->lower
[i
] = gfc_copy_expr (from
->lower
[i
]);
981 to
->upper
[i
] = gfc_copy_expr (from
->upper
[i
]);
985 to
->lower
[i
] = from
->lower
[i
];
986 to
->upper
[i
] = from
->upper
[i
];
990 else if (to
->corank
== 0 && from
->corank
> 0)
992 to
->corank
= from
->corank
;
993 to
->cotype
= from
->cotype
;
995 for (int i
= 0; i
< from
->corank
; i
++)
997 /* Do not exceed the limits on lower[] and upper[]. gfortran
998 cleans up elsewhere. */
999 int k
= from
->rank
+ i
;
1000 int j
= to
->rank
+ i
;
1001 if (j
>= GFC_MAX_DIMENSIONS
)
1006 to
->lower
[j
] = gfc_copy_expr (from
->lower
[k
]);
1007 to
->upper
[j
] = gfc_copy_expr (from
->upper
[k
]);
1011 to
->lower
[j
] = from
->lower
[k
];
1012 to
->upper
[j
] = from
->upper
[k
];
1017 if (to
->rank
+ to
->corank
> GFC_MAX_DIMENSIONS
)
1019 gfc_error ("Sum of array rank %d and corank %d at %C exceeds maximum "
1020 "allowed dimensions of %d",
1021 to
->rank
, to
->corank
, GFC_MAX_DIMENSIONS
);
1022 to
->corank
= GFC_MAX_DIMENSIONS
- to
->rank
;
1029 /* Match an intent specification. Since this can only happen after an
1030 INTENT word, a legal intent-spec must follow. */
1033 match_intent_spec (void)
1036 if (gfc_match (" ( in out )") == MATCH_YES
)
1037 return INTENT_INOUT
;
1038 if (gfc_match (" ( in )") == MATCH_YES
)
1040 if (gfc_match (" ( out )") == MATCH_YES
)
1043 gfc_error ("Bad INTENT specification at %C");
1044 return INTENT_UNKNOWN
;
1048 /* Matches a character length specification, which is either a
1049 specification expression, '*', or ':'. */
1052 char_len_param_value (gfc_expr
**expr
, bool *deferred
)
1059 if (gfc_match_char ('*') == MATCH_YES
)
1062 if (gfc_match_char (':') == MATCH_YES
)
1064 if (!gfc_notify_std (GFC_STD_F2003
, "deferred type parameter at %C"))
1072 m
= gfc_match_expr (expr
);
1074 if (m
== MATCH_NO
|| m
== MATCH_ERROR
)
1077 if (!gfc_expr_check_typed (*expr
, gfc_current_ns
, false))
1080 /* If gfortran gets an EXPR_OP, try to simplifiy it. This catches things
1081 like CHARACTER(([1])). */
1082 if ((*expr
)->expr_type
== EXPR_OP
)
1083 gfc_simplify_expr (*expr
, 1);
1085 if ((*expr
)->expr_type
== EXPR_FUNCTION
)
1087 if ((*expr
)->ts
.type
== BT_INTEGER
1088 || ((*expr
)->ts
.type
== BT_UNKNOWN
1089 && strcmp((*expr
)->symtree
->name
, "null") != 0))
1094 else if ((*expr
)->expr_type
== EXPR_CONSTANT
)
1096 /* F2008, 4.4.3.1: The length is a type parameter; its kind is
1097 processor dependent and its value is greater than or equal to zero.
1098 F2008, 4.4.3.2: If the character length parameter value evaluates
1099 to a negative value, the length of character entities declared
1102 if ((*expr
)->ts
.type
== BT_INTEGER
)
1104 if (mpz_cmp_si ((*expr
)->value
.integer
, 0) < 0)
1105 mpz_set_si ((*expr
)->value
.integer
, 0);
1110 else if ((*expr
)->expr_type
== EXPR_ARRAY
)
1112 else if ((*expr
)->expr_type
== EXPR_VARIABLE
)
1117 e
= gfc_copy_expr (*expr
);
1119 /* This catches the invalid code "[character(m(2:3)) :: 'x', 'y']",
1120 which causes an ICE if gfc_reduce_init_expr() is called. */
1121 if (e
->ref
&& e
->ref
->type
== REF_ARRAY
1122 && e
->ref
->u
.ar
.type
== AR_UNKNOWN
1123 && e
->ref
->u
.ar
.dimen_type
[0] == DIMEN_RANGE
)
1126 t
= gfc_reduce_init_expr (e
);
1128 if (!t
&& e
->ts
.type
== BT_UNKNOWN
1129 && e
->symtree
->n
.sym
->attr
.untyped
== 1
1130 && (flag_implicit_none
1131 || e
->symtree
->n
.sym
->ns
->seen_implicit_none
== 1
1132 || e
->symtree
->n
.sym
->ns
->parent
->seen_implicit_none
== 1))
1138 if ((e
->ref
&& e
->ref
->type
== REF_ARRAY
1139 && e
->ref
->u
.ar
.type
!= AR_ELEMENT
)
1140 || (!e
->ref
&& e
->expr_type
== EXPR_ARRAY
))
1155 gfc_error ("Scalar INTEGER expression expected at %L", &(*expr
)->where
);
1160 /* A character length is a '*' followed by a literal integer or a
1161 char_len_param_value in parenthesis. */
1164 match_char_length (gfc_expr
**expr
, bool *deferred
, bool obsolescent_check
)
1170 m
= gfc_match_char ('*');
1174 m
= gfc_match_small_literal_int (&length
, NULL
);
1175 if (m
== MATCH_ERROR
)
1180 if (obsolescent_check
1181 && !gfc_notify_std (GFC_STD_F95_OBS
, "Old-style character length at %C"))
1183 *expr
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
, length
);
1187 if (gfc_match_char ('(') == MATCH_NO
)
1190 m
= char_len_param_value (expr
, deferred
);
1191 if (m
!= MATCH_YES
&& gfc_matching_function
)
1193 gfc_undo_symbols ();
1197 if (m
== MATCH_ERROR
)
1202 if (gfc_match_char (')') == MATCH_NO
)
1204 gfc_free_expr (*expr
);
1212 gfc_error ("Syntax error in character length specification at %C");
1217 /* Special subroutine for finding a symbol. Check if the name is found
1218 in the current name space. If not, and we're compiling a function or
1219 subroutine and the parent compilation unit is an interface, then check
1220 to see if the name we've been given is the name of the interface
1221 (located in another namespace). */
1224 find_special (const char *name
, gfc_symbol
**result
, bool allow_subroutine
)
1230 i
= gfc_get_sym_tree (name
, NULL
, &st
, allow_subroutine
);
1233 *result
= st
? st
->n
.sym
: NULL
;
1237 if (gfc_current_state () != COMP_SUBROUTINE
1238 && gfc_current_state () != COMP_FUNCTION
)
1241 s
= gfc_state_stack
->previous
;
1245 if (s
->state
!= COMP_INTERFACE
)
1248 goto end
; /* Nameless interface. */
1250 if (strcmp (name
, s
->sym
->name
) == 0)
1261 /* Special subroutine for getting a symbol node associated with a
1262 procedure name, used in SUBROUTINE and FUNCTION statements. The
1263 symbol is created in the parent using with symtree node in the
1264 child unit pointing to the symbol. If the current namespace has no
1265 parent, then the symbol is just created in the current unit. */
1268 get_proc_name (const char *name
, gfc_symbol
**result
, bool module_fcn_entry
)
1274 /* Module functions have to be left in their own namespace because
1275 they have potentially (almost certainly!) already been referenced.
1276 In this sense, they are rather like external functions. This is
1277 fixed up in resolve.c(resolve_entries), where the symbol name-
1278 space is set to point to the master function, so that the fake
1279 result mechanism can work. */
1280 if (module_fcn_entry
)
1282 /* Present if entry is declared to be a module procedure. */
1283 rc
= gfc_find_symbol (name
, gfc_current_ns
->parent
, 0, result
);
1285 if (*result
== NULL
)
1286 rc
= gfc_get_symbol (name
, NULL
, result
);
1287 else if (!gfc_get_symbol (name
, NULL
, &sym
) && sym
1288 && (*result
)->ts
.type
== BT_UNKNOWN
1289 && sym
->attr
.flavor
== FL_UNKNOWN
)
1290 /* Pick up the typespec for the entry, if declared in the function
1291 body. Note that this symbol is FL_UNKNOWN because it will
1292 only have appeared in a type declaration. The local symtree
1293 is set to point to the module symbol and a unique symtree
1294 to the local version. This latter ensures a correct clearing
1297 /* If the ENTRY proceeds its specification, we need to ensure
1298 that this does not raise a "has no IMPLICIT type" error. */
1299 if (sym
->ts
.type
== BT_UNKNOWN
)
1300 sym
->attr
.untyped
= 1;
1302 (*result
)->ts
= sym
->ts
;
1304 /* Put the symbol in the procedure namespace so that, should
1305 the ENTRY precede its specification, the specification
1307 (*result
)->ns
= gfc_current_ns
;
1309 gfc_find_sym_tree (name
, gfc_current_ns
, 0, &st
);
1310 st
->n
.sym
= *result
;
1311 st
= gfc_get_unique_symtree (gfc_current_ns
);
1317 rc
= gfc_get_symbol (name
, gfc_current_ns
->parent
, result
);
1323 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
1326 if (sym
->attr
.module_procedure
&& sym
->attr
.if_source
== IFSRC_IFBODY
)
1328 /* Create a partially populated interface symbol to carry the
1329 characteristics of the procedure and the result. */
1330 sym
->tlink
= gfc_new_symbol (name
, sym
->ns
);
1331 gfc_add_type (sym
->tlink
, &(sym
->ts
), &gfc_current_locus
);
1332 gfc_copy_attr (&sym
->tlink
->attr
, &sym
->attr
, NULL
);
1333 if (sym
->attr
.dimension
)
1334 sym
->tlink
->as
= gfc_copy_array_spec (sym
->as
);
1336 /* Ideally, at this point, a copy would be made of the formal
1337 arguments and their namespace. However, this does not appear
1338 to be necessary, albeit at the expense of not being able to
1339 use gfc_compare_interfaces directly. */
1341 if (sym
->result
&& sym
->result
!= sym
)
1343 sym
->tlink
->result
= sym
->result
;
1346 else if (sym
->result
)
1348 sym
->tlink
->result
= sym
->tlink
;
1351 else if (sym
&& !sym
->gfc_new
1352 && gfc_current_state () != COMP_INTERFACE
)
1354 /* Trap another encompassed procedure with the same name. All
1355 these conditions are necessary to avoid picking up an entry
1356 whose name clashes with that of the encompassing procedure;
1357 this is handled using gsymbols to register unique, globally
1358 accessible names. */
1359 if (sym
->attr
.flavor
!= 0
1360 && sym
->attr
.proc
!= 0
1361 && (sym
->attr
.subroutine
|| sym
->attr
.function
|| sym
->attr
.entry
)
1362 && sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
1364 gfc_error_now ("Procedure %qs at %C is already defined at %L",
1365 name
, &sym
->declared_at
);
1368 if (sym
->attr
.flavor
!= 0
1369 && sym
->attr
.entry
&& sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
1371 gfc_error_now ("Procedure %qs at %C is already defined at %L",
1372 name
, &sym
->declared_at
);
1376 if (sym
->attr
.external
&& sym
->attr
.procedure
1377 && gfc_current_state () == COMP_CONTAINS
)
1379 gfc_error_now ("Contained procedure %qs at %C clashes with "
1380 "procedure defined at %L",
1381 name
, &sym
->declared_at
);
1385 /* Trap a procedure with a name the same as interface in the
1386 encompassing scope. */
1387 if (sym
->attr
.generic
!= 0
1388 && (sym
->attr
.subroutine
|| sym
->attr
.function
)
1389 && !sym
->attr
.mod_proc
)
1391 gfc_error_now ("Name %qs at %C is already defined"
1392 " as a generic interface at %L",
1393 name
, &sym
->declared_at
);
1397 /* Trap declarations of attributes in encompassing scope. The
1398 signature for this is that ts.kind is nonzero for no-CLASS
1399 entity. For a CLASS entity, ts.kind is zero. */
1400 if ((sym
->ts
.kind
!= 0 || sym
->ts
.type
== BT_CLASS
)
1401 && !sym
->attr
.implicit_type
1402 && sym
->attr
.proc
== 0
1403 && gfc_current_ns
->parent
!= NULL
1404 && sym
->attr
.access
== 0
1405 && !module_fcn_entry
)
1407 gfc_error_now ("Procedure %qs at %C has an explicit interface "
1408 "from a previous declaration", name
);
1413 /* C1246 (R1225) MODULE shall appear only in the function-stmt or
1414 subroutine-stmt of a module subprogram or of a nonabstract interface
1415 body that is declared in the scoping unit of a module or submodule. */
1416 if (sym
->attr
.external
1417 && (sym
->attr
.subroutine
|| sym
->attr
.function
)
1418 && sym
->attr
.if_source
== IFSRC_IFBODY
1419 && !current_attr
.module_procedure
1420 && sym
->attr
.proc
== PROC_MODULE
1421 && gfc_state_stack
->state
== COMP_CONTAINS
)
1423 gfc_error_now ("Procedure %qs defined in interface body at %L "
1424 "clashes with internal procedure defined at %C",
1425 name
, &sym
->declared_at
);
1429 if (sym
&& !sym
->gfc_new
1430 && sym
->attr
.flavor
!= FL_UNKNOWN
1431 && sym
->attr
.referenced
== 0 && sym
->attr
.subroutine
== 1
1432 && gfc_state_stack
->state
== COMP_CONTAINS
1433 && gfc_state_stack
->previous
->state
== COMP_SUBROUTINE
)
1435 gfc_error_now ("Procedure %qs at %C is already defined at %L",
1436 name
, &sym
->declared_at
);
1440 if (gfc_current_ns
->parent
== NULL
|| *result
== NULL
)
1443 /* Module function entries will already have a symtree in
1444 the current namespace but will need one at module level. */
1445 if (module_fcn_entry
)
1447 /* Present if entry is declared to be a module procedure. */
1448 rc
= gfc_find_sym_tree (name
, gfc_current_ns
->parent
, 0, &st
);
1450 st
= gfc_new_symtree (&gfc_current_ns
->parent
->sym_root
, name
);
1453 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, name
);
1458 /* See if the procedure should be a module procedure. */
1460 if (((sym
->ns
->proc_name
!= NULL
1461 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
1462 && sym
->attr
.proc
!= PROC_MODULE
)
1463 || (module_fcn_entry
&& sym
->attr
.proc
!= PROC_MODULE
))
1464 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
1471 /* Verify that the given symbol representing a parameter is C
1472 interoperable, by checking to see if it was marked as such after
1473 its declaration. If the given symbol is not interoperable, a
1474 warning is reported, thus removing the need to return the status to
1475 the calling function. The standard does not require the user use
1476 one of the iso_c_binding named constants to declare an
1477 interoperable parameter, but we can't be sure if the param is C
1478 interop or not if the user doesn't. For example, integer(4) may be
1479 legal Fortran, but doesn't have meaning in C. It may interop with
1480 a number of the C types, which causes a problem because the
1481 compiler can't know which one. This code is almost certainly not
1482 portable, and the user will get what they deserve if the C type
1483 across platforms isn't always interoperable with integer(4). If
1484 the user had used something like integer(c_int) or integer(c_long),
1485 the compiler could have automatically handled the varying sizes
1486 across platforms. */
1489 gfc_verify_c_interop_param (gfc_symbol
*sym
)
1491 int is_c_interop
= 0;
1494 /* We check implicitly typed variables in symbol.c:gfc_set_default_type().
1495 Don't repeat the checks here. */
1496 if (sym
->attr
.implicit_type
)
1499 /* For subroutines or functions that are passed to a BIND(C) procedure,
1500 they're interoperable if they're BIND(C) and their params are all
1502 if (sym
->attr
.flavor
== FL_PROCEDURE
)
1504 if (sym
->attr
.is_bind_c
== 0)
1506 gfc_error_now ("Procedure %qs at %L must have the BIND(C) "
1507 "attribute to be C interoperable", sym
->name
,
1508 &(sym
->declared_at
));
1513 if (sym
->attr
.is_c_interop
== 1)
1514 /* We've already checked this procedure; don't check it again. */
1517 return verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
1522 /* See if we've stored a reference to a procedure that owns sym. */
1523 if (sym
->ns
!= NULL
&& sym
->ns
->proc_name
!= NULL
)
1525 if (sym
->ns
->proc_name
->attr
.is_bind_c
== 1)
1527 is_c_interop
= (gfc_verify_c_interop(&(sym
->ts
)) ? 1 : 0);
1529 if (is_c_interop
!= 1)
1531 /* Make personalized messages to give better feedback. */
1532 if (sym
->ts
.type
== BT_DERIVED
)
1533 gfc_error ("Variable %qs at %L is a dummy argument to the "
1534 "BIND(C) procedure %qs but is not C interoperable "
1535 "because derived type %qs is not C interoperable",
1536 sym
->name
, &(sym
->declared_at
),
1537 sym
->ns
->proc_name
->name
,
1538 sym
->ts
.u
.derived
->name
);
1539 else if (sym
->ts
.type
== BT_CLASS
)
1540 gfc_error ("Variable %qs at %L is a dummy argument to the "
1541 "BIND(C) procedure %qs but is not C interoperable "
1542 "because it is polymorphic",
1543 sym
->name
, &(sym
->declared_at
),
1544 sym
->ns
->proc_name
->name
);
1545 else if (warn_c_binding_type
)
1546 gfc_warning (OPT_Wc_binding_type
,
1547 "Variable %qs at %L is a dummy argument of the "
1548 "BIND(C) procedure %qs but may not be C "
1550 sym
->name
, &(sym
->declared_at
),
1551 sym
->ns
->proc_name
->name
);
1554 /* Per F2018, 18.3.6 (5), pointer + contiguous is not permitted. */
1555 if (sym
->attr
.pointer
&& sym
->attr
.contiguous
)
1556 gfc_error ("Dummy argument %qs at %L may not be a pointer with "
1557 "CONTIGUOUS attribute as procedure %qs is BIND(C)",
1558 sym
->name
, &sym
->declared_at
, sym
->ns
->proc_name
->name
);
1560 /* Per F2018, C1557, pointer/allocatable dummies to a bind(c)
1561 procedure that are default-initialized are not permitted. */
1562 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
1563 && sym
->ts
.type
== BT_DERIVED
1564 && gfc_has_default_initializer (sym
->ts
.u
.derived
))
1566 gfc_error ("Default-initialized %s dummy argument %qs "
1567 "at %L is not permitted in BIND(C) procedure %qs",
1568 (sym
->attr
.pointer
? "pointer" : "allocatable"),
1569 sym
->name
, &sym
->declared_at
,
1570 sym
->ns
->proc_name
->name
);
1574 /* Character strings are only C interoperable if they have a
1575 length of 1. However, as an argument they are also iteroperable
1576 when passed as descriptor (which requires len=: or len=*). */
1577 if (sym
->ts
.type
== BT_CHARACTER
)
1579 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
1581 if (sym
->attr
.allocatable
|| sym
->attr
.pointer
)
1583 /* F2018, 18.3.6 (6). */
1584 if (!sym
->ts
.deferred
)
1586 if (sym
->attr
.allocatable
)
1587 gfc_error ("Allocatable character dummy argument %qs "
1588 "at %L must have deferred length as "
1589 "procedure %qs is BIND(C)", sym
->name
,
1590 &sym
->declared_at
, sym
->ns
->proc_name
->name
);
1592 gfc_error ("Pointer character dummy argument %qs at %L "
1593 "must have deferred length as procedure %qs "
1594 "is BIND(C)", sym
->name
, &sym
->declared_at
,
1595 sym
->ns
->proc_name
->name
);
1598 else if (!gfc_notify_std (GFC_STD_F2018
,
1599 "Deferred-length character dummy "
1600 "argument %qs at %L of procedure "
1601 "%qs with BIND(C) attribute",
1602 sym
->name
, &sym
->declared_at
,
1603 sym
->ns
->proc_name
->name
))
1605 else if (!sym
->attr
.dimension
)
1607 /* FIXME: Use CFI array descriptor for scalars. */
1608 gfc_error ("Sorry, deferred-length scalar character dummy "
1609 "argument %qs at %L of procedure %qs with "
1610 "BIND(C) not yet supported", sym
->name
,
1611 &sym
->declared_at
, sym
->ns
->proc_name
->name
);
1615 else if (sym
->attr
.value
1616 && (!cl
|| !cl
->length
1617 || cl
->length
->expr_type
!= EXPR_CONSTANT
1618 || mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0))
1620 gfc_error ("Character dummy argument %qs at %L must be "
1621 "of length 1 as it has the VALUE attribute",
1622 sym
->name
, &sym
->declared_at
);
1625 else if (!cl
|| !cl
->length
)
1627 /* Assumed length; F2018, 18.3.6 (5)(2).
1628 Uses the CFI array descriptor - also for scalars and
1629 explicit-size/assumed-size arrays. */
1630 if (!gfc_notify_std (GFC_STD_F2018
,
1631 "Assumed-length character dummy argument "
1632 "%qs at %L of procedure %qs with BIND(C) "
1633 "attribute", sym
->name
, &sym
->declared_at
,
1634 sym
->ns
->proc_name
->name
))
1636 else if (!sym
->attr
.dimension
1637 || sym
->as
->type
== AS_ASSUMED_SIZE
1638 || sym
->as
->type
== AS_EXPLICIT
)
1640 /* FIXME: Valid - should use the CFI array descriptor, but
1641 not yet handled for scalars and assumed-/explicit-size
1643 gfc_error ("Sorry, character dummy argument %qs at %L "
1644 "with assumed length is not yet supported for "
1645 "procedure %qs with BIND(C) attribute",
1646 sym
->name
, &sym
->declared_at
,
1647 sym
->ns
->proc_name
->name
);
1651 else if (cl
->length
->expr_type
!= EXPR_CONSTANT
1652 || mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
1654 /* F2018, 18.3.6, (5), item 4. */
1655 if (!sym
->attr
.dimension
1656 || sym
->as
->type
== AS_ASSUMED_SIZE
1657 || sym
->as
->type
== AS_EXPLICIT
)
1659 gfc_error ("Character dummy argument %qs at %L must be "
1660 "of constant length of one or assumed length, "
1661 "unless it has assumed shape or assumed rank, "
1662 "as procedure %qs has the BIND(C) attribute",
1663 sym
->name
, &sym
->declared_at
,
1664 sym
->ns
->proc_name
->name
);
1667 /* else: valid only since F2018 - and an assumed-shape/rank
1668 array; however, gfc_notify_std is already called when
1669 those array types are used. Thus, silently accept F200x. */
1673 /* We have to make sure that any param to a bind(c) routine does
1674 not have the allocatable, pointer, or optional attributes,
1675 according to J3/04-007, section 5.1. */
1676 if (sym
->attr
.allocatable
== 1
1677 && !gfc_notify_std (GFC_STD_F2018
, "Variable %qs at %L with "
1678 "ALLOCATABLE attribute in procedure %qs "
1679 "with BIND(C)", sym
->name
,
1680 &(sym
->declared_at
),
1681 sym
->ns
->proc_name
->name
))
1684 if (sym
->attr
.pointer
== 1
1685 && !gfc_notify_std (GFC_STD_F2018
, "Variable %qs at %L with "
1686 "POINTER attribute in procedure %qs "
1687 "with BIND(C)", sym
->name
,
1688 &(sym
->declared_at
),
1689 sym
->ns
->proc_name
->name
))
1692 if (sym
->attr
.optional
== 1 && sym
->attr
.value
)
1694 gfc_error ("Variable %qs at %L cannot have both the OPTIONAL "
1695 "and the VALUE attribute because procedure %qs "
1696 "is BIND(C)", sym
->name
, &(sym
->declared_at
),
1697 sym
->ns
->proc_name
->name
);
1700 else if (sym
->attr
.optional
== 1
1701 && !gfc_notify_std (GFC_STD_F2018
, "Variable %qs "
1702 "at %L with OPTIONAL attribute in "
1703 "procedure %qs which is BIND(C)",
1704 sym
->name
, &(sym
->declared_at
),
1705 sym
->ns
->proc_name
->name
))
1708 /* Make sure that if it has the dimension attribute, that it is
1709 either assumed size or explicit shape. Deferred shape is already
1710 covered by the pointer/allocatable attribute. */
1711 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SHAPE
1712 && !gfc_notify_std (GFC_STD_F2018
, "Assumed-shape array %qs "
1713 "at %L as dummy argument to the BIND(C) "
1714 "procedure %qs at %L", sym
->name
,
1715 &(sym
->declared_at
),
1716 sym
->ns
->proc_name
->name
,
1717 &(sym
->ns
->proc_name
->declared_at
)))
1727 /* Function called by variable_decl() that adds a name to the symbol table. */
1730 build_sym (const char *name
, gfc_charlen
*cl
, bool cl_deferred
,
1731 gfc_array_spec
**as
, locus
*var_locus
)
1733 symbol_attribute attr
;
1738 /* Symbols in a submodule are host associated from the parent module or
1739 submodules. Therefore, they can be overridden by declarations in the
1740 submodule scope. Deal with this by attaching the existing symbol to
1741 a new symtree and recycling the old symtree with a new symbol... */
1742 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
1743 if (st
!= NULL
&& gfc_state_stack
->state
== COMP_SUBMODULE
1744 && st
->n
.sym
!= NULL
1745 && st
->n
.sym
->attr
.host_assoc
&& st
->n
.sym
->attr
.used_in_submodule
)
1747 gfc_symtree
*s
= gfc_get_unique_symtree (gfc_current_ns
);
1748 s
->n
.sym
= st
->n
.sym
;
1749 sym
= gfc_new_symbol (name
, gfc_current_ns
);
1754 gfc_set_sym_referenced (sym
);
1756 /* ...Otherwise generate a new symtree and new symbol. */
1757 else if (gfc_get_symbol (name
, NULL
, &sym
))
1760 /* Check if the name has already been defined as a type. The
1761 first letter of the symtree will be in upper case then. Of
1762 course, this is only necessary if the upper case letter is
1763 actually different. */
1765 upper
= TOUPPER(name
[0]);
1766 if (upper
!= name
[0])
1768 char u_name
[GFC_MAX_SYMBOL_LEN
+ 1];
1771 gcc_assert (strlen(name
) <= GFC_MAX_SYMBOL_LEN
);
1772 strcpy (u_name
, name
);
1775 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, u_name
);
1777 /* STRUCTURE types can alias symbol names */
1778 if (st
!= 0 && st
->n
.sym
->attr
.flavor
!= FL_STRUCT
)
1780 gfc_error ("Symbol %qs at %C also declared as a type at %L", name
,
1781 &st
->n
.sym
->declared_at
);
1786 /* Start updating the symbol table. Add basic type attribute if present. */
1787 if (current_ts
.type
!= BT_UNKNOWN
1788 && (sym
->attr
.implicit_type
== 0
1789 || !gfc_compare_types (&sym
->ts
, ¤t_ts
))
1790 && !gfc_add_type (sym
, ¤t_ts
, var_locus
))
1793 if (sym
->ts
.type
== BT_CHARACTER
)
1796 sym
->ts
.deferred
= cl_deferred
;
1799 /* Add dimension attribute if present. */
1800 if (!gfc_set_array_spec (sym
, *as
, var_locus
))
1804 /* Add attribute to symbol. The copy is so that we can reset the
1805 dimension attribute. */
1806 attr
= current_attr
;
1808 attr
.codimension
= 0;
1810 if (!gfc_copy_attr (&sym
->attr
, &attr
, var_locus
))
1813 /* Finish any work that may need to be done for the binding label,
1814 if it's a bind(c). The bind(c) attr is found before the symbol
1815 is made, and before the symbol name (for data decls), so the
1816 current_ts is holding the binding label, or nothing if the
1817 name= attr wasn't given. Therefore, test here if we're dealing
1818 with a bind(c) and make sure the binding label is set correctly. */
1819 if (sym
->attr
.is_bind_c
== 1)
1821 if (!sym
->binding_label
)
1823 /* Set the binding label and verify that if a NAME= was specified
1824 then only one identifier was in the entity-decl-list. */
1825 if (!set_binding_label (&sym
->binding_label
, sym
->name
,
1826 num_idents_on_line
))
1831 /* See if we know we're in a common block, and if it's a bind(c)
1832 common then we need to make sure we're an interoperable type. */
1833 if (sym
->attr
.in_common
== 1)
1835 /* Test the common block object. */
1836 if (sym
->common_block
!= NULL
&& sym
->common_block
->is_bind_c
== 1
1837 && sym
->ts
.is_c_interop
!= 1)
1839 gfc_error_now ("Variable %qs in common block %qs at %C "
1840 "must be declared with a C interoperable "
1841 "kind since common block %qs is BIND(C)",
1842 sym
->name
, sym
->common_block
->name
,
1843 sym
->common_block
->name
);
1848 sym
->attr
.implied_index
= 0;
1850 /* Use the parameter expressions for a parameterized derived type. */
1851 if ((sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
1852 && sym
->ts
.u
.derived
->attr
.pdt_type
&& type_param_spec_list
)
1853 sym
->param_list
= gfc_copy_actual_arglist (type_param_spec_list
);
1855 if (sym
->ts
.type
== BT_CLASS
)
1856 return gfc_build_class_symbol (&sym
->ts
, &sym
->attr
, &sym
->as
);
1862 /* Set character constant to the given length. The constant will be padded or
1863 truncated. If we're inside an array constructor without a typespec, we
1864 additionally check that all elements have the same length; check_len -1
1865 means no checking. */
1868 gfc_set_constant_character_len (gfc_charlen_t len
, gfc_expr
*expr
,
1869 gfc_charlen_t check_len
)
1874 if (expr
->ts
.type
!= BT_CHARACTER
)
1877 if (expr
->expr_type
!= EXPR_CONSTANT
)
1879 gfc_error_now ("CHARACTER length must be a constant at %L", &expr
->where
);
1883 slen
= expr
->value
.character
.length
;
1886 s
= gfc_get_wide_string (len
+ 1);
1887 memcpy (s
, expr
->value
.character
.string
,
1888 MIN (len
, slen
) * sizeof (gfc_char_t
));
1890 gfc_wide_memset (&s
[slen
], ' ', len
- slen
);
1892 if (warn_character_truncation
&& slen
> len
)
1893 gfc_warning_now (OPT_Wcharacter_truncation
,
1894 "CHARACTER expression at %L is being truncated "
1895 "(%ld/%ld)", &expr
->where
,
1896 (long) slen
, (long) len
);
1898 /* Apply the standard by 'hand' otherwise it gets cleared for
1900 if (check_len
!= -1 && slen
!= check_len
1901 && !(gfc_option
.allow_std
& GFC_STD_GNU
))
1902 gfc_error_now ("The CHARACTER elements of the array constructor "
1903 "at %L must have the same length (%ld/%ld)",
1904 &expr
->where
, (long) slen
,
1908 free (expr
->value
.character
.string
);
1909 expr
->value
.character
.string
= s
;
1910 expr
->value
.character
.length
= len
;
1911 /* If explicit representation was given, clear it
1912 as it is no longer needed after padding. */
1913 if (expr
->representation
.length
)
1915 expr
->representation
.length
= 0;
1916 free (expr
->representation
.string
);
1917 expr
->representation
.string
= NULL
;
1923 /* Function to create and update the enumerator history
1924 using the information passed as arguments.
1925 Pointer "max_enum" is also updated, to point to
1926 enum history node containing largest initializer.
1928 SYM points to the symbol node of enumerator.
1929 INIT points to its enumerator value. */
1932 create_enum_history (gfc_symbol
*sym
, gfc_expr
*init
)
1934 enumerator_history
*new_enum_history
;
1935 gcc_assert (sym
!= NULL
&& init
!= NULL
);
1937 new_enum_history
= XCNEW (enumerator_history
);
1939 new_enum_history
->sym
= sym
;
1940 new_enum_history
->initializer
= init
;
1941 new_enum_history
->next
= NULL
;
1943 if (enum_history
== NULL
)
1945 enum_history
= new_enum_history
;
1946 max_enum
= enum_history
;
1950 new_enum_history
->next
= enum_history
;
1951 enum_history
= new_enum_history
;
1953 if (mpz_cmp (max_enum
->initializer
->value
.integer
,
1954 new_enum_history
->initializer
->value
.integer
) < 0)
1955 max_enum
= new_enum_history
;
1960 /* Function to free enum kind history. */
1963 gfc_free_enum_history (void)
1965 enumerator_history
*current
= enum_history
;
1966 enumerator_history
*next
;
1968 while (current
!= NULL
)
1970 next
= current
->next
;
1975 enum_history
= NULL
;
1979 /* Function called by variable_decl() that adds an initialization
1980 expression to a symbol. */
1983 add_init_expr_to_sym (const char *name
, gfc_expr
**initp
, locus
*var_locus
)
1985 symbol_attribute attr
;
1990 if (find_special (name
, &sym
, false))
1995 /* If this symbol is confirming an implicit parameter type,
1996 then an initialization expression is not allowed. */
1997 if (attr
.flavor
== FL_PARAMETER
&& sym
->value
!= NULL
)
2001 gfc_error ("Initializer not allowed for PARAMETER %qs at %C",
2011 /* An initializer is required for PARAMETER declarations. */
2012 if (attr
.flavor
== FL_PARAMETER
)
2014 gfc_error ("PARAMETER at %L is missing an initializer", var_locus
);
2020 /* If a variable appears in a DATA block, it cannot have an
2024 gfc_error ("Variable %qs at %C with an initializer already "
2025 "appears in a DATA statement", sym
->name
);
2029 /* Check if the assignment can happen. This has to be put off
2030 until later for derived type variables and procedure pointers. */
2031 if (!gfc_bt_struct (sym
->ts
.type
) && !gfc_bt_struct (init
->ts
.type
)
2032 && sym
->ts
.type
!= BT_CLASS
&& init
->ts
.type
!= BT_CLASS
2033 && !sym
->attr
.proc_pointer
2034 && !gfc_check_assign_symbol (sym
, NULL
, init
))
2037 if (sym
->ts
.type
== BT_CHARACTER
&& sym
->ts
.u
.cl
2038 && init
->ts
.type
== BT_CHARACTER
)
2040 /* Update symbol character length according initializer. */
2041 if (!gfc_check_assign_symbol (sym
, NULL
, init
))
2044 if (sym
->ts
.u
.cl
->length
== NULL
)
2047 /* If there are multiple CHARACTER variables declared on the
2048 same line, we don't want them to share the same length. */
2049 sym
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2051 if (sym
->attr
.flavor
== FL_PARAMETER
)
2053 if (init
->expr_type
== EXPR_CONSTANT
)
2055 clen
= init
->value
.character
.length
;
2056 sym
->ts
.u
.cl
->length
2057 = gfc_get_int_expr (gfc_charlen_int_kind
,
2060 else if (init
->expr_type
== EXPR_ARRAY
)
2062 if (init
->ts
.u
.cl
&& init
->ts
.u
.cl
->length
)
2064 const gfc_expr
*length
= init
->ts
.u
.cl
->length
;
2065 if (length
->expr_type
!= EXPR_CONSTANT
)
2067 gfc_error ("Cannot initialize parameter array "
2069 "with variable length elements",
2073 clen
= mpz_get_si (length
->value
.integer
);
2075 else if (init
->value
.constructor
)
2078 c
= gfc_constructor_first (init
->value
.constructor
);
2079 clen
= c
->expr
->value
.character
.length
;
2083 sym
->ts
.u
.cl
->length
2084 = gfc_get_int_expr (gfc_charlen_int_kind
,
2087 else if (init
->ts
.u
.cl
&& init
->ts
.u
.cl
->length
)
2088 sym
->ts
.u
.cl
->length
=
2089 gfc_copy_expr (init
->ts
.u
.cl
->length
);
2092 /* Update initializer character length according symbol. */
2093 else if (sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2095 if (!gfc_specification_expr (sym
->ts
.u
.cl
->length
))
2098 int k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
,
2100 /* resolve_charlen will complain later on if the length
2101 is too large. Just skeep the initialization in that case. */
2102 if (mpz_cmp (sym
->ts
.u
.cl
->length
->value
.integer
,
2103 gfc_integer_kinds
[k
].huge
) <= 0)
2106 = gfc_mpz_get_hwi (sym
->ts
.u
.cl
->length
->value
.integer
);
2108 if (init
->expr_type
== EXPR_CONSTANT
)
2109 gfc_set_constant_character_len (len
, init
, -1);
2110 else if (init
->expr_type
== EXPR_ARRAY
)
2114 /* Build a new charlen to prevent simplification from
2115 deleting the length before it is resolved. */
2116 init
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2117 init
->ts
.u
.cl
->length
2118 = gfc_copy_expr (sym
->ts
.u
.cl
->length
);
2120 for (c
= gfc_constructor_first (init
->value
.constructor
);
2121 c
; c
= gfc_constructor_next (c
))
2122 gfc_set_constant_character_len (len
, c
->expr
, -1);
2128 /* If sym is implied-shape, set its upper bounds from init. */
2129 if (sym
->attr
.flavor
== FL_PARAMETER
&& sym
->attr
.dimension
2130 && sym
->as
->type
== AS_IMPLIED_SHAPE
)
2134 if (init
->rank
== 0)
2136 gfc_error ("Cannot initialize implied-shape array at %L"
2137 " with scalar", &sym
->declared_at
);
2141 /* The shape may be NULL for EXPR_ARRAY, set it. */
2142 if (init
->shape
== NULL
)
2144 gcc_assert (init
->expr_type
== EXPR_ARRAY
);
2145 init
->shape
= gfc_get_shape (1);
2146 if (!gfc_array_size (init
, &init
->shape
[0]))
2147 gfc_internal_error ("gfc_array_size failed");
2150 for (dim
= 0; dim
< sym
->as
->rank
; ++dim
)
2153 gfc_expr
*e
, *lower
;
2155 lower
= sym
->as
->lower
[dim
];
2157 /* If the lower bound is an array element from another
2158 parameterized array, then it is marked with EXPR_VARIABLE and
2159 is an initialization expression. Try to reduce it. */
2160 if (lower
->expr_type
== EXPR_VARIABLE
)
2161 gfc_reduce_init_expr (lower
);
2163 if (lower
->expr_type
== EXPR_CONSTANT
)
2165 /* All dimensions must be without upper bound. */
2166 gcc_assert (!sym
->as
->upper
[dim
]);
2169 e
= gfc_get_constant_expr (BT_INTEGER
, k
, &sym
->declared_at
);
2170 mpz_add (e
->value
.integer
, lower
->value
.integer
,
2172 mpz_sub_ui (e
->value
.integer
, e
->value
.integer
, 1);
2173 sym
->as
->upper
[dim
] = e
;
2177 gfc_error ("Non-constant lower bound in implied-shape"
2178 " declaration at %L", &lower
->where
);
2183 sym
->as
->type
= AS_EXPLICIT
;
2186 /* Ensure that explicit bounds are simplified. */
2187 if (sym
->attr
.flavor
== FL_PARAMETER
&& sym
->attr
.dimension
2188 && sym
->as
->type
== AS_EXPLICIT
)
2190 for (int dim
= 0; dim
< sym
->as
->rank
; ++dim
)
2194 e
= sym
->as
->lower
[dim
];
2195 if (e
->expr_type
!= EXPR_CONSTANT
)
2196 gfc_reduce_init_expr (e
);
2198 e
= sym
->as
->upper
[dim
];
2199 if (e
->expr_type
!= EXPR_CONSTANT
)
2200 gfc_reduce_init_expr (e
);
2204 /* Need to check if the expression we initialized this
2205 to was one of the iso_c_binding named constants. If so,
2206 and we're a parameter (constant), let it be iso_c.
2208 integer(c_int), parameter :: my_int = c_int
2209 integer(my_int) :: my_int_2
2210 If we mark my_int as iso_c (since we can see it's value
2211 is equal to one of the named constants), then my_int_2
2212 will be considered C interoperable. */
2213 if (sym
->ts
.type
!= BT_CHARACTER
&& !gfc_bt_struct (sym
->ts
.type
))
2215 sym
->ts
.is_iso_c
|= init
->ts
.is_iso_c
;
2216 sym
->ts
.is_c_interop
|= init
->ts
.is_c_interop
;
2217 /* attr bits needed for module files. */
2218 sym
->attr
.is_iso_c
|= init
->ts
.is_iso_c
;
2219 sym
->attr
.is_c_interop
|= init
->ts
.is_c_interop
;
2220 if (init
->ts
.is_iso_c
)
2221 sym
->ts
.f90_type
= init
->ts
.f90_type
;
2224 /* Add initializer. Make sure we keep the ranks sane. */
2225 if (sym
->attr
.dimension
&& init
->rank
== 0)
2230 if (sym
->attr
.flavor
== FL_PARAMETER
2231 && init
->expr_type
== EXPR_CONSTANT
2232 && spec_size (sym
->as
, &size
)
2233 && mpz_cmp_si (size
, 0) > 0)
2235 array
= gfc_get_array_expr (init
->ts
.type
, init
->ts
.kind
,
2237 for (n
= 0; n
< (int)mpz_get_si (size
); n
++)
2238 gfc_constructor_append_expr (&array
->value
.constructor
,
2241 : gfc_copy_expr (init
),
2244 array
->shape
= gfc_get_shape (sym
->as
->rank
);
2245 for (n
= 0; n
< sym
->as
->rank
; n
++)
2246 spec_dimen_size (sym
->as
, n
, &array
->shape
[n
]);
2251 init
->rank
= sym
->as
->rank
;
2255 if (sym
->attr
.save
== SAVE_NONE
)
2256 sym
->attr
.save
= SAVE_IMPLICIT
;
2264 /* Function called by variable_decl() that adds a name to a structure
2268 build_struct (const char *name
, gfc_charlen
*cl
, gfc_expr
**init
,
2269 gfc_array_spec
**as
)
2274 /* F03:C438/C439. If the current symbol is of the same derived type that we're
2275 constructing, it must have the pointer attribute. */
2276 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
2277 && current_ts
.u
.derived
== gfc_current_block ()
2278 && current_attr
.pointer
== 0)
2280 if (current_attr
.allocatable
2281 && !gfc_notify_std(GFC_STD_F2008
, "Component at %C "
2282 "must have the POINTER attribute"))
2286 else if (current_attr
.allocatable
== 0)
2288 gfc_error ("Component at %C must have the POINTER attribute");
2294 if (current_ts
.type
== BT_CLASS
2295 && !(current_attr
.pointer
|| current_attr
.allocatable
))
2297 gfc_error ("Component %qs with CLASS at %C must be allocatable "
2298 "or pointer", name
);
2302 if (gfc_current_block ()->attr
.pointer
&& (*as
)->rank
!= 0)
2304 if ((*as
)->type
!= AS_DEFERRED
&& (*as
)->type
!= AS_EXPLICIT
)
2306 gfc_error ("Array component of structure at %C must have explicit "
2307 "or deferred shape");
2312 /* If we are in a nested union/map definition, gfc_add_component will not
2313 properly find repeated components because:
2314 (i) gfc_add_component does a flat search, where components of unions
2315 and maps are implicity chained so nested components may conflict.
2316 (ii) Unions and maps are not linked as components of their parent
2317 structures until after they are parsed.
2318 For (i) we use gfc_find_component which searches recursively, and for (ii)
2319 we search each block directly from the parse stack until we find the top
2322 s
= gfc_state_stack
;
2323 if (s
->state
== COMP_UNION
|| s
->state
== COMP_MAP
)
2325 while (s
->state
== COMP_UNION
|| gfc_comp_struct (s
->state
))
2327 c
= gfc_find_component (s
->sym
, name
, true, true, NULL
);
2330 gfc_error_now ("Component %qs at %C already declared at %L",
2334 /* Break after we've searched the entire chain. */
2335 if (s
->state
== COMP_DERIVED
|| s
->state
== COMP_STRUCTURE
)
2341 if (!gfc_add_component (gfc_current_block(), name
, &c
))
2345 if (c
->ts
.type
== BT_CHARACTER
)
2348 if (c
->ts
.type
!= BT_CLASS
&& c
->ts
.type
!= BT_DERIVED
2349 && (c
->ts
.kind
== 0 || c
->ts
.type
== BT_CHARACTER
)
2350 && saved_kind_expr
!= NULL
)
2351 c
->kind_expr
= gfc_copy_expr (saved_kind_expr
);
2353 c
->attr
= current_attr
;
2355 c
->initializer
= *init
;
2362 c
->attr
.codimension
= 1;
2364 c
->attr
.dimension
= 1;
2368 gfc_apply_init (&c
->ts
, &c
->attr
, c
->initializer
);
2370 /* Check array components. */
2371 if (!c
->attr
.dimension
)
2374 if (c
->attr
.pointer
)
2376 if (c
->as
->type
!= AS_DEFERRED
)
2378 gfc_error ("Pointer array component of structure at %C must have a "
2383 else if (c
->attr
.allocatable
)
2385 if (c
->as
->type
!= AS_DEFERRED
)
2387 gfc_error ("Allocatable component of structure at %C must have a "
2394 if (c
->as
->type
!= AS_EXPLICIT
)
2396 gfc_error ("Array component of structure at %C must have an "
2403 if (c
->ts
.type
== BT_CLASS
)
2404 return gfc_build_class_symbol (&c
->ts
, &c
->attr
, &c
->as
);
2406 if (c
->attr
.pdt_kind
|| c
->attr
.pdt_len
)
2409 gfc_find_symbol (c
->name
, gfc_current_block ()->f2k_derived
,
2413 gfc_error ("Type parameter %qs at %C has no corresponding entry "
2414 "in the type parameter name list at %L",
2415 c
->name
, &gfc_current_block ()->declared_at
);
2419 sym
->attr
.pdt_kind
= c
->attr
.pdt_kind
;
2420 sym
->attr
.pdt_len
= c
->attr
.pdt_len
;
2422 sym
->value
= gfc_copy_expr (c
->initializer
);
2423 sym
->attr
.flavor
= FL_VARIABLE
;
2426 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
2427 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_template
2428 && decl_type_param_list
)
2429 c
->param_list
= gfc_copy_actual_arglist (decl_type_param_list
);
2435 /* Match a 'NULL()', and possibly take care of some side effects. */
2438 gfc_match_null (gfc_expr
**result
)
2441 match m
, m2
= MATCH_NO
;
2443 if ((m
= gfc_match (" null ( )")) == MATCH_ERROR
)
2449 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2451 if ((m2
= gfc_match (" null (")) != MATCH_YES
)
2454 old_loc
= gfc_current_locus
;
2455 if ((m2
= gfc_match (" %n ) ", name
)) == MATCH_ERROR
)
2458 && ((m2
= gfc_match (" mold = %n )", name
)) == MATCH_ERROR
))
2462 gfc_current_locus
= old_loc
;
2467 /* The NULL symbol now has to be/become an intrinsic function. */
2468 if (gfc_get_symbol ("null", NULL
, &sym
))
2470 gfc_error ("NULL() initialization at %C is ambiguous");
2474 gfc_intrinsic_symbol (sym
);
2476 if (sym
->attr
.proc
!= PROC_INTRINSIC
2477 && !(sym
->attr
.use_assoc
&& sym
->attr
.intrinsic
)
2478 && (!gfc_add_procedure(&sym
->attr
, PROC_INTRINSIC
, sym
->name
, NULL
)
2479 || !gfc_add_function (&sym
->attr
, sym
->name
, NULL
)))
2482 *result
= gfc_get_null_expr (&gfc_current_locus
);
2484 /* Invalid per F2008, C512. */
2485 if (m2
== MATCH_YES
)
2487 gfc_error ("NULL() initialization at %C may not have MOLD");
2495 /* Match the initialization expr for a data pointer or procedure pointer. */
2498 match_pointer_init (gfc_expr
**init
, int procptr
)
2502 if (gfc_pure (NULL
) && !gfc_comp_struct (gfc_state_stack
->state
))
2504 gfc_error ("Initialization of pointer at %C is not allowed in "
2505 "a PURE procedure");
2508 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
2510 /* Match NULL() initialization. */
2511 m
= gfc_match_null (init
);
2515 /* Match non-NULL initialization. */
2516 gfc_matching_ptr_assignment
= !procptr
;
2517 gfc_matching_procptr_assignment
= procptr
;
2518 m
= gfc_match_rvalue (init
);
2519 gfc_matching_ptr_assignment
= 0;
2520 gfc_matching_procptr_assignment
= 0;
2521 if (m
== MATCH_ERROR
)
2523 else if (m
== MATCH_NO
)
2525 gfc_error ("Error in pointer initialization at %C");
2529 if (!procptr
&& !gfc_resolve_expr (*init
))
2532 if (!gfc_notify_std (GFC_STD_F2008
, "non-NULL pointer "
2533 "initialization at %C"))
2541 check_function_name (char *name
)
2543 /* In functions that have a RESULT variable defined, the function name always
2544 refers to function calls. Therefore, the name is not allowed to appear in
2545 specification statements. When checking this, be careful about
2546 'hidden' procedure pointer results ('ppr@'). */
2548 if (gfc_current_state () == COMP_FUNCTION
)
2550 gfc_symbol
*block
= gfc_current_block ();
2551 if (block
&& block
->result
&& block
->result
!= block
2552 && strcmp (block
->result
->name
, "ppr@") != 0
2553 && strcmp (block
->name
, name
) == 0)
2555 gfc_error ("RESULT variable %qs at %L prohibits FUNCTION name %qs at %C "
2556 "from appearing in a specification statement",
2557 block
->result
->name
, &block
->result
->declared_at
, name
);
2566 /* Match a variable name with an optional initializer. When this
2567 subroutine is called, a variable is expected to be parsed next.
2568 Depending on what is happening at the moment, updates either the
2569 symbol table or the current interface. */
2572 variable_decl (int elem
)
2574 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2575 static unsigned int fill_id
= 0;
2576 gfc_expr
*initializer
, *char_len
;
2578 gfc_array_spec
*cp_as
; /* Extra copy for Cray Pointees. */
2591 /* When we get here, we've just matched a list of attributes and
2592 maybe a type and a double colon. The next thing we expect to see
2593 is the name of the symbol. */
2595 /* If we are parsing a structure with legacy support, we allow the symbol
2596 name to be '%FILL' which gives it an anonymous (inaccessible) name. */
2598 gfc_gobble_whitespace ();
2599 c
= gfc_peek_ascii_char ();
2602 gfc_next_ascii_char (); /* Burn % character. */
2603 m
= gfc_match ("fill");
2606 if (gfc_current_state () != COMP_STRUCTURE
)
2608 if (flag_dec_structure
)
2609 gfc_error ("%qs not allowed outside STRUCTURE at %C", "%FILL");
2611 gfc_error ("%qs at %C is a DEC extension, enable with "
2612 "%<-fdec-structure%>", "%FILL");
2619 gfc_error ("%qs entity cannot have attributes at %C", "%FILL");
2624 /* %FILL components are given invalid fortran names. */
2625 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "%%FILL%u", fill_id
++);
2629 gfc_error ("Invalid character %qc in variable name at %C", c
);
2635 m
= gfc_match_name (name
);
2640 var_locus
= gfc_current_locus
;
2642 /* Now we could see the optional array spec. or character length. */
2643 m
= gfc_match_array_spec (&as
, true, true);
2644 if (m
== MATCH_ERROR
)
2648 as
= gfc_copy_array_spec (current_as
);
2650 && !merge_array_spec (current_as
, as
, true))
2656 if (flag_cray_pointer
)
2657 cp_as
= gfc_copy_array_spec (as
);
2659 /* At this point, we know for sure if the symbol is PARAMETER and can thus
2660 determine (and check) whether it can be implied-shape. If it
2661 was parsed as assumed-size, change it because PARAMETERs cannot
2664 An explicit-shape-array cannot appear under several conditions.
2665 That check is done here as well. */
2668 if (as
->type
== AS_IMPLIED_SHAPE
&& current_attr
.flavor
!= FL_PARAMETER
)
2671 gfc_error ("Non-PARAMETER symbol %qs at %L cannot be implied-shape",
2676 if (as
->type
== AS_ASSUMED_SIZE
&& as
->rank
== 1
2677 && current_attr
.flavor
== FL_PARAMETER
)
2678 as
->type
= AS_IMPLIED_SHAPE
;
2680 if (as
->type
== AS_IMPLIED_SHAPE
2681 && !gfc_notify_std (GFC_STD_F2008
, "Implied-shape array at %L",
2688 gfc_seen_div0
= false;
2690 /* F2018:C830 (R816) An explicit-shape-spec whose bounds are not
2691 constant expressions shall appear only in a subprogram, derived
2692 type definition, BLOCK construct, or interface body. */
2693 if (as
->type
== AS_EXPLICIT
2694 && gfc_current_state () != COMP_BLOCK
2695 && gfc_current_state () != COMP_DERIVED
2696 && gfc_current_state () != COMP_FUNCTION
2697 && gfc_current_state () != COMP_INTERFACE
2698 && gfc_current_state () != COMP_SUBROUTINE
)
2701 bool not_constant
= false;
2703 for (int i
= 0; i
< as
->rank
; i
++)
2705 e
= gfc_copy_expr (as
->lower
[i
]);
2706 if (!gfc_resolve_expr (e
) && gfc_seen_div0
)
2712 gfc_simplify_expr (e
, 0);
2713 if (e
&& (e
->expr_type
!= EXPR_CONSTANT
))
2715 not_constant
= true;
2720 e
= gfc_copy_expr (as
->upper
[i
]);
2721 if (!gfc_resolve_expr (e
) && gfc_seen_div0
)
2727 gfc_simplify_expr (e
, 0);
2728 if (e
&& (e
->expr_type
!= EXPR_CONSTANT
))
2730 not_constant
= true;
2736 if (not_constant
&& e
->ts
.type
!= BT_INTEGER
)
2738 gfc_error ("Explicit array shape at %C must be constant of "
2739 "INTEGER type and not %s type",
2740 gfc_basic_typename (e
->ts
.type
));
2746 gfc_error ("Explicit shaped array with nonconstant bounds at %C");
2751 if (as
->type
== AS_EXPLICIT
)
2753 for (int i
= 0; i
< as
->rank
; i
++)
2757 if (e
->expr_type
!= EXPR_CONSTANT
)
2759 n
= gfc_copy_expr (e
);
2760 if (!gfc_simplify_expr (n
, 1) && gfc_seen_div0
)
2766 if (n
->expr_type
== EXPR_CONSTANT
)
2767 gfc_replace_expr (e
, n
);
2772 if (e
->expr_type
!= EXPR_CONSTANT
)
2774 n
= gfc_copy_expr (e
);
2775 if (!gfc_simplify_expr (n
, 1) && gfc_seen_div0
)
2781 if (n
->expr_type
== EXPR_CONSTANT
)
2782 gfc_replace_expr (e
, n
);
2792 cl_deferred
= false;
2794 if (current_ts
.type
== BT_CHARACTER
)
2796 switch (match_char_length (&char_len
, &cl_deferred
, false))
2799 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2801 cl
->length
= char_len
;
2804 /* Non-constant lengths need to be copied after the first
2805 element. Also copy assumed lengths. */
2808 && (current_ts
.u
.cl
->length
== NULL
2809 || current_ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
2811 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2812 cl
->length
= gfc_copy_expr (current_ts
.u
.cl
->length
);
2815 cl
= current_ts
.u
.cl
;
2817 cl_deferred
= current_ts
.deferred
;
2826 /* The dummy arguments and result of the abreviated form of MODULE
2827 PROCEDUREs, used in SUBMODULES should not be redefined. */
2828 if (gfc_current_ns
->proc_name
2829 && gfc_current_ns
->proc_name
->abr_modproc_decl
)
2831 gfc_find_symbol (name
, gfc_current_ns
, 1, &sym
);
2832 if (sym
!= NULL
&& (sym
->attr
.dummy
|| sym
->attr
.result
))
2835 gfc_error ("%qs at %C is a redefinition of the declaration "
2836 "in the corresponding interface for MODULE "
2837 "PROCEDURE %qs", sym
->name
,
2838 gfc_current_ns
->proc_name
->name
);
2843 /* %FILL components may not have initializers. */
2844 if (startswith (name
, "%FILL") && gfc_match_eos () != MATCH_YES
)
2846 gfc_error ("%qs entity cannot have an initializer at %C", "%FILL");
2851 /* If this symbol has already shown up in a Cray Pointer declaration,
2852 and this is not a component declaration,
2853 then we want to set the type & bail out. */
2854 if (flag_cray_pointer
&& !gfc_comp_struct (gfc_current_state ()))
2856 gfc_find_symbol (name
, gfc_current_ns
, 0, &sym
);
2857 if (sym
!= NULL
&& sym
->attr
.cray_pointee
)
2860 if (!gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
2866 /* Check to see if we have an array specification. */
2869 if (sym
->as
!= NULL
)
2871 gfc_error ("Duplicate array spec for Cray pointee at %C");
2872 gfc_free_array_spec (cp_as
);
2878 if (!gfc_set_array_spec (sym
, cp_as
, &var_locus
))
2879 gfc_internal_error ("Cannot set pointee array spec.");
2881 /* Fix the array spec. */
2882 m
= gfc_mod_pointee_as (sym
->as
);
2883 if (m
== MATCH_ERROR
)
2891 gfc_free_array_spec (cp_as
);
2895 /* Procedure pointer as function result. */
2896 if (gfc_current_state () == COMP_FUNCTION
2897 && strcmp ("ppr@", gfc_current_block ()->name
) == 0
2898 && strcmp (name
, gfc_current_block ()->ns
->proc_name
->name
) == 0)
2899 strcpy (name
, "ppr@");
2901 if (gfc_current_state () == COMP_FUNCTION
2902 && strcmp (name
, gfc_current_block ()->name
) == 0
2903 && gfc_current_block ()->result
2904 && strcmp ("ppr@", gfc_current_block ()->result
->name
) == 0)
2905 strcpy (name
, "ppr@");
2907 /* OK, we've successfully matched the declaration. Now put the
2908 symbol in the current namespace, because it might be used in the
2909 optional initialization expression for this symbol, e.g. this is
2912 integer, parameter :: i = huge(i)
2914 This is only true for parameters or variables of a basic type.
2915 For components of derived types, it is not true, so we don't
2916 create a symbol for those yet. If we fail to create the symbol,
2918 if (!gfc_comp_struct (gfc_current_state ())
2919 && !build_sym (name
, cl
, cl_deferred
, &as
, &var_locus
))
2925 if (!check_function_name (name
))
2931 /* We allow old-style initializations of the form
2932 integer i /2/, j(4) /3*3, 1/
2933 (if no colon has been seen). These are different from data
2934 statements in that initializers are only allowed to apply to the
2935 variable immediately preceding, i.e.
2937 is not allowed. Therefore we have to do some work manually, that
2938 could otherwise be left to the matchers for DATA statements. */
2940 if (!colon_seen
&& gfc_match (" /") == MATCH_YES
)
2942 if (!gfc_notify_std (GFC_STD_GNU
, "Old-style "
2943 "initialization at %C"))
2946 /* Allow old style initializations for components of STRUCTUREs and MAPs
2947 but not components of derived types. */
2948 else if (gfc_current_state () == COMP_DERIVED
)
2950 gfc_error ("Invalid old style initialization for derived type "
2956 /* For structure components, read the initializer as a special
2957 expression and let the rest of this function apply the initializer
2959 else if (gfc_comp_struct (gfc_current_state ()))
2961 m
= match_clist_expr (&initializer
, ¤t_ts
, as
);
2963 gfc_error ("Syntax error in old style initialization of %s at %C",
2969 /* Otherwise we treat the old style initialization just like a
2970 DATA declaration for the current variable. */
2972 return match_old_style_init (name
);
2975 /* The double colon must be present in order to have initializers.
2976 Otherwise the statement is ambiguous with an assignment statement. */
2979 if (gfc_match (" =>") == MATCH_YES
)
2981 if (!current_attr
.pointer
)
2983 gfc_error ("Initialization at %C isn't for a pointer variable");
2988 m
= match_pointer_init (&initializer
, 0);
2992 /* The target of a pointer initialization must have the SAVE
2993 attribute. A variable in PROGRAM, MODULE, or SUBMODULE scope
2994 is implicit SAVEd. Explicitly, set the SAVE_IMPLICIT value. */
2995 if (initializer
->expr_type
== EXPR_VARIABLE
2996 && initializer
->symtree
->n
.sym
->attr
.save
== SAVE_NONE
2997 && (gfc_current_state () == COMP_PROGRAM
2998 || gfc_current_state () == COMP_MODULE
2999 || gfc_current_state () == COMP_SUBMODULE
))
3000 initializer
->symtree
->n
.sym
->attr
.save
= SAVE_IMPLICIT
;
3002 else if (gfc_match_char ('=') == MATCH_YES
)
3004 if (current_attr
.pointer
)
3006 gfc_error ("Pointer initialization at %C requires %<=>%>, "
3012 m
= gfc_match_init_expr (&initializer
);
3015 gfc_error ("Expected an initialization expression at %C");
3019 if (current_attr
.flavor
!= FL_PARAMETER
&& gfc_pure (NULL
)
3020 && !gfc_comp_struct (gfc_state_stack
->state
))
3022 gfc_error ("Initialization of variable at %C is not allowed in "
3023 "a PURE procedure");
3027 if (current_attr
.flavor
!= FL_PARAMETER
3028 && !gfc_comp_struct (gfc_state_stack
->state
))
3029 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
3036 if (initializer
!= NULL
&& current_attr
.allocatable
3037 && gfc_comp_struct (gfc_current_state ()))
3039 gfc_error ("Initialization of allocatable component at %C is not "
3045 if (gfc_current_state () == COMP_DERIVED
3046 && initializer
&& initializer
->ts
.type
== BT_HOLLERITH
)
3048 gfc_error ("Initialization of structure component with a HOLLERITH "
3049 "constant at %L is not allowed", &initializer
->where
);
3054 if (gfc_current_state () == COMP_DERIVED
3055 && gfc_current_block ()->attr
.pdt_template
)
3058 gfc_find_symbol (name
, gfc_current_block ()->f2k_derived
,
3060 if (!param
&& (current_attr
.pdt_kind
|| current_attr
.pdt_len
))
3062 gfc_error ("The component with KIND or LEN attribute at %C does not "
3063 "not appear in the type parameter list at %L",
3064 &gfc_current_block ()->declared_at
);
3068 else if (param
&& !(current_attr
.pdt_kind
|| current_attr
.pdt_len
))
3070 gfc_error ("The component at %C that appears in the type parameter "
3071 "list at %L has neither the KIND nor LEN attribute",
3072 &gfc_current_block ()->declared_at
);
3076 else if (as
&& (current_attr
.pdt_kind
|| current_attr
.pdt_len
))
3078 gfc_error ("The component at %C which is a type parameter must be "
3083 else if (param
&& initializer
)
3085 if (initializer
->ts
.type
== BT_BOZ
)
3087 gfc_error ("BOZ literal constant at %L cannot appear as an "
3088 "initializer", &initializer
->where
);
3092 param
->value
= gfc_copy_expr (initializer
);
3096 /* Before adding a possible initilizer, do a simple check for compatibility
3097 of lhs and rhs types. Assigning a REAL value to a derived type is not a
3099 if (current_ts
.type
== BT_DERIVED
&& initializer
3100 && (gfc_numeric_ts (&initializer
->ts
)
3101 || initializer
->ts
.type
== BT_LOGICAL
3102 || initializer
->ts
.type
== BT_CHARACTER
))
3104 gfc_error ("Incompatible initialization between a derived type "
3105 "entity and an entity with %qs type at %C",
3106 gfc_typename (initializer
));
3112 /* Add the initializer. Note that it is fine if initializer is
3113 NULL here, because we sometimes also need to check if a
3114 declaration *must* have an initialization expression. */
3115 if (!gfc_comp_struct (gfc_current_state ()))
3116 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
3119 if (current_ts
.type
== BT_DERIVED
3120 && !current_attr
.pointer
&& !initializer
)
3121 initializer
= gfc_default_initializer (¤t_ts
);
3122 t
= build_struct (name
, cl
, &initializer
, &as
);
3124 /* If we match a nested structure definition we expect to see the
3125 * body even if the variable declarations blow up, so we need to keep
3126 * the structure declaration around. */
3127 if (gfc_new_block
&& gfc_new_block
->attr
.flavor
== FL_STRUCT
)
3128 gfc_commit_symbol (gfc_new_block
);
3131 m
= (t
) ? MATCH_YES
: MATCH_ERROR
;
3134 /* Free stuff up and return. */
3135 gfc_seen_div0
= false;
3136 gfc_free_expr (initializer
);
3137 gfc_free_array_spec (as
);
3143 /* Match an extended-f77 "TYPESPEC*bytesize"-style kind specification.
3144 This assumes that the byte size is equal to the kind number for
3145 non-COMPLEX types, and equal to twice the kind number for COMPLEX. */
3148 gfc_match_old_kind_spec (gfc_typespec
*ts
)
3153 if (gfc_match_char ('*') != MATCH_YES
)
3156 m
= gfc_match_small_literal_int (&ts
->kind
, NULL
);
3160 original_kind
= ts
->kind
;
3162 /* Massage the kind numbers for complex types. */
3163 if (ts
->type
== BT_COMPLEX
)
3167 gfc_error ("Old-style type declaration %s*%d not supported at %C",
3168 gfc_basic_typename (ts
->type
), original_kind
);
3175 if (ts
->type
== BT_INTEGER
&& ts
->kind
== 4 && flag_integer4_kind
== 8)
3178 if (ts
->type
== BT_REAL
|| ts
->type
== BT_COMPLEX
)
3182 if (flag_real4_kind
== 8)
3184 if (flag_real4_kind
== 10)
3186 if (flag_real4_kind
== 16)
3189 else if (ts
->kind
== 8)
3191 if (flag_real8_kind
== 4)
3193 if (flag_real8_kind
== 10)
3195 if (flag_real8_kind
== 16)
3200 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
3202 gfc_error ("Old-style type declaration %s*%d not supported at %C",
3203 gfc_basic_typename (ts
->type
), original_kind
);
3207 if (!gfc_notify_std (GFC_STD_GNU
,
3208 "Nonstandard type declaration %s*%d at %C",
3209 gfc_basic_typename(ts
->type
), original_kind
))
3216 /* Match a kind specification. Since kinds are generally optional, we
3217 usually return MATCH_NO if something goes wrong. If a "kind="
3218 string is found, then we know we have an error. */
3221 gfc_match_kind_spec (gfc_typespec
*ts
, bool kind_expr_only
)
3231 saved_kind_expr
= NULL
;
3233 where
= loc
= gfc_current_locus
;
3238 if (gfc_match_char ('(') == MATCH_NO
)
3241 /* Also gobbles optional text. */
3242 if (gfc_match (" kind = ") == MATCH_YES
)
3245 loc
= gfc_current_locus
;
3249 n
= gfc_match_init_expr (&e
);
3251 if (gfc_derived_parameter_expr (e
))
3254 saved_kind_expr
= gfc_copy_expr (e
);
3255 goto close_brackets
;
3260 if (gfc_matching_function
)
3262 /* The function kind expression might include use associated or
3263 imported parameters and try again after the specification
3265 if (gfc_match_char (')') != MATCH_YES
)
3267 gfc_error ("Missing right parenthesis at %C");
3273 gfc_undo_symbols ();
3278 /* ....or else, the match is real. */
3280 gfc_error ("Expected initialization expression at %C");
3288 gfc_error ("Expected scalar initialization expression at %C");
3293 if (gfc_extract_int (e
, &ts
->kind
, 1))
3299 /* Before throwing away the expression, let's see if we had a
3300 C interoperable kind (and store the fact). */
3301 if (e
->ts
.is_c_interop
== 1)
3303 /* Mark this as C interoperable if being declared with one
3304 of the named constants from iso_c_binding. */
3305 ts
->is_c_interop
= e
->ts
.is_iso_c
;
3306 ts
->f90_type
= e
->ts
.f90_type
;
3308 ts
->interop_kind
= e
->symtree
->n
.sym
;
3314 /* Ignore errors to this point, if we've gotten here. This means
3315 we ignore the m=MATCH_ERROR from above. */
3316 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
3318 gfc_error ("Kind %d not supported for type %s at %C", ts
->kind
,
3319 gfc_basic_typename (ts
->type
));
3320 gfc_current_locus
= where
;
3324 /* Warn if, e.g., c_int is used for a REAL variable, but not
3325 if, e.g., c_double is used for COMPLEX as the standard
3326 explicitly says that the kind type parameter for complex and real
3327 variable is the same, i.e. c_float == c_float_complex. */
3328 if (ts
->f90_type
!= BT_UNKNOWN
&& ts
->f90_type
!= ts
->type
3329 && !((ts
->f90_type
== BT_REAL
&& ts
->type
== BT_COMPLEX
)
3330 || (ts
->f90_type
== BT_COMPLEX
&& ts
->type
== BT_REAL
)))
3331 gfc_warning_now (0, "C kind type parameter is for type %s but type at %L "
3332 "is %s", gfc_basic_typename (ts
->f90_type
), &where
,
3333 gfc_basic_typename (ts
->type
));
3337 gfc_gobble_whitespace ();
3338 if ((c
= gfc_next_ascii_char ()) != ')'
3339 && (ts
->type
!= BT_CHARACTER
|| c
!= ','))
3341 if (ts
->type
== BT_CHARACTER
)
3342 gfc_error ("Missing right parenthesis or comma at %C");
3344 gfc_error ("Missing right parenthesis at %C");
3348 /* All tests passed. */
3351 if(m
== MATCH_ERROR
)
3352 gfc_current_locus
= where
;
3354 if (ts
->type
== BT_INTEGER
&& ts
->kind
== 4 && flag_integer4_kind
== 8)
3357 if (ts
->type
== BT_REAL
|| ts
->type
== BT_COMPLEX
)
3361 if (flag_real4_kind
== 8)
3363 if (flag_real4_kind
== 10)
3365 if (flag_real4_kind
== 16)
3368 else if (ts
->kind
== 8)
3370 if (flag_real8_kind
== 4)
3372 if (flag_real8_kind
== 10)
3374 if (flag_real8_kind
== 16)
3379 /* Return what we know from the test(s). */
3384 gfc_current_locus
= where
;
3390 match_char_kind (int * kind
, int * is_iso_c
)
3399 where
= gfc_current_locus
;
3401 n
= gfc_match_init_expr (&e
);
3403 if (n
!= MATCH_YES
&& gfc_matching_function
)
3405 /* The expression might include use-associated or imported
3406 parameters and try again after the specification
3409 gfc_undo_symbols ();
3414 gfc_error ("Expected initialization expression at %C");
3420 gfc_error ("Expected scalar initialization expression at %C");
3425 if (gfc_derived_parameter_expr (e
))
3427 saved_kind_expr
= e
;
3432 fail
= gfc_extract_int (e
, kind
, 1);
3433 *is_iso_c
= e
->ts
.is_iso_c
;
3442 /* Ignore errors to this point, if we've gotten here. This means
3443 we ignore the m=MATCH_ERROR from above. */
3444 if (gfc_validate_kind (BT_CHARACTER
, *kind
, true) < 0)
3446 gfc_error ("Kind %d is not supported for CHARACTER at %C", *kind
);
3450 /* All tests passed. */
3453 if (m
== MATCH_ERROR
)
3454 gfc_current_locus
= where
;
3456 /* Return what we know from the test(s). */
3461 gfc_current_locus
= where
;
3466 /* Match the various kind/length specifications in a CHARACTER
3467 declaration. We don't return MATCH_NO. */
3470 gfc_match_char_spec (gfc_typespec
*ts
)
3472 int kind
, seen_length
, is_iso_c
;
3484 /* Try the old-style specification first. */
3485 old_char_selector
= 0;
3487 m
= match_char_length (&len
, &deferred
, true);
3491 old_char_selector
= 1;
3496 m
= gfc_match_char ('(');
3499 m
= MATCH_YES
; /* Character without length is a single char. */
3503 /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ). */
3504 if (gfc_match (" kind =") == MATCH_YES
)
3506 m
= match_char_kind (&kind
, &is_iso_c
);
3508 if (m
== MATCH_ERROR
)
3513 if (gfc_match (" , len =") == MATCH_NO
)
3516 m
= char_len_param_value (&len
, &deferred
);
3519 if (m
== MATCH_ERROR
)
3526 /* Try to match "LEN = <len-param>" or "LEN = <len-param>, KIND = <int>". */
3527 if (gfc_match (" len =") == MATCH_YES
)
3529 m
= char_len_param_value (&len
, &deferred
);
3532 if (m
== MATCH_ERROR
)
3536 if (gfc_match_char (')') == MATCH_YES
)
3539 if (gfc_match (" , kind =") != MATCH_YES
)
3542 if (match_char_kind (&kind
, &is_iso_c
) == MATCH_ERROR
)
3548 /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ). */
3549 m
= char_len_param_value (&len
, &deferred
);
3552 if (m
== MATCH_ERROR
)
3556 m
= gfc_match_char (')');
3560 if (gfc_match_char (',') != MATCH_YES
)
3563 gfc_match (" kind ="); /* Gobble optional text. */
3565 m
= match_char_kind (&kind
, &is_iso_c
);
3566 if (m
== MATCH_ERROR
)
3572 /* Require a right-paren at this point. */
3573 m
= gfc_match_char (')');
3578 gfc_error ("Syntax error in CHARACTER declaration at %C");
3580 gfc_free_expr (len
);
3584 /* Deal with character functions after USE and IMPORT statements. */
3585 if (gfc_matching_function
)
3587 gfc_free_expr (len
);
3588 gfc_undo_symbols ();
3594 gfc_free_expr (len
);
3598 /* Do some final massaging of the length values. */
3599 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
3601 if (seen_length
== 0)
3602 cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
, 1);
3605 /* If gfortran ends up here, then len may be reducible to a constant.
3606 Try to do that here. If it does not reduce, simply assign len to
3607 charlen. A complication occurs with user-defined generic functions,
3608 which are not resolved. Use a private namespace to deal with
3609 generic functions. */
3611 if (len
&& len
->expr_type
!= EXPR_CONSTANT
)
3613 gfc_namespace
*old_ns
;
3616 old_ns
= gfc_current_ns
;
3617 gfc_current_ns
= gfc_get_namespace (NULL
, 0);
3619 e
= gfc_copy_expr (len
);
3620 gfc_reduce_init_expr (e
);
3621 if (e
->expr_type
== EXPR_CONSTANT
)
3623 gfc_replace_expr (len
, e
);
3624 if (mpz_cmp_si (len
->value
.integer
, 0) < 0)
3625 mpz_set_ui (len
->value
.integer
, 0);
3630 gfc_free_namespace (gfc_current_ns
);
3631 gfc_current_ns
= old_ns
;
3638 ts
->kind
= kind
== 0 ? gfc_default_character_kind
: kind
;
3639 ts
->deferred
= deferred
;
3641 /* We have to know if it was a C interoperable kind so we can
3642 do accurate type checking of bind(c) procs, etc. */
3644 /* Mark this as C interoperable if being declared with one
3645 of the named constants from iso_c_binding. */
3646 ts
->is_c_interop
= is_iso_c
;
3647 else if (len
!= NULL
)
3648 /* Here, we might have parsed something such as: character(c_char)
3649 In this case, the parsing code above grabs the c_char when
3650 looking for the length (line 1690, roughly). it's the last
3651 testcase for parsing the kind params of a character variable.
3652 However, it's not actually the length. this seems like it
3654 To see if the user used a C interop kind, test the expr
3655 of the so called length, and see if it's C interoperable. */
3656 ts
->is_c_interop
= len
->ts
.is_iso_c
;
3662 /* Matches a RECORD declaration. */
3665 match_record_decl (char *name
)
3668 old_loc
= gfc_current_locus
;
3671 m
= gfc_match (" record /");
3674 if (!flag_dec_structure
)
3676 gfc_current_locus
= old_loc
;
3677 gfc_error ("RECORD at %C is an extension, enable it with "
3678 "%<-fdec-structure%>");
3681 m
= gfc_match (" %n/", name
);
3686 gfc_current_locus
= old_loc
;
3687 if (flag_dec_structure
3688 && (gfc_match (" record% ") == MATCH_YES
3689 || gfc_match (" record%t") == MATCH_YES
))
3690 gfc_error ("Structure name expected after RECORD at %C");
3698 /* This function uses the gfc_actual_arglist 'type_param_spec_list' as a source
3699 of expressions to substitute into the possibly parameterized expression
3700 'e'. Using a list is inefficient but should not be too bad since the
3701 number of type parameters is not likely to be large. */
3703 insert_parameter_exprs (gfc_expr
* e
, gfc_symbol
* sym ATTRIBUTE_UNUSED
,
3706 gfc_actual_arglist
*param
;
3709 if (e
->expr_type
!= EXPR_VARIABLE
)
3712 gcc_assert (e
->symtree
);
3713 if (e
->symtree
->n
.sym
->attr
.pdt_kind
3714 || (*f
!= 0 && e
->symtree
->n
.sym
->attr
.pdt_len
))
3716 for (param
= type_param_spec_list
; param
; param
= param
->next
)
3717 if (strcmp (e
->symtree
->n
.sym
->name
, param
->name
) == 0)
3722 copy
= gfc_copy_expr (param
->expr
);
3733 gfc_insert_kind_parameter_exprs (gfc_expr
*e
)
3735 return gfc_traverse_expr (e
, NULL
, &insert_parameter_exprs
, 0);
3740 gfc_insert_parameter_exprs (gfc_expr
*e
, gfc_actual_arglist
*param_list
)
3742 gfc_actual_arglist
*old_param_spec_list
= type_param_spec_list
;
3743 type_param_spec_list
= param_list
;
3744 return gfc_traverse_expr (e
, NULL
, &insert_parameter_exprs
, 1);
3745 type_param_spec_list
= NULL
;
3746 type_param_spec_list
= old_param_spec_list
;
3749 /* Determines the instance of a parameterized derived type to be used by
3750 matching determining the values of the kind parameters and using them
3751 in the name of the instance. If the instance exists, it is used, otherwise
3752 a new derived type is created. */
3754 gfc_get_pdt_instance (gfc_actual_arglist
*param_list
, gfc_symbol
**sym
,
3755 gfc_actual_arglist
**ext_param_list
)
3757 /* The PDT template symbol. */
3758 gfc_symbol
*pdt
= *sym
;
3759 /* The symbol for the parameter in the template f2k_namespace. */
3761 /* The hoped for instance of the PDT. */
3762 gfc_symbol
*instance
;
3763 /* The list of parameters appearing in the PDT declaration. */
3764 gfc_formal_arglist
*type_param_name_list
;
3765 /* Used to store the parameter specification list during recursive calls. */
3766 gfc_actual_arglist
*old_param_spec_list
;
3767 /* Pointers to the parameter specification being used. */
3768 gfc_actual_arglist
*actual_param
;
3769 gfc_actual_arglist
*tail
= NULL
;
3770 /* Used to build up the name of the PDT instance. The prefix uses 4
3771 characters and each KIND parameter 2 more. Allow 8 of the latter. */
3772 char name
[GFC_MAX_SYMBOL_LEN
+ 21];
3774 bool name_seen
= (param_list
== NULL
);
3775 bool assumed_seen
= false;
3776 bool deferred_seen
= false;
3777 bool spec_error
= false;
3779 gfc_expr
*kind_expr
;
3780 gfc_component
*c1
, *c2
;
3783 type_param_spec_list
= NULL
;
3785 type_param_name_list
= pdt
->formal
;
3786 actual_param
= param_list
;
3787 sprintf (name
, "Pdt%s", pdt
->name
);
3789 /* Run through the parameter name list and pick up the actual
3790 parameter values or use the default values in the PDT declaration. */
3791 for (; type_param_name_list
;
3792 type_param_name_list
= type_param_name_list
->next
)
3794 if (actual_param
&& actual_param
->spec_type
!= SPEC_EXPLICIT
)
3796 if (actual_param
->spec_type
== SPEC_ASSUMED
)
3797 spec_error
= deferred_seen
;
3799 spec_error
= assumed_seen
;
3803 gfc_error ("The type parameter spec list at %C cannot contain "
3804 "both ASSUMED and DEFERRED parameters");
3809 if (actual_param
&& actual_param
->name
)
3811 param
= type_param_name_list
->sym
;
3813 if (!param
|| !param
->name
)
3816 c1
= gfc_find_component (pdt
, param
->name
, false, true, NULL
);
3817 /* An error should already have been thrown in resolve.c
3818 (resolve_fl_derived0). */
3819 if (!pdt
->attr
.use_assoc
&& !c1
)
3825 if (!actual_param
&& !(c1
&& c1
->initializer
))
3827 gfc_error ("The type parameter spec list at %C does not contain "
3828 "enough parameter expressions");
3831 else if (!actual_param
&& c1
&& c1
->initializer
)
3832 kind_expr
= gfc_copy_expr (c1
->initializer
);
3833 else if (actual_param
&& actual_param
->spec_type
== SPEC_EXPLICIT
)
3834 kind_expr
= gfc_copy_expr (actual_param
->expr
);
3838 actual_param
= param_list
;
3839 for (;actual_param
; actual_param
= actual_param
->next
)
3840 if (actual_param
->name
3841 && strcmp (actual_param
->name
, param
->name
) == 0)
3843 if (actual_param
&& actual_param
->spec_type
== SPEC_EXPLICIT
)
3844 kind_expr
= gfc_copy_expr (actual_param
->expr
);
3847 if (c1
->initializer
)
3848 kind_expr
= gfc_copy_expr (c1
->initializer
);
3849 else if (!(actual_param
&& param
->attr
.pdt_len
))
3851 gfc_error ("The derived parameter %qs at %C does not "
3852 "have a default value", param
->name
);
3858 /* Store the current parameter expressions in a temporary actual
3859 arglist 'list' so that they can be substituted in the corresponding
3860 expressions in the PDT instance. */
3861 if (type_param_spec_list
== NULL
)
3863 type_param_spec_list
= gfc_get_actual_arglist ();
3864 tail
= type_param_spec_list
;
3868 tail
->next
= gfc_get_actual_arglist ();
3871 tail
->name
= param
->name
;
3875 /* Try simplification even for LEN expressions. */
3877 gfc_resolve_expr (kind_expr
);
3878 ok
= gfc_simplify_expr (kind_expr
, 1);
3879 /* Variable expressions seem to default to BT_PROCEDURE.
3880 TODO find out why this is and fix it. */
3881 if (kind_expr
->ts
.type
!= BT_INTEGER
3882 && kind_expr
->ts
.type
!= BT_PROCEDURE
)
3884 gfc_error ("The parameter expression at %C must be of "
3885 "INTEGER type and not %s type",
3886 gfc_basic_typename (kind_expr
->ts
.type
));
3889 if (kind_expr
->ts
.type
== BT_INTEGER
&& !ok
)
3891 gfc_error ("The parameter expression at %C does not "
3892 "simplify to an INTEGER constant");
3896 tail
->expr
= gfc_copy_expr (kind_expr
);
3900 tail
->spec_type
= actual_param
->spec_type
;
3902 if (!param
->attr
.pdt_kind
)
3904 if (!name_seen
&& actual_param
)
3905 actual_param
= actual_param
->next
;
3908 gfc_free_expr (kind_expr
);
3915 && (actual_param
->spec_type
== SPEC_ASSUMED
3916 || actual_param
->spec_type
== SPEC_DEFERRED
))
3918 gfc_error ("The KIND parameter %qs at %C cannot either be "
3919 "ASSUMED or DEFERRED", param
->name
);
3923 if (!kind_expr
|| !gfc_is_constant_expr (kind_expr
))
3925 gfc_error ("The value for the KIND parameter %qs at %C does not "
3926 "reduce to a constant expression", param
->name
);
3930 gfc_extract_int (kind_expr
, &kind_value
);
3931 sprintf (name
+ strlen (name
), "_%d", kind_value
);
3933 if (!name_seen
&& actual_param
)
3934 actual_param
= actual_param
->next
;
3935 gfc_free_expr (kind_expr
);
3938 if (!name_seen
&& actual_param
)
3940 gfc_error ("The type parameter spec list at %C contains too many "
3941 "parameter expressions");
3945 /* Now we search for the PDT instance 'name'. If it doesn't exist, we
3946 build it, using 'pdt' as a template. */
3947 if (gfc_get_symbol (name
, pdt
->ns
, &instance
))
3949 gfc_error ("Parameterized derived type at %C is ambiguous");
3955 if (instance
->attr
.flavor
== FL_DERIVED
3956 && instance
->attr
.pdt_type
)
3960 *ext_param_list
= type_param_spec_list
;
3962 gfc_commit_symbols ();
3966 /* Start building the new instance of the parameterized type. */
3967 gfc_copy_attr (&instance
->attr
, &pdt
->attr
, &pdt
->declared_at
);
3968 instance
->attr
.pdt_template
= 0;
3969 instance
->attr
.pdt_type
= 1;
3970 instance
->declared_at
= gfc_current_locus
;
3972 /* Add the components, replacing the parameters in all expressions
3973 with the expressions for their values in 'type_param_spec_list'. */
3974 c1
= pdt
->components
;
3975 tail
= type_param_spec_list
;
3976 for (; c1
; c1
= c1
->next
)
3978 gfc_add_component (instance
, c1
->name
, &c2
);
3981 c2
->attr
= c1
->attr
;
3983 /* The order of declaration of the type_specs might not be the
3984 same as that of the components. */
3985 if (c1
->attr
.pdt_kind
|| c1
->attr
.pdt_len
)
3987 for (tail
= type_param_spec_list
; tail
; tail
= tail
->next
)
3988 if (strcmp (c1
->name
, tail
->name
) == 0)
3992 /* Deal with type extension by recursively calling this function
3993 to obtain the instance of the extended type. */
3994 if (gfc_current_state () != COMP_DERIVED
3995 && c1
== pdt
->components
3996 && (c1
->ts
.type
== BT_DERIVED
|| c1
->ts
.type
== BT_CLASS
)
3997 && c1
->ts
.u
.derived
&& c1
->ts
.u
.derived
->attr
.pdt_template
3998 && gfc_get_derived_super_type (*sym
) == c2
->ts
.u
.derived
)
4000 gfc_formal_arglist
*f
;
4002 old_param_spec_list
= type_param_spec_list
;
4004 /* Obtain a spec list appropriate to the extended type..*/
4005 actual_param
= gfc_copy_actual_arglist (type_param_spec_list
);
4006 type_param_spec_list
= actual_param
;
4007 for (f
= c1
->ts
.u
.derived
->formal
; f
&& f
->next
; f
= f
->next
)
4008 actual_param
= actual_param
->next
;
4011 gfc_free_actual_arglist (actual_param
->next
);
4012 actual_param
->next
= NULL
;
4015 /* Now obtain the PDT instance for the extended type. */
4016 c2
->param_list
= type_param_spec_list
;
4017 m
= gfc_get_pdt_instance (type_param_spec_list
, &c2
->ts
.u
.derived
,
4019 type_param_spec_list
= old_param_spec_list
;
4021 c2
->ts
.u
.derived
->refs
++;
4022 gfc_set_sym_referenced (c2
->ts
.u
.derived
);
4024 /* Set extension level. */
4025 if (c2
->ts
.u
.derived
->attr
.extension
== 255)
4027 /* Since the extension field is 8 bit wide, we can only have
4028 up to 255 extension levels. */
4029 gfc_error ("Maximum extension level reached with type %qs at %L",
4030 c2
->ts
.u
.derived
->name
,
4031 &c2
->ts
.u
.derived
->declared_at
);
4034 instance
->attr
.extension
= c2
->ts
.u
.derived
->attr
.extension
+ 1;
4039 /* Set the component kind using the parameterized expression. */
4040 if ((c1
->ts
.kind
== 0 || c1
->ts
.type
== BT_CHARACTER
)
4041 && c1
->kind_expr
!= NULL
)
4043 gfc_expr
*e
= gfc_copy_expr (c1
->kind_expr
);
4044 gfc_insert_kind_parameter_exprs (e
);
4045 gfc_simplify_expr (e
, 1);
4046 gfc_extract_int (e
, &c2
->ts
.kind
);
4048 if (gfc_validate_kind (c2
->ts
.type
, c2
->ts
.kind
, true) < 0)
4050 gfc_error ("Kind %d not supported for type %s at %C",
4051 c2
->ts
.kind
, gfc_basic_typename (c2
->ts
.type
));
4056 /* Similarly, set the string length if parameterized. */
4057 if (c1
->ts
.type
== BT_CHARACTER
4058 && c1
->ts
.u
.cl
->length
4059 && gfc_derived_parameter_expr (c1
->ts
.u
.cl
->length
))
4062 e
= gfc_copy_expr (c1
->ts
.u
.cl
->length
);
4063 gfc_insert_kind_parameter_exprs (e
);
4064 gfc_simplify_expr (e
, 1);
4065 c2
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4066 c2
->ts
.u
.cl
->length
= e
;
4067 c2
->attr
.pdt_string
= 1;
4070 /* Set up either the KIND/LEN initializer, if constant,
4071 or the parameterized expression. Use the template
4072 initializer if one is not already set in this instance. */
4073 if (c2
->attr
.pdt_kind
|| c2
->attr
.pdt_len
)
4075 if (tail
&& tail
->expr
&& gfc_is_constant_expr (tail
->expr
))
4076 c2
->initializer
= gfc_copy_expr (tail
->expr
);
4077 else if (tail
&& tail
->expr
)
4079 c2
->param_list
= gfc_get_actual_arglist ();
4080 c2
->param_list
->name
= tail
->name
;
4081 c2
->param_list
->expr
= gfc_copy_expr (tail
->expr
);
4082 c2
->param_list
->next
= NULL
;
4085 if (!c2
->initializer
&& c1
->initializer
)
4086 c2
->initializer
= gfc_copy_expr (c1
->initializer
);
4089 /* Copy the array spec. */
4090 c2
->as
= gfc_copy_array_spec (c1
->as
);
4091 if (c1
->ts
.type
== BT_CLASS
)
4092 CLASS_DATA (c2
)->as
= gfc_copy_array_spec (CLASS_DATA (c1
)->as
);
4094 /* Determine if an array spec is parameterized. If so, substitute
4095 in the parameter expressions for the bounds and set the pdt_array
4096 attribute. Notice that this attribute must be unconditionally set
4097 if this is an array of parameterized character length. */
4098 if (c1
->as
&& c1
->as
->type
== AS_EXPLICIT
)
4100 bool pdt_array
= false;
4102 /* Are the bounds of the array parameterized? */
4103 for (i
= 0; i
< c1
->as
->rank
; i
++)
4105 if (gfc_derived_parameter_expr (c1
->as
->lower
[i
]))
4107 if (gfc_derived_parameter_expr (c1
->as
->upper
[i
]))
4111 /* If they are, free the expressions for the bounds and
4112 replace them with the template expressions with substitute
4114 for (i
= 0; pdt_array
&& i
< c1
->as
->rank
; i
++)
4117 e
= gfc_copy_expr (c1
->as
->lower
[i
]);
4118 gfc_insert_kind_parameter_exprs (e
);
4119 gfc_simplify_expr (e
, 1);
4120 gfc_free_expr (c2
->as
->lower
[i
]);
4121 c2
->as
->lower
[i
] = e
;
4122 e
= gfc_copy_expr (c1
->as
->upper
[i
]);
4123 gfc_insert_kind_parameter_exprs (e
);
4124 gfc_simplify_expr (e
, 1);
4125 gfc_free_expr (c2
->as
->upper
[i
]);
4126 c2
->as
->upper
[i
] = e
;
4128 c2
->attr
.pdt_array
= pdt_array
? 1 : c2
->attr
.pdt_string
;
4129 if (c1
->initializer
)
4131 c2
->initializer
= gfc_copy_expr (c1
->initializer
);
4132 gfc_insert_kind_parameter_exprs (c2
->initializer
);
4133 gfc_simplify_expr (c2
->initializer
, 1);
4137 /* Recurse into this function for PDT components. */
4138 if ((c1
->ts
.type
== BT_DERIVED
|| c1
->ts
.type
== BT_CLASS
)
4139 && c1
->ts
.u
.derived
&& c1
->ts
.u
.derived
->attr
.pdt_template
)
4141 gfc_actual_arglist
*params
;
4142 /* The component in the template has a list of specification
4143 expressions derived from its declaration. */
4144 params
= gfc_copy_actual_arglist (c1
->param_list
);
4145 actual_param
= params
;
4146 /* Substitute the template parameters with the expressions
4147 from the specification list. */
4148 for (;actual_param
; actual_param
= actual_param
->next
)
4149 gfc_insert_parameter_exprs (actual_param
->expr
,
4150 type_param_spec_list
);
4152 /* Now obtain the PDT instance for the component. */
4153 old_param_spec_list
= type_param_spec_list
;
4154 m
= gfc_get_pdt_instance (params
, &c2
->ts
.u
.derived
, NULL
);
4155 type_param_spec_list
= old_param_spec_list
;
4157 c2
->param_list
= params
;
4158 if (!(c2
->attr
.pointer
|| c2
->attr
.allocatable
))
4159 c2
->initializer
= gfc_default_initializer (&c2
->ts
);
4161 if (c2
->attr
.allocatable
)
4162 instance
->attr
.alloc_comp
= 1;
4166 gfc_commit_symbol (instance
);
4168 *ext_param_list
= type_param_spec_list
;
4173 gfc_free_actual_arglist (type_param_spec_list
);
4178 /* Match a legacy nonstandard BYTE type-spec. */
4181 match_byte_typespec (gfc_typespec
*ts
)
4183 if (gfc_match (" byte") == MATCH_YES
)
4185 if (!gfc_notify_std (GFC_STD_GNU
, "BYTE type at %C"))
4188 if (gfc_current_form
== FORM_FREE
)
4190 char c
= gfc_peek_ascii_char ();
4191 if (!gfc_is_whitespace (c
) && c
!= ',')
4195 if (gfc_validate_kind (BT_INTEGER
, 1, true) < 0)
4197 gfc_error ("BYTE type used at %C "
4198 "is not available on the target machine");
4202 ts
->type
= BT_INTEGER
;
4210 /* Matches a declaration-type-spec (F03:R502). If successful, sets the ts
4211 structure to the matched specification. This is necessary for FUNCTION and
4212 IMPLICIT statements.
4214 If implicit_flag is nonzero, then we don't check for the optional
4215 kind specification. Not doing so is needed for matching an IMPLICIT
4216 statement correctly. */
4219 gfc_match_decl_type_spec (gfc_typespec
*ts
, int implicit_flag
)
4221 /* Provide sufficient space to hold "pdtsymbol". */
4222 char *name
= XALLOCAVEC (char, GFC_MAX_SYMBOL_LEN
+ 1);
4223 gfc_symbol
*sym
, *dt_sym
;
4226 bool seen_deferred_kind
, matched_type
;
4227 const char *dt_name
;
4229 decl_type_param_list
= NULL
;
4231 /* A belt and braces check that the typespec is correctly being treated
4232 as a deferred characteristic association. */
4233 seen_deferred_kind
= (gfc_current_state () == COMP_FUNCTION
)
4234 && (gfc_current_block ()->result
->ts
.kind
== -1)
4235 && (ts
->kind
== -1);
4237 if (seen_deferred_kind
)
4240 /* Clear the current binding label, in case one is given. */
4241 curr_binding_label
= NULL
;
4243 /* Match BYTE type-spec. */
4244 m
= match_byte_typespec (ts
);
4248 m
= gfc_match (" type (");
4249 matched_type
= (m
== MATCH_YES
);
4252 gfc_gobble_whitespace ();
4253 if (gfc_peek_ascii_char () == '*')
4255 if ((m
= gfc_match ("* ) ")) != MATCH_YES
)
4257 if (gfc_comp_struct (gfc_current_state ()))
4259 gfc_error ("Assumed type at %C is not allowed for components");
4262 if (!gfc_notify_std (GFC_STD_F2018
, "Assumed type at %C"))
4264 ts
->type
= BT_ASSUMED
;
4268 m
= gfc_match ("%n", name
);
4269 matched_type
= (m
== MATCH_YES
);
4272 if ((matched_type
&& strcmp ("integer", name
) == 0)
4273 || (!matched_type
&& gfc_match (" integer") == MATCH_YES
))
4275 ts
->type
= BT_INTEGER
;
4276 ts
->kind
= gfc_default_integer_kind
;
4280 if ((matched_type
&& strcmp ("character", name
) == 0)
4281 || (!matched_type
&& gfc_match (" character") == MATCH_YES
))
4284 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
4285 "intrinsic-type-spec at %C"))
4288 ts
->type
= BT_CHARACTER
;
4289 if (implicit_flag
== 0)
4290 m
= gfc_match_char_spec (ts
);
4294 if (matched_type
&& m
== MATCH_YES
&& gfc_match_char (')') != MATCH_YES
)
4296 gfc_error ("Malformed type-spec at %C");
4303 if ((matched_type
&& strcmp ("real", name
) == 0)
4304 || (!matched_type
&& gfc_match (" real") == MATCH_YES
))
4307 ts
->kind
= gfc_default_real_kind
;
4312 && (strcmp ("doubleprecision", name
) == 0
4313 || (strcmp ("double", name
) == 0
4314 && gfc_match (" precision") == MATCH_YES
)))
4315 || (!matched_type
&& gfc_match (" double precision") == MATCH_YES
))
4318 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
4319 "intrinsic-type-spec at %C"))
4322 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
4324 gfc_error ("Malformed type-spec at %C");
4329 ts
->kind
= gfc_default_double_kind
;
4333 if ((matched_type
&& strcmp ("complex", name
) == 0)
4334 || (!matched_type
&& gfc_match (" complex") == MATCH_YES
))
4336 ts
->type
= BT_COMPLEX
;
4337 ts
->kind
= gfc_default_complex_kind
;
4342 && (strcmp ("doublecomplex", name
) == 0
4343 || (strcmp ("double", name
) == 0
4344 && gfc_match (" complex") == MATCH_YES
)))
4345 || (!matched_type
&& gfc_match (" double complex") == MATCH_YES
))
4347 if (!gfc_notify_std (GFC_STD_GNU
, "DOUBLE COMPLEX at %C"))
4351 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
4352 "intrinsic-type-spec at %C"))
4355 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
4357 gfc_error ("Malformed type-spec at %C");
4361 ts
->type
= BT_COMPLEX
;
4362 ts
->kind
= gfc_default_double_kind
;
4366 if ((matched_type
&& strcmp ("logical", name
) == 0)
4367 || (!matched_type
&& gfc_match (" logical") == MATCH_YES
))
4369 ts
->type
= BT_LOGICAL
;
4370 ts
->kind
= gfc_default_logical_kind
;
4376 m
= gfc_match_actual_arglist (1, &decl_type_param_list
, true);
4377 if (m
== MATCH_ERROR
)
4380 gfc_gobble_whitespace ();
4381 if (gfc_peek_ascii_char () != ')')
4383 gfc_error ("Malformed type-spec at %C");
4386 m
= gfc_match_char (')'); /* Burn closing ')'. */
4390 m
= match_record_decl (name
);
4392 if (matched_type
|| m
== MATCH_YES
)
4394 ts
->type
= BT_DERIVED
;
4395 /* We accept record/s/ or type(s) where s is a structure, but we
4396 * don't need all the extra derived-type stuff for structures. */
4397 if (gfc_find_symbol (gfc_dt_upper_string (name
), NULL
, 1, &sym
))
4399 gfc_error ("Type name %qs at %C is ambiguous", name
);
4403 if (sym
&& sym
->attr
.flavor
== FL_DERIVED
4404 && sym
->attr
.pdt_template
4405 && gfc_current_state () != COMP_DERIVED
)
4407 m
= gfc_get_pdt_instance (decl_type_param_list
, &sym
, NULL
);
4410 gcc_assert (!sym
->attr
.pdt_template
&& sym
->attr
.pdt_type
);
4411 ts
->u
.derived
= sym
;
4412 const char* lower
= gfc_dt_lower_string (sym
->name
);
4413 size_t len
= strlen (lower
);
4414 /* Reallocate with sufficient size. */
4415 if (len
> GFC_MAX_SYMBOL_LEN
)
4416 name
= XALLOCAVEC (char, len
+ 1);
4417 memcpy (name
, lower
, len
);
4421 if (sym
&& sym
->attr
.flavor
== FL_STRUCT
)
4423 ts
->u
.derived
= sym
;
4426 /* Actually a derived type. */
4431 /* Match nested STRUCTURE declarations; only valid within another
4432 structure declaration. */
4433 if (flag_dec_structure
4434 && (gfc_current_state () == COMP_STRUCTURE
4435 || gfc_current_state () == COMP_MAP
))
4437 m
= gfc_match (" structure");
4440 m
= gfc_match_structure_decl ();
4443 /* gfc_new_block is updated by match_structure_decl. */
4444 ts
->type
= BT_DERIVED
;
4445 ts
->u
.derived
= gfc_new_block
;
4449 if (m
== MATCH_ERROR
)
4453 /* Match CLASS declarations. */
4454 m
= gfc_match (" class ( * )");
4455 if (m
== MATCH_ERROR
)
4457 else if (m
== MATCH_YES
)
4461 ts
->type
= BT_CLASS
;
4462 gfc_find_symbol ("STAR", gfc_current_ns
, 1, &upe
);
4465 upe
= gfc_new_symbol ("STAR", gfc_current_ns
);
4466 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "STAR");
4468 gfc_set_sym_referenced (upe
);
4470 upe
->ts
.type
= BT_VOID
;
4471 upe
->attr
.unlimited_polymorphic
= 1;
4472 /* This is essential to force the construction of
4473 unlimited polymorphic component class containers. */
4474 upe
->attr
.zero_comp
= 1;
4475 if (!gfc_add_flavor (&upe
->attr
, FL_DERIVED
, NULL
,
4476 &gfc_current_locus
))
4481 st
= gfc_get_tbp_symtree (&gfc_current_ns
->sym_root
, "STAR");
4485 ts
->u
.derived
= upe
;
4489 m
= gfc_match (" class (");
4492 m
= gfc_match ("%n", name
);
4498 ts
->type
= BT_CLASS
;
4500 if (!gfc_notify_std (GFC_STD_F2003
, "CLASS statement at %C"))
4503 m
= gfc_match_actual_arglist (1, &decl_type_param_list
, true);
4504 if (m
== MATCH_ERROR
)
4507 m
= gfc_match_char (')');
4512 /* Defer association of the derived type until the end of the
4513 specification block. However, if the derived type can be
4514 found, add it to the typespec. */
4515 if (gfc_matching_function
)
4517 ts
->u
.derived
= NULL
;
4518 if (gfc_current_state () != COMP_INTERFACE
4519 && !gfc_find_symbol (name
, NULL
, 1, &sym
) && sym
)
4521 sym
= gfc_find_dt_in_generic (sym
);
4522 ts
->u
.derived
= sym
;
4527 /* Search for the name but allow the components to be defined later. If
4528 type = -1, this typespec has been seen in a function declaration but
4529 the type could not be accessed at that point. The actual derived type is
4530 stored in a symtree with the first letter of the name capitalized; the
4531 symtree with the all lower-case name contains the associated
4532 generic function. */
4533 dt_name
= gfc_dt_upper_string (name
);
4538 gfc_get_ha_symbol (name
, &sym
);
4539 if (sym
->generic
&& gfc_find_symbol (dt_name
, NULL
, 0, &dt_sym
))
4541 gfc_error ("Type name %qs at %C is ambiguous", name
);
4544 if (sym
->generic
&& !dt_sym
)
4545 dt_sym
= gfc_find_dt_in_generic (sym
);
4547 /* Host associated PDTs can get confused with their constructors
4548 because they ar instantiated in the template's namespace. */
4551 if (gfc_find_symbol (dt_name
, NULL
, 1, &dt_sym
))
4553 gfc_error ("Type name %qs at %C is ambiguous", name
);
4556 if (dt_sym
&& !dt_sym
->attr
.pdt_type
)
4560 else if (ts
->kind
== -1)
4562 int iface
= gfc_state_stack
->previous
->state
!= COMP_INTERFACE
4563 || gfc_current_ns
->has_import_set
;
4564 gfc_find_symbol (name
, NULL
, iface
, &sym
);
4565 if (sym
&& sym
->generic
&& gfc_find_symbol (dt_name
, NULL
, 1, &dt_sym
))
4567 gfc_error ("Type name %qs at %C is ambiguous", name
);
4570 if (sym
&& sym
->generic
&& !dt_sym
)
4571 dt_sym
= gfc_find_dt_in_generic (sym
);
4578 if ((sym
->attr
.flavor
!= FL_UNKNOWN
&& sym
->attr
.flavor
!= FL_STRUCT
4579 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.generic
))
4580 || sym
->attr
.subroutine
)
4582 gfc_error ("Type name %qs at %C conflicts with previously declared "
4583 "entity at %L, which has the same name", name
,
4588 if (sym
&& sym
->attr
.flavor
== FL_DERIVED
4589 && sym
->attr
.pdt_template
4590 && gfc_current_state () != COMP_DERIVED
)
4592 m
= gfc_get_pdt_instance (decl_type_param_list
, &sym
, NULL
);
4595 gcc_assert (!sym
->attr
.pdt_template
&& sym
->attr
.pdt_type
);
4596 ts
->u
.derived
= sym
;
4597 strcpy (name
, gfc_dt_lower_string (sym
->name
));
4600 gfc_save_symbol_data (sym
);
4601 gfc_set_sym_referenced (sym
);
4602 if (!sym
->attr
.generic
4603 && !gfc_add_generic (&sym
->attr
, sym
->name
, NULL
))
4606 if (!sym
->attr
.function
4607 && !gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
4610 if (dt_sym
&& dt_sym
->attr
.flavor
== FL_DERIVED
4611 && dt_sym
->attr
.pdt_template
4612 && gfc_current_state () != COMP_DERIVED
)
4614 m
= gfc_get_pdt_instance (decl_type_param_list
, &dt_sym
, NULL
);
4617 gcc_assert (!dt_sym
->attr
.pdt_template
&& dt_sym
->attr
.pdt_type
);
4622 gfc_interface
*intr
, *head
;
4624 /* Use upper case to save the actual derived-type symbol. */
4625 gfc_get_symbol (dt_name
, NULL
, &dt_sym
);
4626 dt_sym
->name
= gfc_get_string ("%s", sym
->name
);
4627 head
= sym
->generic
;
4628 intr
= gfc_get_interface ();
4630 intr
->where
= gfc_current_locus
;
4632 sym
->generic
= intr
;
4633 sym
->attr
.if_source
= IFSRC_DECL
;
4636 gfc_save_symbol_data (dt_sym
);
4638 gfc_set_sym_referenced (dt_sym
);
4640 if (dt_sym
->attr
.flavor
!= FL_DERIVED
&& dt_sym
->attr
.flavor
!= FL_STRUCT
4641 && !gfc_add_flavor (&dt_sym
->attr
, FL_DERIVED
, sym
->name
, NULL
))
4644 ts
->u
.derived
= dt_sym
;
4650 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
4651 "intrinsic-type-spec at %C"))
4654 /* For all types except double, derived and character, look for an
4655 optional kind specifier. MATCH_NO is actually OK at this point. */
4656 if (implicit_flag
== 1)
4658 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
4664 if (gfc_current_form
== FORM_FREE
)
4666 c
= gfc_peek_ascii_char ();
4667 if (!gfc_is_whitespace (c
) && c
!= '*' && c
!= '('
4668 && c
!= ':' && c
!= ',')
4670 if (matched_type
&& c
== ')')
4672 gfc_next_ascii_char ();
4675 gfc_error ("Malformed type-spec at %C");
4680 m
= gfc_match_kind_spec (ts
, false);
4681 if (m
== MATCH_NO
&& ts
->type
!= BT_CHARACTER
)
4683 m
= gfc_match_old_kind_spec (ts
);
4684 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) == -1)
4688 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
4690 gfc_error ("Malformed type-spec at %C");
4694 /* Defer association of the KIND expression of function results
4695 until after USE and IMPORT statements. */
4696 if ((gfc_current_state () == COMP_NONE
&& gfc_error_flag_test ())
4697 || gfc_matching_function
)
4701 m
= MATCH_YES
; /* No kind specifier found. */
4707 /* Match an IMPLICIT NONE statement. Actually, this statement is
4708 already matched in parse.c, or we would not end up here in the
4709 first place. So the only thing we need to check, is if there is
4710 trailing garbage. If not, the match is successful. */
4713 gfc_match_implicit_none (void)
4717 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4719 bool external
= false;
4720 locus cur_loc
= gfc_current_locus
;
4722 if (gfc_current_ns
->seen_implicit_none
4723 || gfc_current_ns
->has_implicit_none_export
)
4725 gfc_error ("Duplicate IMPLICIT NONE statement at %C");
4729 gfc_gobble_whitespace ();
4730 c
= gfc_peek_ascii_char ();
4733 (void) gfc_next_ascii_char ();
4734 if (!gfc_notify_std (GFC_STD_F2018
, "IMPORT NONE with spec list at %C"))
4737 gfc_gobble_whitespace ();
4738 if (gfc_peek_ascii_char () == ')')
4740 (void) gfc_next_ascii_char ();
4746 m
= gfc_match (" %n", name
);
4750 if (strcmp (name
, "type") == 0)
4752 else if (strcmp (name
, "external") == 0)
4757 gfc_gobble_whitespace ();
4758 c
= gfc_next_ascii_char ();
4769 if (gfc_match_eos () != MATCH_YES
)
4772 gfc_set_implicit_none (type
, external
, &cur_loc
);
4778 /* Match the letter range(s) of an IMPLICIT statement. */
4781 match_implicit_range (void)
4787 cur_loc
= gfc_current_locus
;
4789 gfc_gobble_whitespace ();
4790 c
= gfc_next_ascii_char ();
4793 gfc_error ("Missing character range in IMPLICIT at %C");
4800 gfc_gobble_whitespace ();
4801 c1
= gfc_next_ascii_char ();
4805 gfc_gobble_whitespace ();
4806 c
= gfc_next_ascii_char ();
4811 inner
= 0; /* Fall through. */
4818 gfc_gobble_whitespace ();
4819 c2
= gfc_next_ascii_char ();
4823 gfc_gobble_whitespace ();
4824 c
= gfc_next_ascii_char ();
4826 if ((c
!= ',') && (c
!= ')'))
4839 gfc_error ("Letters must be in alphabetic order in "
4840 "IMPLICIT statement at %C");
4844 /* See if we can add the newly matched range to the pending
4845 implicits from this IMPLICIT statement. We do not check for
4846 conflicts with whatever earlier IMPLICIT statements may have
4847 set. This is done when we've successfully finished matching
4849 if (!gfc_add_new_implicit_range (c1
, c2
))
4856 gfc_syntax_error (ST_IMPLICIT
);
4858 gfc_current_locus
= cur_loc
;
4863 /* Match an IMPLICIT statement, storing the types for
4864 gfc_set_implicit() if the statement is accepted by the parser.
4865 There is a strange looking, but legal syntactic construction
4866 possible. It looks like:
4868 IMPLICIT INTEGER (a-b) (c-d)
4870 This is legal if "a-b" is a constant expression that happens to
4871 equal one of the legal kinds for integers. The real problem
4872 happens with an implicit specification that looks like:
4874 IMPLICIT INTEGER (a-b)
4876 In this case, a typespec matcher that is "greedy" (as most of the
4877 matchers are) gobbles the character range as a kindspec, leaving
4878 nothing left. We therefore have to go a bit more slowly in the
4879 matching process by inhibiting the kindspec checking during
4880 typespec matching and checking for a kind later. */
4883 gfc_match_implicit (void)
4890 if (gfc_current_ns
->seen_implicit_none
)
4892 gfc_error ("IMPLICIT statement at %C following an IMPLICIT NONE (type) "
4899 /* We don't allow empty implicit statements. */
4900 if (gfc_match_eos () == MATCH_YES
)
4902 gfc_error ("Empty IMPLICIT statement at %C");
4908 /* First cleanup. */
4909 gfc_clear_new_implicit ();
4911 /* A basic type is mandatory here. */
4912 m
= gfc_match_decl_type_spec (&ts
, 1);
4913 if (m
== MATCH_ERROR
)
4918 cur_loc
= gfc_current_locus
;
4919 m
= match_implicit_range ();
4923 /* We may have <TYPE> (<RANGE>). */
4924 gfc_gobble_whitespace ();
4925 c
= gfc_peek_ascii_char ();
4926 if (c
== ',' || c
== '\n' || c
== ';' || c
== '!')
4928 /* Check for CHARACTER with no length parameter. */
4929 if (ts
.type
== BT_CHARACTER
&& !ts
.u
.cl
)
4931 ts
.kind
= gfc_default_character_kind
;
4932 ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4933 ts
.u
.cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
,
4937 /* Record the Successful match. */
4938 if (!gfc_merge_new_implicit (&ts
))
4941 c
= gfc_next_ascii_char ();
4942 else if (gfc_match_eos () == MATCH_ERROR
)
4947 gfc_current_locus
= cur_loc
;
4950 /* Discard the (incorrectly) matched range. */
4951 gfc_clear_new_implicit ();
4953 /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
4954 if (ts
.type
== BT_CHARACTER
)
4955 m
= gfc_match_char_spec (&ts
);
4956 else if (gfc_numeric_ts(&ts
) || ts
.type
== BT_LOGICAL
)
4958 m
= gfc_match_kind_spec (&ts
, false);
4961 m
= gfc_match_old_kind_spec (&ts
);
4962 if (m
== MATCH_ERROR
)
4968 if (m
== MATCH_ERROR
)
4971 m
= match_implicit_range ();
4972 if (m
== MATCH_ERROR
)
4977 gfc_gobble_whitespace ();
4978 c
= gfc_next_ascii_char ();
4979 if (c
!= ',' && gfc_match_eos () != MATCH_YES
)
4982 if (!gfc_merge_new_implicit (&ts
))
4990 gfc_syntax_error (ST_IMPLICIT
);
4998 gfc_match_import (void)
5000 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5005 if (gfc_current_ns
->proc_name
== NULL
5006 || gfc_current_ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
5008 gfc_error ("IMPORT statement at %C only permitted in "
5009 "an INTERFACE body");
5013 if (gfc_current_ns
->proc_name
->attr
.module_procedure
)
5015 gfc_error ("F2008: C1210 IMPORT statement at %C is not permitted "
5016 "in a module procedure interface body");
5020 if (!gfc_notify_std (GFC_STD_F2003
, "IMPORT statement at %C"))
5023 if (gfc_match_eos () == MATCH_YES
)
5025 /* All host variables should be imported. */
5026 gfc_current_ns
->has_import_set
= 1;
5030 if (gfc_match (" ::") == MATCH_YES
)
5032 if (gfc_match_eos () == MATCH_YES
)
5034 gfc_error ("Expecting list of named entities at %C");
5042 m
= gfc_match (" %n", name
);
5046 if (gfc_current_ns
->parent
!= NULL
5047 && gfc_find_symbol (name
, gfc_current_ns
->parent
, 1, &sym
))
5049 gfc_error ("Type name %qs at %C is ambiguous", name
);
5052 else if (!sym
&& gfc_current_ns
->proc_name
->ns
->parent
!= NULL
5053 && gfc_find_symbol (name
,
5054 gfc_current_ns
->proc_name
->ns
->parent
,
5057 gfc_error ("Type name %qs at %C is ambiguous", name
);
5063 gfc_error ("Cannot IMPORT %qs from host scoping unit "
5064 "at %C - does not exist.", name
);
5068 if (gfc_find_symtree (gfc_current_ns
->sym_root
, name
))
5070 gfc_warning (0, "%qs is already IMPORTed from host scoping unit "
5075 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, name
);
5078 sym
->attr
.imported
= 1;
5080 if (sym
->attr
.generic
&& (sym
= gfc_find_dt_in_generic (sym
)))
5082 /* The actual derived type is stored in a symtree with the first
5083 letter of the name capitalized; the symtree with the all
5084 lower-case name contains the associated generic function. */
5085 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
,
5086 gfc_dt_upper_string (name
));
5089 sym
->attr
.imported
= 1;
5102 if (gfc_match_eos () == MATCH_YES
)
5104 if (gfc_match_char (',') != MATCH_YES
)
5111 gfc_error ("Syntax error in IMPORT statement at %C");
5116 /* A minimal implementation of gfc_match without whitespace, escape
5117 characters or variable arguments. Returns true if the next
5118 characters match the TARGET template exactly. */
5121 match_string_p (const char *target
)
5125 for (p
= target
; *p
; p
++)
5126 if ((char) gfc_next_ascii_char () != *p
)
5131 /* Matches an attribute specification including array specs. If
5132 successful, leaves the variables current_attr and current_as
5133 holding the specification. Also sets the colon_seen variable for
5134 later use by matchers associated with initializations.
5136 This subroutine is a little tricky in the sense that we don't know
5137 if we really have an attr-spec until we hit the double colon.
5138 Until that time, we can only return MATCH_NO. This forces us to
5139 check for duplicate specification at this level. */
5142 match_attr_spec (void)
5144 /* Modifiers that can exist in a type statement. */
5146 { GFC_DECL_BEGIN
= 0, DECL_ALLOCATABLE
= GFC_DECL_BEGIN
,
5147 DECL_IN
= INTENT_IN
, DECL_OUT
= INTENT_OUT
, DECL_INOUT
= INTENT_INOUT
,
5148 DECL_DIMENSION
, DECL_EXTERNAL
,
5149 DECL_INTRINSIC
, DECL_OPTIONAL
,
5150 DECL_PARAMETER
, DECL_POINTER
, DECL_PROTECTED
, DECL_PRIVATE
,
5151 DECL_STATIC
, DECL_AUTOMATIC
,
5152 DECL_PUBLIC
, DECL_SAVE
, DECL_TARGET
, DECL_VALUE
, DECL_VOLATILE
,
5153 DECL_IS_BIND_C
, DECL_CODIMENSION
, DECL_ASYNCHRONOUS
, DECL_CONTIGUOUS
,
5154 DECL_LEN
, DECL_KIND
, DECL_NONE
, GFC_DECL_END
/* Sentinel */
5157 /* GFC_DECL_END is the sentinel, index starts at 0. */
5158 #define NUM_DECL GFC_DECL_END
5160 /* Make sure that values from sym_intent are safe to be used here. */
5161 gcc_assert (INTENT_IN
> 0);
5163 locus start
, seen_at
[NUM_DECL
];
5170 gfc_clear_attr (¤t_attr
);
5171 start
= gfc_current_locus
;
5177 /* See if we get all of the keywords up to the final double colon. */
5178 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
5186 gfc_gobble_whitespace ();
5188 ch
= gfc_next_ascii_char ();
5191 /* This is the successful exit condition for the loop. */
5192 if (gfc_next_ascii_char () == ':')
5197 gfc_gobble_whitespace ();
5198 switch (gfc_peek_ascii_char ())
5201 gfc_next_ascii_char ();
5202 switch (gfc_next_ascii_char ())
5205 if (match_string_p ("locatable"))
5207 /* Matched "allocatable". */
5208 d
= DECL_ALLOCATABLE
;
5213 if (match_string_p ("ynchronous"))
5215 /* Matched "asynchronous". */
5216 d
= DECL_ASYNCHRONOUS
;
5221 if (match_string_p ("tomatic"))
5223 /* Matched "automatic". */
5231 /* Try and match the bind(c). */
5232 m
= gfc_match_bind_c (NULL
, true);
5235 else if (m
== MATCH_ERROR
)
5240 gfc_next_ascii_char ();
5241 if ('o' != gfc_next_ascii_char ())
5243 switch (gfc_next_ascii_char ())
5246 if (match_string_p ("imension"))
5248 d
= DECL_CODIMENSION
;
5253 if (match_string_p ("tiguous"))
5255 d
= DECL_CONTIGUOUS
;
5262 if (match_string_p ("dimension"))
5267 if (match_string_p ("external"))
5272 if (match_string_p ("int"))
5274 ch
= gfc_next_ascii_char ();
5277 if (match_string_p ("nt"))
5279 /* Matched "intent". */
5280 d
= match_intent_spec ();
5281 if (d
== INTENT_UNKNOWN
)
5290 if (match_string_p ("insic"))
5292 /* Matched "intrinsic". */
5300 if (match_string_p ("kind"))
5305 if (match_string_p ("len"))
5310 if (match_string_p ("optional"))
5315 gfc_next_ascii_char ();
5316 switch (gfc_next_ascii_char ())
5319 if (match_string_p ("rameter"))
5321 /* Matched "parameter". */
5327 if (match_string_p ("inter"))
5329 /* Matched "pointer". */
5335 ch
= gfc_next_ascii_char ();
5338 if (match_string_p ("vate"))
5340 /* Matched "private". */
5346 if (match_string_p ("tected"))
5348 /* Matched "protected". */
5355 if (match_string_p ("blic"))
5357 /* Matched "public". */
5365 gfc_next_ascii_char ();
5366 switch (gfc_next_ascii_char ())
5369 if (match_string_p ("ve"))
5371 /* Matched "save". */
5377 if (match_string_p ("atic"))
5379 /* Matched "static". */
5387 if (match_string_p ("target"))
5392 gfc_next_ascii_char ();
5393 ch
= gfc_next_ascii_char ();
5396 if (match_string_p ("lue"))
5398 /* Matched "value". */
5404 if (match_string_p ("latile"))
5406 /* Matched "volatile". */
5414 /* No double colon and no recognizable decl_type, so assume that
5415 we've been looking at something else the whole time. */
5422 /* Check to make sure any parens are paired up correctly. */
5423 if (gfc_match_parens () == MATCH_ERROR
)
5430 seen_at
[d
] = gfc_current_locus
;
5432 if (d
== DECL_DIMENSION
|| d
== DECL_CODIMENSION
)
5434 gfc_array_spec
*as
= NULL
;
5436 m
= gfc_match_array_spec (&as
, d
== DECL_DIMENSION
,
5437 d
== DECL_CODIMENSION
);
5439 if (current_as
== NULL
)
5441 else if (m
== MATCH_YES
)
5443 if (!merge_array_spec (as
, current_as
, false))
5450 if (d
== DECL_CODIMENSION
)
5451 gfc_error ("Missing codimension specification at %C");
5453 gfc_error ("Missing dimension specification at %C");
5457 if (m
== MATCH_ERROR
)
5462 /* Since we've seen a double colon, we have to be looking at an
5463 attr-spec. This means that we can now issue errors. */
5464 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
5469 case DECL_ALLOCATABLE
:
5470 attr
= "ALLOCATABLE";
5472 case DECL_ASYNCHRONOUS
:
5473 attr
= "ASYNCHRONOUS";
5475 case DECL_CODIMENSION
:
5476 attr
= "CODIMENSION";
5478 case DECL_CONTIGUOUS
:
5479 attr
= "CONTIGUOUS";
5481 case DECL_DIMENSION
:
5488 attr
= "INTENT (IN)";
5491 attr
= "INTENT (OUT)";
5494 attr
= "INTENT (IN OUT)";
5496 case DECL_INTRINSIC
:
5508 case DECL_PARAMETER
:
5514 case DECL_PROTECTED
:
5529 case DECL_AUTOMATIC
:
5535 case DECL_IS_BIND_C
:
5545 attr
= NULL
; /* This shouldn't happen. */
5548 gfc_error ("Duplicate %s attribute at %L", attr
, &seen_at
[d
]);
5553 /* Now that we've dealt with duplicate attributes, add the attributes
5554 to the current attribute. */
5555 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
5562 if ((d
== DECL_STATIC
|| d
== DECL_AUTOMATIC
)
5563 && !flag_dec_static
)
5565 gfc_error ("%s at %L is a DEC extension, enable with "
5567 d
== DECL_STATIC
? "STATIC" : "AUTOMATIC", &seen_at
[d
]);
5571 /* Allow SAVE with STATIC, but don't complain. */
5572 if (d
== DECL_STATIC
&& seen
[DECL_SAVE
])
5575 if (gfc_comp_struct (gfc_current_state ())
5576 && d
!= DECL_DIMENSION
&& d
!= DECL_CODIMENSION
5577 && d
!= DECL_POINTER
&& d
!= DECL_PRIVATE
5578 && d
!= DECL_PUBLIC
&& d
!= DECL_CONTIGUOUS
&& d
!= DECL_NONE
)
5580 bool is_derived
= gfc_current_state () == COMP_DERIVED
;
5581 if (d
== DECL_ALLOCATABLE
)
5583 if (!gfc_notify_std (GFC_STD_F2003
, is_derived
5584 ? G_("ALLOCATABLE attribute at %C in a "
5586 : G_("ALLOCATABLE attribute at %C in a "
5587 "STRUCTURE definition")))
5593 else if (d
== DECL_KIND
)
5595 if (!gfc_notify_std (GFC_STD_F2003
, is_derived
5596 ? G_("KIND attribute at %C in a "
5598 : G_("KIND attribute at %C in a "
5599 "STRUCTURE definition")))
5604 if (current_ts
.type
!= BT_INTEGER
)
5606 gfc_error ("Component with KIND attribute at %C must be "
5611 if (current_ts
.kind
!= gfc_default_integer_kind
)
5613 gfc_error ("Component with KIND attribute at %C must be "
5614 "default integer kind (%d)",
5615 gfc_default_integer_kind
);
5620 else if (d
== DECL_LEN
)
5622 if (!gfc_notify_std (GFC_STD_F2003
, is_derived
5623 ? G_("LEN attribute at %C in a "
5625 : G_("LEN attribute at %C in a "
5626 "STRUCTURE definition")))
5631 if (current_ts
.type
!= BT_INTEGER
)
5633 gfc_error ("Component with LEN attribute at %C must be "
5638 if (current_ts
.kind
!= gfc_default_integer_kind
)
5640 gfc_error ("Component with LEN attribute at %C must be "
5641 "default integer kind (%d)",
5642 gfc_default_integer_kind
);
5649 gfc_error (is_derived
? G_("Attribute at %L is not allowed in a "
5651 : G_("Attribute at %L is not allowed in a "
5652 "STRUCTURE definition"), &seen_at
[d
]);
5658 if ((d
== DECL_PRIVATE
|| d
== DECL_PUBLIC
)
5659 && gfc_current_state () != COMP_MODULE
)
5661 if (d
== DECL_PRIVATE
)
5665 if (gfc_current_state () == COMP_DERIVED
5666 && gfc_state_stack
->previous
5667 && gfc_state_stack
->previous
->state
== COMP_MODULE
)
5669 if (!gfc_notify_std (GFC_STD_F2003
, "Attribute %s "
5670 "at %L in a TYPE definition", attr
,
5679 gfc_error ("%s attribute at %L is not allowed outside of the "
5680 "specification part of a module", attr
, &seen_at
[d
]);
5686 if (gfc_current_state () != COMP_DERIVED
5687 && (d
== DECL_KIND
|| d
== DECL_LEN
))
5689 gfc_error ("Attribute at %L is not allowed outside a TYPE "
5690 "definition", &seen_at
[d
]);
5697 case DECL_ALLOCATABLE
:
5698 t
= gfc_add_allocatable (¤t_attr
, &seen_at
[d
]);
5701 case DECL_ASYNCHRONOUS
:
5702 if (!gfc_notify_std (GFC_STD_F2003
, "ASYNCHRONOUS attribute at %C"))
5705 t
= gfc_add_asynchronous (¤t_attr
, NULL
, &seen_at
[d
]);
5708 case DECL_CODIMENSION
:
5709 t
= gfc_add_codimension (¤t_attr
, NULL
, &seen_at
[d
]);
5712 case DECL_CONTIGUOUS
:
5713 if (!gfc_notify_std (GFC_STD_F2008
, "CONTIGUOUS attribute at %C"))
5716 t
= gfc_add_contiguous (¤t_attr
, NULL
, &seen_at
[d
]);
5719 case DECL_DIMENSION
:
5720 t
= gfc_add_dimension (¤t_attr
, NULL
, &seen_at
[d
]);
5724 t
= gfc_add_external (¤t_attr
, &seen_at
[d
]);
5728 t
= gfc_add_intent (¤t_attr
, INTENT_IN
, &seen_at
[d
]);
5732 t
= gfc_add_intent (¤t_attr
, INTENT_OUT
, &seen_at
[d
]);
5736 t
= gfc_add_intent (¤t_attr
, INTENT_INOUT
, &seen_at
[d
]);
5739 case DECL_INTRINSIC
:
5740 t
= gfc_add_intrinsic (¤t_attr
, &seen_at
[d
]);
5744 t
= gfc_add_optional (¤t_attr
, &seen_at
[d
]);
5748 t
= gfc_add_kind (¤t_attr
, &seen_at
[d
]);
5752 t
= gfc_add_len (¤t_attr
, &seen_at
[d
]);
5755 case DECL_PARAMETER
:
5756 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, &seen_at
[d
]);
5760 t
= gfc_add_pointer (¤t_attr
, &seen_at
[d
]);
5763 case DECL_PROTECTED
:
5764 if (gfc_current_state () != COMP_MODULE
5765 || (gfc_current_ns
->proc_name
5766 && gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
))
5768 gfc_error ("PROTECTED at %C only allowed in specification "
5769 "part of a module");
5774 if (!gfc_notify_std (GFC_STD_F2003
, "PROTECTED attribute at %C"))
5777 t
= gfc_add_protected (¤t_attr
, NULL
, &seen_at
[d
]);
5781 t
= gfc_add_access (¤t_attr
, ACCESS_PRIVATE
, NULL
,
5786 t
= gfc_add_access (¤t_attr
, ACCESS_PUBLIC
, NULL
,
5792 t
= gfc_add_save (¤t_attr
, SAVE_EXPLICIT
, NULL
, &seen_at
[d
]);
5795 case DECL_AUTOMATIC
:
5796 t
= gfc_add_automatic (¤t_attr
, NULL
, &seen_at
[d
]);
5800 t
= gfc_add_target (¤t_attr
, &seen_at
[d
]);
5803 case DECL_IS_BIND_C
:
5804 t
= gfc_add_is_bind_c(¤t_attr
, NULL
, &seen_at
[d
], 0);
5808 if (!gfc_notify_std (GFC_STD_F2003
, "VALUE attribute at %C"))
5811 t
= gfc_add_value (¤t_attr
, NULL
, &seen_at
[d
]);
5815 if (!gfc_notify_std (GFC_STD_F2003
, "VOLATILE attribute at %C"))
5818 t
= gfc_add_volatile (¤t_attr
, NULL
, &seen_at
[d
]);
5822 gfc_internal_error ("match_attr_spec(): Bad attribute");
5832 /* Since Fortran 2008 module variables implicitly have the SAVE attribute. */
5833 if ((gfc_current_state () == COMP_MODULE
5834 || gfc_current_state () == COMP_SUBMODULE
)
5835 && !current_attr
.save
5836 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
5837 current_attr
.save
= SAVE_IMPLICIT
;
5843 gfc_current_locus
= start
;
5844 gfc_free_array_spec (current_as
);
5851 /* Set the binding label, dest_label, either with the binding label
5852 stored in the given gfc_typespec, ts, or if none was provided, it
5853 will be the symbol name in all lower case, as required by the draft
5854 (J3/04-007, section 15.4.1). If a binding label was given and
5855 there is more than one argument (num_idents), it is an error. */
5858 set_binding_label (const char **dest_label
, const char *sym_name
,
5861 if (num_idents
> 1 && has_name_equals
)
5863 gfc_error ("Multiple identifiers provided with "
5864 "single NAME= specifier at %C");
5868 if (curr_binding_label
)
5869 /* Binding label given; store in temp holder till have sym. */
5870 *dest_label
= curr_binding_label
;
5873 /* No binding label given, and the NAME= specifier did not exist,
5874 which means there was no NAME="". */
5875 if (sym_name
!= NULL
&& has_name_equals
== 0)
5876 *dest_label
= IDENTIFIER_POINTER (get_identifier (sym_name
));
5883 /* Set the status of the given common block as being BIND(C) or not,
5884 depending on the given parameter, is_bind_c. */
5887 set_com_block_bind_c (gfc_common_head
*com_block
, int is_bind_c
)
5889 com_block
->is_bind_c
= is_bind_c
;
5894 /* Verify that the given gfc_typespec is for a C interoperable type. */
5897 gfc_verify_c_interop (gfc_typespec
*ts
)
5899 if (ts
->type
== BT_DERIVED
&& ts
->u
.derived
!= NULL
)
5900 return (ts
->u
.derived
->ts
.is_c_interop
|| ts
->u
.derived
->attr
.is_bind_c
)
5902 else if (ts
->type
== BT_CLASS
)
5904 else if (ts
->is_c_interop
!= 1 && ts
->type
!= BT_ASSUMED
)
5911 /* Verify that the variables of a given common block, which has been
5912 defined with the attribute specifier bind(c), to be of a C
5913 interoperable type. Errors will be reported here, if
5917 verify_com_block_vars_c_interop (gfc_common_head
*com_block
)
5919 gfc_symbol
*curr_sym
= NULL
;
5922 curr_sym
= com_block
->head
;
5924 /* Make sure we have at least one symbol. */
5925 if (curr_sym
== NULL
)
5928 /* Here we know we have a symbol, so we'll execute this loop
5932 /* The second to last param, 1, says this is in a common block. */
5933 retval
= verify_bind_c_sym (curr_sym
, &(curr_sym
->ts
), 1, com_block
);
5934 curr_sym
= curr_sym
->common_next
;
5935 } while (curr_sym
!= NULL
);
5941 /* Verify that a given BIND(C) symbol is C interoperable. If it is not,
5942 an appropriate error message is reported. */
5945 verify_bind_c_sym (gfc_symbol
*tmp_sym
, gfc_typespec
*ts
,
5946 int is_in_common
, gfc_common_head
*com_block
)
5948 bool bind_c_function
= false;
5951 if (tmp_sym
->attr
.function
&& tmp_sym
->attr
.is_bind_c
)
5952 bind_c_function
= true;
5954 if (tmp_sym
->attr
.function
&& tmp_sym
->result
!= NULL
)
5956 tmp_sym
= tmp_sym
->result
;
5957 /* Make sure it wasn't an implicitly typed result. */
5958 if (tmp_sym
->attr
.implicit_type
&& warn_c_binding_type
)
5960 gfc_warning (OPT_Wc_binding_type
,
5961 "Implicitly declared BIND(C) function %qs at "
5962 "%L may not be C interoperable", tmp_sym
->name
,
5963 &tmp_sym
->declared_at
);
5964 tmp_sym
->ts
.f90_type
= tmp_sym
->ts
.type
;
5965 /* Mark it as C interoperable to prevent duplicate warnings. */
5966 tmp_sym
->ts
.is_c_interop
= 1;
5967 tmp_sym
->attr
.is_c_interop
= 1;
5971 /* Here, we know we have the bind(c) attribute, so if we have
5972 enough type info, then verify that it's a C interop kind.
5973 The info could be in the symbol already, or possibly still in
5974 the given ts (current_ts), so look in both. */
5975 if (tmp_sym
->ts
.type
!= BT_UNKNOWN
|| ts
->type
!= BT_UNKNOWN
)
5977 if (!gfc_verify_c_interop (&(tmp_sym
->ts
)))
5979 /* See if we're dealing with a sym in a common block or not. */
5980 if (is_in_common
== 1 && warn_c_binding_type
)
5982 gfc_warning (OPT_Wc_binding_type
,
5983 "Variable %qs in common block %qs at %L "
5984 "may not be a C interoperable "
5985 "kind though common block %qs is BIND(C)",
5986 tmp_sym
->name
, com_block
->name
,
5987 &(tmp_sym
->declared_at
), com_block
->name
);
5991 if (tmp_sym
->ts
.type
== BT_DERIVED
|| ts
->type
== BT_DERIVED
)
5992 gfc_error ("Type declaration %qs at %L is not C "
5993 "interoperable but it is BIND(C)",
5994 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5995 else if (warn_c_binding_type
)
5996 gfc_warning (OPT_Wc_binding_type
, "Variable %qs at %L "
5997 "may not be a C interoperable "
5998 "kind but it is BIND(C)",
5999 tmp_sym
->name
, &(tmp_sym
->declared_at
));
6003 /* Variables declared w/in a common block can't be bind(c)
6004 since there's no way for C to see these variables, so there's
6005 semantically no reason for the attribute. */
6006 if (is_in_common
== 1 && tmp_sym
->attr
.is_bind_c
== 1)
6008 gfc_error ("Variable %qs in common block %qs at "
6009 "%L cannot be declared with BIND(C) "
6010 "since it is not a global",
6011 tmp_sym
->name
, com_block
->name
,
6012 &(tmp_sym
->declared_at
));
6016 /* Scalar variables that are bind(c) cannot have the pointer
6017 or allocatable attributes. */
6018 if (tmp_sym
->attr
.is_bind_c
== 1)
6020 if (tmp_sym
->attr
.pointer
== 1)
6022 gfc_error ("Variable %qs at %L cannot have both the "
6023 "POINTER and BIND(C) attributes",
6024 tmp_sym
->name
, &(tmp_sym
->declared_at
));
6028 if (tmp_sym
->attr
.allocatable
== 1)
6030 gfc_error ("Variable %qs at %L cannot have both the "
6031 "ALLOCATABLE and BIND(C) attributes",
6032 tmp_sym
->name
, &(tmp_sym
->declared_at
));
6038 /* If it is a BIND(C) function, make sure the return value is a
6039 scalar value. The previous tests in this function made sure
6040 the type is interoperable. */
6041 if (bind_c_function
&& tmp_sym
->as
!= NULL
)
6042 gfc_error ("Return type of BIND(C) function %qs at %L cannot "
6043 "be an array", tmp_sym
->name
, &(tmp_sym
->declared_at
));
6045 /* BIND(C) functions cannot return a character string. */
6046 if (bind_c_function
&& tmp_sym
->ts
.type
== BT_CHARACTER
)
6047 if (tmp_sym
->ts
.u
.cl
== NULL
|| tmp_sym
->ts
.u
.cl
->length
== NULL
6048 || tmp_sym
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
6049 || mpz_cmp_si (tmp_sym
->ts
.u
.cl
->length
->value
.integer
, 1) != 0)
6050 gfc_error ("Return type of BIND(C) function %qs of character "
6051 "type at %L must have length 1", tmp_sym
->name
,
6052 &(tmp_sym
->declared_at
));
6055 /* See if the symbol has been marked as private. If it has, make sure
6056 there is no binding label and warn the user if there is one. */
6057 if (tmp_sym
->attr
.access
== ACCESS_PRIVATE
6058 && tmp_sym
->binding_label
)
6059 /* Use gfc_warning_now because we won't say that the symbol fails
6060 just because of this. */
6061 gfc_warning_now (0, "Symbol %qs at %L is marked PRIVATE but has been "
6062 "given the binding label %qs", tmp_sym
->name
,
6063 &(tmp_sym
->declared_at
), tmp_sym
->binding_label
);
6069 /* Set the appropriate fields for a symbol that's been declared as
6070 BIND(C) (the is_bind_c flag and the binding label), and verify that
6071 the type is C interoperable. Errors are reported by the functions
6072 used to set/test these fields. */
6075 set_verify_bind_c_sym (gfc_symbol
*tmp_sym
, int num_idents
)
6079 /* TODO: Do we need to make sure the vars aren't marked private? */
6081 /* Set the is_bind_c bit in symbol_attribute. */
6082 gfc_add_is_bind_c (&(tmp_sym
->attr
), tmp_sym
->name
, &gfc_current_locus
, 0);
6084 if (!set_binding_label (&tmp_sym
->binding_label
, tmp_sym
->name
, num_idents
))
6091 /* Set the fields marking the given common block as BIND(C), including
6092 a binding label, and report any errors encountered. */
6095 set_verify_bind_c_com_block (gfc_common_head
*com_block
, int num_idents
)
6099 /* destLabel, common name, typespec (which may have binding label). */
6100 if (!set_binding_label (&com_block
->binding_label
, com_block
->name
,
6104 /* Set the given common block (com_block) to being bind(c) (1). */
6105 set_com_block_bind_c (com_block
, 1);
6111 /* Retrieve the list of one or more identifiers that the given bind(c)
6112 attribute applies to. */
6115 get_bind_c_idents (void)
6117 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6119 gfc_symbol
*tmp_sym
= NULL
;
6121 gfc_common_head
*com_block
= NULL
;
6123 if (gfc_match_name (name
) == MATCH_YES
)
6125 found_id
= MATCH_YES
;
6126 gfc_get_ha_symbol (name
, &tmp_sym
);
6128 else if (gfc_match_common_name (name
) == MATCH_YES
)
6130 found_id
= MATCH_YES
;
6131 com_block
= gfc_get_common (name
, 0);
6135 gfc_error ("Need either entity or common block name for "
6136 "attribute specification statement at %C");
6140 /* Save the current identifier and look for more. */
6143 /* Increment the number of identifiers found for this spec stmt. */
6146 /* Make sure we have a sym or com block, and verify that it can
6147 be bind(c). Set the appropriate field(s) and look for more
6149 if (tmp_sym
!= NULL
|| com_block
!= NULL
)
6151 if (tmp_sym
!= NULL
)
6153 if (!set_verify_bind_c_sym (tmp_sym
, num_idents
))
6158 if (!set_verify_bind_c_com_block (com_block
, num_idents
))
6162 /* Look to see if we have another identifier. */
6164 if (gfc_match_eos () == MATCH_YES
)
6165 found_id
= MATCH_NO
;
6166 else if (gfc_match_char (',') != MATCH_YES
)
6167 found_id
= MATCH_NO
;
6168 else if (gfc_match_name (name
) == MATCH_YES
)
6170 found_id
= MATCH_YES
;
6171 gfc_get_ha_symbol (name
, &tmp_sym
);
6173 else if (gfc_match_common_name (name
) == MATCH_YES
)
6175 found_id
= MATCH_YES
;
6176 com_block
= gfc_get_common (name
, 0);
6180 gfc_error ("Missing entity or common block name for "
6181 "attribute specification statement at %C");
6187 gfc_internal_error ("Missing symbol");
6189 } while (found_id
== MATCH_YES
);
6191 /* if we get here we were successful */
6196 /* Try and match a BIND(C) attribute specification statement. */
6199 gfc_match_bind_c_stmt (void)
6201 match found_match
= MATCH_NO
;
6206 /* This may not be necessary. */
6208 /* Clear the temporary binding label holder. */
6209 curr_binding_label
= NULL
;
6211 /* Look for the bind(c). */
6212 found_match
= gfc_match_bind_c (NULL
, true);
6214 if (found_match
== MATCH_YES
)
6216 if (!gfc_notify_std (GFC_STD_F2003
, "BIND(C) statement at %C"))
6219 /* Look for the :: now, but it is not required. */
6222 /* Get the identifier(s) that needs to be updated. This may need to
6223 change to hand the flag(s) for the attr specified so all identifiers
6224 found can have all appropriate parts updated (assuming that the same
6225 spec stmt can have multiple attrs, such as both bind(c) and
6227 if (!get_bind_c_idents ())
6228 /* Error message should have printed already. */
6236 /* Match a data declaration statement. */
6239 gfc_match_data_decl (void)
6245 type_param_spec_list
= NULL
;
6246 decl_type_param_list
= NULL
;
6248 num_idents_on_line
= 0;
6250 m
= gfc_match_decl_type_spec (¤t_ts
, 0);
6254 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
6255 && !gfc_comp_struct (gfc_current_state ()))
6257 sym
= gfc_use_derived (current_ts
.u
.derived
);
6265 current_ts
.u
.derived
= sym
;
6268 m
= match_attr_spec ();
6269 if (m
== MATCH_ERROR
)
6275 if (current_ts
.type
== BT_CLASS
6276 && current_ts
.u
.derived
->attr
.unlimited_polymorphic
)
6279 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
6280 && current_ts
.u
.derived
->components
== NULL
6281 && !current_ts
.u
.derived
->attr
.zero_comp
)
6284 if (current_attr
.pointer
&& gfc_comp_struct (gfc_current_state ()))
6287 if (current_attr
.allocatable
&& gfc_current_state () == COMP_DERIVED
)
6290 gfc_find_symbol (current_ts
.u
.derived
->name
,
6291 current_ts
.u
.derived
->ns
, 1, &sym
);
6293 /* Any symbol that we find had better be a type definition
6294 which has its components defined, or be a structure definition
6295 actively being parsed. */
6296 if (sym
!= NULL
&& gfc_fl_struct (sym
->attr
.flavor
)
6297 && (current_ts
.u
.derived
->components
!= NULL
6298 || current_ts
.u
.derived
->attr
.zero_comp
6299 || current_ts
.u
.derived
== gfc_new_block
))
6302 gfc_error ("Derived type at %C has not been previously defined "
6303 "and so cannot appear in a derived type definition");
6309 /* If we have an old-style character declaration, and no new-style
6310 attribute specifications, then there a comma is optional between
6311 the type specification and the variable list. */
6312 if (m
== MATCH_NO
&& current_ts
.type
== BT_CHARACTER
&& old_char_selector
)
6313 gfc_match_char (',');
6315 /* Give the types/attributes to symbols that follow. Give the element
6316 a number so that repeat character length expressions can be copied. */
6320 num_idents_on_line
++;
6321 m
= variable_decl (elem
++);
6322 if (m
== MATCH_ERROR
)
6327 if (gfc_match_eos () == MATCH_YES
)
6329 if (gfc_match_char (',') != MATCH_YES
)
6333 if (!gfc_error_flag_test ())
6335 /* An anonymous structure declaration is unambiguous; if we matched one
6336 according to gfc_match_structure_decl, we need to return MATCH_YES
6337 here to avoid confusing the remaining matchers, even if there was an
6338 error during variable_decl. We must flush any such errors. Note this
6339 causes the parser to gracefully continue parsing the remaining input
6340 as a structure body, which likely follows. */
6341 if (current_ts
.type
== BT_DERIVED
&& current_ts
.u
.derived
6342 && gfc_fl_struct (current_ts
.u
.derived
->attr
.flavor
))
6344 gfc_error_now ("Syntax error in anonymous structure declaration"
6346 /* Skip the bad variable_decl and line up for the start of the
6348 gfc_error_recovery ();
6353 gfc_error ("Syntax error in data declaration at %C");
6358 gfc_free_data_all (gfc_current_ns
);
6361 if (saved_kind_expr
)
6362 gfc_free_expr (saved_kind_expr
);
6363 if (type_param_spec_list
)
6364 gfc_free_actual_arglist (type_param_spec_list
);
6365 if (decl_type_param_list
)
6366 gfc_free_actual_arglist (decl_type_param_list
);
6367 saved_kind_expr
= NULL
;
6368 gfc_free_array_spec (current_as
);
6374 in_module_or_interface(void)
6376 if (gfc_current_state () == COMP_MODULE
6377 || gfc_current_state () == COMP_SUBMODULE
6378 || gfc_current_state () == COMP_INTERFACE
)
6381 if (gfc_state_stack
->state
== COMP_CONTAINS
6382 || gfc_state_stack
->state
== COMP_FUNCTION
6383 || gfc_state_stack
->state
== COMP_SUBROUTINE
)
6386 for (p
= gfc_state_stack
->previous
; p
; p
= p
->previous
)
6388 if (p
->state
== COMP_MODULE
|| p
->state
== COMP_SUBMODULE
6389 || p
->state
== COMP_INTERFACE
)
6396 /* Match a prefix associated with a function or subroutine
6397 declaration. If the typespec pointer is nonnull, then a typespec
6398 can be matched. Note that if nothing matches, MATCH_YES is
6399 returned (the null string was matched). */
6402 gfc_match_prefix (gfc_typespec
*ts
)
6408 gfc_clear_attr (¤t_attr
);
6410 seen_impure
= false;
6412 gcc_assert (!gfc_matching_prefix
);
6413 gfc_matching_prefix
= true;
6417 found_prefix
= false;
6419 /* MODULE is a prefix like PURE, ELEMENTAL, etc., having a
6420 corresponding attribute seems natural and distinguishes these
6421 procedures from procedure types of PROC_MODULE, which these are
6423 if (gfc_match ("module% ") == MATCH_YES
)
6425 if (!gfc_notify_std (GFC_STD_F2008
, "MODULE prefix at %C"))
6428 if (!in_module_or_interface ())
6430 gfc_error ("MODULE prefix at %C found outside of a module, "
6431 "submodule, or interface");
6435 current_attr
.module_procedure
= 1;
6436 found_prefix
= true;
6439 if (!seen_type
&& ts
!= NULL
)
6442 m
= gfc_match_decl_type_spec (ts
, 0);
6443 if (m
== MATCH_ERROR
)
6445 if (m
== MATCH_YES
&& gfc_match_space () == MATCH_YES
)
6448 found_prefix
= true;
6452 if (gfc_match ("elemental% ") == MATCH_YES
)
6454 if (!gfc_add_elemental (¤t_attr
, NULL
))
6457 found_prefix
= true;
6460 if (gfc_match ("pure% ") == MATCH_YES
)
6462 if (!gfc_add_pure (¤t_attr
, NULL
))
6465 found_prefix
= true;
6468 if (gfc_match ("recursive% ") == MATCH_YES
)
6470 if (!gfc_add_recursive (¤t_attr
, NULL
))
6473 found_prefix
= true;
6476 /* IMPURE is a somewhat special case, as it needs not set an actual
6477 attribute but rather only prevents ELEMENTAL routines from being
6478 automatically PURE. */
6479 if (gfc_match ("impure% ") == MATCH_YES
)
6481 if (!gfc_notify_std (GFC_STD_F2008
, "IMPURE procedure at %C"))
6485 found_prefix
= true;
6488 while (found_prefix
);
6490 /* IMPURE and PURE must not both appear, of course. */
6491 if (seen_impure
&& current_attr
.pure
)
6493 gfc_error ("PURE and IMPURE must not appear both at %C");
6497 /* If IMPURE it not seen but the procedure is ELEMENTAL, mark it as PURE. */
6498 if (!seen_impure
&& current_attr
.elemental
&& !current_attr
.pure
)
6500 if (!gfc_add_pure (¤t_attr
, NULL
))
6504 /* At this point, the next item is not a prefix. */
6505 gcc_assert (gfc_matching_prefix
);
6507 gfc_matching_prefix
= false;
6511 gcc_assert (gfc_matching_prefix
);
6512 gfc_matching_prefix
= false;
6517 /* Copy attributes matched by gfc_match_prefix() to attributes on a symbol. */
6520 copy_prefix (symbol_attribute
*dest
, locus
*where
)
6522 if (dest
->module_procedure
)
6524 if (current_attr
.elemental
)
6525 dest
->elemental
= 1;
6527 if (current_attr
.pure
)
6530 if (current_attr
.recursive
)
6531 dest
->recursive
= 1;
6533 /* Module procedures are unusual in that the 'dest' is copied from
6534 the interface declaration. However, this is an oportunity to
6535 check that the submodule declaration is compliant with the
6537 if (dest
->elemental
&& !current_attr
.elemental
)
6539 gfc_error ("ELEMENTAL prefix in MODULE PROCEDURE interface is "
6540 "missing at %L", where
);
6544 if (dest
->pure
&& !current_attr
.pure
)
6546 gfc_error ("PURE prefix in MODULE PROCEDURE interface is "
6547 "missing at %L", where
);
6551 if (dest
->recursive
&& !current_attr
.recursive
)
6553 gfc_error ("RECURSIVE prefix in MODULE PROCEDURE interface is "
6554 "missing at %L", where
);
6561 if (current_attr
.elemental
&& !gfc_add_elemental (dest
, where
))
6564 if (current_attr
.pure
&& !gfc_add_pure (dest
, where
))
6567 if (current_attr
.recursive
&& !gfc_add_recursive (dest
, where
))
6574 /* Match a formal argument list or, if typeparam is true, a
6575 type_param_name_list. */
6578 gfc_match_formal_arglist (gfc_symbol
*progname
, int st_flag
,
6579 int null_flag
, bool typeparam
)
6581 gfc_formal_arglist
*head
, *tail
, *p
, *q
;
6582 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6585 gfc_formal_arglist
*formal
= NULL
;
6589 /* Keep the interface formal argument list and null it so that the
6590 matching for the new declaration can be done. The numbers and
6591 names of the arguments are checked here. The interface formal
6592 arguments are retained in formal_arglist and the characteristics
6593 are compared in resolve.c(resolve_fl_procedure). See the remark
6594 in get_proc_name about the eventual need to copy the formal_arglist
6595 and populate the formal namespace of the interface symbol. */
6596 if (progname
->attr
.module_procedure
6597 && progname
->attr
.host_assoc
)
6599 formal
= progname
->formal
;
6600 progname
->formal
= NULL
;
6603 if (gfc_match_char ('(') != MATCH_YES
)
6610 if (gfc_match_char (')') == MATCH_YES
)
6614 gfc_error_now ("A type parameter list is required at %C");
6624 if (gfc_match_char ('*') == MATCH_YES
)
6627 if (!typeparam
&& !gfc_notify_std (GFC_STD_F95_OBS
,
6628 "Alternate-return argument at %C"))
6634 gfc_error_now ("A parameter name is required at %C");
6638 m
= gfc_match_name (name
);
6642 gfc_error_now ("A parameter name is required at %C");
6646 if (!typeparam
&& gfc_get_symbol (name
, NULL
, &sym
))
6649 && gfc_get_symbol (name
, progname
->f2k_derived
, &sym
))
6653 p
= gfc_get_formal_arglist ();
6665 /* We don't add the VARIABLE flavor because the name could be a
6666 dummy procedure. We don't apply these attributes to formal
6667 arguments of statement functions. */
6668 if (sym
!= NULL
&& !st_flag
6669 && (!gfc_add_dummy(&sym
->attr
, sym
->name
, NULL
)
6670 || !gfc_missing_attr (&sym
->attr
, NULL
)))
6676 /* The name of a program unit can be in a different namespace,
6677 so check for it explicitly. After the statement is accepted,
6678 the name is checked for especially in gfc_get_symbol(). */
6679 if (gfc_new_block
!= NULL
&& sym
!= NULL
&& !typeparam
6680 && strcmp (sym
->name
, gfc_new_block
->name
) == 0)
6682 gfc_error ("Name %qs at %C is the name of the procedure",
6688 if (gfc_match_char (')') == MATCH_YES
)
6691 m
= gfc_match_char (',');
6695 gfc_error_now ("Expected parameter list in type declaration "
6698 gfc_error ("Unexpected junk in formal argument list at %C");
6704 /* Check for duplicate symbols in the formal argument list. */
6707 for (p
= head
; p
->next
; p
= p
->next
)
6712 for (q
= p
->next
; q
; q
= q
->next
)
6713 if (p
->sym
== q
->sym
)
6716 gfc_error_now ("Duplicate name %qs in parameter "
6717 "list at %C", p
->sym
->name
);
6719 gfc_error ("Duplicate symbol %qs in formal argument "
6720 "list at %C", p
->sym
->name
);
6728 if (!gfc_add_explicit_interface (progname
, IFSRC_DECL
, head
, NULL
))
6734 /* gfc_error_now used in following and return with MATCH_YES because
6735 doing otherwise results in a cascade of extraneous errors and in
6736 some cases an ICE in symbol.c(gfc_release_symbol). */
6737 if (progname
->attr
.module_procedure
&& progname
->attr
.host_assoc
)
6739 bool arg_count_mismatch
= false;
6741 if (!formal
&& head
)
6742 arg_count_mismatch
= true;
6744 /* Abbreviated module procedure declaration is not meant to have any
6745 formal arguments! */
6746 if (!progname
->abr_modproc_decl
&& formal
&& !head
)
6747 arg_count_mismatch
= true;
6749 for (p
= formal
, q
= head
; p
&& q
; p
= p
->next
, q
= q
->next
)
6751 if ((p
->next
!= NULL
&& q
->next
== NULL
)
6752 || (p
->next
== NULL
&& q
->next
!= NULL
))
6753 arg_count_mismatch
= true;
6754 else if ((p
->sym
== NULL
&& q
->sym
== NULL
)
6755 || strcmp (p
->sym
->name
, q
->sym
->name
) == 0)
6758 gfc_error_now ("Mismatch in MODULE PROCEDURE formal "
6759 "argument names (%s/%s) at %C",
6760 p
->sym
->name
, q
->sym
->name
);
6763 if (arg_count_mismatch
)
6764 gfc_error_now ("Mismatch in number of MODULE PROCEDURE "
6765 "formal arguments at %C");
6771 gfc_free_formal_arglist (head
);
6776 /* Match a RESULT specification following a function declaration or
6777 ENTRY statement. Also matches the end-of-statement. */
6780 match_result (gfc_symbol
*function
, gfc_symbol
**result
)
6782 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6786 if (gfc_match (" result (") != MATCH_YES
)
6789 m
= gfc_match_name (name
);
6793 /* Get the right paren, and that's it because there could be the
6794 bind(c) attribute after the result clause. */
6795 if (gfc_match_char (')') != MATCH_YES
)
6797 /* TODO: should report the missing right paren here. */
6801 if (strcmp (function
->name
, name
) == 0)
6803 gfc_error ("RESULT variable at %C must be different than function name");
6807 if (gfc_get_symbol (name
, NULL
, &r
))
6810 if (!gfc_add_result (&r
->attr
, r
->name
, NULL
))
6819 /* Match a function suffix, which could be a combination of a result
6820 clause and BIND(C), either one, or neither. The draft does not
6821 require them to come in a specific order. */
6824 gfc_match_suffix (gfc_symbol
*sym
, gfc_symbol
**result
)
6826 match is_bind_c
; /* Found bind(c). */
6827 match is_result
; /* Found result clause. */
6828 match found_match
; /* Status of whether we've found a good match. */
6829 char peek_char
; /* Character we're going to peek at. */
6830 bool allow_binding_name
;
6832 /* Initialize to having found nothing. */
6833 found_match
= MATCH_NO
;
6834 is_bind_c
= MATCH_NO
;
6835 is_result
= MATCH_NO
;
6837 /* Get the next char to narrow between result and bind(c). */
6838 gfc_gobble_whitespace ();
6839 peek_char
= gfc_peek_ascii_char ();
6841 /* C binding names are not allowed for internal procedures. */
6842 if (gfc_current_state () == COMP_CONTAINS
6843 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
6844 allow_binding_name
= false;
6846 allow_binding_name
= true;
6851 /* Look for result clause. */
6852 is_result
= match_result (sym
, result
);
6853 if (is_result
== MATCH_YES
)
6855 /* Now see if there is a bind(c) after it. */
6856 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
6857 /* We've found the result clause and possibly bind(c). */
6858 found_match
= MATCH_YES
;
6861 /* This should only be MATCH_ERROR. */
6862 found_match
= is_result
;
6865 /* Look for bind(c) first. */
6866 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
6867 if (is_bind_c
== MATCH_YES
)
6869 /* Now see if a result clause followed it. */
6870 is_result
= match_result (sym
, result
);
6871 found_match
= MATCH_YES
;
6875 /* Should only be a MATCH_ERROR if we get here after seeing 'b'. */
6876 found_match
= MATCH_ERROR
;
6880 gfc_error ("Unexpected junk after function declaration at %C");
6881 found_match
= MATCH_ERROR
;
6885 if (is_bind_c
== MATCH_YES
)
6887 /* Fortran 2008 draft allows BIND(C) for internal procedures. */
6888 if (gfc_current_state () == COMP_CONTAINS
6889 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
6890 && !gfc_notify_std (GFC_STD_F2008
, "BIND(C) attribute "
6891 "at %L may not be specified for an internal "
6892 "procedure", &gfc_current_locus
))
6895 if (!gfc_add_is_bind_c (&(sym
->attr
), sym
->name
, &gfc_current_locus
, 1))
6903 /* Procedure pointer return value without RESULT statement:
6904 Add "hidden" result variable named "ppr@". */
6907 add_hidden_procptr_result (gfc_symbol
*sym
)
6911 if (gfc_notification_std (GFC_STD_F2003
) == ERROR
)
6914 /* First usage case: PROCEDURE and EXTERNAL statements. */
6915 case1
= gfc_current_state () == COMP_FUNCTION
&& gfc_current_block ()
6916 && strcmp (gfc_current_block ()->name
, sym
->name
) == 0
6917 && sym
->attr
.external
;
6918 /* Second usage case: INTERFACE statements. */
6919 case2
= gfc_current_state () == COMP_INTERFACE
&& gfc_state_stack
->previous
6920 && gfc_state_stack
->previous
->state
== COMP_FUNCTION
6921 && strcmp (gfc_state_stack
->previous
->sym
->name
, sym
->name
) == 0;
6927 gfc_get_sym_tree ("ppr@", gfc_current_ns
, &stree
, false);
6931 gfc_get_sym_tree ("ppr@", gfc_current_ns
->parent
, &stree
, false);
6932 st2
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "ppr@");
6933 st2
->n
.sym
= stree
->n
.sym
;
6934 stree
->n
.sym
->refs
++;
6936 sym
->result
= stree
->n
.sym
;
6938 sym
->result
->attr
.proc_pointer
= sym
->attr
.proc_pointer
;
6939 sym
->result
->attr
.pointer
= sym
->attr
.pointer
;
6940 sym
->result
->attr
.external
= sym
->attr
.external
;
6941 sym
->result
->attr
.referenced
= sym
->attr
.referenced
;
6942 sym
->result
->ts
= sym
->ts
;
6943 sym
->attr
.proc_pointer
= 0;
6944 sym
->attr
.pointer
= 0;
6945 sym
->attr
.external
= 0;
6946 if (sym
->result
->attr
.external
&& sym
->result
->attr
.pointer
)
6948 sym
->result
->attr
.pointer
= 0;
6949 sym
->result
->attr
.proc_pointer
= 1;
6952 return gfc_add_result (&sym
->result
->attr
, sym
->result
->name
, NULL
);
6954 /* POINTER after PROCEDURE/EXTERNAL/INTERFACE statement. */
6955 else if (sym
->attr
.function
&& !sym
->attr
.external
&& sym
->attr
.pointer
6956 && sym
->result
&& sym
->result
!= sym
&& sym
->result
->attr
.external
6957 && sym
== gfc_current_ns
->proc_name
6958 && sym
== sym
->result
->ns
->proc_name
6959 && strcmp ("ppr@", sym
->result
->name
) == 0)
6961 sym
->result
->attr
.proc_pointer
= 1;
6962 sym
->attr
.pointer
= 0;
6970 /* Match the interface for a PROCEDURE declaration,
6971 including brackets (R1212). */
6974 match_procedure_interface (gfc_symbol
**proc_if
)
6978 locus old_loc
, entry_loc
;
6979 gfc_namespace
*old_ns
= gfc_current_ns
;
6980 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6982 old_loc
= entry_loc
= gfc_current_locus
;
6983 gfc_clear_ts (¤t_ts
);
6985 if (gfc_match (" (") != MATCH_YES
)
6987 gfc_current_locus
= entry_loc
;
6991 /* Get the type spec. for the procedure interface. */
6992 old_loc
= gfc_current_locus
;
6993 m
= gfc_match_decl_type_spec (¤t_ts
, 0);
6994 gfc_gobble_whitespace ();
6995 if (m
== MATCH_YES
|| (m
== MATCH_NO
&& gfc_peek_ascii_char () == ')'))
6998 if (m
== MATCH_ERROR
)
7001 /* Procedure interface is itself a procedure. */
7002 gfc_current_locus
= old_loc
;
7003 m
= gfc_match_name (name
);
7005 /* First look to see if it is already accessible in the current
7006 namespace because it is use associated or contained. */
7008 if (gfc_find_sym_tree (name
, NULL
, 0, &st
))
7011 /* If it is still not found, then try the parent namespace, if it
7012 exists and create the symbol there if it is still not found. */
7013 if (gfc_current_ns
->parent
)
7014 gfc_current_ns
= gfc_current_ns
->parent
;
7015 if (st
== NULL
&& gfc_get_ha_sym_tree (name
, &st
))
7018 gfc_current_ns
= old_ns
;
7019 *proc_if
= st
->n
.sym
;
7024 /* Resolve interface if possible. That way, attr.procedure is only set
7025 if it is declared by a later procedure-declaration-stmt, which is
7026 invalid per F08:C1216 (cf. resolve_procedure_interface). */
7027 while ((*proc_if
)->ts
.interface
7028 && *proc_if
!= (*proc_if
)->ts
.interface
)
7029 *proc_if
= (*proc_if
)->ts
.interface
;
7031 if ((*proc_if
)->attr
.flavor
== FL_UNKNOWN
7032 && (*proc_if
)->ts
.type
== BT_UNKNOWN
7033 && !gfc_add_flavor (&(*proc_if
)->attr
, FL_PROCEDURE
,
7034 (*proc_if
)->name
, NULL
))
7039 if (gfc_match (" )") != MATCH_YES
)
7041 gfc_current_locus
= entry_loc
;
7049 /* Match a PROCEDURE declaration (R1211). */
7052 match_procedure_decl (void)
7055 gfc_symbol
*sym
, *proc_if
= NULL
;
7057 gfc_expr
*initializer
= NULL
;
7059 /* Parse interface (with brackets). */
7060 m
= match_procedure_interface (&proc_if
);
7064 /* Parse attributes (with colons). */
7065 m
= match_attr_spec();
7066 if (m
== MATCH_ERROR
)
7069 if (proc_if
&& proc_if
->attr
.is_bind_c
&& !current_attr
.is_bind_c
)
7071 current_attr
.is_bind_c
= 1;
7072 has_name_equals
= 0;
7073 curr_binding_label
= NULL
;
7076 /* Get procedure symbols. */
7079 m
= gfc_match_symbol (&sym
, 0);
7082 else if (m
== MATCH_ERROR
)
7085 /* Add current_attr to the symbol attributes. */
7086 if (!gfc_copy_attr (&sym
->attr
, ¤t_attr
, NULL
))
7089 if (sym
->attr
.is_bind_c
)
7091 /* Check for C1218. */
7092 if (!proc_if
|| !proc_if
->attr
.is_bind_c
)
7094 gfc_error ("BIND(C) attribute at %C requires "
7095 "an interface with BIND(C)");
7098 /* Check for C1217. */
7099 if (has_name_equals
&& sym
->attr
.pointer
)
7101 gfc_error ("BIND(C) procedure with NAME may not have "
7102 "POINTER attribute at %C");
7105 if (has_name_equals
&& sym
->attr
.dummy
)
7107 gfc_error ("Dummy procedure at %C may not have "
7108 "BIND(C) attribute with NAME");
7111 /* Set binding label for BIND(C). */
7112 if (!set_binding_label (&sym
->binding_label
, sym
->name
, num
))
7116 if (!gfc_add_external (&sym
->attr
, NULL
))
7119 if (add_hidden_procptr_result (sym
))
7122 if (!gfc_add_proc (&sym
->attr
, sym
->name
, NULL
))
7125 /* Set interface. */
7126 if (proc_if
!= NULL
)
7128 if (sym
->ts
.type
!= BT_UNKNOWN
)
7130 gfc_error ("Procedure %qs at %L already has basic type of %s",
7131 sym
->name
, &gfc_current_locus
,
7132 gfc_basic_typename (sym
->ts
.type
));
7135 sym
->ts
.interface
= proc_if
;
7136 sym
->attr
.untyped
= 1;
7137 sym
->attr
.if_source
= IFSRC_IFBODY
;
7139 else if (current_ts
.type
!= BT_UNKNOWN
)
7141 if (!gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
7143 sym
->ts
.interface
= gfc_new_symbol ("", gfc_current_ns
);
7144 sym
->ts
.interface
->ts
= current_ts
;
7145 sym
->ts
.interface
->attr
.flavor
= FL_PROCEDURE
;
7146 sym
->ts
.interface
->attr
.function
= 1;
7147 sym
->attr
.function
= 1;
7148 sym
->attr
.if_source
= IFSRC_UNKNOWN
;
7151 if (gfc_match (" =>") == MATCH_YES
)
7153 if (!current_attr
.pointer
)
7155 gfc_error ("Initialization at %C isn't for a pointer variable");
7160 m
= match_pointer_init (&initializer
, 1);
7164 if (!add_init_expr_to_sym (sym
->name
, &initializer
, &gfc_current_locus
))
7169 if (gfc_match_eos () == MATCH_YES
)
7171 if (gfc_match_char (',') != MATCH_YES
)
7176 gfc_error ("Syntax error in PROCEDURE statement at %C");
7180 /* Free stuff up and return. */
7181 gfc_free_expr (initializer
);
7187 match_binding_attributes (gfc_typebound_proc
* ba
, bool generic
, bool ppc
);
7190 /* Match a procedure pointer component declaration (R445). */
7193 match_ppc_decl (void)
7196 gfc_symbol
*proc_if
= NULL
;
7200 gfc_expr
*initializer
= NULL
;
7201 gfc_typebound_proc
* tb
;
7202 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7204 /* Parse interface (with brackets). */
7205 m
= match_procedure_interface (&proc_if
);
7209 /* Parse attributes. */
7210 tb
= XCNEW (gfc_typebound_proc
);
7211 tb
->where
= gfc_current_locus
;
7212 m
= match_binding_attributes (tb
, false, true);
7213 if (m
== MATCH_ERROR
)
7216 gfc_clear_attr (¤t_attr
);
7217 current_attr
.procedure
= 1;
7218 current_attr
.proc_pointer
= 1;
7219 current_attr
.access
= tb
->access
;
7220 current_attr
.flavor
= FL_PROCEDURE
;
7222 /* Match the colons (required). */
7223 if (gfc_match (" ::") != MATCH_YES
)
7225 gfc_error ("Expected %<::%> after binding-attributes at %C");
7229 /* Check for C450. */
7230 if (!tb
->nopass
&& proc_if
== NULL
)
7232 gfc_error("NOPASS or explicit interface required at %C");
7236 if (!gfc_notify_std (GFC_STD_F2003
, "Procedure pointer component at %C"))
7239 /* Match PPC names. */
7243 m
= gfc_match_name (name
);
7246 else if (m
== MATCH_ERROR
)
7249 if (!gfc_add_component (gfc_current_block(), name
, &c
))
7252 /* Add current_attr to the symbol attributes. */
7253 if (!gfc_copy_attr (&c
->attr
, ¤t_attr
, NULL
))
7256 if (!gfc_add_external (&c
->attr
, NULL
))
7259 if (!gfc_add_proc (&c
->attr
, name
, NULL
))
7266 c
->tb
= XCNEW (gfc_typebound_proc
);
7267 c
->tb
->where
= gfc_current_locus
;
7271 /* Set interface. */
7272 if (proc_if
!= NULL
)
7274 c
->ts
.interface
= proc_if
;
7275 c
->attr
.untyped
= 1;
7276 c
->attr
.if_source
= IFSRC_IFBODY
;
7278 else if (ts
.type
!= BT_UNKNOWN
)
7281 c
->ts
.interface
= gfc_new_symbol ("", gfc_current_ns
);
7282 c
->ts
.interface
->result
= c
->ts
.interface
;
7283 c
->ts
.interface
->ts
= ts
;
7284 c
->ts
.interface
->attr
.flavor
= FL_PROCEDURE
;
7285 c
->ts
.interface
->attr
.function
= 1;
7286 c
->attr
.function
= 1;
7287 c
->attr
.if_source
= IFSRC_UNKNOWN
;
7290 if (gfc_match (" =>") == MATCH_YES
)
7292 m
= match_pointer_init (&initializer
, 1);
7295 gfc_free_expr (initializer
);
7298 c
->initializer
= initializer
;
7301 if (gfc_match_eos () == MATCH_YES
)
7303 if (gfc_match_char (',') != MATCH_YES
)
7308 gfc_error ("Syntax error in procedure pointer component at %C");
7313 /* Match a PROCEDURE declaration inside an interface (R1206). */
7316 match_procedure_in_interface (void)
7320 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7323 if (current_interface
.type
== INTERFACE_NAMELESS
7324 || current_interface
.type
== INTERFACE_ABSTRACT
)
7326 gfc_error ("PROCEDURE at %C must be in a generic interface");
7330 /* Check if the F2008 optional double colon appears. */
7331 gfc_gobble_whitespace ();
7332 old_locus
= gfc_current_locus
;
7333 if (gfc_match ("::") == MATCH_YES
)
7335 if (!gfc_notify_std (GFC_STD_F2008
, "double colon in "
7336 "MODULE PROCEDURE statement at %L", &old_locus
))
7340 gfc_current_locus
= old_locus
;
7344 m
= gfc_match_name (name
);
7347 else if (m
== MATCH_ERROR
)
7349 if (gfc_get_symbol (name
, gfc_current_ns
->parent
, &sym
))
7352 if (!gfc_add_interface (sym
))
7355 if (gfc_match_eos () == MATCH_YES
)
7357 if (gfc_match_char (',') != MATCH_YES
)
7364 gfc_error ("Syntax error in PROCEDURE statement at %C");
7369 /* General matcher for PROCEDURE declarations. */
7371 static match
match_procedure_in_type (void);
7374 gfc_match_procedure (void)
7378 switch (gfc_current_state ())
7383 case COMP_SUBMODULE
:
7384 case COMP_SUBROUTINE
:
7387 m
= match_procedure_decl ();
7389 case COMP_INTERFACE
:
7390 m
= match_procedure_in_interface ();
7393 m
= match_ppc_decl ();
7395 case COMP_DERIVED_CONTAINS
:
7396 m
= match_procedure_in_type ();
7405 if (!gfc_notify_std (GFC_STD_F2003
, "PROCEDURE statement at %C"))
7412 /* Warn if a matched procedure has the same name as an intrinsic; this is
7413 simply a wrapper around gfc_warn_intrinsic_shadow that interprets the current
7414 parser-state-stack to find out whether we're in a module. */
7417 do_warn_intrinsic_shadow (const gfc_symbol
* sym
, bool func
)
7421 in_module
= (gfc_state_stack
->previous
7422 && (gfc_state_stack
->previous
->state
== COMP_MODULE
7423 || gfc_state_stack
->previous
->state
== COMP_SUBMODULE
));
7425 gfc_warn_intrinsic_shadow (sym
, in_module
, func
);
7429 /* Match a function declaration. */
7432 gfc_match_function_decl (void)
7434 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7435 gfc_symbol
*sym
, *result
;
7439 match found_match
; /* Status returned by match func. */
7441 if (gfc_current_state () != COMP_NONE
7442 && gfc_current_state () != COMP_INTERFACE
7443 && gfc_current_state () != COMP_CONTAINS
)
7446 gfc_clear_ts (¤t_ts
);
7448 old_loc
= gfc_current_locus
;
7450 m
= gfc_match_prefix (¤t_ts
);
7453 gfc_current_locus
= old_loc
;
7457 if (gfc_match ("function% %n", name
) != MATCH_YES
)
7459 gfc_current_locus
= old_loc
;
7463 if (get_proc_name (name
, &sym
, false))
7466 if (add_hidden_procptr_result (sym
))
7469 if (current_attr
.module_procedure
)
7470 sym
->attr
.module_procedure
= 1;
7472 gfc_new_block
= sym
;
7474 m
= gfc_match_formal_arglist (sym
, 0, 0);
7477 gfc_error ("Expected formal argument list in function "
7478 "definition at %C");
7482 else if (m
== MATCH_ERROR
)
7487 /* According to the draft, the bind(c) and result clause can
7488 come in either order after the formal_arg_list (i.e., either
7489 can be first, both can exist together or by themselves or neither
7490 one). Therefore, the match_result can't match the end of the
7491 string, and check for the bind(c) or result clause in either order. */
7492 found_match
= gfc_match_eos ();
7494 /* Make sure that it isn't already declared as BIND(C). If it is, it
7495 must have been marked BIND(C) with a BIND(C) attribute and that is
7496 not allowed for procedures. */
7497 if (sym
->attr
.is_bind_c
== 1)
7499 sym
->attr
.is_bind_c
= 0;
7501 if (gfc_state_stack
->previous
7502 && gfc_state_stack
->previous
->state
!= COMP_SUBMODULE
)
7505 loc
= sym
->old_symbol
!= NULL
7506 ? sym
->old_symbol
->declared_at
: gfc_current_locus
;
7507 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7508 "variables or common blocks", &loc
);
7512 if (found_match
!= MATCH_YES
)
7514 /* If we haven't found the end-of-statement, look for a suffix. */
7515 suffix_match
= gfc_match_suffix (sym
, &result
);
7516 if (suffix_match
== MATCH_YES
)
7517 /* Need to get the eos now. */
7518 found_match
= gfc_match_eos ();
7520 found_match
= suffix_match
;
7523 /* F2018 C1550 (R1526) If MODULE appears in the prefix of a module
7524 subprogram and a binding label is specified, it shall be the
7525 same as the binding label specified in the corresponding module
7526 procedure interface body. */
7527 if (sym
->attr
.is_bind_c
&& sym
->attr
.module_procedure
&& sym
->old_symbol
7528 && strcmp (sym
->name
, sym
->old_symbol
->name
) == 0
7529 && sym
->binding_label
&& sym
->old_symbol
->binding_label
7530 && strcmp (sym
->binding_label
, sym
->old_symbol
->binding_label
) != 0)
7532 const char *null
= "NULL", *s1
, *s2
;
7533 s1
= sym
->binding_label
;
7535 s2
= sym
->old_symbol
->binding_label
;
7537 gfc_error ("Mismatch in BIND(C) names (%qs/%qs) at %C", s1
, s2
);
7538 sym
->refs
++; /* Needed to avoid an ICE in gfc_release_symbol */
7542 if(found_match
!= MATCH_YES
)
7546 /* Make changes to the symbol. */
7549 if (!gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
7552 if (!gfc_missing_attr (&sym
->attr
, NULL
))
7555 if (!copy_prefix (&sym
->attr
, &sym
->declared_at
))
7557 if(!sym
->attr
.module_procedure
)
7563 /* Delay matching the function characteristics until after the
7564 specification block by signalling kind=-1. */
7565 sym
->declared_at
= old_loc
;
7566 if (current_ts
.type
!= BT_UNKNOWN
)
7567 current_ts
.kind
= -1;
7569 current_ts
.kind
= 0;
7573 if (current_ts
.type
!= BT_UNKNOWN
7574 && !gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
7580 if (current_ts
.type
!= BT_UNKNOWN
7581 && !gfc_add_type (result
, ¤t_ts
, &gfc_current_locus
))
7583 sym
->result
= result
;
7586 /* Warn if this procedure has the same name as an intrinsic. */
7587 do_warn_intrinsic_shadow (sym
, true);
7593 gfc_current_locus
= old_loc
;
7598 /* This is mostly a copy of parse.c(add_global_procedure) but modified to
7599 pass the name of the entry, rather than the gfc_current_block name, and
7600 to return false upon finding an existing global entry. */
7603 add_global_entry (const char *name
, const char *binding_label
, bool sub
,
7607 enum gfc_symbol_type type
;
7609 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
7611 /* Only in Fortran 2003: For procedures with a binding label also the Fortran
7612 name is a global identifier. */
7613 if (!binding_label
|| gfc_notification_std (GFC_STD_F2008
))
7615 s
= gfc_get_gsymbol (name
, false);
7617 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= type
))
7619 gfc_global_used (s
, where
);
7628 s
->ns
= gfc_current_ns
;
7632 /* Don't add the symbol multiple times. */
7634 && (!gfc_notification_std (GFC_STD_F2008
)
7635 || strcmp (name
, binding_label
) != 0))
7637 s
= gfc_get_gsymbol (binding_label
, true);
7639 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= type
))
7641 gfc_global_used (s
, where
);
7648 s
->binding_label
= binding_label
;
7651 s
->ns
= gfc_current_ns
;
7659 /* Match an ENTRY statement. */
7662 gfc_match_entry (void)
7667 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7668 gfc_compile_state state
;
7672 bool module_procedure
;
7676 m
= gfc_match_name (name
);
7680 if (!gfc_notify_std (GFC_STD_F2008_OBS
, "ENTRY statement at %C"))
7683 state
= gfc_current_state ();
7684 if (state
!= COMP_SUBROUTINE
&& state
!= COMP_FUNCTION
)
7689 gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
7692 gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
7694 case COMP_SUBMODULE
:
7695 gfc_error ("ENTRY statement at %C cannot appear within a SUBMODULE");
7697 case COMP_BLOCK_DATA
:
7698 gfc_error ("ENTRY statement at %C cannot appear within "
7701 case COMP_INTERFACE
:
7702 gfc_error ("ENTRY statement at %C cannot appear within "
7705 case COMP_STRUCTURE
:
7706 gfc_error ("ENTRY statement at %C cannot appear within "
7707 "a STRUCTURE block");
7710 gfc_error ("ENTRY statement at %C cannot appear within "
7711 "a DERIVED TYPE block");
7714 gfc_error ("ENTRY statement at %C cannot appear within "
7715 "an IF-THEN block");
7718 case COMP_DO_CONCURRENT
:
7719 gfc_error ("ENTRY statement at %C cannot appear within "
7723 gfc_error ("ENTRY statement at %C cannot appear within "
7727 gfc_error ("ENTRY statement at %C cannot appear within "
7731 gfc_error ("ENTRY statement at %C cannot appear within "
7735 gfc_error ("ENTRY statement at %C cannot appear within "
7736 "a contained subprogram");
7739 gfc_error ("Unexpected ENTRY statement at %C");
7744 if ((state
== COMP_SUBROUTINE
|| state
== COMP_FUNCTION
)
7745 && gfc_state_stack
->previous
->state
== COMP_INTERFACE
)
7747 gfc_error ("ENTRY statement at %C cannot appear within an INTERFACE");
7751 module_procedure
= gfc_current_ns
->parent
!= NULL
7752 && gfc_current_ns
->parent
->proc_name
7753 && gfc_current_ns
->parent
->proc_name
->attr
.flavor
7756 if (gfc_current_ns
->parent
!= NULL
7757 && gfc_current_ns
->parent
->proc_name
7758 && !module_procedure
)
7760 gfc_error("ENTRY statement at %C cannot appear in a "
7761 "contained procedure");
7765 /* Module function entries need special care in get_proc_name
7766 because previous references within the function will have
7767 created symbols attached to the current namespace. */
7768 if (get_proc_name (name
, &entry
,
7769 gfc_current_ns
->parent
!= NULL
7770 && module_procedure
))
7773 proc
= gfc_current_block ();
7775 /* Make sure that it isn't already declared as BIND(C). If it is, it
7776 must have been marked BIND(C) with a BIND(C) attribute and that is
7777 not allowed for procedures. */
7778 if (entry
->attr
.is_bind_c
== 1)
7782 entry
->attr
.is_bind_c
= 0;
7784 loc
= entry
->old_symbol
!= NULL
7785 ? entry
->old_symbol
->declared_at
: gfc_current_locus
;
7786 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7787 "variables or common blocks", &loc
);
7790 /* Check what next non-whitespace character is so we can tell if there
7791 is the required parens if we have a BIND(C). */
7792 old_loc
= gfc_current_locus
;
7793 gfc_gobble_whitespace ();
7794 peek_char
= gfc_peek_ascii_char ();
7796 if (state
== COMP_SUBROUTINE
)
7798 m
= gfc_match_formal_arglist (entry
, 0, 1);
7802 /* Call gfc_match_bind_c with allow_binding_name = true as ENTRY can
7803 never be an internal procedure. */
7804 is_bind_c
= gfc_match_bind_c (entry
, true);
7805 if (is_bind_c
== MATCH_ERROR
)
7807 if (is_bind_c
== MATCH_YES
)
7809 if (peek_char
!= '(')
7811 gfc_error ("Missing required parentheses before BIND(C) at %C");
7815 if (!gfc_add_is_bind_c (&(entry
->attr
), entry
->name
,
7816 &(entry
->declared_at
), 1))
7821 if (!gfc_current_ns
->parent
7822 && !add_global_entry (name
, entry
->binding_label
, true,
7826 /* An entry in a subroutine. */
7827 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
7828 || !gfc_add_subroutine (&entry
->attr
, entry
->name
, NULL
))
7833 /* An entry in a function.
7834 We need to take special care because writing
7839 ENTRY f() RESULT (r)
7841 ENTRY f RESULT (r). */
7842 if (gfc_match_eos () == MATCH_YES
)
7844 gfc_current_locus
= old_loc
;
7845 /* Match the empty argument list, and add the interface to
7847 m
= gfc_match_formal_arglist (entry
, 0, 1);
7850 m
= gfc_match_formal_arglist (entry
, 0, 0);
7857 if (gfc_match_eos () == MATCH_YES
)
7859 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
7860 || !gfc_add_function (&entry
->attr
, entry
->name
, NULL
))
7863 entry
->result
= entry
;
7867 m
= gfc_match_suffix (entry
, &result
);
7869 gfc_syntax_error (ST_ENTRY
);
7875 if (!gfc_add_result (&result
->attr
, result
->name
, NULL
)
7876 || !gfc_add_entry (&entry
->attr
, result
->name
, NULL
)
7877 || !gfc_add_function (&entry
->attr
, result
->name
, NULL
))
7879 entry
->result
= result
;
7883 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
7884 || !gfc_add_function (&entry
->attr
, entry
->name
, NULL
))
7886 entry
->result
= entry
;
7890 if (!gfc_current_ns
->parent
7891 && !add_global_entry (name
, entry
->binding_label
, false,
7896 if (gfc_match_eos () != MATCH_YES
)
7898 gfc_syntax_error (ST_ENTRY
);
7902 /* F2018:C1546 An elemental procedure shall not have the BIND attribute. */
7903 if (proc
->attr
.elemental
&& entry
->attr
.is_bind_c
)
7905 gfc_error ("ENTRY statement at %L with BIND(C) prohibited in an "
7906 "elemental procedure", &entry
->declared_at
);
7910 entry
->attr
.recursive
= proc
->attr
.recursive
;
7911 entry
->attr
.elemental
= proc
->attr
.elemental
;
7912 entry
->attr
.pure
= proc
->attr
.pure
;
7914 el
= gfc_get_entry_list ();
7916 el
->next
= gfc_current_ns
->entries
;
7917 gfc_current_ns
->entries
= el
;
7919 el
->id
= el
->next
->id
+ 1;
7923 new_st
.op
= EXEC_ENTRY
;
7924 new_st
.ext
.entry
= el
;
7930 /* Match a subroutine statement, including optional prefixes. */
7933 gfc_match_subroutine (void)
7935 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7940 bool allow_binding_name
;
7943 if (gfc_current_state () != COMP_NONE
7944 && gfc_current_state () != COMP_INTERFACE
7945 && gfc_current_state () != COMP_CONTAINS
)
7948 m
= gfc_match_prefix (NULL
);
7952 m
= gfc_match ("subroutine% %n", name
);
7956 if (get_proc_name (name
, &sym
, false))
7959 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
7960 the symbol existed before. */
7961 sym
->declared_at
= gfc_current_locus
;
7963 if (current_attr
.module_procedure
)
7964 sym
->attr
.module_procedure
= 1;
7966 if (add_hidden_procptr_result (sym
))
7969 gfc_new_block
= sym
;
7971 /* Check what next non-whitespace character is so we can tell if there
7972 is the required parens if we have a BIND(C). */
7973 gfc_gobble_whitespace ();
7974 peek_char
= gfc_peek_ascii_char ();
7976 if (!gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
))
7979 if (gfc_match_formal_arglist (sym
, 0, 1) != MATCH_YES
)
7982 /* Make sure that it isn't already declared as BIND(C). If it is, it
7983 must have been marked BIND(C) with a BIND(C) attribute and that is
7984 not allowed for procedures. */
7985 if (sym
->attr
.is_bind_c
== 1)
7987 sym
->attr
.is_bind_c
= 0;
7989 if (gfc_state_stack
->previous
7990 && gfc_state_stack
->previous
->state
!= COMP_SUBMODULE
)
7993 loc
= sym
->old_symbol
!= NULL
7994 ? sym
->old_symbol
->declared_at
: gfc_current_locus
;
7995 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7996 "variables or common blocks", &loc
);
8000 /* C binding names are not allowed for internal procedures. */
8001 if (gfc_current_state () == COMP_CONTAINS
8002 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
8003 allow_binding_name
= false;
8005 allow_binding_name
= true;
8007 /* Here, we are just checking if it has the bind(c) attribute, and if
8008 so, then we need to make sure it's all correct. If it doesn't,
8009 we still need to continue matching the rest of the subroutine line. */
8010 gfc_gobble_whitespace ();
8011 loc
= gfc_current_locus
;
8012 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
8013 if (is_bind_c
== MATCH_ERROR
)
8015 /* There was an attempt at the bind(c), but it was wrong. An
8016 error message should have been printed w/in the gfc_match_bind_c
8017 so here we'll just return the MATCH_ERROR. */
8021 if (is_bind_c
== MATCH_YES
)
8023 gfc_formal_arglist
*arg
;
8025 /* The following is allowed in the Fortran 2008 draft. */
8026 if (gfc_current_state () == COMP_CONTAINS
8027 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
8028 && !gfc_notify_std (GFC_STD_F2008
, "BIND(C) attribute "
8029 "at %L may not be specified for an internal "
8030 "procedure", &gfc_current_locus
))
8033 if (peek_char
!= '(')
8035 gfc_error ("Missing required parentheses before BIND(C) at %C");
8039 /* F2018 C1550 (R1526) If MODULE appears in the prefix of a module
8040 subprogram and a binding label is specified, it shall be the
8041 same as the binding label specified in the corresponding module
8042 procedure interface body. */
8043 if (sym
->attr
.module_procedure
&& sym
->old_symbol
8044 && strcmp (sym
->name
, sym
->old_symbol
->name
) == 0
8045 && sym
->binding_label
&& sym
->old_symbol
->binding_label
8046 && strcmp (sym
->binding_label
, sym
->old_symbol
->binding_label
) != 0)
8048 const char *null
= "NULL", *s1
, *s2
;
8049 s1
= sym
->binding_label
;
8051 s2
= sym
->old_symbol
->binding_label
;
8053 gfc_error ("Mismatch in BIND(C) names (%qs/%qs) at %C", s1
, s2
);
8054 sym
->refs
++; /* Needed to avoid an ICE in gfc_release_symbol */
8058 /* Scan the dummy arguments for an alternate return. */
8059 for (arg
= sym
->formal
; arg
; arg
= arg
->next
)
8062 gfc_error ("Alternate return dummy argument cannot appear in a "
8063 "SUBROUTINE with the BIND(C) attribute at %L", &loc
);
8067 if (!gfc_add_is_bind_c (&(sym
->attr
), sym
->name
, &(sym
->declared_at
), 1))
8071 if (gfc_match_eos () != MATCH_YES
)
8073 gfc_syntax_error (ST_SUBROUTINE
);
8077 if (!copy_prefix (&sym
->attr
, &sym
->declared_at
))
8079 if(!sym
->attr
.module_procedure
)
8085 /* Warn if it has the same name as an intrinsic. */
8086 do_warn_intrinsic_shadow (sym
, false);
8092 /* Check that the NAME identifier in a BIND attribute or statement
8093 is conform to C identifier rules. */
8096 check_bind_name_identifier (char **name
)
8098 char *n
= *name
, *p
;
8100 /* Remove leading spaces. */
8104 /* On an empty string, free memory and set name to NULL. */
8112 /* Remove trailing spaces. */
8113 p
= n
+ strlen(n
) - 1;
8117 /* Insert the identifier into the symbol table. */
8122 /* Now check that identifier is valid under C rules. */
8125 gfc_error ("Invalid C identifier in NAME= specifier at %C");
8130 if (!(ISALNUM (*p
) || *p
== '_' || *p
== '$'))
8132 gfc_error ("Invalid C identifier in NAME= specifier at %C");
8140 /* Match a BIND(C) specifier, with the optional 'name=' specifier if
8141 given, and set the binding label in either the given symbol (if not
8142 NULL), or in the current_ts. The symbol may be NULL because we may
8143 encounter the BIND(C) before the declaration itself. Return
8144 MATCH_NO if what we're looking at isn't a BIND(C) specifier,
8145 MATCH_ERROR if it is a BIND(C) clause but an error was encountered,
8146 or MATCH_YES if the specifier was correct and the binding label and
8147 bind(c) fields were set correctly for the given symbol or the
8148 current_ts. If allow_binding_name is false, no binding name may be
8152 gfc_match_bind_c (gfc_symbol
*sym
, bool allow_binding_name
)
8154 char *binding_label
= NULL
;
8157 /* Initialize the flag that specifies whether we encountered a NAME=
8158 specifier or not. */
8159 has_name_equals
= 0;
8161 /* This much we have to be able to match, in this order, if
8162 there is a bind(c) label. */
8163 if (gfc_match (" bind ( c ") != MATCH_YES
)
8166 /* Now see if there is a binding label, or if we've reached the
8167 end of the bind(c) attribute without one. */
8168 if (gfc_match_char (',') == MATCH_YES
)
8170 if (gfc_match (" name = ") != MATCH_YES
)
8172 gfc_error ("Syntax error in NAME= specifier for binding label "
8174 /* should give an error message here */
8178 has_name_equals
= 1;
8180 if (gfc_match_init_expr (&e
) != MATCH_YES
)
8186 if (!gfc_simplify_expr(e
, 0))
8188 gfc_error ("NAME= specifier at %C should be a constant expression");
8193 if (e
->expr_type
!= EXPR_CONSTANT
|| e
->ts
.type
!= BT_CHARACTER
8194 || e
->ts
.kind
!= gfc_default_character_kind
|| e
->rank
!= 0)
8196 gfc_error ("NAME= specifier at %C should be a scalar of "
8197 "default character kind");
8202 // Get a C string from the Fortran string constant
8203 binding_label
= gfc_widechar_to_char (e
->value
.character
.string
,
8204 e
->value
.character
.length
);
8207 // Check that it is valid (old gfc_match_name_C)
8208 if (check_bind_name_identifier (&binding_label
) != MATCH_YES
)
8212 /* Get the required right paren. */
8213 if (gfc_match_char (')') != MATCH_YES
)
8215 gfc_error ("Missing closing paren for binding label at %C");
8219 if (has_name_equals
&& !allow_binding_name
)
8221 gfc_error ("No binding name is allowed in BIND(C) at %C");
8225 if (has_name_equals
&& sym
!= NULL
&& sym
->attr
.dummy
)
8227 gfc_error ("For dummy procedure %s, no binding name is "
8228 "allowed in BIND(C) at %C", sym
->name
);
8233 /* Save the binding label to the symbol. If sym is null, we're
8234 probably matching the typespec attributes of a declaration and
8235 haven't gotten the name yet, and therefore, no symbol yet. */
8239 sym
->binding_label
= binding_label
;
8241 curr_binding_label
= binding_label
;
8243 else if (allow_binding_name
)
8245 /* No binding label, but if symbol isn't null, we
8246 can set the label for it here.
8247 If name="" or allow_binding_name is false, no C binding name is
8249 if (sym
!= NULL
&& sym
->name
!= NULL
&& has_name_equals
== 0)
8250 sym
->binding_label
= IDENTIFIER_POINTER (get_identifier (sym
->name
));
8253 if (has_name_equals
&& gfc_current_state () == COMP_INTERFACE
8254 && current_interface
.type
== INTERFACE_ABSTRACT
)
8256 gfc_error ("NAME not allowed on BIND(C) for ABSTRACT INTERFACE at %C");
8264 /* Return nonzero if we're currently compiling a contained procedure. */
8267 contained_procedure (void)
8269 gfc_state_data
*s
= gfc_state_stack
;
8271 if ((s
->state
== COMP_SUBROUTINE
|| s
->state
== COMP_FUNCTION
)
8272 && s
->previous
!= NULL
&& s
->previous
->state
== COMP_CONTAINS
)
8278 /* Set the kind of each enumerator. The kind is selected such that it is
8279 interoperable with the corresponding C enumeration type, making
8280 sure that -fshort-enums is honored. */
8285 enumerator_history
*current_history
= NULL
;
8289 if (max_enum
== NULL
|| enum_history
== NULL
)
8292 if (!flag_short_enums
)
8298 kind
= gfc_integer_kinds
[i
++].kind
;
8300 while (kind
< gfc_c_int_kind
8301 && gfc_check_integer_range (max_enum
->initializer
->value
.integer
,
8304 current_history
= enum_history
;
8305 while (current_history
!= NULL
)
8307 current_history
->sym
->ts
.kind
= kind
;
8308 current_history
= current_history
->next
;
8313 /* Match any of the various end-block statements. Returns the type of
8314 END to the caller. The END INTERFACE, END IF, END DO, END SELECT
8315 and END BLOCK statements cannot be replaced by a single END statement. */
8318 gfc_match_end (gfc_statement
*st
)
8320 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8321 gfc_compile_state state
;
8323 const char *block_name
;
8327 gfc_namespace
*parent_ns
, *ns
, *prev_ns
;
8328 gfc_namespace
**nsp
;
8329 bool abreviated_modproc_decl
= false;
8330 bool got_matching_end
= false;
8332 old_loc
= gfc_current_locus
;
8333 if (gfc_match ("end") != MATCH_YES
)
8336 state
= gfc_current_state ();
8337 block_name
= gfc_current_block () == NULL
8338 ? NULL
: gfc_current_block ()->name
;
8342 case COMP_ASSOCIATE
:
8344 if (startswith (block_name
, "block@"))
8349 case COMP_DERIVED_CONTAINS
:
8350 state
= gfc_state_stack
->previous
->state
;
8351 block_name
= gfc_state_stack
->previous
->sym
== NULL
8352 ? NULL
: gfc_state_stack
->previous
->sym
->name
;
8353 abreviated_modproc_decl
= gfc_state_stack
->previous
->sym
8354 && gfc_state_stack
->previous
->sym
->abr_modproc_decl
;
8361 if (!abreviated_modproc_decl
)
8362 abreviated_modproc_decl
= gfc_current_block ()
8363 && gfc_current_block ()->abr_modproc_decl
;
8369 *st
= ST_END_PROGRAM
;
8370 target
= " program";
8374 case COMP_SUBROUTINE
:
8375 *st
= ST_END_SUBROUTINE
;
8376 if (!abreviated_modproc_decl
)
8377 target
= " subroutine";
8379 target
= " procedure";
8380 eos_ok
= !contained_procedure ();
8384 *st
= ST_END_FUNCTION
;
8385 if (!abreviated_modproc_decl
)
8386 target
= " function";
8388 target
= " procedure";
8389 eos_ok
= !contained_procedure ();
8392 case COMP_BLOCK_DATA
:
8393 *st
= ST_END_BLOCK_DATA
;
8394 target
= " block data";
8399 *st
= ST_END_MODULE
;
8404 case COMP_SUBMODULE
:
8405 *st
= ST_END_SUBMODULE
;
8406 target
= " submodule";
8410 case COMP_INTERFACE
:
8411 *st
= ST_END_INTERFACE
;
8412 target
= " interface";
8428 case COMP_STRUCTURE
:
8429 *st
= ST_END_STRUCTURE
;
8430 target
= " structure";
8435 case COMP_DERIVED_CONTAINS
:
8441 case COMP_ASSOCIATE
:
8442 *st
= ST_END_ASSOCIATE
;
8443 target
= " associate";
8460 case COMP_DO_CONCURRENT
:
8467 *st
= ST_END_CRITICAL
;
8468 target
= " critical";
8473 case COMP_SELECT_TYPE
:
8474 case COMP_SELECT_RANK
:
8475 *st
= ST_END_SELECT
;
8481 *st
= ST_END_FORALL
;
8496 last_initializer
= NULL
;
8498 gfc_free_enum_history ();
8502 gfc_error ("Unexpected END statement at %C");
8506 old_loc
= gfc_current_locus
;
8507 if (gfc_match_eos () == MATCH_YES
)
8509 if (!eos_ok
&& (*st
== ST_END_SUBROUTINE
|| *st
== ST_END_FUNCTION
))
8511 if (!gfc_notify_std (GFC_STD_F2008
, "END statement "
8512 "instead of %s statement at %L",
8513 abreviated_modproc_decl
? "END PROCEDURE"
8514 : gfc_ascii_statement(*st
), &old_loc
))
8519 /* We would have required END [something]. */
8520 gfc_error ("%s statement expected at %L",
8521 gfc_ascii_statement (*st
), &old_loc
);
8528 /* Verify that we've got the sort of end-block that we're expecting. */
8529 if (gfc_match (target
) != MATCH_YES
)
8531 gfc_error ("Expecting %s statement at %L", abreviated_modproc_decl
8532 ? "END PROCEDURE" : gfc_ascii_statement(*st
), &old_loc
);
8536 got_matching_end
= true;
8538 old_loc
= gfc_current_locus
;
8539 /* If we're at the end, make sure a block name wasn't required. */
8540 if (gfc_match_eos () == MATCH_YES
)
8543 if (*st
!= ST_ENDDO
&& *st
!= ST_ENDIF
&& *st
!= ST_END_SELECT
8544 && *st
!= ST_END_FORALL
&& *st
!= ST_END_WHERE
&& *st
!= ST_END_BLOCK
8545 && *st
!= ST_END_ASSOCIATE
&& *st
!= ST_END_CRITICAL
)
8551 gfc_error ("Expected block name of %qs in %s statement at %L",
8552 block_name
, gfc_ascii_statement (*st
), &old_loc
);
8557 /* END INTERFACE has a special handler for its several possible endings. */
8558 if (*st
== ST_END_INTERFACE
)
8559 return gfc_match_end_interface ();
8561 /* We haven't hit the end of statement, so what is left must be an
8563 m
= gfc_match_space ();
8565 m
= gfc_match_name (name
);
8568 gfc_error ("Expected terminating name at %C");
8572 if (block_name
== NULL
)
8575 /* We have to pick out the declared submodule name from the composite
8576 required by F2008:11.2.3 para 2, which ends in the declared name. */
8577 if (state
== COMP_SUBMODULE
)
8578 block_name
= strchr (block_name
, '.') + 1;
8580 if (strcmp (name
, block_name
) != 0 && strcmp (block_name
, "ppr@") != 0)
8582 gfc_error ("Expected label %qs for %s statement at %C", block_name
,
8583 gfc_ascii_statement (*st
));
8586 /* Procedure pointer as function result. */
8587 else if (strcmp (block_name
, "ppr@") == 0
8588 && strcmp (name
, gfc_current_block ()->ns
->proc_name
->name
) != 0)
8590 gfc_error ("Expected label %qs for %s statement at %C",
8591 gfc_current_block ()->ns
->proc_name
->name
,
8592 gfc_ascii_statement (*st
));
8596 if (gfc_match_eos () == MATCH_YES
)
8600 gfc_syntax_error (*st
);
8603 gfc_current_locus
= old_loc
;
8605 /* If we are missing an END BLOCK, we created a half-ready namespace.
8606 Remove it from the parent namespace's sibling list. */
8608 while (state
== COMP_BLOCK
&& !got_matching_end
)
8610 parent_ns
= gfc_current_ns
->parent
;
8612 nsp
= &(gfc_state_stack
->previous
->tail
->ext
.block
.ns
);
8618 if (ns
== gfc_current_ns
)
8620 if (prev_ns
== NULL
)
8623 prev_ns
->sibling
= ns
->sibling
;
8629 gfc_free_namespace (gfc_current_ns
);
8630 gfc_current_ns
= parent_ns
;
8631 gfc_state_stack
= gfc_state_stack
->previous
;
8632 state
= gfc_current_state ();
8640 /***************** Attribute declaration statements ****************/
8642 /* Set the attribute of a single variable. */
8647 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8650 /* Workaround -Wmaybe-uninitialized false positive during
8651 profiledbootstrap by initializing them. */
8652 gfc_symbol
*sym
= NULL
;
8658 m
= gfc_match_name (name
);
8662 if (find_special (name
, &sym
, false))
8665 if (!check_function_name (name
))
8671 var_locus
= gfc_current_locus
;
8673 /* Deal with possible array specification for certain attributes. */
8674 if (current_attr
.dimension
8675 || current_attr
.codimension
8676 || current_attr
.allocatable
8677 || current_attr
.pointer
8678 || current_attr
.target
)
8680 m
= gfc_match_array_spec (&as
, !current_attr
.codimension
,
8681 !current_attr
.dimension
8682 && !current_attr
.pointer
8683 && !current_attr
.target
);
8684 if (m
== MATCH_ERROR
)
8687 if (current_attr
.dimension
&& m
== MATCH_NO
)
8689 gfc_error ("Missing array specification at %L in DIMENSION "
8690 "statement", &var_locus
);
8695 if (current_attr
.dimension
&& sym
->value
)
8697 gfc_error ("Dimensions specified for %s at %L after its "
8698 "initialization", sym
->name
, &var_locus
);
8703 if (current_attr
.codimension
&& m
== MATCH_NO
)
8705 gfc_error ("Missing array specification at %L in CODIMENSION "
8706 "statement", &var_locus
);
8711 if ((current_attr
.allocatable
|| current_attr
.pointer
)
8712 && (m
== MATCH_YES
) && (as
->type
!= AS_DEFERRED
))
8714 gfc_error ("Array specification must be deferred at %L", &var_locus
);
8720 /* Update symbol table. DIMENSION attribute is set in
8721 gfc_set_array_spec(). For CLASS variables, this must be applied
8722 to the first component, or '_data' field. */
8723 if (sym
->ts
.type
== BT_CLASS
&& sym
->ts
.u
.derived
->attr
.is_class
)
8725 /* gfc_set_array_spec sets sym->attr not CLASS_DATA(sym)->attr. Check
8726 for duplicate attribute here. */
8727 if (CLASS_DATA(sym
)->attr
.dimension
== 1 && as
)
8729 gfc_error ("Duplicate DIMENSION attribute at %C");
8734 if (!gfc_copy_attr (&CLASS_DATA(sym
)->attr
, ¤t_attr
, &var_locus
))
8742 if (current_attr
.dimension
== 0 && current_attr
.codimension
== 0
8743 && !gfc_copy_attr (&sym
->attr
, ¤t_attr
, &var_locus
))
8750 if (sym
->ts
.type
== BT_CLASS
8751 && !gfc_build_class_symbol (&sym
->ts
, &sym
->attr
, &sym
->as
))
8757 if (!gfc_set_array_spec (sym
, as
, &var_locus
))
8763 if (sym
->attr
.cray_pointee
&& sym
->as
!= NULL
)
8765 /* Fix the array spec. */
8766 m
= gfc_mod_pointee_as (sym
->as
);
8767 if (m
== MATCH_ERROR
)
8771 if (!gfc_add_attribute (&sym
->attr
, &var_locus
))
8777 if ((current_attr
.external
|| current_attr
.intrinsic
)
8778 && sym
->attr
.flavor
!= FL_PROCEDURE
8779 && !gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, NULL
))
8785 add_hidden_procptr_result (sym
);
8790 gfc_free_array_spec (as
);
8795 /* Generic attribute declaration subroutine. Used for attributes that
8796 just have a list of names. */
8803 /* Gobble the optional double colon, by simply ignoring the result
8813 if (gfc_match_eos () == MATCH_YES
)
8819 if (gfc_match_char (',') != MATCH_YES
)
8821 gfc_error ("Unexpected character in variable list at %C");
8831 /* This routine matches Cray Pointer declarations of the form:
8832 pointer ( <pointer>, <pointee> )
8834 pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...
8835 The pointer, if already declared, should be an integer. Otherwise, we
8836 set it as BT_INTEGER with kind gfc_index_integer_kind. The pointee may
8837 be either a scalar, or an array declaration. No space is allocated for
8838 the pointee. For the statement
8839 pointer (ipt, ar(10))
8840 any subsequent uses of ar will be translated (in C-notation) as
8841 ar(i) => ((<type> *) ipt)(i)
8842 After gimplification, pointee variable will disappear in the code. */
8845 cray_pointer_decl (void)
8848 gfc_array_spec
*as
= NULL
;
8849 gfc_symbol
*cptr
; /* Pointer symbol. */
8850 gfc_symbol
*cpte
; /* Pointee symbol. */
8856 if (gfc_match_char ('(') != MATCH_YES
)
8858 gfc_error ("Expected %<(%> at %C");
8862 /* Match pointer. */
8863 var_locus
= gfc_current_locus
;
8864 gfc_clear_attr (¤t_attr
);
8865 gfc_add_cray_pointer (¤t_attr
, &var_locus
);
8866 current_ts
.type
= BT_INTEGER
;
8867 current_ts
.kind
= gfc_index_integer_kind
;
8869 m
= gfc_match_symbol (&cptr
, 0);
8872 gfc_error ("Expected variable name at %C");
8876 if (!gfc_add_cray_pointer (&cptr
->attr
, &var_locus
))
8879 gfc_set_sym_referenced (cptr
);
8881 if (cptr
->ts
.type
== BT_UNKNOWN
) /* Override the type, if necessary. */
8883 cptr
->ts
.type
= BT_INTEGER
;
8884 cptr
->ts
.kind
= gfc_index_integer_kind
;
8886 else if (cptr
->ts
.type
!= BT_INTEGER
)
8888 gfc_error ("Cray pointer at %C must be an integer");
8891 else if (cptr
->ts
.kind
< gfc_index_integer_kind
)
8892 gfc_warning (0, "Cray pointer at %C has %d bytes of precision;"
8893 " memory addresses require %d bytes",
8894 cptr
->ts
.kind
, gfc_index_integer_kind
);
8896 if (gfc_match_char (',') != MATCH_YES
)
8898 gfc_error ("Expected \",\" at %C");
8902 /* Match Pointee. */
8903 var_locus
= gfc_current_locus
;
8904 gfc_clear_attr (¤t_attr
);
8905 gfc_add_cray_pointee (¤t_attr
, &var_locus
);
8906 current_ts
.type
= BT_UNKNOWN
;
8907 current_ts
.kind
= 0;
8909 m
= gfc_match_symbol (&cpte
, 0);
8912 gfc_error ("Expected variable name at %C");
8916 /* Check for an optional array spec. */
8917 m
= gfc_match_array_spec (&as
, true, false);
8918 if (m
== MATCH_ERROR
)
8920 gfc_free_array_spec (as
);
8923 else if (m
== MATCH_NO
)
8925 gfc_free_array_spec (as
);
8929 if (!gfc_add_cray_pointee (&cpte
->attr
, &var_locus
))
8932 gfc_set_sym_referenced (cpte
);
8934 if (cpte
->as
== NULL
)
8936 if (!gfc_set_array_spec (cpte
, as
, &var_locus
))
8937 gfc_internal_error ("Cannot set Cray pointee array spec.");
8939 else if (as
!= NULL
)
8941 gfc_error ("Duplicate array spec for Cray pointee at %C");
8942 gfc_free_array_spec (as
);
8948 if (cpte
->as
!= NULL
)
8950 /* Fix array spec. */
8951 m
= gfc_mod_pointee_as (cpte
->as
);
8952 if (m
== MATCH_ERROR
)
8956 /* Point the Pointee at the Pointer. */
8957 cpte
->cp_pointer
= cptr
;
8959 if (gfc_match_char (')') != MATCH_YES
)
8961 gfc_error ("Expected \")\" at %C");
8964 m
= gfc_match_char (',');
8966 done
= true; /* Stop searching for more declarations. */
8970 if (m
== MATCH_ERROR
/* Failed when trying to find ',' above. */
8971 || gfc_match_eos () != MATCH_YES
)
8973 gfc_error ("Expected %<,%> or end of statement at %C");
8981 gfc_match_external (void)
8984 gfc_clear_attr (¤t_attr
);
8985 current_attr
.external
= 1;
8987 return attr_decl ();
8992 gfc_match_intent (void)
8996 /* This is not allowed within a BLOCK construct! */
8997 if (gfc_current_state () == COMP_BLOCK
)
8999 gfc_error ("INTENT is not allowed inside of BLOCK at %C");
9003 intent
= match_intent_spec ();
9004 if (intent
== INTENT_UNKNOWN
)
9007 gfc_clear_attr (¤t_attr
);
9008 current_attr
.intent
= intent
;
9010 return attr_decl ();
9015 gfc_match_intrinsic (void)
9018 gfc_clear_attr (¤t_attr
);
9019 current_attr
.intrinsic
= 1;
9021 return attr_decl ();
9026 gfc_match_optional (void)
9028 /* This is not allowed within a BLOCK construct! */
9029 if (gfc_current_state () == COMP_BLOCK
)
9031 gfc_error ("OPTIONAL is not allowed inside of BLOCK at %C");
9035 gfc_clear_attr (¤t_attr
);
9036 current_attr
.optional
= 1;
9038 return attr_decl ();
9043 gfc_match_pointer (void)
9045 gfc_gobble_whitespace ();
9046 if (gfc_peek_ascii_char () == '(')
9048 if (!flag_cray_pointer
)
9050 gfc_error ("Cray pointer declaration at %C requires "
9051 "%<-fcray-pointer%> flag");
9054 return cray_pointer_decl ();
9058 gfc_clear_attr (¤t_attr
);
9059 current_attr
.pointer
= 1;
9061 return attr_decl ();
9067 gfc_match_allocatable (void)
9069 gfc_clear_attr (¤t_attr
);
9070 current_attr
.allocatable
= 1;
9072 return attr_decl ();
9077 gfc_match_codimension (void)
9079 gfc_clear_attr (¤t_attr
);
9080 current_attr
.codimension
= 1;
9082 return attr_decl ();
9087 gfc_match_contiguous (void)
9089 if (!gfc_notify_std (GFC_STD_F2008
, "CONTIGUOUS statement at %C"))
9092 gfc_clear_attr (¤t_attr
);
9093 current_attr
.contiguous
= 1;
9095 return attr_decl ();
9100 gfc_match_dimension (void)
9102 gfc_clear_attr (¤t_attr
);
9103 current_attr
.dimension
= 1;
9105 return attr_decl ();
9110 gfc_match_target (void)
9112 gfc_clear_attr (¤t_attr
);
9113 current_attr
.target
= 1;
9115 return attr_decl ();
9119 /* Match the list of entities being specified in a PUBLIC or PRIVATE
9123 access_attr_decl (gfc_statement st
)
9125 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9126 interface_type type
;
9128 gfc_symbol
*sym
, *dt_sym
;
9129 gfc_intrinsic_op op
;
9131 gfc_access access
= (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
9133 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
9138 m
= gfc_match_generic_spec (&type
, name
, &op
);
9141 if (m
== MATCH_ERROR
)
9146 case INTERFACE_NAMELESS
:
9147 case INTERFACE_ABSTRACT
:
9150 case INTERFACE_GENERIC
:
9151 case INTERFACE_DTIO
:
9153 if (gfc_get_symbol (name
, NULL
, &sym
))
9156 if (type
== INTERFACE_DTIO
9157 && gfc_current_ns
->proc_name
9158 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
9159 && sym
->attr
.flavor
== FL_UNKNOWN
)
9160 sym
->attr
.flavor
= FL_PROCEDURE
;
9162 if (!gfc_add_access (&sym
->attr
, access
, sym
->name
, NULL
))
9165 if (sym
->attr
.generic
&& (dt_sym
= gfc_find_dt_in_generic (sym
))
9166 && !gfc_add_access (&dt_sym
->attr
, access
, sym
->name
, NULL
))
9171 case INTERFACE_INTRINSIC_OP
:
9172 if (gfc_current_ns
->operator_access
[op
] == ACCESS_UNKNOWN
)
9174 gfc_intrinsic_op other_op
;
9176 gfc_current_ns
->operator_access
[op
] = access
;
9178 /* Handle the case if there is another op with the same
9179 function, for INTRINSIC_EQ vs. INTRINSIC_EQ_OS and so on. */
9180 other_op
= gfc_equivalent_op (op
);
9182 if (other_op
!= INTRINSIC_NONE
)
9183 gfc_current_ns
->operator_access
[other_op
] = access
;
9187 gfc_error ("Access specification of the %s operator at %C has "
9188 "already been specified", gfc_op2string (op
));
9194 case INTERFACE_USER_OP
:
9195 uop
= gfc_get_uop (name
);
9197 if (uop
->access
== ACCESS_UNKNOWN
)
9199 uop
->access
= access
;
9203 gfc_error ("Access specification of the .%s. operator at %C "
9204 "has already been specified", uop
->name
);
9211 if (gfc_match_char (',') == MATCH_NO
)
9215 if (gfc_match_eos () != MATCH_YES
)
9220 gfc_syntax_error (st
);
9228 gfc_match_protected (void)
9234 /* PROTECTED has already been seen, but must be followed by whitespace
9236 c
= gfc_peek_ascii_char ();
9237 if (!gfc_is_whitespace (c
) && c
!= ':')
9240 if (!gfc_current_ns
->proc_name
9241 || gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
9243 gfc_error ("PROTECTED at %C only allowed in specification "
9244 "part of a module");
9251 if (!gfc_notify_std (GFC_STD_F2003
, "PROTECTED statement at %C"))
9254 /* PROTECTED has an entity-list. */
9255 if (gfc_match_eos () == MATCH_YES
)
9260 m
= gfc_match_symbol (&sym
, 0);
9264 if (!gfc_add_protected (&sym
->attr
, sym
->name
, &gfc_current_locus
))
9276 if (gfc_match_eos () == MATCH_YES
)
9278 if (gfc_match_char (',') != MATCH_YES
)
9285 gfc_error ("Syntax error in PROTECTED statement at %C");
9290 /* The PRIVATE statement is a bit weird in that it can be an attribute
9291 declaration, but also works as a standalone statement inside of a
9292 type declaration or a module. */
9295 gfc_match_private (gfc_statement
*st
)
9297 gfc_state_data
*prev
;
9299 if (gfc_match ("private") != MATCH_YES
)
9302 /* Try matching PRIVATE without an access-list. */
9303 if (gfc_match_eos () == MATCH_YES
)
9305 prev
= gfc_state_stack
->previous
;
9306 if (gfc_current_state () != COMP_MODULE
9307 && !(gfc_current_state () == COMP_DERIVED
9308 && prev
&& prev
->state
== COMP_MODULE
)
9309 && !(gfc_current_state () == COMP_DERIVED_CONTAINS
9310 && prev
->previous
&& prev
->previous
->state
== COMP_MODULE
))
9312 gfc_error ("PRIVATE statement at %C is only allowed in the "
9313 "specification part of a module");
9321 /* At this point in free-form source code, PRIVATE must be followed
9322 by whitespace or ::. */
9323 if (gfc_current_form
== FORM_FREE
)
9325 char c
= gfc_peek_ascii_char ();
9326 if (!gfc_is_whitespace (c
) && c
!= ':')
9330 prev
= gfc_state_stack
->previous
;
9331 if (gfc_current_state () != COMP_MODULE
9332 && !(gfc_current_state () == COMP_DERIVED
9333 && prev
&& prev
->state
== COMP_MODULE
)
9334 && !(gfc_current_state () == COMP_DERIVED_CONTAINS
9335 && prev
->previous
&& prev
->previous
->state
== COMP_MODULE
))
9337 gfc_error ("PRIVATE statement at %C is only allowed in the "
9338 "specification part of a module");
9343 return access_attr_decl (ST_PRIVATE
);
9348 gfc_match_public (gfc_statement
*st
)
9350 if (gfc_match ("public") != MATCH_YES
)
9353 /* Try matching PUBLIC without an access-list. */
9354 if (gfc_match_eos () == MATCH_YES
)
9356 if (gfc_current_state () != COMP_MODULE
)
9358 gfc_error ("PUBLIC statement at %C is only allowed in the "
9359 "specification part of a module");
9367 /* At this point in free-form source code, PUBLIC must be followed
9368 by whitespace or ::. */
9369 if (gfc_current_form
== FORM_FREE
)
9371 char c
= gfc_peek_ascii_char ();
9372 if (!gfc_is_whitespace (c
) && c
!= ':')
9376 if (gfc_current_state () != COMP_MODULE
)
9378 gfc_error ("PUBLIC statement at %C is only allowed in the "
9379 "specification part of a module");
9384 return access_attr_decl (ST_PUBLIC
);
9388 /* Workhorse for gfc_match_parameter. */
9398 m
= gfc_match_symbol (&sym
, 0);
9400 gfc_error ("Expected variable name at %C in PARAMETER statement");
9405 if (gfc_match_char ('=') == MATCH_NO
)
9407 gfc_error ("Expected = sign in PARAMETER statement at %C");
9411 m
= gfc_match_init_expr (&init
);
9413 gfc_error ("Expected expression at %C in PARAMETER statement");
9417 if (sym
->ts
.type
== BT_UNKNOWN
9418 && !gfc_set_default_type (sym
, 1, NULL
))
9424 if (!gfc_check_assign_symbol (sym
, NULL
, init
)
9425 || !gfc_add_flavor (&sym
->attr
, FL_PARAMETER
, sym
->name
, NULL
))
9433 gfc_error ("Initializing already initialized variable at %C");
9438 t
= add_init_expr_to_sym (sym
->name
, &init
, &gfc_current_locus
);
9439 return (t
) ? MATCH_YES
: MATCH_ERROR
;
9442 gfc_free_expr (init
);
9447 /* Match a parameter statement, with the weird syntax that these have. */
9450 gfc_match_parameter (void)
9452 const char *term
= " )%t";
9455 if (gfc_match_char ('(') == MATCH_NO
)
9457 /* With legacy PARAMETER statements, don't expect a terminating ')'. */
9458 if (!gfc_notify_std (GFC_STD_LEGACY
, "PARAMETER without '()' at %C"))
9469 if (gfc_match (term
) == MATCH_YES
)
9472 if (gfc_match_char (',') != MATCH_YES
)
9474 gfc_error ("Unexpected characters in PARAMETER statement at %C");
9485 gfc_match_automatic (void)
9489 bool seen_symbol
= false;
9491 if (!flag_dec_static
)
9493 gfc_error ("%s at %C is a DEC extension, enable with "
9504 m
= gfc_match_symbol (&sym
, 0);
9514 if (!gfc_add_automatic (&sym
->attr
, sym
->name
, &gfc_current_locus
))
9520 if (gfc_match_eos () == MATCH_YES
)
9522 if (gfc_match_char (',') != MATCH_YES
)
9528 gfc_error ("Expected entity-list in AUTOMATIC statement at %C");
9535 gfc_error ("Syntax error in AUTOMATIC statement at %C");
9541 gfc_match_static (void)
9545 bool seen_symbol
= false;
9547 if (!flag_dec_static
)
9549 gfc_error ("%s at %C is a DEC extension, enable with "
9559 m
= gfc_match_symbol (&sym
, 0);
9569 if (!gfc_add_save (&sym
->attr
, SAVE_EXPLICIT
, sym
->name
,
9570 &gfc_current_locus
))
9576 if (gfc_match_eos () == MATCH_YES
)
9578 if (gfc_match_char (',') != MATCH_YES
)
9584 gfc_error ("Expected entity-list in STATIC statement at %C");
9591 gfc_error ("Syntax error in STATIC statement at %C");
9596 /* Save statements have a special syntax. */
9599 gfc_match_save (void)
9601 char n
[GFC_MAX_SYMBOL_LEN
+1];
9606 if (gfc_match_eos () == MATCH_YES
)
9608 if (gfc_current_ns
->seen_save
)
9610 if (!gfc_notify_std (GFC_STD_LEGACY
, "Blanket SAVE statement at %C "
9611 "follows previous SAVE statement"))
9615 gfc_current_ns
->save_all
= gfc_current_ns
->seen_save
= 1;
9619 if (gfc_current_ns
->save_all
)
9621 if (!gfc_notify_std (GFC_STD_LEGACY
, "SAVE statement at %C follows "
9622 "blanket SAVE statement"))
9630 m
= gfc_match_symbol (&sym
, 0);
9634 if (!gfc_add_save (&sym
->attr
, SAVE_EXPLICIT
, sym
->name
,
9635 &gfc_current_locus
))
9646 m
= gfc_match (" / %n /", &n
);
9647 if (m
== MATCH_ERROR
)
9652 c
= gfc_get_common (n
, 0);
9655 gfc_current_ns
->seen_save
= 1;
9658 if (gfc_match_eos () == MATCH_YES
)
9660 if (gfc_match_char (',') != MATCH_YES
)
9667 if (gfc_current_ns
->seen_save
)
9669 gfc_error ("Syntax error in SAVE statement at %C");
9678 gfc_match_value (void)
9683 /* This is not allowed within a BLOCK construct! */
9684 if (gfc_current_state () == COMP_BLOCK
)
9686 gfc_error ("VALUE is not allowed inside of BLOCK at %C");
9690 if (!gfc_notify_std (GFC_STD_F2003
, "VALUE statement at %C"))
9693 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
9698 if (gfc_match_eos () == MATCH_YES
)
9703 m
= gfc_match_symbol (&sym
, 0);
9707 if (!gfc_add_value (&sym
->attr
, sym
->name
, &gfc_current_locus
))
9719 if (gfc_match_eos () == MATCH_YES
)
9721 if (gfc_match_char (',') != MATCH_YES
)
9728 gfc_error ("Syntax error in VALUE statement at %C");
9734 gfc_match_volatile (void)
9740 if (!gfc_notify_std (GFC_STD_F2003
, "VOLATILE statement at %C"))
9743 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
9748 if (gfc_match_eos () == MATCH_YES
)
9753 /* VOLATILE is special because it can be added to host-associated
9754 symbols locally. Except for coarrays. */
9755 m
= gfc_match_symbol (&sym
, 1);
9759 name
= XCNEWVAR (char, strlen (sym
->name
) + 1);
9760 strcpy (name
, sym
->name
);
9761 if (!check_function_name (name
))
9763 /* F2008, C560+C561. VOLATILE for host-/use-associated variable or
9764 for variable in a BLOCK which is defined outside of the BLOCK. */
9765 if (sym
->ns
!= gfc_current_ns
&& sym
->attr
.codimension
)
9767 gfc_error ("Specifying VOLATILE for coarray variable %qs at "
9768 "%C, which is use-/host-associated", sym
->name
);
9771 if (!gfc_add_volatile (&sym
->attr
, sym
->name
, &gfc_current_locus
))
9783 if (gfc_match_eos () == MATCH_YES
)
9785 if (gfc_match_char (',') != MATCH_YES
)
9792 gfc_error ("Syntax error in VOLATILE statement at %C");
9798 gfc_match_asynchronous (void)
9804 if (!gfc_notify_std (GFC_STD_F2003
, "ASYNCHRONOUS statement at %C"))
9807 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
9812 if (gfc_match_eos () == MATCH_YES
)
9817 /* ASYNCHRONOUS is special because it can be added to host-associated
9819 m
= gfc_match_symbol (&sym
, 1);
9823 name
= XCNEWVAR (char, strlen (sym
->name
) + 1);
9824 strcpy (name
, sym
->name
);
9825 if (!check_function_name (name
))
9827 if (!gfc_add_asynchronous (&sym
->attr
, sym
->name
, &gfc_current_locus
))
9839 if (gfc_match_eos () == MATCH_YES
)
9841 if (gfc_match_char (',') != MATCH_YES
)
9848 gfc_error ("Syntax error in ASYNCHRONOUS statement at %C");
9853 /* Match a module procedure statement in a submodule. */
9856 gfc_match_submod_proc (void)
9858 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9859 gfc_symbol
*sym
, *fsym
;
9861 gfc_formal_arglist
*formal
, *head
, *tail
;
9863 if (gfc_current_state () != COMP_CONTAINS
9864 || !(gfc_state_stack
->previous
9865 && (gfc_state_stack
->previous
->state
== COMP_SUBMODULE
9866 || gfc_state_stack
->previous
->state
== COMP_MODULE
)))
9869 m
= gfc_match (" module% procedure% %n", name
);
9873 if (!gfc_notify_std (GFC_STD_F2008
, "MODULE PROCEDURE declaration "
9877 if (get_proc_name (name
, &sym
, false))
9880 /* Make sure that the result field is appropriately filled. */
9881 if (sym
->tlink
&& sym
->tlink
->attr
.function
)
9883 if (sym
->tlink
->result
&& sym
->tlink
->result
!= sym
->tlink
)
9885 sym
->result
= sym
->tlink
->result
;
9886 if (!sym
->result
->attr
.use_assoc
)
9888 gfc_symtree
*st
= gfc_new_symtree (&gfc_current_ns
->sym_root
,
9890 st
->n
.sym
= sym
->result
;
9891 sym
->result
->refs
++;
9898 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
9899 the symbol existed before. */
9900 sym
->declared_at
= gfc_current_locus
;
9902 if (!sym
->attr
.module_procedure
)
9905 /* Signal match_end to expect "end procedure". */
9906 sym
->abr_modproc_decl
= 1;
9908 /* Change from IFSRC_IFBODY coming from the interface declaration. */
9909 sym
->attr
.if_source
= IFSRC_DECL
;
9911 gfc_new_block
= sym
;
9913 /* Make a new formal arglist with the symbols in the procedure
9916 for (formal
= sym
->formal
; formal
&& formal
->sym
; formal
= formal
->next
)
9918 if (formal
== sym
->formal
)
9919 head
= tail
= gfc_get_formal_arglist ();
9922 tail
->next
= gfc_get_formal_arglist ();
9926 if (gfc_copy_dummy_sym (&fsym
, formal
->sym
, 0))
9930 gfc_set_sym_referenced (fsym
);
9933 /* The dummy symbols get cleaned up, when the formal_namespace of the
9934 interface declaration is cleared. This allows us to add the
9935 explicit interface as is done for other type of procedure. */
9936 if (!gfc_add_explicit_interface (sym
, IFSRC_DECL
, head
,
9937 &gfc_current_locus
))
9940 if (gfc_match_eos () != MATCH_YES
)
9942 /* Unset st->n.sym. Note: in reject_statement (), the symbol changes are
9943 undone, such that the st->n.sym->formal points to the original symbol;
9944 if now this namespace is finalized, the formal namespace is freed,
9945 but it might be still needed in the parent namespace. */
9946 gfc_symtree
*st
= gfc_find_symtree (gfc_current_ns
->sym_root
, sym
->name
);
9948 gfc_free_symbol (sym
->tlink
);
9951 gfc_syntax_error (ST_MODULE_PROC
);
9958 gfc_free_formal_arglist (head
);
9963 /* Match a module procedure statement. Note that we have to modify
9964 symbols in the parent's namespace because the current one was there
9965 to receive symbols that are in an interface's formal argument list. */
9968 gfc_match_modproc (void)
9970 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9974 gfc_namespace
*module_ns
;
9975 gfc_interface
*old_interface_head
, *interface
;
9977 if ((gfc_state_stack
->state
!= COMP_INTERFACE
9978 && gfc_state_stack
->state
!= COMP_CONTAINS
)
9979 || gfc_state_stack
->previous
== NULL
9980 || current_interface
.type
== INTERFACE_NAMELESS
9981 || current_interface
.type
== INTERFACE_ABSTRACT
)
9983 gfc_error ("MODULE PROCEDURE at %C must be in a generic module "
9988 module_ns
= gfc_current_ns
->parent
;
9989 for (; module_ns
; module_ns
= module_ns
->parent
)
9990 if (module_ns
->proc_name
->attr
.flavor
== FL_MODULE
9991 || module_ns
->proc_name
->attr
.flavor
== FL_PROGRAM
9992 || (module_ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
9993 && !module_ns
->proc_name
->attr
.contained
))
9996 if (module_ns
== NULL
)
9999 /* Store the current state of the interface. We will need it if we
10000 end up with a syntax error and need to recover. */
10001 old_interface_head
= gfc_current_interface_head ();
10003 /* Check if the F2008 optional double colon appears. */
10004 gfc_gobble_whitespace ();
10005 old_locus
= gfc_current_locus
;
10006 if (gfc_match ("::") == MATCH_YES
)
10008 if (!gfc_notify_std (GFC_STD_F2008
, "double colon in "
10009 "MODULE PROCEDURE statement at %L", &old_locus
))
10010 return MATCH_ERROR
;
10013 gfc_current_locus
= old_locus
;
10018 old_locus
= gfc_current_locus
;
10020 m
= gfc_match_name (name
);
10023 if (m
!= MATCH_YES
)
10024 return MATCH_ERROR
;
10026 /* Check for syntax error before starting to add symbols to the
10027 current namespace. */
10028 if (gfc_match_eos () == MATCH_YES
)
10031 if (!last
&& gfc_match_char (',') != MATCH_YES
)
10034 /* Now we're sure the syntax is valid, we process this item
10036 if (gfc_get_symbol (name
, module_ns
, &sym
))
10037 return MATCH_ERROR
;
10039 if (sym
->attr
.intrinsic
)
10041 gfc_error ("Intrinsic procedure at %L cannot be a MODULE "
10042 "PROCEDURE", &old_locus
);
10043 return MATCH_ERROR
;
10046 if (sym
->attr
.proc
!= PROC_MODULE
10047 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
10048 return MATCH_ERROR
;
10050 if (!gfc_add_interface (sym
))
10051 return MATCH_ERROR
;
10053 sym
->attr
.mod_proc
= 1;
10054 sym
->declared_at
= old_locus
;
10063 /* Restore the previous state of the interface. */
10064 interface
= gfc_current_interface_head ();
10065 gfc_set_current_interface_head (old_interface_head
);
10067 /* Free the new interfaces. */
10068 while (interface
!= old_interface_head
)
10070 gfc_interface
*i
= interface
->next
;
10075 /* And issue a syntax error. */
10076 gfc_syntax_error (ST_MODULE_PROC
);
10077 return MATCH_ERROR
;
10081 /* Check a derived type that is being extended. */
10084 check_extended_derived_type (char *name
)
10086 gfc_symbol
*extended
;
10088 if (gfc_find_symbol (name
, gfc_current_ns
, 1, &extended
))
10090 gfc_error ("Ambiguous symbol in TYPE definition at %C");
10094 extended
= gfc_find_dt_in_generic (extended
);
10099 gfc_error ("Symbol %qs at %C has not been previously defined", name
);
10103 if (extended
->attr
.flavor
!= FL_DERIVED
)
10105 gfc_error ("%qs in EXTENDS expression at %C is not a "
10106 "derived type", name
);
10110 if (extended
->attr
.is_bind_c
)
10112 gfc_error ("%qs cannot be extended at %C because it "
10113 "is BIND(C)", extended
->name
);
10117 if (extended
->attr
.sequence
)
10119 gfc_error ("%qs cannot be extended at %C because it "
10120 "is a SEQUENCE type", extended
->name
);
10128 /* Match the optional attribute specifiers for a type declaration.
10129 Return MATCH_ERROR if an error is encountered in one of the handled
10130 attributes (public, private, bind(c)), MATCH_NO if what's found is
10131 not a handled attribute, and MATCH_YES otherwise. TODO: More error
10132 checking on attribute conflicts needs to be done. */
10135 gfc_get_type_attr_spec (symbol_attribute
*attr
, char *name
)
10137 /* See if the derived type is marked as private. */
10138 if (gfc_match (" , private") == MATCH_YES
)
10140 if (gfc_current_state () != COMP_MODULE
)
10142 gfc_error ("Derived type at %C can only be PRIVATE in the "
10143 "specification part of a module");
10144 return MATCH_ERROR
;
10147 if (!gfc_add_access (attr
, ACCESS_PRIVATE
, NULL
, NULL
))
10148 return MATCH_ERROR
;
10150 else if (gfc_match (" , public") == MATCH_YES
)
10152 if (gfc_current_state () != COMP_MODULE
)
10154 gfc_error ("Derived type at %C can only be PUBLIC in the "
10155 "specification part of a module");
10156 return MATCH_ERROR
;
10159 if (!gfc_add_access (attr
, ACCESS_PUBLIC
, NULL
, NULL
))
10160 return MATCH_ERROR
;
10162 else if (gfc_match (" , bind ( c )") == MATCH_YES
)
10164 /* If the type is defined to be bind(c) it then needs to make
10165 sure that all fields are interoperable. This will
10166 need to be a semantic check on the finished derived type.
10167 See 15.2.3 (lines 9-12) of F2003 draft. */
10168 if (!gfc_add_is_bind_c (attr
, NULL
, &gfc_current_locus
, 0))
10169 return MATCH_ERROR
;
10171 /* TODO: attr conflicts need to be checked, probably in symbol.c. */
10173 else if (gfc_match (" , abstract") == MATCH_YES
)
10175 if (!gfc_notify_std (GFC_STD_F2003
, "ABSTRACT type at %C"))
10176 return MATCH_ERROR
;
10178 if (!gfc_add_abstract (attr
, &gfc_current_locus
))
10179 return MATCH_ERROR
;
10181 else if (name
&& gfc_match (" , extends ( %n )", name
) == MATCH_YES
)
10183 if (!gfc_add_extension (attr
, &gfc_current_locus
))
10184 return MATCH_ERROR
;
10189 /* If we get here, something matched. */
10194 /* Common function for type declaration blocks similar to derived types, such
10195 as STRUCTURES and MAPs. Unlike derived types, a structure type
10196 does NOT have a generic symbol matching the name given by the user.
10197 STRUCTUREs can share names with variables and PARAMETERs so we must allow
10198 for the creation of an independent symbol.
10199 Other parameters are a message to prefix errors with, the name of the new
10200 type to be created, and the flavor to add to the resulting symbol. */
10203 get_struct_decl (const char *name
, sym_flavor fl
, locus
*decl
,
10204 gfc_symbol
**result
)
10209 gcc_assert (name
[0] == (char) TOUPPER (name
[0]));
10214 where
= gfc_current_locus
;
10216 if (gfc_get_symbol (name
, NULL
, &sym
))
10221 gfc_internal_error ("Failed to create structure type '%s' at %C", name
);
10225 if (sym
->components
!= NULL
|| sym
->attr
.zero_comp
)
10227 gfc_error ("Type definition of %qs at %C was already defined at %L",
10228 sym
->name
, &sym
->declared_at
);
10232 sym
->declared_at
= where
;
10234 if (sym
->attr
.flavor
!= fl
10235 && !gfc_add_flavor (&sym
->attr
, fl
, sym
->name
, NULL
))
10238 if (!sym
->hash_value
)
10239 /* Set the hash for the compound name for this type. */
10240 sym
->hash_value
= gfc_hash_value (sym
);
10242 /* Normally the type is expected to have been completely parsed by the time
10243 a field declaration with this type is seen. For unions, maps, and nested
10244 structure declarations, we need to indicate that it is okay that we
10245 haven't seen any components yet. This will be updated after the structure
10246 is fully parsed. */
10247 sym
->attr
.zero_comp
= 0;
10249 /* Structures always act like derived-types with the SEQUENCE attribute */
10250 gfc_add_sequence (&sym
->attr
, sym
->name
, NULL
);
10252 if (result
) *result
= sym
;
10258 /* Match the opening of a MAP block. Like a struct within a union in C;
10259 behaves identical to STRUCTURE blocks. */
10262 gfc_match_map (void)
10264 /* Counter used to give unique internal names to map structures. */
10265 static unsigned int gfc_map_id
= 0;
10266 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10270 old_loc
= gfc_current_locus
;
10272 if (gfc_match_eos () != MATCH_YES
)
10274 gfc_error ("Junk after MAP statement at %C");
10275 gfc_current_locus
= old_loc
;
10276 return MATCH_ERROR
;
10279 /* Map blocks are anonymous so we make up unique names for the symbol table
10280 which are invalid Fortran identifiers. */
10281 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "MM$%u", gfc_map_id
++);
10283 if (!get_struct_decl (name
, FL_STRUCT
, &old_loc
, &sym
))
10284 return MATCH_ERROR
;
10286 gfc_new_block
= sym
;
10292 /* Match the opening of a UNION block. */
10295 gfc_match_union (void)
10297 /* Counter used to give unique internal names to union types. */
10298 static unsigned int gfc_union_id
= 0;
10299 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10303 old_loc
= gfc_current_locus
;
10305 if (gfc_match_eos () != MATCH_YES
)
10307 gfc_error ("Junk after UNION statement at %C");
10308 gfc_current_locus
= old_loc
;
10309 return MATCH_ERROR
;
10312 /* Unions are anonymous so we make up unique names for the symbol table
10313 which are invalid Fortran identifiers. */
10314 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "UU$%u", gfc_union_id
++);
10316 if (!get_struct_decl (name
, FL_UNION
, &old_loc
, &sym
))
10317 return MATCH_ERROR
;
10319 gfc_new_block
= sym
;
10325 /* Match the beginning of a STRUCTURE declaration. This is similar to
10326 matching the beginning of a derived type declaration with a few
10327 twists. The resulting type symbol has no access control or other
10328 interesting attributes. */
10331 gfc_match_structure_decl (void)
10333 /* Counter used to give unique internal names to anonymous structures. */
10334 static unsigned int gfc_structure_id
= 0;
10335 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10340 if (!flag_dec_structure
)
10342 gfc_error ("%s at %C is a DEC extension, enable with "
10343 "%<-fdec-structure%>",
10345 return MATCH_ERROR
;
10350 m
= gfc_match (" /%n/", name
);
10351 if (m
!= MATCH_YES
)
10353 /* Non-nested structure declarations require a structure name. */
10354 if (!gfc_comp_struct (gfc_current_state ()))
10356 gfc_error ("Structure name expected in non-nested structure "
10357 "declaration at %C");
10358 return MATCH_ERROR
;
10360 /* This is an anonymous structure; make up a unique name for it
10361 (upper-case letters never make it to symbol names from the source).
10362 The important thing is initializing the type variable
10363 and setting gfc_new_symbol, which is immediately used by
10364 parse_structure () and variable_decl () to add components of
10366 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "SS$%u", gfc_structure_id
++);
10369 where
= gfc_current_locus
;
10370 /* No field list allowed after non-nested structure declaration. */
10371 if (!gfc_comp_struct (gfc_current_state ())
10372 && gfc_match_eos () != MATCH_YES
)
10374 gfc_error ("Junk after non-nested STRUCTURE statement at %C");
10375 return MATCH_ERROR
;
10378 /* Make sure the name is not the name of an intrinsic type. */
10379 if (gfc_is_intrinsic_typename (name
))
10381 gfc_error ("Structure name %qs at %C cannot be the same as an"
10382 " intrinsic type", name
);
10383 return MATCH_ERROR
;
10386 /* Store the actual type symbol for the structure with an upper-case first
10387 letter (an invalid Fortran identifier). */
10389 if (!get_struct_decl (gfc_dt_upper_string (name
), FL_STRUCT
, &where
, &sym
))
10390 return MATCH_ERROR
;
10392 gfc_new_block
= sym
;
10397 /* This function does some work to determine which matcher should be used to
10398 * match a statement beginning with "TYPE". This is used to disambiguate TYPE
10399 * as an alias for PRINT from derived type declarations, TYPE IS statements,
10400 * and [parameterized] derived type declarations. */
10403 gfc_match_type (gfc_statement
*st
)
10405 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10409 /* Requires -fdec. */
10413 m
= gfc_match ("type");
10414 if (m
!= MATCH_YES
)
10416 /* If we already have an error in the buffer, it is probably from failing to
10417 * match a derived type data declaration. Let it happen. */
10418 else if (gfc_error_flag_test ())
10421 old_loc
= gfc_current_locus
;
10424 /* If we see an attribute list before anything else it's definitely a derived
10425 * type declaration. */
10426 if (gfc_match (" ,") == MATCH_YES
|| gfc_match (" ::") == MATCH_YES
)
10429 /* By now "TYPE" has already been matched. If we do not see a name, this may
10430 * be something like "TYPE *" or "TYPE <fmt>". */
10431 m
= gfc_match_name (name
);
10432 if (m
!= MATCH_YES
)
10434 /* Let print match if it can, otherwise throw an error from
10435 * gfc_match_derived_decl. */
10436 gfc_current_locus
= old_loc
;
10437 if (gfc_match_print () == MATCH_YES
)
10445 /* Check for EOS. */
10446 if (gfc_match_eos () == MATCH_YES
)
10448 /* By now we have "TYPE <name> <EOS>". Check first if the name is an
10449 * intrinsic typename - if so let gfc_match_derived_decl dump an error.
10450 * Otherwise if gfc_match_derived_decl fails it's probably an existing
10451 * symbol which can be printed. */
10452 gfc_current_locus
= old_loc
;
10453 m
= gfc_match_derived_decl ();
10454 if (gfc_is_intrinsic_typename (name
) || m
== MATCH_YES
)
10456 *st
= ST_DERIVED_DECL
;
10462 /* Here we have "TYPE <name>". Check for <TYPE IS (> or a PDT declaration
10463 like <type name(parameter)>. */
10464 gfc_gobble_whitespace ();
10465 bool paren
= gfc_peek_ascii_char () == '(';
10468 if (strcmp ("is", name
) == 0)
10475 /* Treat TYPE... like PRINT... */
10476 gfc_current_locus
= old_loc
;
10478 return gfc_match_print ();
10481 gfc_current_locus
= old_loc
;
10482 *st
= ST_DERIVED_DECL
;
10483 return gfc_match_derived_decl ();
10486 gfc_current_locus
= old_loc
;
10488 return gfc_match_type_is ();
10492 /* Match the beginning of a derived type declaration. If a type name
10493 was the result of a function, then it is possible to have a symbol
10494 already to be known as a derived type yet have no components. */
10497 gfc_match_derived_decl (void)
10499 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10500 char parent
[GFC_MAX_SYMBOL_LEN
+ 1];
10501 symbol_attribute attr
;
10502 gfc_symbol
*sym
, *gensym
;
10503 gfc_symbol
*extended
;
10505 match is_type_attr_spec
= MATCH_NO
;
10506 bool seen_attr
= false;
10507 gfc_interface
*intr
= NULL
, *head
;
10508 bool parameterized_type
= false;
10509 bool seen_colons
= false;
10511 if (gfc_comp_struct (gfc_current_state ()))
10516 gfc_clear_attr (&attr
);
10521 is_type_attr_spec
= gfc_get_type_attr_spec (&attr
, parent
);
10522 if (is_type_attr_spec
== MATCH_ERROR
)
10523 return MATCH_ERROR
;
10524 if (is_type_attr_spec
== MATCH_YES
)
10526 } while (is_type_attr_spec
== MATCH_YES
);
10528 /* Deal with derived type extensions. The extension attribute has
10529 been added to 'attr' but now the parent type must be found and
10532 extended
= check_extended_derived_type (parent
);
10534 if (parent
[0] && !extended
)
10535 return MATCH_ERROR
;
10537 m
= gfc_match (" ::");
10538 if (m
== MATCH_YES
)
10540 seen_colons
= true;
10542 else if (seen_attr
)
10544 gfc_error ("Expected :: in TYPE definition at %C");
10545 return MATCH_ERROR
;
10548 /* In free source form, need to check for TYPE XXX as oppose to TYPEXXX.
10549 But, we need to simply return for TYPE(. */
10550 if (m
== MATCH_NO
&& gfc_current_form
== FORM_FREE
)
10552 char c
= gfc_peek_ascii_char ();
10555 if (!gfc_is_whitespace (c
))
10557 gfc_error ("Mangled derived type definition at %C");
10562 m
= gfc_match (" %n ", name
);
10563 if (m
!= MATCH_YES
)
10566 /* Make sure that we don't identify TYPE IS (...) as a parameterized
10567 derived type named 'is'.
10568 TODO Expand the check, when 'name' = "is" by matching " (tname) "
10569 and checking if this is a(n intrinsic) typename. This picks up
10570 misplaced TYPE IS statements such as in select_type_1.f03. */
10571 if (gfc_peek_ascii_char () == '(')
10573 if (gfc_current_state () == COMP_SELECT_TYPE
10574 || (!seen_colons
&& !strcmp (name
, "is")))
10576 parameterized_type
= true;
10579 m
= gfc_match_eos ();
10580 if (m
!= MATCH_YES
&& !parameterized_type
)
10583 /* Make sure the name is not the name of an intrinsic type. */
10584 if (gfc_is_intrinsic_typename (name
))
10586 gfc_error ("Type name %qs at %C cannot be the same as an intrinsic "
10588 return MATCH_ERROR
;
10591 if (gfc_get_symbol (name
, NULL
, &gensym
))
10592 return MATCH_ERROR
;
10594 if (!gensym
->attr
.generic
&& gensym
->ts
.type
!= BT_UNKNOWN
)
10596 if (gensym
->ts
.u
.derived
)
10597 gfc_error ("Derived type name %qs at %C already has a basic type "
10598 "of %s", gensym
->name
, gfc_typename (&gensym
->ts
));
10600 gfc_error ("Derived type name %qs at %C already has a basic type",
10602 return MATCH_ERROR
;
10605 if (!gensym
->attr
.generic
10606 && !gfc_add_generic (&gensym
->attr
, gensym
->name
, NULL
))
10607 return MATCH_ERROR
;
10609 if (!gensym
->attr
.function
10610 && !gfc_add_function (&gensym
->attr
, gensym
->name
, NULL
))
10611 return MATCH_ERROR
;
10613 if (gensym
->attr
.dummy
)
10615 gfc_error ("Dummy argument %qs at %L cannot be a derived type at %C",
10616 name
, &gensym
->declared_at
);
10617 return MATCH_ERROR
;
10620 sym
= gfc_find_dt_in_generic (gensym
);
10622 if (sym
&& (sym
->components
!= NULL
|| sym
->attr
.zero_comp
))
10624 gfc_error ("Derived type definition of %qs at %C has already been "
10625 "defined", sym
->name
);
10626 return MATCH_ERROR
;
10631 /* Use upper case to save the actual derived-type symbol. */
10632 gfc_get_symbol (gfc_dt_upper_string (gensym
->name
), NULL
, &sym
);
10633 sym
->name
= gfc_get_string ("%s", gensym
->name
);
10634 head
= gensym
->generic
;
10635 intr
= gfc_get_interface ();
10637 intr
->where
= gfc_current_locus
;
10638 intr
->sym
->declared_at
= gfc_current_locus
;
10640 gensym
->generic
= intr
;
10641 gensym
->attr
.if_source
= IFSRC_DECL
;
10644 /* The symbol may already have the derived attribute without the
10645 components. The ways this can happen is via a function
10646 definition, an INTRINSIC statement or a subtype in another
10647 derived type that is a pointer. The first part of the AND clause
10648 is true if the symbol is not the return value of a function. */
10649 if (sym
->attr
.flavor
!= FL_DERIVED
10650 && !gfc_add_flavor (&sym
->attr
, FL_DERIVED
, sym
->name
, NULL
))
10651 return MATCH_ERROR
;
10653 if (attr
.access
!= ACCESS_UNKNOWN
10654 && !gfc_add_access (&sym
->attr
, attr
.access
, sym
->name
, NULL
))
10655 return MATCH_ERROR
;
10656 else if (sym
->attr
.access
== ACCESS_UNKNOWN
10657 && gensym
->attr
.access
!= ACCESS_UNKNOWN
10658 && !gfc_add_access (&sym
->attr
, gensym
->attr
.access
,
10660 return MATCH_ERROR
;
10662 if (sym
->attr
.access
!= ACCESS_UNKNOWN
10663 && gensym
->attr
.access
== ACCESS_UNKNOWN
)
10664 gensym
->attr
.access
= sym
->attr
.access
;
10666 /* See if the derived type was labeled as bind(c). */
10667 if (attr
.is_bind_c
!= 0)
10668 sym
->attr
.is_bind_c
= attr
.is_bind_c
;
10670 /* Construct the f2k_derived namespace if it is not yet there. */
10671 if (!sym
->f2k_derived
)
10672 sym
->f2k_derived
= gfc_get_namespace (NULL
, 0);
10674 if (parameterized_type
)
10676 /* Ignore error or mismatches by going to the end of the statement
10677 in order to avoid the component declarations causing problems. */
10678 m
= gfc_match_formal_arglist (sym
, 0, 0, true);
10679 if (m
!= MATCH_YES
)
10680 gfc_error_recovery ();
10682 sym
->attr
.pdt_template
= 1;
10683 m
= gfc_match_eos ();
10684 if (m
!= MATCH_YES
)
10686 gfc_error_recovery ();
10687 gfc_error_now ("Garbage after PARAMETERIZED TYPE declaration at %C");
10691 if (extended
&& !sym
->components
)
10694 gfc_formal_arglist
*f
, *g
, *h
;
10696 /* Add the extended derived type as the first component. */
10697 gfc_add_component (sym
, parent
, &p
);
10699 gfc_set_sym_referenced (extended
);
10701 p
->ts
.type
= BT_DERIVED
;
10702 p
->ts
.u
.derived
= extended
;
10703 p
->initializer
= gfc_default_initializer (&p
->ts
);
10705 /* Set extension level. */
10706 if (extended
->attr
.extension
== 255)
10708 /* Since the extension field is 8 bit wide, we can only have
10709 up to 255 extension levels. */
10710 gfc_error ("Maximum extension level reached with type %qs at %L",
10711 extended
->name
, &extended
->declared_at
);
10712 return MATCH_ERROR
;
10714 sym
->attr
.extension
= extended
->attr
.extension
+ 1;
10716 /* Provide the links between the extended type and its extension. */
10717 if (!extended
->f2k_derived
)
10718 extended
->f2k_derived
= gfc_get_namespace (NULL
, 0);
10720 /* Copy the extended type-param-name-list from the extended type,
10721 append those of the extension and add the whole lot to the
10723 if (extended
->attr
.pdt_template
)
10726 sym
->attr
.pdt_template
= 1;
10727 for (f
= extended
->formal
; f
; f
= f
->next
)
10729 if (f
== extended
->formal
)
10731 g
= gfc_get_formal_arglist ();
10736 g
->next
= gfc_get_formal_arglist ();
10741 g
->next
= sym
->formal
;
10746 if (!sym
->hash_value
)
10747 /* Set the hash for the compound name for this type. */
10748 sym
->hash_value
= gfc_hash_value (sym
);
10750 /* Take over the ABSTRACT attribute. */
10751 sym
->attr
.abstract
= attr
.abstract
;
10753 gfc_new_block
= sym
;
10759 /* Cray Pointees can be declared as:
10760 pointer (ipt, a (n,m,...,*)) */
10763 gfc_mod_pointee_as (gfc_array_spec
*as
)
10765 as
->cray_pointee
= true; /* This will be useful to know later. */
10766 if (as
->type
== AS_ASSUMED_SIZE
)
10767 as
->cp_was_assumed
= true;
10768 else if (as
->type
== AS_ASSUMED_SHAPE
)
10770 gfc_error ("Cray Pointee at %C cannot be assumed shape array");
10771 return MATCH_ERROR
;
10777 /* Match the enum definition statement, here we are trying to match
10778 the first line of enum definition statement.
10779 Returns MATCH_YES if match is found. */
10782 gfc_match_enum (void)
10786 m
= gfc_match_eos ();
10787 if (m
!= MATCH_YES
)
10790 if (!gfc_notify_std (GFC_STD_F2003
, "ENUM and ENUMERATOR at %C"))
10791 return MATCH_ERROR
;
10797 /* Returns an initializer whose value is one higher than the value of the
10798 LAST_INITIALIZER argument. If the argument is NULL, the
10799 initializers value will be set to zero. The initializer's kind
10800 will be set to gfc_c_int_kind.
10802 If -fshort-enums is given, the appropriate kind will be selected
10803 later after all enumerators have been parsed. A warning is issued
10804 here if an initializer exceeds gfc_c_int_kind. */
10807 enum_initializer (gfc_expr
*last_initializer
, locus where
)
10810 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_c_int_kind
, &where
);
10812 mpz_init (result
->value
.integer
);
10814 if (last_initializer
!= NULL
)
10816 mpz_add_ui (result
->value
.integer
, last_initializer
->value
.integer
, 1);
10817 result
->where
= last_initializer
->where
;
10819 if (gfc_check_integer_range (result
->value
.integer
,
10820 gfc_c_int_kind
) != ARITH_OK
)
10822 gfc_error ("Enumerator exceeds the C integer type at %C");
10828 /* Control comes here, if it's the very first enumerator and no
10829 initializer has been given. It will be initialized to zero. */
10830 mpz_set_si (result
->value
.integer
, 0);
10837 /* Match a variable name with an optional initializer. When this
10838 subroutine is called, a variable is expected to be parsed next.
10839 Depending on what is happening at the moment, updates either the
10840 symbol table or the current interface. */
10843 enumerator_decl (void)
10845 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10846 gfc_expr
*initializer
;
10847 gfc_array_spec
*as
= NULL
;
10854 initializer
= NULL
;
10855 old_locus
= gfc_current_locus
;
10857 /* When we get here, we've just matched a list of attributes and
10858 maybe a type and a double colon. The next thing we expect to see
10859 is the name of the symbol. */
10860 m
= gfc_match_name (name
);
10861 if (m
!= MATCH_YES
)
10864 var_locus
= gfc_current_locus
;
10866 /* OK, we've successfully matched the declaration. Now put the
10867 symbol in the current namespace. If we fail to create the symbol,
10869 if (!build_sym (name
, NULL
, false, &as
, &var_locus
))
10875 /* The double colon must be present in order to have initializers.
10876 Otherwise the statement is ambiguous with an assignment statement. */
10879 if (gfc_match_char ('=') == MATCH_YES
)
10881 m
= gfc_match_init_expr (&initializer
);
10884 gfc_error ("Expected an initialization expression at %C");
10888 if (m
!= MATCH_YES
)
10893 /* If we do not have an initializer, the initialization value of the
10894 previous enumerator (stored in last_initializer) is incremented
10895 by 1 and is used to initialize the current enumerator. */
10896 if (initializer
== NULL
)
10897 initializer
= enum_initializer (last_initializer
, old_locus
);
10899 if (initializer
== NULL
|| initializer
->ts
.type
!= BT_INTEGER
)
10901 gfc_error ("ENUMERATOR %L not initialized with integer expression",
10907 /* Store this current initializer, for the next enumerator variable
10908 to be parsed. add_init_expr_to_sym() zeros initializer, so we
10909 use last_initializer below. */
10910 last_initializer
= initializer
;
10911 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
10913 /* Maintain enumerator history. */
10914 gfc_find_symbol (name
, NULL
, 0, &sym
);
10915 create_enum_history (sym
, last_initializer
);
10917 return (t
) ? MATCH_YES
: MATCH_ERROR
;
10920 /* Free stuff up and return. */
10921 gfc_free_expr (initializer
);
10927 /* Match the enumerator definition statement. */
10930 gfc_match_enumerator_def (void)
10935 gfc_clear_ts (¤t_ts
);
10937 m
= gfc_match (" enumerator");
10938 if (m
!= MATCH_YES
)
10941 m
= gfc_match (" :: ");
10942 if (m
== MATCH_ERROR
)
10945 colon_seen
= (m
== MATCH_YES
);
10947 if (gfc_current_state () != COMP_ENUM
)
10949 gfc_error ("ENUM definition statement expected before %C");
10950 gfc_free_enum_history ();
10951 return MATCH_ERROR
;
10954 (¤t_ts
)->type
= BT_INTEGER
;
10955 (¤t_ts
)->kind
= gfc_c_int_kind
;
10957 gfc_clear_attr (¤t_attr
);
10958 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, NULL
);
10967 m
= enumerator_decl ();
10968 if (m
== MATCH_ERROR
)
10970 gfc_free_enum_history ();
10976 if (gfc_match_eos () == MATCH_YES
)
10978 if (gfc_match_char (',') != MATCH_YES
)
10982 if (gfc_current_state () == COMP_ENUM
)
10984 gfc_free_enum_history ();
10985 gfc_error ("Syntax error in ENUMERATOR definition at %C");
10990 gfc_free_array_spec (current_as
);
10997 /* Match binding attributes. */
11000 match_binding_attributes (gfc_typebound_proc
* ba
, bool generic
, bool ppc
)
11002 bool found_passing
= false;
11003 bool seen_ptr
= false;
11004 match m
= MATCH_YES
;
11006 /* Initialize to defaults. Do so even before the MATCH_NO check so that in
11007 this case the defaults are in there. */
11008 ba
->access
= ACCESS_UNKNOWN
;
11009 ba
->pass_arg
= NULL
;
11010 ba
->pass_arg_num
= 0;
11012 ba
->non_overridable
= 0;
11016 /* If we find a comma, we believe there are binding attributes. */
11017 m
= gfc_match_char (',');
11023 /* Access specifier. */
11025 m
= gfc_match (" public");
11026 if (m
== MATCH_ERROR
)
11028 if (m
== MATCH_YES
)
11030 if (ba
->access
!= ACCESS_UNKNOWN
)
11032 gfc_error ("Duplicate access-specifier at %C");
11036 ba
->access
= ACCESS_PUBLIC
;
11040 m
= gfc_match (" private");
11041 if (m
== MATCH_ERROR
)
11043 if (m
== MATCH_YES
)
11045 if (ba
->access
!= ACCESS_UNKNOWN
)
11047 gfc_error ("Duplicate access-specifier at %C");
11051 ba
->access
= ACCESS_PRIVATE
;
11055 /* If inside GENERIC, the following is not allowed. */
11060 m
= gfc_match (" nopass");
11061 if (m
== MATCH_ERROR
)
11063 if (m
== MATCH_YES
)
11067 gfc_error ("Binding attributes already specify passing,"
11068 " illegal NOPASS at %C");
11072 found_passing
= true;
11077 /* PASS possibly including argument. */
11078 m
= gfc_match (" pass");
11079 if (m
== MATCH_ERROR
)
11081 if (m
== MATCH_YES
)
11083 char arg
[GFC_MAX_SYMBOL_LEN
+ 1];
11087 gfc_error ("Binding attributes already specify passing,"
11088 " illegal PASS at %C");
11092 m
= gfc_match (" ( %n )", arg
);
11093 if (m
== MATCH_ERROR
)
11095 if (m
== MATCH_YES
)
11096 ba
->pass_arg
= gfc_get_string ("%s", arg
);
11097 gcc_assert ((m
== MATCH_YES
) == (ba
->pass_arg
!= NULL
));
11099 found_passing
= true;
11106 /* POINTER flag. */
11107 m
= gfc_match (" pointer");
11108 if (m
== MATCH_ERROR
)
11110 if (m
== MATCH_YES
)
11114 gfc_error ("Duplicate POINTER attribute at %C");
11124 /* NON_OVERRIDABLE flag. */
11125 m
= gfc_match (" non_overridable");
11126 if (m
== MATCH_ERROR
)
11128 if (m
== MATCH_YES
)
11130 if (ba
->non_overridable
)
11132 gfc_error ("Duplicate NON_OVERRIDABLE at %C");
11136 ba
->non_overridable
= 1;
11140 /* DEFERRED flag. */
11141 m
= gfc_match (" deferred");
11142 if (m
== MATCH_ERROR
)
11144 if (m
== MATCH_YES
)
11148 gfc_error ("Duplicate DEFERRED at %C");
11159 /* Nothing matching found. */
11161 gfc_error ("Expected access-specifier at %C");
11163 gfc_error ("Expected binding attribute at %C");
11166 while (gfc_match_char (',') == MATCH_YES
);
11168 /* NON_OVERRIDABLE and DEFERRED exclude themselves. */
11169 if (ba
->non_overridable
&& ba
->deferred
)
11171 gfc_error ("NON_OVERRIDABLE and DEFERRED cannot both appear at %C");
11178 if (ba
->access
== ACCESS_UNKNOWN
)
11179 ba
->access
= ppc
? gfc_current_block()->component_access
11180 : gfc_typebound_default_access
;
11182 if (ppc
&& !seen_ptr
)
11184 gfc_error ("POINTER attribute is required for procedure pointer component"
11192 return MATCH_ERROR
;
11196 /* Match a PROCEDURE specific binding inside a derived type. */
11199 match_procedure_in_type (void)
11201 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
11202 char target_buf
[GFC_MAX_SYMBOL_LEN
+ 1];
11203 char* target
= NULL
, *ifc
= NULL
;
11204 gfc_typebound_proc tb
;
11208 gfc_symtree
* stree
;
11213 /* Check current state. */
11214 gcc_assert (gfc_state_stack
->state
== COMP_DERIVED_CONTAINS
);
11215 block
= gfc_state_stack
->previous
->sym
;
11216 gcc_assert (block
);
11218 /* Try to match PROCEDURE(interface). */
11219 if (gfc_match (" (") == MATCH_YES
)
11221 m
= gfc_match_name (target_buf
);
11222 if (m
== MATCH_ERROR
)
11224 if (m
!= MATCH_YES
)
11226 gfc_error ("Interface-name expected after %<(%> at %C");
11227 return MATCH_ERROR
;
11230 if (gfc_match (" )") != MATCH_YES
)
11232 gfc_error ("%<)%> expected at %C");
11233 return MATCH_ERROR
;
11239 /* Construct the data structure. */
11240 memset (&tb
, 0, sizeof (tb
));
11241 tb
.where
= gfc_current_locus
;
11243 /* Match binding attributes. */
11244 m
= match_binding_attributes (&tb
, false, false);
11245 if (m
== MATCH_ERROR
)
11247 seen_attrs
= (m
== MATCH_YES
);
11249 /* Check that attribute DEFERRED is given if an interface is specified. */
11250 if (tb
.deferred
&& !ifc
)
11252 gfc_error ("Interface must be specified for DEFERRED binding at %C");
11253 return MATCH_ERROR
;
11255 if (ifc
&& !tb
.deferred
)
11257 gfc_error ("PROCEDURE(interface) at %C should be declared DEFERRED");
11258 return MATCH_ERROR
;
11261 /* Match the colons. */
11262 m
= gfc_match (" ::");
11263 if (m
== MATCH_ERROR
)
11265 seen_colons
= (m
== MATCH_YES
);
11266 if (seen_attrs
&& !seen_colons
)
11268 gfc_error ("Expected %<::%> after binding-attributes at %C");
11269 return MATCH_ERROR
;
11272 /* Match the binding names. */
11275 m
= gfc_match_name (name
);
11276 if (m
== MATCH_ERROR
)
11280 gfc_error ("Expected binding name at %C");
11281 return MATCH_ERROR
;
11284 if (num
>1 && !gfc_notify_std (GFC_STD_F2008
, "PROCEDURE list at %C"))
11285 return MATCH_ERROR
;
11287 /* Try to match the '=> target', if it's there. */
11289 m
= gfc_match (" =>");
11290 if (m
== MATCH_ERROR
)
11292 if (m
== MATCH_YES
)
11296 gfc_error ("%<=> target%> is invalid for DEFERRED binding at %C");
11297 return MATCH_ERROR
;
11302 gfc_error ("%<::%> needed in PROCEDURE binding with explicit target"
11304 return MATCH_ERROR
;
11307 m
= gfc_match_name (target_buf
);
11308 if (m
== MATCH_ERROR
)
11312 gfc_error ("Expected binding target after %<=>%> at %C");
11313 return MATCH_ERROR
;
11315 target
= target_buf
;
11318 /* If no target was found, it has the same name as the binding. */
11322 /* Get the namespace to insert the symbols into. */
11323 ns
= block
->f2k_derived
;
11326 /* If the binding is DEFERRED, check that the containing type is ABSTRACT. */
11327 if (tb
.deferred
&& !block
->attr
.abstract
)
11329 gfc_error ("Type %qs containing DEFERRED binding at %C "
11330 "is not ABSTRACT", block
->name
);
11331 return MATCH_ERROR
;
11334 /* See if we already have a binding with this name in the symtree which
11335 would be an error. If a GENERIC already targeted this binding, it may
11336 be already there but then typebound is still NULL. */
11337 stree
= gfc_find_symtree (ns
->tb_sym_root
, name
);
11338 if (stree
&& stree
->n
.tb
)
11340 gfc_error ("There is already a procedure with binding name %qs for "
11341 "the derived type %qs at %C", name
, block
->name
);
11342 return MATCH_ERROR
;
11345 /* Insert it and set attributes. */
11349 stree
= gfc_new_symtree (&ns
->tb_sym_root
, name
);
11350 gcc_assert (stree
);
11352 stree
->n
.tb
= gfc_get_typebound_proc (&tb
);
11354 if (gfc_get_sym_tree (target
, gfc_current_ns
, &stree
->n
.tb
->u
.specific
,
11356 return MATCH_ERROR
;
11357 gfc_set_sym_referenced (stree
->n
.tb
->u
.specific
->n
.sym
);
11358 gfc_add_flavor(&stree
->n
.tb
->u
.specific
->n
.sym
->attr
, FL_PROCEDURE
,
11359 target
, &stree
->n
.tb
->u
.specific
->n
.sym
->declared_at
);
11361 if (gfc_match_eos () == MATCH_YES
)
11363 if (gfc_match_char (',') != MATCH_YES
)
11368 gfc_error ("Syntax error in PROCEDURE statement at %C");
11369 return MATCH_ERROR
;
11373 /* Match a GENERIC procedure binding inside a derived type. */
11376 gfc_match_generic (void)
11378 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
11379 char bind_name
[GFC_MAX_SYMBOL_LEN
+ 16]; /* Allow space for OPERATOR(...). */
11381 gfc_typebound_proc tbattr
; /* Used for match_binding_attributes. */
11382 gfc_typebound_proc
* tb
;
11384 interface_type op_type
;
11385 gfc_intrinsic_op op
;
11388 /* Check current state. */
11389 if (gfc_current_state () == COMP_DERIVED
)
11391 gfc_error ("GENERIC at %C must be inside a derived-type CONTAINS");
11392 return MATCH_ERROR
;
11394 if (gfc_current_state () != COMP_DERIVED_CONTAINS
)
11396 block
= gfc_state_stack
->previous
->sym
;
11397 ns
= block
->f2k_derived
;
11398 gcc_assert (block
&& ns
);
11400 memset (&tbattr
, 0, sizeof (tbattr
));
11401 tbattr
.where
= gfc_current_locus
;
11403 /* See if we get an access-specifier. */
11404 m
= match_binding_attributes (&tbattr
, true, false);
11405 if (m
== MATCH_ERROR
)
11408 /* Now the colons, those are required. */
11409 if (gfc_match (" ::") != MATCH_YES
)
11411 gfc_error ("Expected %<::%> at %C");
11415 /* Match the binding name; depending on type (operator / generic) format
11416 it for future error messages into bind_name. */
11418 m
= gfc_match_generic_spec (&op_type
, name
, &op
);
11419 if (m
== MATCH_ERROR
)
11420 return MATCH_ERROR
;
11423 gfc_error ("Expected generic name or operator descriptor at %C");
11429 case INTERFACE_GENERIC
:
11430 case INTERFACE_DTIO
:
11431 snprintf (bind_name
, sizeof (bind_name
), "%s", name
);
11434 case INTERFACE_USER_OP
:
11435 snprintf (bind_name
, sizeof (bind_name
), "OPERATOR(.%s.)", name
);
11438 case INTERFACE_INTRINSIC_OP
:
11439 snprintf (bind_name
, sizeof (bind_name
), "OPERATOR(%s)",
11440 gfc_op2string (op
));
11443 case INTERFACE_NAMELESS
:
11444 gfc_error ("Malformed GENERIC statement at %C");
11449 gcc_unreachable ();
11452 /* Match the required =>. */
11453 if (gfc_match (" =>") != MATCH_YES
)
11455 gfc_error ("Expected %<=>%> at %C");
11459 /* Try to find existing GENERIC binding with this name / for this operator;
11460 if there is something, check that it is another GENERIC and then extend
11461 it rather than building a new node. Otherwise, create it and put it
11462 at the right position. */
11466 case INTERFACE_DTIO
:
11467 case INTERFACE_USER_OP
:
11468 case INTERFACE_GENERIC
:
11470 const bool is_op
= (op_type
== INTERFACE_USER_OP
);
11473 st
= gfc_find_symtree (is_op
? ns
->tb_uop_root
: ns
->tb_sym_root
, name
);
11474 tb
= st
? st
->n
.tb
: NULL
;
11478 case INTERFACE_INTRINSIC_OP
:
11479 tb
= ns
->tb_op
[op
];
11483 gcc_unreachable ();
11488 if (!tb
->is_generic
)
11490 gcc_assert (op_type
== INTERFACE_GENERIC
);
11491 gfc_error ("There's already a non-generic procedure with binding name"
11492 " %qs for the derived type %qs at %C",
11493 bind_name
, block
->name
);
11497 if (tb
->access
!= tbattr
.access
)
11499 gfc_error ("Binding at %C must have the same access as already"
11500 " defined binding %qs", bind_name
);
11506 tb
= gfc_get_typebound_proc (NULL
);
11507 tb
->where
= gfc_current_locus
;
11508 tb
->access
= tbattr
.access
;
11509 tb
->is_generic
= 1;
11510 tb
->u
.generic
= NULL
;
11514 case INTERFACE_DTIO
:
11515 case INTERFACE_GENERIC
:
11516 case INTERFACE_USER_OP
:
11518 const bool is_op
= (op_type
== INTERFACE_USER_OP
);
11519 gfc_symtree
* st
= gfc_get_tbp_symtree (is_op
? &ns
->tb_uop_root
:
11520 &ns
->tb_sym_root
, name
);
11527 case INTERFACE_INTRINSIC_OP
:
11528 ns
->tb_op
[op
] = tb
;
11532 gcc_unreachable ();
11536 /* Now, match all following names as specific targets. */
11539 gfc_symtree
* target_st
;
11540 gfc_tbp_generic
* target
;
11542 m
= gfc_match_name (name
);
11543 if (m
== MATCH_ERROR
)
11547 gfc_error ("Expected specific binding name at %C");
11551 target_st
= gfc_get_tbp_symtree (&ns
->tb_sym_root
, name
);
11553 /* See if this is a duplicate specification. */
11554 for (target
= tb
->u
.generic
; target
; target
= target
->next
)
11555 if (target_st
== target
->specific_st
)
11557 gfc_error ("%qs already defined as specific binding for the"
11558 " generic %qs at %C", name
, bind_name
);
11562 target
= gfc_get_tbp_generic ();
11563 target
->specific_st
= target_st
;
11564 target
->specific
= NULL
;
11565 target
->next
= tb
->u
.generic
;
11566 target
->is_operator
= ((op_type
== INTERFACE_USER_OP
)
11567 || (op_type
== INTERFACE_INTRINSIC_OP
));
11568 tb
->u
.generic
= target
;
11570 while (gfc_match (" ,") == MATCH_YES
);
11572 /* Here should be the end. */
11573 if (gfc_match_eos () != MATCH_YES
)
11575 gfc_error ("Junk after GENERIC binding at %C");
11582 return MATCH_ERROR
;
11586 /* Match a FINAL declaration inside a derived type. */
11589 gfc_match_final_decl (void)
11591 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
11594 gfc_namespace
* module_ns
;
11598 if (gfc_current_form
== FORM_FREE
)
11600 char c
= gfc_peek_ascii_char ();
11601 if (!gfc_is_whitespace (c
) && c
!= ':')
11605 if (gfc_state_stack
->state
!= COMP_DERIVED_CONTAINS
)
11607 if (gfc_current_form
== FORM_FIXED
)
11610 gfc_error ("FINAL declaration at %C must be inside a derived type "
11611 "CONTAINS section");
11612 return MATCH_ERROR
;
11615 block
= gfc_state_stack
->previous
->sym
;
11616 gcc_assert (block
);
11618 if (!gfc_state_stack
->previous
|| !gfc_state_stack
->previous
->previous
11619 || gfc_state_stack
->previous
->previous
->state
!= COMP_MODULE
)
11621 gfc_error ("Derived type declaration with FINAL at %C must be in the"
11622 " specification part of a MODULE");
11623 return MATCH_ERROR
;
11626 module_ns
= gfc_current_ns
;
11627 gcc_assert (module_ns
);
11628 gcc_assert (module_ns
->proc_name
->attr
.flavor
== FL_MODULE
);
11630 /* Match optional ::, don't care about MATCH_YES or MATCH_NO. */
11631 if (gfc_match (" ::") == MATCH_ERROR
)
11632 return MATCH_ERROR
;
11634 /* Match the sequence of procedure names. */
11641 if (first
&& gfc_match_eos () == MATCH_YES
)
11643 gfc_error ("Empty FINAL at %C");
11644 return MATCH_ERROR
;
11647 m
= gfc_match_name (name
);
11650 gfc_error ("Expected module procedure name at %C");
11651 return MATCH_ERROR
;
11653 else if (m
!= MATCH_YES
)
11654 return MATCH_ERROR
;
11656 if (gfc_match_eos () == MATCH_YES
)
11658 if (!last
&& gfc_match_char (',') != MATCH_YES
)
11660 gfc_error ("Expected %<,%> at %C");
11661 return MATCH_ERROR
;
11664 if (gfc_get_symbol (name
, module_ns
, &sym
))
11666 gfc_error ("Unknown procedure name %qs at %C", name
);
11667 return MATCH_ERROR
;
11670 /* Mark the symbol as module procedure. */
11671 if (sym
->attr
.proc
!= PROC_MODULE
11672 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
11673 return MATCH_ERROR
;
11675 /* Check if we already have this symbol in the list, this is an error. */
11676 for (f
= block
->f2k_derived
->finalizers
; f
; f
= f
->next
)
11677 if (f
->proc_sym
== sym
)
11679 gfc_error ("%qs at %C is already defined as FINAL procedure",
11681 return MATCH_ERROR
;
11684 /* Add this symbol to the list of finalizers. */
11685 gcc_assert (block
->f2k_derived
);
11687 f
= XCNEW (gfc_finalizer
);
11689 f
->proc_tree
= NULL
;
11690 f
->where
= gfc_current_locus
;
11691 f
->next
= block
->f2k_derived
->finalizers
;
11692 block
->f2k_derived
->finalizers
= f
;
11702 const ext_attr_t ext_attr_list
[] = {
11703 { "dllimport", EXT_ATTR_DLLIMPORT
, "dllimport" },
11704 { "dllexport", EXT_ATTR_DLLEXPORT
, "dllexport" },
11705 { "cdecl", EXT_ATTR_CDECL
, "cdecl" },
11706 { "stdcall", EXT_ATTR_STDCALL
, "stdcall" },
11707 { "fastcall", EXT_ATTR_FASTCALL
, "fastcall" },
11708 { "no_arg_check", EXT_ATTR_NO_ARG_CHECK
, NULL
},
11709 { "deprecated", EXT_ATTR_DEPRECATED
, NULL
},
11710 { NULL
, EXT_ATTR_LAST
, NULL
}
11713 /* Match a !GCC$ ATTRIBUTES statement of the form:
11714 !GCC$ ATTRIBUTES attribute-list :: var-name [, var-name] ...
11715 When we come here, we have already matched the !GCC$ ATTRIBUTES string.
11717 TODO: We should support all GCC attributes using the same syntax for
11718 the attribute list, i.e. the list in C
11719 __attributes(( attribute-list ))
11721 !GCC$ ATTRIBUTES attribute-list ::
11722 Cf. c-parser.c's c_parser_attributes; the data can then directly be
11725 As there is absolutely no risk of confusion, we should never return
11728 gfc_match_gcc_attributes (void)
11730 symbol_attribute attr
;
11731 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
11736 gfc_clear_attr (&attr
);
11741 if (gfc_match_name (name
) != MATCH_YES
)
11742 return MATCH_ERROR
;
11744 for (id
= 0; id
< EXT_ATTR_LAST
; id
++)
11745 if (strcmp (name
, ext_attr_list
[id
].name
) == 0)
11748 if (id
== EXT_ATTR_LAST
)
11750 gfc_error ("Unknown attribute in !GCC$ ATTRIBUTES statement at %C");
11751 return MATCH_ERROR
;
11754 if (!gfc_add_ext_attribute (&attr
, (ext_attr_id_t
)id
, &gfc_current_locus
))
11755 return MATCH_ERROR
;
11757 gfc_gobble_whitespace ();
11758 ch
= gfc_next_ascii_char ();
11761 /* This is the successful exit condition for the loop. */
11762 if (gfc_next_ascii_char () == ':')
11772 if (gfc_match_eos () == MATCH_YES
)
11777 m
= gfc_match_name (name
);
11778 if (m
!= MATCH_YES
)
11781 if (find_special (name
, &sym
, true))
11782 return MATCH_ERROR
;
11784 sym
->attr
.ext_attr
|= attr
.ext_attr
;
11786 if (gfc_match_eos () == MATCH_YES
)
11789 if (gfc_match_char (',') != MATCH_YES
)
11796 gfc_error ("Syntax error in !GCC$ ATTRIBUTES statement at %C");
11797 return MATCH_ERROR
;
11801 /* Match a !GCC$ UNROLL statement of the form:
11804 The parameter n is the number of times we are supposed to unroll.
11806 When we come here, we have already matched the !GCC$ UNROLL string. */
11808 gfc_match_gcc_unroll (void)
11812 if (gfc_match_small_int (&value
) == MATCH_YES
)
11814 if (value
< 0 || value
> USHRT_MAX
)
11816 gfc_error ("%<GCC unroll%> directive requires a"
11817 " non-negative integral constant"
11818 " less than or equal to %u at %C",
11821 return MATCH_ERROR
;
11823 if (gfc_match_eos () == MATCH_YES
)
11825 directive_unroll
= value
== 0 ? 1 : value
;
11830 gfc_error ("Syntax error in !GCC$ UNROLL directive at %C");
11831 return MATCH_ERROR
;
11834 /* Match a !GCC$ builtin (b) attributes simd flags if('target') form:
11836 The parameter b is name of a middle-end built-in.
11837 FLAGS is optional and must be one of:
11841 IF('target') is optional and TARGET is a name of a multilib ABI.
11843 When we come here, we have already matched the !GCC$ builtin string. */
11846 gfc_match_gcc_builtin (void)
11848 char builtin
[GFC_MAX_SYMBOL_LEN
+ 1];
11849 char target
[GFC_MAX_SYMBOL_LEN
+ 1];
11851 if (gfc_match (" ( %n ) attributes simd", builtin
) != MATCH_YES
)
11852 return MATCH_ERROR
;
11854 gfc_simd_clause clause
= SIMD_NONE
;
11855 if (gfc_match (" ( notinbranch ) ") == MATCH_YES
)
11856 clause
= SIMD_NOTINBRANCH
;
11857 else if (gfc_match (" ( inbranch ) ") == MATCH_YES
)
11858 clause
= SIMD_INBRANCH
;
11860 if (gfc_match (" if ( '%n' ) ", target
) == MATCH_YES
)
11862 const char *abi
= targetm
.get_multilib_abi_name ();
11863 if (abi
== NULL
|| strcmp (abi
, target
) != 0)
11867 if (gfc_vectorized_builtins
== NULL
)
11868 gfc_vectorized_builtins
= new hash_map
<nofree_string_hash
, int> ();
11870 char *r
= XNEWVEC (char, strlen (builtin
) + 32);
11871 sprintf (r
, "__builtin_%s", builtin
);
11874 int &value
= gfc_vectorized_builtins
->get_or_insert (r
, &existed
);
11882 /* Match an !GCC$ IVDEP statement.
11883 When we come here, we have already matched the !GCC$ IVDEP string. */
11886 gfc_match_gcc_ivdep (void)
11888 if (gfc_match_eos () == MATCH_YES
)
11890 directive_ivdep
= true;
11894 gfc_error ("Syntax error in !GCC$ IVDEP directive at %C");
11895 return MATCH_ERROR
;
11898 /* Match an !GCC$ VECTOR statement.
11899 When we come here, we have already matched the !GCC$ VECTOR string. */
11902 gfc_match_gcc_vector (void)
11904 if (gfc_match_eos () == MATCH_YES
)
11906 directive_vector
= true;
11907 directive_novector
= false;
11911 gfc_error ("Syntax error in !GCC$ VECTOR directive at %C");
11912 return MATCH_ERROR
;
11915 /* Match an !GCC$ NOVECTOR statement.
11916 When we come here, we have already matched the !GCC$ NOVECTOR string. */
11919 gfc_match_gcc_novector (void)
11921 if (gfc_match_eos () == MATCH_YES
)
11923 directive_novector
= true;
11924 directive_vector
= false;
11928 gfc_error ("Syntax error in !GCC$ NOVECTOR directive at %C");
11929 return MATCH_ERROR
;