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 /* Character strings are only C interoperable if they have a
1556 if (sym
->ts
.type
== BT_CHARACTER
&& !sym
->attr
.dimension
)
1558 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
1559 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
1560 || mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
1562 gfc_error ("Character argument %qs at %L "
1563 "must be length 1 because "
1564 "procedure %qs is BIND(C)",
1565 sym
->name
, &sym
->declared_at
,
1566 sym
->ns
->proc_name
->name
);
1571 /* We have to make sure that any param to a bind(c) routine does
1572 not have the allocatable, pointer, or optional attributes,
1573 according to J3/04-007, section 5.1. */
1574 if (sym
->attr
.allocatable
== 1
1575 && !gfc_notify_std (GFC_STD_F2018
, "Variable %qs at %L with "
1576 "ALLOCATABLE attribute in procedure %qs "
1577 "with BIND(C)", sym
->name
,
1578 &(sym
->declared_at
),
1579 sym
->ns
->proc_name
->name
))
1582 if (sym
->attr
.pointer
== 1
1583 && !gfc_notify_std (GFC_STD_F2018
, "Variable %qs at %L with "
1584 "POINTER attribute in procedure %qs "
1585 "with BIND(C)", sym
->name
,
1586 &(sym
->declared_at
),
1587 sym
->ns
->proc_name
->name
))
1590 if (sym
->attr
.optional
== 1 && sym
->attr
.value
)
1592 gfc_error ("Variable %qs at %L cannot have both the OPTIONAL "
1593 "and the VALUE attribute because procedure %qs "
1594 "is BIND(C)", sym
->name
, &(sym
->declared_at
),
1595 sym
->ns
->proc_name
->name
);
1598 else if (sym
->attr
.optional
== 1
1599 && !gfc_notify_std (GFC_STD_F2018
, "Variable %qs "
1600 "at %L with OPTIONAL attribute in "
1601 "procedure %qs which is BIND(C)",
1602 sym
->name
, &(sym
->declared_at
),
1603 sym
->ns
->proc_name
->name
))
1606 /* Make sure that if it has the dimension attribute, that it is
1607 either assumed size or explicit shape. Deferred shape is already
1608 covered by the pointer/allocatable attribute. */
1609 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SHAPE
1610 && !gfc_notify_std (GFC_STD_F2018
, "Assumed-shape array %qs "
1611 "at %L as dummy argument to the BIND(C) "
1612 "procedure %qs at %L", sym
->name
,
1613 &(sym
->declared_at
),
1614 sym
->ns
->proc_name
->name
,
1615 &(sym
->ns
->proc_name
->declared_at
)))
1625 /* Function called by variable_decl() that adds a name to the symbol table. */
1628 build_sym (const char *name
, gfc_charlen
*cl
, bool cl_deferred
,
1629 gfc_array_spec
**as
, locus
*var_locus
)
1631 symbol_attribute attr
;
1636 /* Symbols in a submodule are host associated from the parent module or
1637 submodules. Therefore, they can be overridden by declarations in the
1638 submodule scope. Deal with this by attaching the existing symbol to
1639 a new symtree and recycling the old symtree with a new symbol... */
1640 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
1641 if (st
!= NULL
&& gfc_state_stack
->state
== COMP_SUBMODULE
1642 && st
->n
.sym
!= NULL
1643 && st
->n
.sym
->attr
.host_assoc
&& st
->n
.sym
->attr
.used_in_submodule
)
1645 gfc_symtree
*s
= gfc_get_unique_symtree (gfc_current_ns
);
1646 s
->n
.sym
= st
->n
.sym
;
1647 sym
= gfc_new_symbol (name
, gfc_current_ns
);
1652 gfc_set_sym_referenced (sym
);
1654 /* ...Otherwise generate a new symtree and new symbol. */
1655 else if (gfc_get_symbol (name
, NULL
, &sym
))
1658 /* Check if the name has already been defined as a type. The
1659 first letter of the symtree will be in upper case then. Of
1660 course, this is only necessary if the upper case letter is
1661 actually different. */
1663 upper
= TOUPPER(name
[0]);
1664 if (upper
!= name
[0])
1666 char u_name
[GFC_MAX_SYMBOL_LEN
+ 1];
1669 gcc_assert (strlen(name
) <= GFC_MAX_SYMBOL_LEN
);
1670 strcpy (u_name
, name
);
1673 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, u_name
);
1675 /* STRUCTURE types can alias symbol names */
1676 if (st
!= 0 && st
->n
.sym
->attr
.flavor
!= FL_STRUCT
)
1678 gfc_error ("Symbol %qs at %C also declared as a type at %L", name
,
1679 &st
->n
.sym
->declared_at
);
1684 /* Start updating the symbol table. Add basic type attribute if present. */
1685 if (current_ts
.type
!= BT_UNKNOWN
1686 && (sym
->attr
.implicit_type
== 0
1687 || !gfc_compare_types (&sym
->ts
, ¤t_ts
))
1688 && !gfc_add_type (sym
, ¤t_ts
, var_locus
))
1691 if (sym
->ts
.type
== BT_CHARACTER
)
1694 sym
->ts
.deferred
= cl_deferred
;
1697 /* Add dimension attribute if present. */
1698 if (!gfc_set_array_spec (sym
, *as
, var_locus
))
1702 /* Add attribute to symbol. The copy is so that we can reset the
1703 dimension attribute. */
1704 attr
= current_attr
;
1706 attr
.codimension
= 0;
1708 if (!gfc_copy_attr (&sym
->attr
, &attr
, var_locus
))
1711 /* Finish any work that may need to be done for the binding label,
1712 if it's a bind(c). The bind(c) attr is found before the symbol
1713 is made, and before the symbol name (for data decls), so the
1714 current_ts is holding the binding label, or nothing if the
1715 name= attr wasn't given. Therefore, test here if we're dealing
1716 with a bind(c) and make sure the binding label is set correctly. */
1717 if (sym
->attr
.is_bind_c
== 1)
1719 if (!sym
->binding_label
)
1721 /* Set the binding label and verify that if a NAME= was specified
1722 then only one identifier was in the entity-decl-list. */
1723 if (!set_binding_label (&sym
->binding_label
, sym
->name
,
1724 num_idents_on_line
))
1729 /* See if we know we're in a common block, and if it's a bind(c)
1730 common then we need to make sure we're an interoperable type. */
1731 if (sym
->attr
.in_common
== 1)
1733 /* Test the common block object. */
1734 if (sym
->common_block
!= NULL
&& sym
->common_block
->is_bind_c
== 1
1735 && sym
->ts
.is_c_interop
!= 1)
1737 gfc_error_now ("Variable %qs in common block %qs at %C "
1738 "must be declared with a C interoperable "
1739 "kind since common block %qs is BIND(C)",
1740 sym
->name
, sym
->common_block
->name
,
1741 sym
->common_block
->name
);
1746 sym
->attr
.implied_index
= 0;
1748 /* Use the parameter expressions for a parameterized derived type. */
1749 if ((sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
1750 && sym
->ts
.u
.derived
->attr
.pdt_type
&& type_param_spec_list
)
1751 sym
->param_list
= gfc_copy_actual_arglist (type_param_spec_list
);
1753 if (sym
->ts
.type
== BT_CLASS
)
1754 return gfc_build_class_symbol (&sym
->ts
, &sym
->attr
, &sym
->as
);
1760 /* Set character constant to the given length. The constant will be padded or
1761 truncated. If we're inside an array constructor without a typespec, we
1762 additionally check that all elements have the same length; check_len -1
1763 means no checking. */
1766 gfc_set_constant_character_len (gfc_charlen_t len
, gfc_expr
*expr
,
1767 gfc_charlen_t check_len
)
1772 if (expr
->ts
.type
!= BT_CHARACTER
)
1775 if (expr
->expr_type
!= EXPR_CONSTANT
)
1777 gfc_error_now ("CHARACTER length must be a constant at %L", &expr
->where
);
1781 slen
= expr
->value
.character
.length
;
1784 s
= gfc_get_wide_string (len
+ 1);
1785 memcpy (s
, expr
->value
.character
.string
,
1786 MIN (len
, slen
) * sizeof (gfc_char_t
));
1788 gfc_wide_memset (&s
[slen
], ' ', len
- slen
);
1790 if (warn_character_truncation
&& slen
> len
)
1791 gfc_warning_now (OPT_Wcharacter_truncation
,
1792 "CHARACTER expression at %L is being truncated "
1793 "(%ld/%ld)", &expr
->where
,
1794 (long) slen
, (long) len
);
1796 /* Apply the standard by 'hand' otherwise it gets cleared for
1798 if (check_len
!= -1 && slen
!= check_len
1799 && !(gfc_option
.allow_std
& GFC_STD_GNU
))
1800 gfc_error_now ("The CHARACTER elements of the array constructor "
1801 "at %L must have the same length (%ld/%ld)",
1802 &expr
->where
, (long) slen
,
1806 free (expr
->value
.character
.string
);
1807 expr
->value
.character
.string
= s
;
1808 expr
->value
.character
.length
= len
;
1809 /* If explicit representation was given, clear it
1810 as it is no longer needed after padding. */
1811 if (expr
->representation
.length
)
1813 expr
->representation
.length
= 0;
1814 free (expr
->representation
.string
);
1815 expr
->representation
.string
= NULL
;
1821 /* Function to create and update the enumerator history
1822 using the information passed as arguments.
1823 Pointer "max_enum" is also updated, to point to
1824 enum history node containing largest initializer.
1826 SYM points to the symbol node of enumerator.
1827 INIT points to its enumerator value. */
1830 create_enum_history (gfc_symbol
*sym
, gfc_expr
*init
)
1832 enumerator_history
*new_enum_history
;
1833 gcc_assert (sym
!= NULL
&& init
!= NULL
);
1835 new_enum_history
= XCNEW (enumerator_history
);
1837 new_enum_history
->sym
= sym
;
1838 new_enum_history
->initializer
= init
;
1839 new_enum_history
->next
= NULL
;
1841 if (enum_history
== NULL
)
1843 enum_history
= new_enum_history
;
1844 max_enum
= enum_history
;
1848 new_enum_history
->next
= enum_history
;
1849 enum_history
= new_enum_history
;
1851 if (mpz_cmp (max_enum
->initializer
->value
.integer
,
1852 new_enum_history
->initializer
->value
.integer
) < 0)
1853 max_enum
= new_enum_history
;
1858 /* Function to free enum kind history. */
1861 gfc_free_enum_history (void)
1863 enumerator_history
*current
= enum_history
;
1864 enumerator_history
*next
;
1866 while (current
!= NULL
)
1868 next
= current
->next
;
1873 enum_history
= NULL
;
1877 /* Function called by variable_decl() that adds an initialization
1878 expression to a symbol. */
1881 add_init_expr_to_sym (const char *name
, gfc_expr
**initp
, locus
*var_locus
)
1883 symbol_attribute attr
;
1888 if (find_special (name
, &sym
, false))
1893 /* If this symbol is confirming an implicit parameter type,
1894 then an initialization expression is not allowed. */
1895 if (attr
.flavor
== FL_PARAMETER
&& sym
->value
!= NULL
)
1899 gfc_error ("Initializer not allowed for PARAMETER %qs at %C",
1909 /* An initializer is required for PARAMETER declarations. */
1910 if (attr
.flavor
== FL_PARAMETER
)
1912 gfc_error ("PARAMETER at %L is missing an initializer", var_locus
);
1918 /* If a variable appears in a DATA block, it cannot have an
1922 gfc_error ("Variable %qs at %C with an initializer already "
1923 "appears in a DATA statement", sym
->name
);
1927 /* Check if the assignment can happen. This has to be put off
1928 until later for derived type variables and procedure pointers. */
1929 if (!gfc_bt_struct (sym
->ts
.type
) && !gfc_bt_struct (init
->ts
.type
)
1930 && sym
->ts
.type
!= BT_CLASS
&& init
->ts
.type
!= BT_CLASS
1931 && !sym
->attr
.proc_pointer
1932 && !gfc_check_assign_symbol (sym
, NULL
, init
))
1935 if (sym
->ts
.type
== BT_CHARACTER
&& sym
->ts
.u
.cl
1936 && init
->ts
.type
== BT_CHARACTER
)
1938 /* Update symbol character length according initializer. */
1939 if (!gfc_check_assign_symbol (sym
, NULL
, init
))
1942 if (sym
->ts
.u
.cl
->length
== NULL
)
1945 /* If there are multiple CHARACTER variables declared on the
1946 same line, we don't want them to share the same length. */
1947 sym
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1949 if (sym
->attr
.flavor
== FL_PARAMETER
)
1951 if (init
->expr_type
== EXPR_CONSTANT
)
1953 clen
= init
->value
.character
.length
;
1954 sym
->ts
.u
.cl
->length
1955 = gfc_get_int_expr (gfc_charlen_int_kind
,
1958 else if (init
->expr_type
== EXPR_ARRAY
)
1960 if (init
->ts
.u
.cl
&& init
->ts
.u
.cl
->length
)
1962 const gfc_expr
*length
= init
->ts
.u
.cl
->length
;
1963 if (length
->expr_type
!= EXPR_CONSTANT
)
1965 gfc_error ("Cannot initialize parameter array "
1967 "with variable length elements",
1971 clen
= mpz_get_si (length
->value
.integer
);
1973 else if (init
->value
.constructor
)
1976 c
= gfc_constructor_first (init
->value
.constructor
);
1977 clen
= c
->expr
->value
.character
.length
;
1981 sym
->ts
.u
.cl
->length
1982 = gfc_get_int_expr (gfc_charlen_int_kind
,
1985 else if (init
->ts
.u
.cl
&& init
->ts
.u
.cl
->length
)
1986 sym
->ts
.u
.cl
->length
=
1987 gfc_copy_expr (init
->ts
.u
.cl
->length
);
1990 /* Update initializer character length according symbol. */
1991 else if (sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1993 if (!gfc_specification_expr (sym
->ts
.u
.cl
->length
))
1996 int k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
,
1998 /* resolve_charlen will complain later on if the length
1999 is too large. Just skeep the initialization in that case. */
2000 if (mpz_cmp (sym
->ts
.u
.cl
->length
->value
.integer
,
2001 gfc_integer_kinds
[k
].huge
) <= 0)
2004 = gfc_mpz_get_hwi (sym
->ts
.u
.cl
->length
->value
.integer
);
2006 if (init
->expr_type
== EXPR_CONSTANT
)
2007 gfc_set_constant_character_len (len
, init
, -1);
2008 else if (init
->expr_type
== EXPR_ARRAY
)
2012 /* Build a new charlen to prevent simplification from
2013 deleting the length before it is resolved. */
2014 init
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2015 init
->ts
.u
.cl
->length
2016 = gfc_copy_expr (sym
->ts
.u
.cl
->length
);
2018 for (c
= gfc_constructor_first (init
->value
.constructor
);
2019 c
; c
= gfc_constructor_next (c
))
2020 gfc_set_constant_character_len (len
, c
->expr
, -1);
2026 /* If sym is implied-shape, set its upper bounds from init. */
2027 if (sym
->attr
.flavor
== FL_PARAMETER
&& sym
->attr
.dimension
2028 && sym
->as
->type
== AS_IMPLIED_SHAPE
)
2032 if (init
->rank
== 0)
2034 gfc_error ("Cannot initialize implied-shape array at %L"
2035 " with scalar", &sym
->declared_at
);
2039 /* The shape may be NULL for EXPR_ARRAY, set it. */
2040 if (init
->shape
== NULL
)
2042 gcc_assert (init
->expr_type
== EXPR_ARRAY
);
2043 init
->shape
= gfc_get_shape (1);
2044 if (!gfc_array_size (init
, &init
->shape
[0]))
2045 gfc_internal_error ("gfc_array_size failed");
2048 for (dim
= 0; dim
< sym
->as
->rank
; ++dim
)
2051 gfc_expr
*e
, *lower
;
2053 lower
= sym
->as
->lower
[dim
];
2055 /* If the lower bound is an array element from another
2056 parameterized array, then it is marked with EXPR_VARIABLE and
2057 is an initialization expression. Try to reduce it. */
2058 if (lower
->expr_type
== EXPR_VARIABLE
)
2059 gfc_reduce_init_expr (lower
);
2061 if (lower
->expr_type
== EXPR_CONSTANT
)
2063 /* All dimensions must be without upper bound. */
2064 gcc_assert (!sym
->as
->upper
[dim
]);
2067 e
= gfc_get_constant_expr (BT_INTEGER
, k
, &sym
->declared_at
);
2068 mpz_add (e
->value
.integer
, lower
->value
.integer
,
2070 mpz_sub_ui (e
->value
.integer
, e
->value
.integer
, 1);
2071 sym
->as
->upper
[dim
] = e
;
2075 gfc_error ("Non-constant lower bound in implied-shape"
2076 " declaration at %L", &lower
->where
);
2081 sym
->as
->type
= AS_EXPLICIT
;
2084 /* Need to check if the expression we initialized this
2085 to was one of the iso_c_binding named constants. If so,
2086 and we're a parameter (constant), let it be iso_c.
2088 integer(c_int), parameter :: my_int = c_int
2089 integer(my_int) :: my_int_2
2090 If we mark my_int as iso_c (since we can see it's value
2091 is equal to one of the named constants), then my_int_2
2092 will be considered C interoperable. */
2093 if (sym
->ts
.type
!= BT_CHARACTER
&& !gfc_bt_struct (sym
->ts
.type
))
2095 sym
->ts
.is_iso_c
|= init
->ts
.is_iso_c
;
2096 sym
->ts
.is_c_interop
|= init
->ts
.is_c_interop
;
2097 /* attr bits needed for module files. */
2098 sym
->attr
.is_iso_c
|= init
->ts
.is_iso_c
;
2099 sym
->attr
.is_c_interop
|= init
->ts
.is_c_interop
;
2100 if (init
->ts
.is_iso_c
)
2101 sym
->ts
.f90_type
= init
->ts
.f90_type
;
2104 /* Add initializer. Make sure we keep the ranks sane. */
2105 if (sym
->attr
.dimension
&& init
->rank
== 0)
2110 if (sym
->attr
.flavor
== FL_PARAMETER
2111 && init
->expr_type
== EXPR_CONSTANT
2112 && spec_size (sym
->as
, &size
)
2113 && mpz_cmp_si (size
, 0) > 0)
2115 array
= gfc_get_array_expr (init
->ts
.type
, init
->ts
.kind
,
2117 for (n
= 0; n
< (int)mpz_get_si (size
); n
++)
2118 gfc_constructor_append_expr (&array
->value
.constructor
,
2121 : gfc_copy_expr (init
),
2124 array
->shape
= gfc_get_shape (sym
->as
->rank
);
2125 for (n
= 0; n
< sym
->as
->rank
; n
++)
2126 spec_dimen_size (sym
->as
, n
, &array
->shape
[n
]);
2131 init
->rank
= sym
->as
->rank
;
2135 if (sym
->attr
.save
== SAVE_NONE
)
2136 sym
->attr
.save
= SAVE_IMPLICIT
;
2144 /* Function called by variable_decl() that adds a name to a structure
2148 build_struct (const char *name
, gfc_charlen
*cl
, gfc_expr
**init
,
2149 gfc_array_spec
**as
)
2154 /* F03:C438/C439. If the current symbol is of the same derived type that we're
2155 constructing, it must have the pointer attribute. */
2156 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
2157 && current_ts
.u
.derived
== gfc_current_block ()
2158 && current_attr
.pointer
== 0)
2160 if (current_attr
.allocatable
2161 && !gfc_notify_std(GFC_STD_F2008
, "Component at %C "
2162 "must have the POINTER attribute"))
2166 else if (current_attr
.allocatable
== 0)
2168 gfc_error ("Component at %C must have the POINTER attribute");
2174 if (current_ts
.type
== BT_CLASS
2175 && !(current_attr
.pointer
|| current_attr
.allocatable
))
2177 gfc_error ("Component %qs with CLASS at %C must be allocatable "
2178 "or pointer", name
);
2182 if (gfc_current_block ()->attr
.pointer
&& (*as
)->rank
!= 0)
2184 if ((*as
)->type
!= AS_DEFERRED
&& (*as
)->type
!= AS_EXPLICIT
)
2186 gfc_error ("Array component of structure at %C must have explicit "
2187 "or deferred shape");
2192 /* If we are in a nested union/map definition, gfc_add_component will not
2193 properly find repeated components because:
2194 (i) gfc_add_component does a flat search, where components of unions
2195 and maps are implicity chained so nested components may conflict.
2196 (ii) Unions and maps are not linked as components of their parent
2197 structures until after they are parsed.
2198 For (i) we use gfc_find_component which searches recursively, and for (ii)
2199 we search each block directly from the parse stack until we find the top
2202 s
= gfc_state_stack
;
2203 if (s
->state
== COMP_UNION
|| s
->state
== COMP_MAP
)
2205 while (s
->state
== COMP_UNION
|| gfc_comp_struct (s
->state
))
2207 c
= gfc_find_component (s
->sym
, name
, true, true, NULL
);
2210 gfc_error_now ("Component %qs at %C already declared at %L",
2214 /* Break after we've searched the entire chain. */
2215 if (s
->state
== COMP_DERIVED
|| s
->state
== COMP_STRUCTURE
)
2221 if (!gfc_add_component (gfc_current_block(), name
, &c
))
2225 if (c
->ts
.type
== BT_CHARACTER
)
2228 if (c
->ts
.type
!= BT_CLASS
&& c
->ts
.type
!= BT_DERIVED
2229 && (c
->ts
.kind
== 0 || c
->ts
.type
== BT_CHARACTER
)
2230 && saved_kind_expr
!= NULL
)
2231 c
->kind_expr
= gfc_copy_expr (saved_kind_expr
);
2233 c
->attr
= current_attr
;
2235 c
->initializer
= *init
;
2242 c
->attr
.codimension
= 1;
2244 c
->attr
.dimension
= 1;
2248 gfc_apply_init (&c
->ts
, &c
->attr
, c
->initializer
);
2250 /* Check array components. */
2251 if (!c
->attr
.dimension
)
2254 if (c
->attr
.pointer
)
2256 if (c
->as
->type
!= AS_DEFERRED
)
2258 gfc_error ("Pointer array component of structure at %C must have a "
2263 else if (c
->attr
.allocatable
)
2265 if (c
->as
->type
!= AS_DEFERRED
)
2267 gfc_error ("Allocatable component of structure at %C must have a "
2274 if (c
->as
->type
!= AS_EXPLICIT
)
2276 gfc_error ("Array component of structure at %C must have an "
2283 if (c
->ts
.type
== BT_CLASS
)
2284 return gfc_build_class_symbol (&c
->ts
, &c
->attr
, &c
->as
);
2286 if (c
->attr
.pdt_kind
|| c
->attr
.pdt_len
)
2289 gfc_find_symbol (c
->name
, gfc_current_block ()->f2k_derived
,
2293 gfc_error ("Type parameter %qs at %C has no corresponding entry "
2294 "in the type parameter name list at %L",
2295 c
->name
, &gfc_current_block ()->declared_at
);
2299 sym
->attr
.pdt_kind
= c
->attr
.pdt_kind
;
2300 sym
->attr
.pdt_len
= c
->attr
.pdt_len
;
2302 sym
->value
= gfc_copy_expr (c
->initializer
);
2303 sym
->attr
.flavor
= FL_VARIABLE
;
2306 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
2307 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_template
2308 && decl_type_param_list
)
2309 c
->param_list
= gfc_copy_actual_arglist (decl_type_param_list
);
2315 /* Match a 'NULL()', and possibly take care of some side effects. */
2318 gfc_match_null (gfc_expr
**result
)
2321 match m
, m2
= MATCH_NO
;
2323 if ((m
= gfc_match (" null ( )")) == MATCH_ERROR
)
2329 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2331 if ((m2
= gfc_match (" null (")) != MATCH_YES
)
2334 old_loc
= gfc_current_locus
;
2335 if ((m2
= gfc_match (" %n ) ", name
)) == MATCH_ERROR
)
2338 && ((m2
= gfc_match (" mold = %n )", name
)) == MATCH_ERROR
))
2342 gfc_current_locus
= old_loc
;
2347 /* The NULL symbol now has to be/become an intrinsic function. */
2348 if (gfc_get_symbol ("null", NULL
, &sym
))
2350 gfc_error ("NULL() initialization at %C is ambiguous");
2354 gfc_intrinsic_symbol (sym
);
2356 if (sym
->attr
.proc
!= PROC_INTRINSIC
2357 && !(sym
->attr
.use_assoc
&& sym
->attr
.intrinsic
)
2358 && (!gfc_add_procedure(&sym
->attr
, PROC_INTRINSIC
, sym
->name
, NULL
)
2359 || !gfc_add_function (&sym
->attr
, sym
->name
, NULL
)))
2362 *result
= gfc_get_null_expr (&gfc_current_locus
);
2364 /* Invalid per F2008, C512. */
2365 if (m2
== MATCH_YES
)
2367 gfc_error ("NULL() initialization at %C may not have MOLD");
2375 /* Match the initialization expr for a data pointer or procedure pointer. */
2378 match_pointer_init (gfc_expr
**init
, int procptr
)
2382 if (gfc_pure (NULL
) && !gfc_comp_struct (gfc_state_stack
->state
))
2384 gfc_error ("Initialization of pointer at %C is not allowed in "
2385 "a PURE procedure");
2388 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
2390 /* Match NULL() initialization. */
2391 m
= gfc_match_null (init
);
2395 /* Match non-NULL initialization. */
2396 gfc_matching_ptr_assignment
= !procptr
;
2397 gfc_matching_procptr_assignment
= procptr
;
2398 m
= gfc_match_rvalue (init
);
2399 gfc_matching_ptr_assignment
= 0;
2400 gfc_matching_procptr_assignment
= 0;
2401 if (m
== MATCH_ERROR
)
2403 else if (m
== MATCH_NO
)
2405 gfc_error ("Error in pointer initialization at %C");
2409 if (!procptr
&& !gfc_resolve_expr (*init
))
2412 if (!gfc_notify_std (GFC_STD_F2008
, "non-NULL pointer "
2413 "initialization at %C"))
2421 check_function_name (char *name
)
2423 /* In functions that have a RESULT variable defined, the function name always
2424 refers to function calls. Therefore, the name is not allowed to appear in
2425 specification statements. When checking this, be careful about
2426 'hidden' procedure pointer results ('ppr@'). */
2428 if (gfc_current_state () == COMP_FUNCTION
)
2430 gfc_symbol
*block
= gfc_current_block ();
2431 if (block
&& block
->result
&& block
->result
!= block
2432 && strcmp (block
->result
->name
, "ppr@") != 0
2433 && strcmp (block
->name
, name
) == 0)
2435 gfc_error ("RESULT variable %qs at %L prohibits FUNCTION name %qs at %C "
2436 "from appearing in a specification statement",
2437 block
->result
->name
, &block
->result
->declared_at
, name
);
2446 /* Match a variable name with an optional initializer. When this
2447 subroutine is called, a variable is expected to be parsed next.
2448 Depending on what is happening at the moment, updates either the
2449 symbol table or the current interface. */
2452 variable_decl (int elem
)
2454 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2455 static unsigned int fill_id
= 0;
2456 gfc_expr
*initializer
, *char_len
;
2458 gfc_array_spec
*cp_as
; /* Extra copy for Cray Pointees. */
2471 /* When we get here, we've just matched a list of attributes and
2472 maybe a type and a double colon. The next thing we expect to see
2473 is the name of the symbol. */
2475 /* If we are parsing a structure with legacy support, we allow the symbol
2476 name to be '%FILL' which gives it an anonymous (inaccessible) name. */
2478 gfc_gobble_whitespace ();
2479 c
= gfc_peek_ascii_char ();
2482 gfc_next_ascii_char (); /* Burn % character. */
2483 m
= gfc_match ("fill");
2486 if (gfc_current_state () != COMP_STRUCTURE
)
2488 if (flag_dec_structure
)
2489 gfc_error ("%qs not allowed outside STRUCTURE at %C", "%FILL");
2491 gfc_error ("%qs at %C is a DEC extension, enable with "
2492 "%<-fdec-structure%>", "%FILL");
2499 gfc_error ("%qs entity cannot have attributes at %C", "%FILL");
2504 /* %FILL components are given invalid fortran names. */
2505 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "%%FILL%u", fill_id
++);
2509 gfc_error ("Invalid character %qc in variable name at %C", c
);
2515 m
= gfc_match_name (name
);
2520 var_locus
= gfc_current_locus
;
2522 /* Now we could see the optional array spec. or character length. */
2523 m
= gfc_match_array_spec (&as
, true, true);
2524 if (m
== MATCH_ERROR
)
2528 as
= gfc_copy_array_spec (current_as
);
2530 && !merge_array_spec (current_as
, as
, true))
2536 if (flag_cray_pointer
)
2537 cp_as
= gfc_copy_array_spec (as
);
2539 /* At this point, we know for sure if the symbol is PARAMETER and can thus
2540 determine (and check) whether it can be implied-shape. If it
2541 was parsed as assumed-size, change it because PARAMETERs cannot
2544 An explicit-shape-array cannot appear under several conditions.
2545 That check is done here as well. */
2548 if (as
->type
== AS_IMPLIED_SHAPE
&& current_attr
.flavor
!= FL_PARAMETER
)
2551 gfc_error ("Non-PARAMETER symbol %qs at %L cannot be implied-shape",
2556 if (as
->type
== AS_ASSUMED_SIZE
&& as
->rank
== 1
2557 && current_attr
.flavor
== FL_PARAMETER
)
2558 as
->type
= AS_IMPLIED_SHAPE
;
2560 if (as
->type
== AS_IMPLIED_SHAPE
2561 && !gfc_notify_std (GFC_STD_F2008
, "Implied-shape array at %L",
2568 gfc_seen_div0
= false;
2570 /* F2018:C830 (R816) An explicit-shape-spec whose bounds are not
2571 constant expressions shall appear only in a subprogram, derived
2572 type definition, BLOCK construct, or interface body. */
2573 if (as
->type
== AS_EXPLICIT
2574 && gfc_current_state () != COMP_BLOCK
2575 && gfc_current_state () != COMP_DERIVED
2576 && gfc_current_state () != COMP_FUNCTION
2577 && gfc_current_state () != COMP_INTERFACE
2578 && gfc_current_state () != COMP_SUBROUTINE
)
2581 bool not_constant
= false;
2583 for (int i
= 0; i
< as
->rank
; i
++)
2585 e
= gfc_copy_expr (as
->lower
[i
]);
2586 if (!gfc_resolve_expr (e
) && gfc_seen_div0
)
2592 gfc_simplify_expr (e
, 0);
2593 if (e
&& (e
->expr_type
!= EXPR_CONSTANT
))
2595 not_constant
= true;
2600 e
= gfc_copy_expr (as
->upper
[i
]);
2601 if (!gfc_resolve_expr (e
) && gfc_seen_div0
)
2607 gfc_simplify_expr (e
, 0);
2608 if (e
&& (e
->expr_type
!= EXPR_CONSTANT
))
2610 not_constant
= true;
2616 if (not_constant
&& e
->ts
.type
!= BT_INTEGER
)
2618 gfc_error ("Explicit array shape at %C must be constant of "
2619 "INTEGER type and not %s type",
2620 gfc_basic_typename (e
->ts
.type
));
2626 gfc_error ("Explicit shaped array with nonconstant bounds at %C");
2631 if (as
->type
== AS_EXPLICIT
)
2633 for (int i
= 0; i
< as
->rank
; i
++)
2637 if (e
->expr_type
!= EXPR_CONSTANT
)
2639 n
= gfc_copy_expr (e
);
2640 if (!gfc_simplify_expr (n
, 1) && gfc_seen_div0
)
2646 if (n
->expr_type
== EXPR_CONSTANT
)
2647 gfc_replace_expr (e
, n
);
2652 if (e
->expr_type
!= EXPR_CONSTANT
)
2654 n
= gfc_copy_expr (e
);
2655 if (!gfc_simplify_expr (n
, 1) && gfc_seen_div0
)
2661 if (n
->expr_type
== EXPR_CONSTANT
)
2662 gfc_replace_expr (e
, n
);
2672 cl_deferred
= false;
2674 if (current_ts
.type
== BT_CHARACTER
)
2676 switch (match_char_length (&char_len
, &cl_deferred
, false))
2679 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2681 cl
->length
= char_len
;
2684 /* Non-constant lengths need to be copied after the first
2685 element. Also copy assumed lengths. */
2688 && (current_ts
.u
.cl
->length
== NULL
2689 || current_ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
2691 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2692 cl
->length
= gfc_copy_expr (current_ts
.u
.cl
->length
);
2695 cl
= current_ts
.u
.cl
;
2697 cl_deferred
= current_ts
.deferred
;
2706 /* The dummy arguments and result of the abreviated form of MODULE
2707 PROCEDUREs, used in SUBMODULES should not be redefined. */
2708 if (gfc_current_ns
->proc_name
2709 && gfc_current_ns
->proc_name
->abr_modproc_decl
)
2711 gfc_find_symbol (name
, gfc_current_ns
, 1, &sym
);
2712 if (sym
!= NULL
&& (sym
->attr
.dummy
|| sym
->attr
.result
))
2715 gfc_error ("%qs at %C is a redefinition of the declaration "
2716 "in the corresponding interface for MODULE "
2717 "PROCEDURE %qs", sym
->name
,
2718 gfc_current_ns
->proc_name
->name
);
2723 /* %FILL components may not have initializers. */
2724 if (gfc_str_startswith (name
, "%FILL") && gfc_match_eos () != MATCH_YES
)
2726 gfc_error ("%qs entity cannot have an initializer at %C", "%FILL");
2731 /* If this symbol has already shown up in a Cray Pointer declaration,
2732 and this is not a component declaration,
2733 then we want to set the type & bail out. */
2734 if (flag_cray_pointer
&& !gfc_comp_struct (gfc_current_state ()))
2736 gfc_find_symbol (name
, gfc_current_ns
, 0, &sym
);
2737 if (sym
!= NULL
&& sym
->attr
.cray_pointee
)
2740 if (!gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
2746 /* Check to see if we have an array specification. */
2749 if (sym
->as
!= NULL
)
2751 gfc_error ("Duplicate array spec for Cray pointee at %C");
2752 gfc_free_array_spec (cp_as
);
2758 if (!gfc_set_array_spec (sym
, cp_as
, &var_locus
))
2759 gfc_internal_error ("Cannot set pointee array spec.");
2761 /* Fix the array spec. */
2762 m
= gfc_mod_pointee_as (sym
->as
);
2763 if (m
== MATCH_ERROR
)
2771 gfc_free_array_spec (cp_as
);
2775 /* Procedure pointer as function result. */
2776 if (gfc_current_state () == COMP_FUNCTION
2777 && strcmp ("ppr@", gfc_current_block ()->name
) == 0
2778 && strcmp (name
, gfc_current_block ()->ns
->proc_name
->name
) == 0)
2779 strcpy (name
, "ppr@");
2781 if (gfc_current_state () == COMP_FUNCTION
2782 && strcmp (name
, gfc_current_block ()->name
) == 0
2783 && gfc_current_block ()->result
2784 && strcmp ("ppr@", gfc_current_block ()->result
->name
) == 0)
2785 strcpy (name
, "ppr@");
2787 /* OK, we've successfully matched the declaration. Now put the
2788 symbol in the current namespace, because it might be used in the
2789 optional initialization expression for this symbol, e.g. this is
2792 integer, parameter :: i = huge(i)
2794 This is only true for parameters or variables of a basic type.
2795 For components of derived types, it is not true, so we don't
2796 create a symbol for those yet. If we fail to create the symbol,
2798 if (!gfc_comp_struct (gfc_current_state ())
2799 && !build_sym (name
, cl
, cl_deferred
, &as
, &var_locus
))
2805 if (!check_function_name (name
))
2811 /* We allow old-style initializations of the form
2812 integer i /2/, j(4) /3*3, 1/
2813 (if no colon has been seen). These are different from data
2814 statements in that initializers are only allowed to apply to the
2815 variable immediately preceding, i.e.
2817 is not allowed. Therefore we have to do some work manually, that
2818 could otherwise be left to the matchers for DATA statements. */
2820 if (!colon_seen
&& gfc_match (" /") == MATCH_YES
)
2822 if (!gfc_notify_std (GFC_STD_GNU
, "Old-style "
2823 "initialization at %C"))
2826 /* Allow old style initializations for components of STRUCTUREs and MAPs
2827 but not components of derived types. */
2828 else if (gfc_current_state () == COMP_DERIVED
)
2830 gfc_error ("Invalid old style initialization for derived type "
2836 /* For structure components, read the initializer as a special
2837 expression and let the rest of this function apply the initializer
2839 else if (gfc_comp_struct (gfc_current_state ()))
2841 m
= match_clist_expr (&initializer
, ¤t_ts
, as
);
2843 gfc_error ("Syntax error in old style initialization of %s at %C",
2849 /* Otherwise we treat the old style initialization just like a
2850 DATA declaration for the current variable. */
2852 return match_old_style_init (name
);
2855 /* The double colon must be present in order to have initializers.
2856 Otherwise the statement is ambiguous with an assignment statement. */
2859 if (gfc_match (" =>") == MATCH_YES
)
2861 if (!current_attr
.pointer
)
2863 gfc_error ("Initialization at %C isn't for a pointer variable");
2868 m
= match_pointer_init (&initializer
, 0);
2872 /* The target of a pointer initialization must have the SAVE
2873 attribute. A variable in PROGRAM, MODULE, or SUBMODULE scope
2874 is implicit SAVEd. Explicitly, set the SAVE_IMPLICIT value. */
2875 if (initializer
->expr_type
== EXPR_VARIABLE
2876 && initializer
->symtree
->n
.sym
->attr
.save
== SAVE_NONE
2877 && (gfc_current_state () == COMP_PROGRAM
2878 || gfc_current_state () == COMP_MODULE
2879 || gfc_current_state () == COMP_SUBMODULE
))
2880 initializer
->symtree
->n
.sym
->attr
.save
= SAVE_IMPLICIT
;
2882 else if (gfc_match_char ('=') == MATCH_YES
)
2884 if (current_attr
.pointer
)
2886 gfc_error ("Pointer initialization at %C requires %<=>%>, "
2892 m
= gfc_match_init_expr (&initializer
);
2895 gfc_error ("Expected an initialization expression at %C");
2899 if (current_attr
.flavor
!= FL_PARAMETER
&& gfc_pure (NULL
)
2900 && !gfc_comp_struct (gfc_state_stack
->state
))
2902 gfc_error ("Initialization of variable at %C is not allowed in "
2903 "a PURE procedure");
2907 if (current_attr
.flavor
!= FL_PARAMETER
2908 && !gfc_comp_struct (gfc_state_stack
->state
))
2909 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
2916 if (initializer
!= NULL
&& current_attr
.allocatable
2917 && gfc_comp_struct (gfc_current_state ()))
2919 gfc_error ("Initialization of allocatable component at %C is not "
2925 if (gfc_current_state () == COMP_DERIVED
2926 && initializer
&& initializer
->ts
.type
== BT_HOLLERITH
)
2928 gfc_error ("Initialization of structure component with a HOLLERITH "
2929 "constant at %L is not allowed", &initializer
->where
);
2934 if (gfc_current_state () == COMP_DERIVED
2935 && gfc_current_block ()->attr
.pdt_template
)
2938 gfc_find_symbol (name
, gfc_current_block ()->f2k_derived
,
2940 if (!param
&& (current_attr
.pdt_kind
|| current_attr
.pdt_len
))
2942 gfc_error ("The component with KIND or LEN attribute at %C does not "
2943 "not appear in the type parameter list at %L",
2944 &gfc_current_block ()->declared_at
);
2948 else if (param
&& !(current_attr
.pdt_kind
|| current_attr
.pdt_len
))
2950 gfc_error ("The component at %C that appears in the type parameter "
2951 "list at %L has neither the KIND nor LEN attribute",
2952 &gfc_current_block ()->declared_at
);
2956 else if (as
&& (current_attr
.pdt_kind
|| current_attr
.pdt_len
))
2958 gfc_error ("The component at %C which is a type parameter must be "
2963 else if (param
&& initializer
)
2965 if (initializer
->ts
.type
== BT_BOZ
)
2967 gfc_error ("BOZ literal constant at %L cannot appear as an "
2968 "initializer", &initializer
->where
);
2972 param
->value
= gfc_copy_expr (initializer
);
2976 /* Before adding a possible initilizer, do a simple check for compatibility
2977 of lhs and rhs types. Assigning a REAL value to a derived type is not a
2979 if (current_ts
.type
== BT_DERIVED
&& initializer
2980 && (gfc_numeric_ts (&initializer
->ts
)
2981 || initializer
->ts
.type
== BT_LOGICAL
2982 || initializer
->ts
.type
== BT_CHARACTER
))
2984 gfc_error ("Incompatible initialization between a derived type "
2985 "entity and an entity with %qs type at %C",
2986 gfc_typename (initializer
));
2992 /* Add the initializer. Note that it is fine if initializer is
2993 NULL here, because we sometimes also need to check if a
2994 declaration *must* have an initialization expression. */
2995 if (!gfc_comp_struct (gfc_current_state ()))
2996 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
2999 if (current_ts
.type
== BT_DERIVED
3000 && !current_attr
.pointer
&& !initializer
)
3001 initializer
= gfc_default_initializer (¤t_ts
);
3002 t
= build_struct (name
, cl
, &initializer
, &as
);
3004 /* If we match a nested structure definition we expect to see the
3005 * body even if the variable declarations blow up, so we need to keep
3006 * the structure declaration around. */
3007 if (gfc_new_block
&& gfc_new_block
->attr
.flavor
== FL_STRUCT
)
3008 gfc_commit_symbol (gfc_new_block
);
3011 m
= (t
) ? MATCH_YES
: MATCH_ERROR
;
3014 /* Free stuff up and return. */
3015 gfc_seen_div0
= false;
3016 gfc_free_expr (initializer
);
3017 gfc_free_array_spec (as
);
3023 /* Match an extended-f77 "TYPESPEC*bytesize"-style kind specification.
3024 This assumes that the byte size is equal to the kind number for
3025 non-COMPLEX types, and equal to twice the kind number for COMPLEX. */
3028 gfc_match_old_kind_spec (gfc_typespec
*ts
)
3033 if (gfc_match_char ('*') != MATCH_YES
)
3036 m
= gfc_match_small_literal_int (&ts
->kind
, NULL
);
3040 original_kind
= ts
->kind
;
3042 /* Massage the kind numbers for complex types. */
3043 if (ts
->type
== BT_COMPLEX
)
3047 gfc_error ("Old-style type declaration %s*%d not supported at %C",
3048 gfc_basic_typename (ts
->type
), original_kind
);
3055 if (ts
->type
== BT_INTEGER
&& ts
->kind
== 4 && flag_integer4_kind
== 8)
3058 if (ts
->type
== BT_REAL
|| ts
->type
== BT_COMPLEX
)
3062 if (flag_real4_kind
== 8)
3064 if (flag_real4_kind
== 10)
3066 if (flag_real4_kind
== 16)
3072 if (flag_real8_kind
== 4)
3074 if (flag_real8_kind
== 10)
3076 if (flag_real8_kind
== 16)
3081 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
3083 gfc_error ("Old-style type declaration %s*%d not supported at %C",
3084 gfc_basic_typename (ts
->type
), original_kind
);
3088 if (!gfc_notify_std (GFC_STD_GNU
,
3089 "Nonstandard type declaration %s*%d at %C",
3090 gfc_basic_typename(ts
->type
), original_kind
))
3097 /* Match a kind specification. Since kinds are generally optional, we
3098 usually return MATCH_NO if something goes wrong. If a "kind="
3099 string is found, then we know we have an error. */
3102 gfc_match_kind_spec (gfc_typespec
*ts
, bool kind_expr_only
)
3112 saved_kind_expr
= NULL
;
3114 where
= loc
= gfc_current_locus
;
3119 if (gfc_match_char ('(') == MATCH_NO
)
3122 /* Also gobbles optional text. */
3123 if (gfc_match (" kind = ") == MATCH_YES
)
3126 loc
= gfc_current_locus
;
3130 n
= gfc_match_init_expr (&e
);
3132 if (gfc_derived_parameter_expr (e
))
3135 saved_kind_expr
= gfc_copy_expr (e
);
3136 goto close_brackets
;
3141 if (gfc_matching_function
)
3143 /* The function kind expression might include use associated or
3144 imported parameters and try again after the specification
3146 if (gfc_match_char (')') != MATCH_YES
)
3148 gfc_error ("Missing right parenthesis at %C");
3154 gfc_undo_symbols ();
3159 /* ....or else, the match is real. */
3161 gfc_error ("Expected initialization expression at %C");
3169 gfc_error ("Expected scalar initialization expression at %C");
3174 if (gfc_extract_int (e
, &ts
->kind
, 1))
3180 /* Before throwing away the expression, let's see if we had a
3181 C interoperable kind (and store the fact). */
3182 if (e
->ts
.is_c_interop
== 1)
3184 /* Mark this as C interoperable if being declared with one
3185 of the named constants from iso_c_binding. */
3186 ts
->is_c_interop
= e
->ts
.is_iso_c
;
3187 ts
->f90_type
= e
->ts
.f90_type
;
3189 ts
->interop_kind
= e
->symtree
->n
.sym
;
3195 /* Ignore errors to this point, if we've gotten here. This means
3196 we ignore the m=MATCH_ERROR from above. */
3197 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
3199 gfc_error ("Kind %d not supported for type %s at %C", ts
->kind
,
3200 gfc_basic_typename (ts
->type
));
3201 gfc_current_locus
= where
;
3205 /* Warn if, e.g., c_int is used for a REAL variable, but not
3206 if, e.g., c_double is used for COMPLEX as the standard
3207 explicitly says that the kind type parameter for complex and real
3208 variable is the same, i.e. c_float == c_float_complex. */
3209 if (ts
->f90_type
!= BT_UNKNOWN
&& ts
->f90_type
!= ts
->type
3210 && !((ts
->f90_type
== BT_REAL
&& ts
->type
== BT_COMPLEX
)
3211 || (ts
->f90_type
== BT_COMPLEX
&& ts
->type
== BT_REAL
)))
3212 gfc_warning_now (0, "C kind type parameter is for type %s but type at %L "
3213 "is %s", gfc_basic_typename (ts
->f90_type
), &where
,
3214 gfc_basic_typename (ts
->type
));
3218 gfc_gobble_whitespace ();
3219 if ((c
= gfc_next_ascii_char ()) != ')'
3220 && (ts
->type
!= BT_CHARACTER
|| c
!= ','))
3222 if (ts
->type
== BT_CHARACTER
)
3223 gfc_error ("Missing right parenthesis or comma at %C");
3225 gfc_error ("Missing right parenthesis at %C");
3229 /* All tests passed. */
3232 if(m
== MATCH_ERROR
)
3233 gfc_current_locus
= where
;
3235 if (ts
->type
== BT_INTEGER
&& ts
->kind
== 4 && flag_integer4_kind
== 8)
3238 if (ts
->type
== BT_REAL
|| ts
->type
== BT_COMPLEX
)
3242 if (flag_real4_kind
== 8)
3244 if (flag_real4_kind
== 10)
3246 if (flag_real4_kind
== 16)
3252 if (flag_real8_kind
== 4)
3254 if (flag_real8_kind
== 10)
3256 if (flag_real8_kind
== 16)
3261 /* Return what we know from the test(s). */
3266 gfc_current_locus
= where
;
3272 match_char_kind (int * kind
, int * is_iso_c
)
3281 where
= gfc_current_locus
;
3283 n
= gfc_match_init_expr (&e
);
3285 if (n
!= MATCH_YES
&& gfc_matching_function
)
3287 /* The expression might include use-associated or imported
3288 parameters and try again after the specification
3291 gfc_undo_symbols ();
3296 gfc_error ("Expected initialization expression at %C");
3302 gfc_error ("Expected scalar initialization expression at %C");
3307 if (gfc_derived_parameter_expr (e
))
3309 saved_kind_expr
= e
;
3314 fail
= gfc_extract_int (e
, kind
, 1);
3315 *is_iso_c
= e
->ts
.is_iso_c
;
3324 /* Ignore errors to this point, if we've gotten here. This means
3325 we ignore the m=MATCH_ERROR from above. */
3326 if (gfc_validate_kind (BT_CHARACTER
, *kind
, true) < 0)
3328 gfc_error ("Kind %d is not supported for CHARACTER at %C", *kind
);
3332 /* All tests passed. */
3335 if (m
== MATCH_ERROR
)
3336 gfc_current_locus
= where
;
3338 /* Return what we know from the test(s). */
3343 gfc_current_locus
= where
;
3348 /* Match the various kind/length specifications in a CHARACTER
3349 declaration. We don't return MATCH_NO. */
3352 gfc_match_char_spec (gfc_typespec
*ts
)
3354 int kind
, seen_length
, is_iso_c
;
3366 /* Try the old-style specification first. */
3367 old_char_selector
= 0;
3369 m
= match_char_length (&len
, &deferred
, true);
3373 old_char_selector
= 1;
3378 m
= gfc_match_char ('(');
3381 m
= MATCH_YES
; /* Character without length is a single char. */
3385 /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ). */
3386 if (gfc_match (" kind =") == MATCH_YES
)
3388 m
= match_char_kind (&kind
, &is_iso_c
);
3390 if (m
== MATCH_ERROR
)
3395 if (gfc_match (" , len =") == MATCH_NO
)
3398 m
= char_len_param_value (&len
, &deferred
);
3401 if (m
== MATCH_ERROR
)
3408 /* Try to match "LEN = <len-param>" or "LEN = <len-param>, KIND = <int>". */
3409 if (gfc_match (" len =") == MATCH_YES
)
3411 m
= char_len_param_value (&len
, &deferred
);
3414 if (m
== MATCH_ERROR
)
3418 if (gfc_match_char (')') == MATCH_YES
)
3421 if (gfc_match (" , kind =") != MATCH_YES
)
3424 if (match_char_kind (&kind
, &is_iso_c
) == MATCH_ERROR
)
3430 /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ). */
3431 m
= char_len_param_value (&len
, &deferred
);
3434 if (m
== MATCH_ERROR
)
3438 m
= gfc_match_char (')');
3442 if (gfc_match_char (',') != MATCH_YES
)
3445 gfc_match (" kind ="); /* Gobble optional text. */
3447 m
= match_char_kind (&kind
, &is_iso_c
);
3448 if (m
== MATCH_ERROR
)
3454 /* Require a right-paren at this point. */
3455 m
= gfc_match_char (')');
3460 gfc_error ("Syntax error in CHARACTER declaration at %C");
3462 gfc_free_expr (len
);
3466 /* Deal with character functions after USE and IMPORT statements. */
3467 if (gfc_matching_function
)
3469 gfc_free_expr (len
);
3470 gfc_undo_symbols ();
3476 gfc_free_expr (len
);
3480 /* Do some final massaging of the length values. */
3481 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
3483 if (seen_length
== 0)
3484 cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
, 1);
3487 /* If gfortran ends up here, then len may be reducible to a constant.
3488 Try to do that here. If it does not reduce, simply assign len to
3489 charlen. A complication occurs with user-defined generic functions,
3490 which are not resolved. Use a private namespace to deal with
3491 generic functions. */
3493 if (len
&& len
->expr_type
!= EXPR_CONSTANT
)
3495 gfc_namespace
*old_ns
;
3498 old_ns
= gfc_current_ns
;
3499 gfc_current_ns
= gfc_get_namespace (NULL
, 0);
3501 e
= gfc_copy_expr (len
);
3502 gfc_reduce_init_expr (e
);
3503 if (e
->expr_type
== EXPR_CONSTANT
)
3505 gfc_replace_expr (len
, e
);
3506 if (mpz_cmp_si (len
->value
.integer
, 0) < 0)
3507 mpz_set_ui (len
->value
.integer
, 0);
3512 gfc_free_namespace (gfc_current_ns
);
3513 gfc_current_ns
= old_ns
;
3520 ts
->kind
= kind
== 0 ? gfc_default_character_kind
: kind
;
3521 ts
->deferred
= deferred
;
3523 /* We have to know if it was a C interoperable kind so we can
3524 do accurate type checking of bind(c) procs, etc. */
3526 /* Mark this as C interoperable if being declared with one
3527 of the named constants from iso_c_binding. */
3528 ts
->is_c_interop
= is_iso_c
;
3529 else if (len
!= NULL
)
3530 /* Here, we might have parsed something such as: character(c_char)
3531 In this case, the parsing code above grabs the c_char when
3532 looking for the length (line 1690, roughly). it's the last
3533 testcase for parsing the kind params of a character variable.
3534 However, it's not actually the length. this seems like it
3536 To see if the user used a C interop kind, test the expr
3537 of the so called length, and see if it's C interoperable. */
3538 ts
->is_c_interop
= len
->ts
.is_iso_c
;
3544 /* Matches a RECORD declaration. */
3547 match_record_decl (char *name
)
3550 old_loc
= gfc_current_locus
;
3553 m
= gfc_match (" record /");
3556 if (!flag_dec_structure
)
3558 gfc_current_locus
= old_loc
;
3559 gfc_error ("RECORD at %C is an extension, enable it with "
3560 "%<-fdec-structure%>");
3563 m
= gfc_match (" %n/", name
);
3568 gfc_current_locus
= old_loc
;
3569 if (flag_dec_structure
3570 && (gfc_match (" record% ") == MATCH_YES
3571 || gfc_match (" record%t") == MATCH_YES
))
3572 gfc_error ("Structure name expected after RECORD at %C");
3580 /* This function uses the gfc_actual_arglist 'type_param_spec_list' as a source
3581 of expressions to substitute into the possibly parameterized expression
3582 'e'. Using a list is inefficient but should not be too bad since the
3583 number of type parameters is not likely to be large. */
3585 insert_parameter_exprs (gfc_expr
* e
, gfc_symbol
* sym ATTRIBUTE_UNUSED
,
3588 gfc_actual_arglist
*param
;
3591 if (e
->expr_type
!= EXPR_VARIABLE
)
3594 gcc_assert (e
->symtree
);
3595 if (e
->symtree
->n
.sym
->attr
.pdt_kind
3596 || (*f
!= 0 && e
->symtree
->n
.sym
->attr
.pdt_len
))
3598 for (param
= type_param_spec_list
; param
; param
= param
->next
)
3599 if (strcmp (e
->symtree
->n
.sym
->name
, param
->name
) == 0)
3604 copy
= gfc_copy_expr (param
->expr
);
3615 gfc_insert_kind_parameter_exprs (gfc_expr
*e
)
3617 return gfc_traverse_expr (e
, NULL
, &insert_parameter_exprs
, 0);
3622 gfc_insert_parameter_exprs (gfc_expr
*e
, gfc_actual_arglist
*param_list
)
3624 gfc_actual_arglist
*old_param_spec_list
= type_param_spec_list
;
3625 type_param_spec_list
= param_list
;
3626 return gfc_traverse_expr (e
, NULL
, &insert_parameter_exprs
, 1);
3627 type_param_spec_list
= NULL
;
3628 type_param_spec_list
= old_param_spec_list
;
3631 /* Determines the instance of a parameterized derived type to be used by
3632 matching determining the values of the kind parameters and using them
3633 in the name of the instance. If the instance exists, it is used, otherwise
3634 a new derived type is created. */
3636 gfc_get_pdt_instance (gfc_actual_arglist
*param_list
, gfc_symbol
**sym
,
3637 gfc_actual_arglist
**ext_param_list
)
3639 /* The PDT template symbol. */
3640 gfc_symbol
*pdt
= *sym
;
3641 /* The symbol for the parameter in the template f2k_namespace. */
3643 /* The hoped for instance of the PDT. */
3644 gfc_symbol
*instance
;
3645 /* The list of parameters appearing in the PDT declaration. */
3646 gfc_formal_arglist
*type_param_name_list
;
3647 /* Used to store the parameter specification list during recursive calls. */
3648 gfc_actual_arglist
*old_param_spec_list
;
3649 /* Pointers to the parameter specification being used. */
3650 gfc_actual_arglist
*actual_param
;
3651 gfc_actual_arglist
*tail
= NULL
;
3652 /* Used to build up the name of the PDT instance. The prefix uses 4
3653 characters and each KIND parameter 2 more. Allow 8 of the latter. */
3654 char name
[GFC_MAX_SYMBOL_LEN
+ 21];
3656 bool name_seen
= (param_list
== NULL
);
3657 bool assumed_seen
= false;
3658 bool deferred_seen
= false;
3659 bool spec_error
= false;
3661 gfc_expr
*kind_expr
;
3662 gfc_component
*c1
, *c2
;
3665 type_param_spec_list
= NULL
;
3667 type_param_name_list
= pdt
->formal
;
3668 actual_param
= param_list
;
3669 sprintf (name
, "Pdt%s", pdt
->name
);
3671 /* Run through the parameter name list and pick up the actual
3672 parameter values or use the default values in the PDT declaration. */
3673 for (; type_param_name_list
;
3674 type_param_name_list
= type_param_name_list
->next
)
3676 if (actual_param
&& actual_param
->spec_type
!= SPEC_EXPLICIT
)
3678 if (actual_param
->spec_type
== SPEC_ASSUMED
)
3679 spec_error
= deferred_seen
;
3681 spec_error
= assumed_seen
;
3685 gfc_error ("The type parameter spec list at %C cannot contain "
3686 "both ASSUMED and DEFERRED parameters");
3691 if (actual_param
&& actual_param
->name
)
3693 param
= type_param_name_list
->sym
;
3695 if (!param
|| !param
->name
)
3698 c1
= gfc_find_component (pdt
, param
->name
, false, true, NULL
);
3699 /* An error should already have been thrown in resolve.c
3700 (resolve_fl_derived0). */
3701 if (!pdt
->attr
.use_assoc
&& !c1
)
3707 if (!actual_param
&& !(c1
&& c1
->initializer
))
3709 gfc_error ("The type parameter spec list at %C does not contain "
3710 "enough parameter expressions");
3713 else if (!actual_param
&& c1
&& c1
->initializer
)
3714 kind_expr
= gfc_copy_expr (c1
->initializer
);
3715 else if (actual_param
&& actual_param
->spec_type
== SPEC_EXPLICIT
)
3716 kind_expr
= gfc_copy_expr (actual_param
->expr
);
3720 actual_param
= param_list
;
3721 for (;actual_param
; actual_param
= actual_param
->next
)
3722 if (actual_param
->name
3723 && strcmp (actual_param
->name
, param
->name
) == 0)
3725 if (actual_param
&& actual_param
->spec_type
== SPEC_EXPLICIT
)
3726 kind_expr
= gfc_copy_expr (actual_param
->expr
);
3729 if (c1
->initializer
)
3730 kind_expr
= gfc_copy_expr (c1
->initializer
);
3731 else if (!(actual_param
&& param
->attr
.pdt_len
))
3733 gfc_error ("The derived parameter %qs at %C does not "
3734 "have a default value", param
->name
);
3740 /* Store the current parameter expressions in a temporary actual
3741 arglist 'list' so that they can be substituted in the corresponding
3742 expressions in the PDT instance. */
3743 if (type_param_spec_list
== NULL
)
3745 type_param_spec_list
= gfc_get_actual_arglist ();
3746 tail
= type_param_spec_list
;
3750 tail
->next
= gfc_get_actual_arglist ();
3753 tail
->name
= param
->name
;
3757 /* Try simplification even for LEN expressions. */
3759 gfc_resolve_expr (kind_expr
);
3760 ok
= gfc_simplify_expr (kind_expr
, 1);
3761 /* Variable expressions seem to default to BT_PROCEDURE.
3762 TODO find out why this is and fix it. */
3763 if (kind_expr
->ts
.type
!= BT_INTEGER
3764 && kind_expr
->ts
.type
!= BT_PROCEDURE
)
3766 gfc_error ("The parameter expression at %C must be of "
3767 "INTEGER type and not %s type",
3768 gfc_basic_typename (kind_expr
->ts
.type
));
3771 if (kind_expr
->ts
.type
== BT_INTEGER
&& !ok
)
3773 gfc_error ("The parameter expression at %C does not "
3774 "simplify to an INTEGER constant");
3778 tail
->expr
= gfc_copy_expr (kind_expr
);
3782 tail
->spec_type
= actual_param
->spec_type
;
3784 if (!param
->attr
.pdt_kind
)
3786 if (!name_seen
&& actual_param
)
3787 actual_param
= actual_param
->next
;
3790 gfc_free_expr (kind_expr
);
3797 && (actual_param
->spec_type
== SPEC_ASSUMED
3798 || actual_param
->spec_type
== SPEC_DEFERRED
))
3800 gfc_error ("The KIND parameter %qs at %C cannot either be "
3801 "ASSUMED or DEFERRED", param
->name
);
3805 if (!kind_expr
|| !gfc_is_constant_expr (kind_expr
))
3807 gfc_error ("The value for the KIND parameter %qs at %C does not "
3808 "reduce to a constant expression", param
->name
);
3812 gfc_extract_int (kind_expr
, &kind_value
);
3813 sprintf (name
+ strlen (name
), "_%d", kind_value
);
3815 if (!name_seen
&& actual_param
)
3816 actual_param
= actual_param
->next
;
3817 gfc_free_expr (kind_expr
);
3820 if (!name_seen
&& actual_param
)
3822 gfc_error ("The type parameter spec list at %C contains too many "
3823 "parameter expressions");
3827 /* Now we search for the PDT instance 'name'. If it doesn't exist, we
3828 build it, using 'pdt' as a template. */
3829 if (gfc_get_symbol (name
, pdt
->ns
, &instance
))
3831 gfc_error ("Parameterized derived type at %C is ambiguous");
3837 if (instance
->attr
.flavor
== FL_DERIVED
3838 && instance
->attr
.pdt_type
)
3842 *ext_param_list
= type_param_spec_list
;
3844 gfc_commit_symbols ();
3848 /* Start building the new instance of the parameterized type. */
3849 gfc_copy_attr (&instance
->attr
, &pdt
->attr
, &pdt
->declared_at
);
3850 instance
->attr
.pdt_template
= 0;
3851 instance
->attr
.pdt_type
= 1;
3852 instance
->declared_at
= gfc_current_locus
;
3854 /* Add the components, replacing the parameters in all expressions
3855 with the expressions for their values in 'type_param_spec_list'. */
3856 c1
= pdt
->components
;
3857 tail
= type_param_spec_list
;
3858 for (; c1
; c1
= c1
->next
)
3860 gfc_add_component (instance
, c1
->name
, &c2
);
3863 c2
->attr
= c1
->attr
;
3865 /* The order of declaration of the type_specs might not be the
3866 same as that of the components. */
3867 if (c1
->attr
.pdt_kind
|| c1
->attr
.pdt_len
)
3869 for (tail
= type_param_spec_list
; tail
; tail
= tail
->next
)
3870 if (strcmp (c1
->name
, tail
->name
) == 0)
3874 /* Deal with type extension by recursively calling this function
3875 to obtain the instance of the extended type. */
3876 if (gfc_current_state () != COMP_DERIVED
3877 && c1
== pdt
->components
3878 && (c1
->ts
.type
== BT_DERIVED
|| c1
->ts
.type
== BT_CLASS
)
3879 && c1
->ts
.u
.derived
&& c1
->ts
.u
.derived
->attr
.pdt_template
3880 && gfc_get_derived_super_type (*sym
) == c2
->ts
.u
.derived
)
3882 gfc_formal_arglist
*f
;
3884 old_param_spec_list
= type_param_spec_list
;
3886 /* Obtain a spec list appropriate to the extended type..*/
3887 actual_param
= gfc_copy_actual_arglist (type_param_spec_list
);
3888 type_param_spec_list
= actual_param
;
3889 for (f
= c1
->ts
.u
.derived
->formal
; f
&& f
->next
; f
= f
->next
)
3890 actual_param
= actual_param
->next
;
3893 gfc_free_actual_arglist (actual_param
->next
);
3894 actual_param
->next
= NULL
;
3897 /* Now obtain the PDT instance for the extended type. */
3898 c2
->param_list
= type_param_spec_list
;
3899 m
= gfc_get_pdt_instance (type_param_spec_list
, &c2
->ts
.u
.derived
,
3901 type_param_spec_list
= old_param_spec_list
;
3903 c2
->ts
.u
.derived
->refs
++;
3904 gfc_set_sym_referenced (c2
->ts
.u
.derived
);
3906 /* Set extension level. */
3907 if (c2
->ts
.u
.derived
->attr
.extension
== 255)
3909 /* Since the extension field is 8 bit wide, we can only have
3910 up to 255 extension levels. */
3911 gfc_error ("Maximum extension level reached with type %qs at %L",
3912 c2
->ts
.u
.derived
->name
,
3913 &c2
->ts
.u
.derived
->declared_at
);
3916 instance
->attr
.extension
= c2
->ts
.u
.derived
->attr
.extension
+ 1;
3921 /* Set the component kind using the parameterized expression. */
3922 if ((c1
->ts
.kind
== 0 || c1
->ts
.type
== BT_CHARACTER
)
3923 && c1
->kind_expr
!= NULL
)
3925 gfc_expr
*e
= gfc_copy_expr (c1
->kind_expr
);
3926 gfc_insert_kind_parameter_exprs (e
);
3927 gfc_simplify_expr (e
, 1);
3928 gfc_extract_int (e
, &c2
->ts
.kind
);
3930 if (gfc_validate_kind (c2
->ts
.type
, c2
->ts
.kind
, true) < 0)
3932 gfc_error ("Kind %d not supported for type %s at %C",
3933 c2
->ts
.kind
, gfc_basic_typename (c2
->ts
.type
));
3938 /* Similarly, set the string length if parameterized. */
3939 if (c1
->ts
.type
== BT_CHARACTER
3940 && c1
->ts
.u
.cl
->length
3941 && gfc_derived_parameter_expr (c1
->ts
.u
.cl
->length
))
3944 e
= gfc_copy_expr (c1
->ts
.u
.cl
->length
);
3945 gfc_insert_kind_parameter_exprs (e
);
3946 gfc_simplify_expr (e
, 1);
3947 c2
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
3948 c2
->ts
.u
.cl
->length
= e
;
3949 c2
->attr
.pdt_string
= 1;
3952 /* Set up either the KIND/LEN initializer, if constant,
3953 or the parameterized expression. Use the template
3954 initializer if one is not already set in this instance. */
3955 if (c2
->attr
.pdt_kind
|| c2
->attr
.pdt_len
)
3957 if (tail
&& tail
->expr
&& gfc_is_constant_expr (tail
->expr
))
3958 c2
->initializer
= gfc_copy_expr (tail
->expr
);
3959 else if (tail
&& tail
->expr
)
3961 c2
->param_list
= gfc_get_actual_arglist ();
3962 c2
->param_list
->name
= tail
->name
;
3963 c2
->param_list
->expr
= gfc_copy_expr (tail
->expr
);
3964 c2
->param_list
->next
= NULL
;
3967 if (!c2
->initializer
&& c1
->initializer
)
3968 c2
->initializer
= gfc_copy_expr (c1
->initializer
);
3971 /* Copy the array spec. */
3972 c2
->as
= gfc_copy_array_spec (c1
->as
);
3973 if (c1
->ts
.type
== BT_CLASS
)
3974 CLASS_DATA (c2
)->as
= gfc_copy_array_spec (CLASS_DATA (c1
)->as
);
3976 /* Determine if an array spec is parameterized. If so, substitute
3977 in the parameter expressions for the bounds and set the pdt_array
3978 attribute. Notice that this attribute must be unconditionally set
3979 if this is an array of parameterized character length. */
3980 if (c1
->as
&& c1
->as
->type
== AS_EXPLICIT
)
3982 bool pdt_array
= false;
3984 /* Are the bounds of the array parameterized? */
3985 for (i
= 0; i
< c1
->as
->rank
; i
++)
3987 if (gfc_derived_parameter_expr (c1
->as
->lower
[i
]))
3989 if (gfc_derived_parameter_expr (c1
->as
->upper
[i
]))
3993 /* If they are, free the expressions for the bounds and
3994 replace them with the template expressions with substitute
3996 for (i
= 0; pdt_array
&& i
< c1
->as
->rank
; i
++)
3999 e
= gfc_copy_expr (c1
->as
->lower
[i
]);
4000 gfc_insert_kind_parameter_exprs (e
);
4001 gfc_simplify_expr (e
, 1);
4002 gfc_free_expr (c2
->as
->lower
[i
]);
4003 c2
->as
->lower
[i
] = e
;
4004 e
= gfc_copy_expr (c1
->as
->upper
[i
]);
4005 gfc_insert_kind_parameter_exprs (e
);
4006 gfc_simplify_expr (e
, 1);
4007 gfc_free_expr (c2
->as
->upper
[i
]);
4008 c2
->as
->upper
[i
] = e
;
4010 c2
->attr
.pdt_array
= pdt_array
? 1 : c2
->attr
.pdt_string
;
4011 if (c1
->initializer
)
4013 c2
->initializer
= gfc_copy_expr (c1
->initializer
);
4014 gfc_insert_kind_parameter_exprs (c2
->initializer
);
4015 gfc_simplify_expr (c2
->initializer
, 1);
4019 /* Recurse into this function for PDT components. */
4020 if ((c1
->ts
.type
== BT_DERIVED
|| c1
->ts
.type
== BT_CLASS
)
4021 && c1
->ts
.u
.derived
&& c1
->ts
.u
.derived
->attr
.pdt_template
)
4023 gfc_actual_arglist
*params
;
4024 /* The component in the template has a list of specification
4025 expressions derived from its declaration. */
4026 params
= gfc_copy_actual_arglist (c1
->param_list
);
4027 actual_param
= params
;
4028 /* Substitute the template parameters with the expressions
4029 from the specification list. */
4030 for (;actual_param
; actual_param
= actual_param
->next
)
4031 gfc_insert_parameter_exprs (actual_param
->expr
,
4032 type_param_spec_list
);
4034 /* Now obtain the PDT instance for the component. */
4035 old_param_spec_list
= type_param_spec_list
;
4036 m
= gfc_get_pdt_instance (params
, &c2
->ts
.u
.derived
, NULL
);
4037 type_param_spec_list
= old_param_spec_list
;
4039 c2
->param_list
= params
;
4040 if (!(c2
->attr
.pointer
|| c2
->attr
.allocatable
))
4041 c2
->initializer
= gfc_default_initializer (&c2
->ts
);
4043 if (c2
->attr
.allocatable
)
4044 instance
->attr
.alloc_comp
= 1;
4048 gfc_commit_symbol (instance
);
4050 *ext_param_list
= type_param_spec_list
;
4055 gfc_free_actual_arglist (type_param_spec_list
);
4060 /* Match a legacy nonstandard BYTE type-spec. */
4063 match_byte_typespec (gfc_typespec
*ts
)
4065 if (gfc_match (" byte") == MATCH_YES
)
4067 if (!gfc_notify_std (GFC_STD_GNU
, "BYTE type at %C"))
4070 if (gfc_current_form
== FORM_FREE
)
4072 char c
= gfc_peek_ascii_char ();
4073 if (!gfc_is_whitespace (c
) && c
!= ',')
4077 if (gfc_validate_kind (BT_INTEGER
, 1, true) < 0)
4079 gfc_error ("BYTE type used at %C "
4080 "is not available on the target machine");
4084 ts
->type
= BT_INTEGER
;
4092 /* Matches a declaration-type-spec (F03:R502). If successful, sets the ts
4093 structure to the matched specification. This is necessary for FUNCTION and
4094 IMPLICIT statements.
4096 If implicit_flag is nonzero, then we don't check for the optional
4097 kind specification. Not doing so is needed for matching an IMPLICIT
4098 statement correctly. */
4101 gfc_match_decl_type_spec (gfc_typespec
*ts
, int implicit_flag
)
4103 /* Provide sufficient space to hold "pdtsymbol". */
4104 char *name
= XALLOCAVEC (char, GFC_MAX_SYMBOL_LEN
+ 1);
4105 gfc_symbol
*sym
, *dt_sym
;
4108 bool seen_deferred_kind
, matched_type
;
4109 const char *dt_name
;
4111 decl_type_param_list
= NULL
;
4113 /* A belt and braces check that the typespec is correctly being treated
4114 as a deferred characteristic association. */
4115 seen_deferred_kind
= (gfc_current_state () == COMP_FUNCTION
)
4116 && (gfc_current_block ()->result
->ts
.kind
== -1)
4117 && (ts
->kind
== -1);
4119 if (seen_deferred_kind
)
4122 /* Clear the current binding label, in case one is given. */
4123 curr_binding_label
= NULL
;
4125 /* Match BYTE type-spec. */
4126 m
= match_byte_typespec (ts
);
4130 m
= gfc_match (" type (");
4131 matched_type
= (m
== MATCH_YES
);
4134 gfc_gobble_whitespace ();
4135 if (gfc_peek_ascii_char () == '*')
4137 if ((m
= gfc_match ("* ) ")) != MATCH_YES
)
4139 if (gfc_comp_struct (gfc_current_state ()))
4141 gfc_error ("Assumed type at %C is not allowed for components");
4144 if (!gfc_notify_std (GFC_STD_F2018
, "Assumed type at %C"))
4146 ts
->type
= BT_ASSUMED
;
4150 m
= gfc_match ("%n", name
);
4151 matched_type
= (m
== MATCH_YES
);
4154 if ((matched_type
&& strcmp ("integer", name
) == 0)
4155 || (!matched_type
&& gfc_match (" integer") == MATCH_YES
))
4157 ts
->type
= BT_INTEGER
;
4158 ts
->kind
= gfc_default_integer_kind
;
4162 if ((matched_type
&& strcmp ("character", name
) == 0)
4163 || (!matched_type
&& gfc_match (" character") == MATCH_YES
))
4166 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
4167 "intrinsic-type-spec at %C"))
4170 ts
->type
= BT_CHARACTER
;
4171 if (implicit_flag
== 0)
4172 m
= gfc_match_char_spec (ts
);
4176 if (matched_type
&& m
== MATCH_YES
&& gfc_match_char (')') != MATCH_YES
)
4178 gfc_error ("Malformed type-spec at %C");
4185 if ((matched_type
&& strcmp ("real", name
) == 0)
4186 || (!matched_type
&& gfc_match (" real") == MATCH_YES
))
4189 ts
->kind
= gfc_default_real_kind
;
4194 && (strcmp ("doubleprecision", name
) == 0
4195 || (strcmp ("double", name
) == 0
4196 && gfc_match (" precision") == MATCH_YES
)))
4197 || (!matched_type
&& gfc_match (" double precision") == MATCH_YES
))
4200 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
4201 "intrinsic-type-spec at %C"))
4204 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
4206 gfc_error ("Malformed type-spec at %C");
4211 ts
->kind
= gfc_default_double_kind
;
4215 if ((matched_type
&& strcmp ("complex", name
) == 0)
4216 || (!matched_type
&& gfc_match (" complex") == MATCH_YES
))
4218 ts
->type
= BT_COMPLEX
;
4219 ts
->kind
= gfc_default_complex_kind
;
4224 && (strcmp ("doublecomplex", name
) == 0
4225 || (strcmp ("double", name
) == 0
4226 && gfc_match (" complex") == MATCH_YES
)))
4227 || (!matched_type
&& gfc_match (" double complex") == MATCH_YES
))
4229 if (!gfc_notify_std (GFC_STD_GNU
, "DOUBLE COMPLEX at %C"))
4233 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
4234 "intrinsic-type-spec at %C"))
4237 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
4239 gfc_error ("Malformed type-spec at %C");
4243 ts
->type
= BT_COMPLEX
;
4244 ts
->kind
= gfc_default_double_kind
;
4248 if ((matched_type
&& strcmp ("logical", name
) == 0)
4249 || (!matched_type
&& gfc_match (" logical") == MATCH_YES
))
4251 ts
->type
= BT_LOGICAL
;
4252 ts
->kind
= gfc_default_logical_kind
;
4258 m
= gfc_match_actual_arglist (1, &decl_type_param_list
, true);
4259 if (m
== MATCH_ERROR
)
4262 gfc_gobble_whitespace ();
4263 if (gfc_peek_ascii_char () != ')')
4265 gfc_error ("Malformed type-spec at %C");
4268 m
= gfc_match_char (')'); /* Burn closing ')'. */
4272 m
= match_record_decl (name
);
4274 if (matched_type
|| m
== MATCH_YES
)
4276 ts
->type
= BT_DERIVED
;
4277 /* We accept record/s/ or type(s) where s is a structure, but we
4278 * don't need all the extra derived-type stuff for structures. */
4279 if (gfc_find_symbol (gfc_dt_upper_string (name
), NULL
, 1, &sym
))
4281 gfc_error ("Type name %qs at %C is ambiguous", name
);
4285 if (sym
&& sym
->attr
.flavor
== FL_DERIVED
4286 && sym
->attr
.pdt_template
4287 && gfc_current_state () != COMP_DERIVED
)
4289 m
= gfc_get_pdt_instance (decl_type_param_list
, &sym
, NULL
);
4292 gcc_assert (!sym
->attr
.pdt_template
&& sym
->attr
.pdt_type
);
4293 ts
->u
.derived
= sym
;
4294 const char* lower
= gfc_dt_lower_string (sym
->name
);
4295 size_t len
= strlen (lower
);
4296 /* Reallocate with sufficient size. */
4297 if (len
> GFC_MAX_SYMBOL_LEN
)
4298 name
= XALLOCAVEC (char, len
+ 1);
4299 memcpy (name
, lower
, len
);
4303 if (sym
&& sym
->attr
.flavor
== FL_STRUCT
)
4305 ts
->u
.derived
= sym
;
4308 /* Actually a derived type. */
4313 /* Match nested STRUCTURE declarations; only valid within another
4314 structure declaration. */
4315 if (flag_dec_structure
4316 && (gfc_current_state () == COMP_STRUCTURE
4317 || gfc_current_state () == COMP_MAP
))
4319 m
= gfc_match (" structure");
4322 m
= gfc_match_structure_decl ();
4325 /* gfc_new_block is updated by match_structure_decl. */
4326 ts
->type
= BT_DERIVED
;
4327 ts
->u
.derived
= gfc_new_block
;
4331 if (m
== MATCH_ERROR
)
4335 /* Match CLASS declarations. */
4336 m
= gfc_match (" class ( * )");
4337 if (m
== MATCH_ERROR
)
4339 else if (m
== MATCH_YES
)
4343 ts
->type
= BT_CLASS
;
4344 gfc_find_symbol ("STAR", gfc_current_ns
, 1, &upe
);
4347 upe
= gfc_new_symbol ("STAR", gfc_current_ns
);
4348 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "STAR");
4350 gfc_set_sym_referenced (upe
);
4352 upe
->ts
.type
= BT_VOID
;
4353 upe
->attr
.unlimited_polymorphic
= 1;
4354 /* This is essential to force the construction of
4355 unlimited polymorphic component class containers. */
4356 upe
->attr
.zero_comp
= 1;
4357 if (!gfc_add_flavor (&upe
->attr
, FL_DERIVED
, NULL
,
4358 &gfc_current_locus
))
4363 st
= gfc_get_tbp_symtree (&gfc_current_ns
->sym_root
, "STAR");
4367 ts
->u
.derived
= upe
;
4371 m
= gfc_match (" class (");
4374 m
= gfc_match ("%n", name
);
4380 ts
->type
= BT_CLASS
;
4382 if (!gfc_notify_std (GFC_STD_F2003
, "CLASS statement at %C"))
4385 m
= gfc_match_actual_arglist (1, &decl_type_param_list
, true);
4386 if (m
== MATCH_ERROR
)
4389 m
= gfc_match_char (')');
4394 /* Defer association of the derived type until the end of the
4395 specification block. However, if the derived type can be
4396 found, add it to the typespec. */
4397 if (gfc_matching_function
)
4399 ts
->u
.derived
= NULL
;
4400 if (gfc_current_state () != COMP_INTERFACE
4401 && !gfc_find_symbol (name
, NULL
, 1, &sym
) && sym
)
4403 sym
= gfc_find_dt_in_generic (sym
);
4404 ts
->u
.derived
= sym
;
4409 /* Search for the name but allow the components to be defined later. If
4410 type = -1, this typespec has been seen in a function declaration but
4411 the type could not be accessed at that point. The actual derived type is
4412 stored in a symtree with the first letter of the name capitalized; the
4413 symtree with the all lower-case name contains the associated
4414 generic function. */
4415 dt_name
= gfc_dt_upper_string (name
);
4420 gfc_get_ha_symbol (name
, &sym
);
4421 if (sym
->generic
&& gfc_find_symbol (dt_name
, NULL
, 0, &dt_sym
))
4423 gfc_error ("Type name %qs at %C is ambiguous", name
);
4426 if (sym
->generic
&& !dt_sym
)
4427 dt_sym
= gfc_find_dt_in_generic (sym
);
4429 /* Host associated PDTs can get confused with their constructors
4430 because they ar instantiated in the template's namespace. */
4433 if (gfc_find_symbol (dt_name
, NULL
, 1, &dt_sym
))
4435 gfc_error ("Type name %qs at %C is ambiguous", name
);
4438 if (dt_sym
&& !dt_sym
->attr
.pdt_type
)
4442 else if (ts
->kind
== -1)
4444 int iface
= gfc_state_stack
->previous
->state
!= COMP_INTERFACE
4445 || gfc_current_ns
->has_import_set
;
4446 gfc_find_symbol (name
, NULL
, iface
, &sym
);
4447 if (sym
&& sym
->generic
&& gfc_find_symbol (dt_name
, NULL
, 1, &dt_sym
))
4449 gfc_error ("Type name %qs at %C is ambiguous", name
);
4452 if (sym
&& sym
->generic
&& !dt_sym
)
4453 dt_sym
= gfc_find_dt_in_generic (sym
);
4460 if ((sym
->attr
.flavor
!= FL_UNKNOWN
&& sym
->attr
.flavor
!= FL_STRUCT
4461 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.generic
))
4462 || sym
->attr
.subroutine
)
4464 gfc_error ("Type name %qs at %C conflicts with previously declared "
4465 "entity at %L, which has the same name", name
,
4470 if (sym
&& sym
->attr
.flavor
== FL_DERIVED
4471 && sym
->attr
.pdt_template
4472 && gfc_current_state () != COMP_DERIVED
)
4474 m
= gfc_get_pdt_instance (decl_type_param_list
, &sym
, NULL
);
4477 gcc_assert (!sym
->attr
.pdt_template
&& sym
->attr
.pdt_type
);
4478 ts
->u
.derived
= sym
;
4479 strcpy (name
, gfc_dt_lower_string (sym
->name
));
4482 gfc_save_symbol_data (sym
);
4483 gfc_set_sym_referenced (sym
);
4484 if (!sym
->attr
.generic
4485 && !gfc_add_generic (&sym
->attr
, sym
->name
, NULL
))
4488 if (!sym
->attr
.function
4489 && !gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
4492 if (dt_sym
&& dt_sym
->attr
.flavor
== FL_DERIVED
4493 && dt_sym
->attr
.pdt_template
4494 && gfc_current_state () != COMP_DERIVED
)
4496 m
= gfc_get_pdt_instance (decl_type_param_list
, &dt_sym
, NULL
);
4499 gcc_assert (!dt_sym
->attr
.pdt_template
&& dt_sym
->attr
.pdt_type
);
4504 gfc_interface
*intr
, *head
;
4506 /* Use upper case to save the actual derived-type symbol. */
4507 gfc_get_symbol (dt_name
, NULL
, &dt_sym
);
4508 dt_sym
->name
= gfc_get_string ("%s", sym
->name
);
4509 head
= sym
->generic
;
4510 intr
= gfc_get_interface ();
4512 intr
->where
= gfc_current_locus
;
4514 sym
->generic
= intr
;
4515 sym
->attr
.if_source
= IFSRC_DECL
;
4518 gfc_save_symbol_data (dt_sym
);
4520 gfc_set_sym_referenced (dt_sym
);
4522 if (dt_sym
->attr
.flavor
!= FL_DERIVED
&& dt_sym
->attr
.flavor
!= FL_STRUCT
4523 && !gfc_add_flavor (&dt_sym
->attr
, FL_DERIVED
, sym
->name
, NULL
))
4526 ts
->u
.derived
= dt_sym
;
4532 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
4533 "intrinsic-type-spec at %C"))
4536 /* For all types except double, derived and character, look for an
4537 optional kind specifier. MATCH_NO is actually OK at this point. */
4538 if (implicit_flag
== 1)
4540 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
4546 if (gfc_current_form
== FORM_FREE
)
4548 c
= gfc_peek_ascii_char ();
4549 if (!gfc_is_whitespace (c
) && c
!= '*' && c
!= '('
4550 && c
!= ':' && c
!= ',')
4552 if (matched_type
&& c
== ')')
4554 gfc_next_ascii_char ();
4557 gfc_error ("Malformed type-spec at %C");
4562 m
= gfc_match_kind_spec (ts
, false);
4563 if (m
== MATCH_NO
&& ts
->type
!= BT_CHARACTER
)
4565 m
= gfc_match_old_kind_spec (ts
);
4566 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) == -1)
4570 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
4572 gfc_error ("Malformed type-spec at %C");
4576 /* Defer association of the KIND expression of function results
4577 until after USE and IMPORT statements. */
4578 if ((gfc_current_state () == COMP_NONE
&& gfc_error_flag_test ())
4579 || gfc_matching_function
)
4583 m
= MATCH_YES
; /* No kind specifier found. */
4589 /* Match an IMPLICIT NONE statement. Actually, this statement is
4590 already matched in parse.c, or we would not end up here in the
4591 first place. So the only thing we need to check, is if there is
4592 trailing garbage. If not, the match is successful. */
4595 gfc_match_implicit_none (void)
4599 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4601 bool external
= false;
4602 locus cur_loc
= gfc_current_locus
;
4604 if (gfc_current_ns
->seen_implicit_none
4605 || gfc_current_ns
->has_implicit_none_export
)
4607 gfc_error ("Duplicate IMPLICIT NONE statement at %C");
4611 gfc_gobble_whitespace ();
4612 c
= gfc_peek_ascii_char ();
4615 (void) gfc_next_ascii_char ();
4616 if (!gfc_notify_std (GFC_STD_F2018
, "IMPORT NONE with spec list at %C"))
4619 gfc_gobble_whitespace ();
4620 if (gfc_peek_ascii_char () == ')')
4622 (void) gfc_next_ascii_char ();
4628 m
= gfc_match (" %n", name
);
4632 if (strcmp (name
, "type") == 0)
4634 else if (strcmp (name
, "external") == 0)
4639 gfc_gobble_whitespace ();
4640 c
= gfc_next_ascii_char ();
4651 if (gfc_match_eos () != MATCH_YES
)
4654 gfc_set_implicit_none (type
, external
, &cur_loc
);
4660 /* Match the letter range(s) of an IMPLICIT statement. */
4663 match_implicit_range (void)
4669 cur_loc
= gfc_current_locus
;
4671 gfc_gobble_whitespace ();
4672 c
= gfc_next_ascii_char ();
4675 gfc_error ("Missing character range in IMPLICIT at %C");
4682 gfc_gobble_whitespace ();
4683 c1
= gfc_next_ascii_char ();
4687 gfc_gobble_whitespace ();
4688 c
= gfc_next_ascii_char ();
4693 inner
= 0; /* Fall through. */
4700 gfc_gobble_whitespace ();
4701 c2
= gfc_next_ascii_char ();
4705 gfc_gobble_whitespace ();
4706 c
= gfc_next_ascii_char ();
4708 if ((c
!= ',') && (c
!= ')'))
4721 gfc_error ("Letters must be in alphabetic order in "
4722 "IMPLICIT statement at %C");
4726 /* See if we can add the newly matched range to the pending
4727 implicits from this IMPLICIT statement. We do not check for
4728 conflicts with whatever earlier IMPLICIT statements may have
4729 set. This is done when we've successfully finished matching
4731 if (!gfc_add_new_implicit_range (c1
, c2
))
4738 gfc_syntax_error (ST_IMPLICIT
);
4740 gfc_current_locus
= cur_loc
;
4745 /* Match an IMPLICIT statement, storing the types for
4746 gfc_set_implicit() if the statement is accepted by the parser.
4747 There is a strange looking, but legal syntactic construction
4748 possible. It looks like:
4750 IMPLICIT INTEGER (a-b) (c-d)
4752 This is legal if "a-b" is a constant expression that happens to
4753 equal one of the legal kinds for integers. The real problem
4754 happens with an implicit specification that looks like:
4756 IMPLICIT INTEGER (a-b)
4758 In this case, a typespec matcher that is "greedy" (as most of the
4759 matchers are) gobbles the character range as a kindspec, leaving
4760 nothing left. We therefore have to go a bit more slowly in the
4761 matching process by inhibiting the kindspec checking during
4762 typespec matching and checking for a kind later. */
4765 gfc_match_implicit (void)
4772 if (gfc_current_ns
->seen_implicit_none
)
4774 gfc_error ("IMPLICIT statement at %C following an IMPLICIT NONE (type) "
4781 /* We don't allow empty implicit statements. */
4782 if (gfc_match_eos () == MATCH_YES
)
4784 gfc_error ("Empty IMPLICIT statement at %C");
4790 /* First cleanup. */
4791 gfc_clear_new_implicit ();
4793 /* A basic type is mandatory here. */
4794 m
= gfc_match_decl_type_spec (&ts
, 1);
4795 if (m
== MATCH_ERROR
)
4800 cur_loc
= gfc_current_locus
;
4801 m
= match_implicit_range ();
4805 /* We may have <TYPE> (<RANGE>). */
4806 gfc_gobble_whitespace ();
4807 c
= gfc_peek_ascii_char ();
4808 if (c
== ',' || c
== '\n' || c
== ';' || c
== '!')
4810 /* Check for CHARACTER with no length parameter. */
4811 if (ts
.type
== BT_CHARACTER
&& !ts
.u
.cl
)
4813 ts
.kind
= gfc_default_character_kind
;
4814 ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4815 ts
.u
.cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
,
4819 /* Record the Successful match. */
4820 if (!gfc_merge_new_implicit (&ts
))
4823 c
= gfc_next_ascii_char ();
4824 else if (gfc_match_eos () == MATCH_ERROR
)
4829 gfc_current_locus
= cur_loc
;
4832 /* Discard the (incorrectly) matched range. */
4833 gfc_clear_new_implicit ();
4835 /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
4836 if (ts
.type
== BT_CHARACTER
)
4837 m
= gfc_match_char_spec (&ts
);
4838 else if (gfc_numeric_ts(&ts
) || ts
.type
== BT_LOGICAL
)
4840 m
= gfc_match_kind_spec (&ts
, false);
4843 m
= gfc_match_old_kind_spec (&ts
);
4844 if (m
== MATCH_ERROR
)
4850 if (m
== MATCH_ERROR
)
4853 m
= match_implicit_range ();
4854 if (m
== MATCH_ERROR
)
4859 gfc_gobble_whitespace ();
4860 c
= gfc_next_ascii_char ();
4861 if (c
!= ',' && gfc_match_eos () != MATCH_YES
)
4864 if (!gfc_merge_new_implicit (&ts
))
4872 gfc_syntax_error (ST_IMPLICIT
);
4880 gfc_match_import (void)
4882 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4887 if (gfc_current_ns
->proc_name
== NULL
4888 || gfc_current_ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
4890 gfc_error ("IMPORT statement at %C only permitted in "
4891 "an INTERFACE body");
4895 if (gfc_current_ns
->proc_name
->attr
.module_procedure
)
4897 gfc_error ("F2008: C1210 IMPORT statement at %C is not permitted "
4898 "in a module procedure interface body");
4902 if (!gfc_notify_std (GFC_STD_F2003
, "IMPORT statement at %C"))
4905 if (gfc_match_eos () == MATCH_YES
)
4907 /* All host variables should be imported. */
4908 gfc_current_ns
->has_import_set
= 1;
4912 if (gfc_match (" ::") == MATCH_YES
)
4914 if (gfc_match_eos () == MATCH_YES
)
4916 gfc_error ("Expecting list of named entities at %C");
4924 m
= gfc_match (" %n", name
);
4928 if (gfc_current_ns
->parent
!= NULL
4929 && gfc_find_symbol (name
, gfc_current_ns
->parent
, 1, &sym
))
4931 gfc_error ("Type name %qs at %C is ambiguous", name
);
4934 else if (!sym
&& gfc_current_ns
->proc_name
->ns
->parent
!= NULL
4935 && gfc_find_symbol (name
,
4936 gfc_current_ns
->proc_name
->ns
->parent
,
4939 gfc_error ("Type name %qs at %C is ambiguous", name
);
4945 gfc_error ("Cannot IMPORT %qs from host scoping unit "
4946 "at %C - does not exist.", name
);
4950 if (gfc_find_symtree (gfc_current_ns
->sym_root
, name
))
4952 gfc_warning (0, "%qs is already IMPORTed from host scoping unit "
4957 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, name
);
4960 sym
->attr
.imported
= 1;
4962 if (sym
->attr
.generic
&& (sym
= gfc_find_dt_in_generic (sym
)))
4964 /* The actual derived type is stored in a symtree with the first
4965 letter of the name capitalized; the symtree with the all
4966 lower-case name contains the associated generic function. */
4967 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
,
4968 gfc_dt_upper_string (name
));
4971 sym
->attr
.imported
= 1;
4984 if (gfc_match_eos () == MATCH_YES
)
4986 if (gfc_match_char (',') != MATCH_YES
)
4993 gfc_error ("Syntax error in IMPORT statement at %C");
4998 /* A minimal implementation of gfc_match without whitespace, escape
4999 characters or variable arguments. Returns true if the next
5000 characters match the TARGET template exactly. */
5003 match_string_p (const char *target
)
5007 for (p
= target
; *p
; p
++)
5008 if ((char) gfc_next_ascii_char () != *p
)
5013 /* Matches an attribute specification including array specs. If
5014 successful, leaves the variables current_attr and current_as
5015 holding the specification. Also sets the colon_seen variable for
5016 later use by matchers associated with initializations.
5018 This subroutine is a little tricky in the sense that we don't know
5019 if we really have an attr-spec until we hit the double colon.
5020 Until that time, we can only return MATCH_NO. This forces us to
5021 check for duplicate specification at this level. */
5024 match_attr_spec (void)
5026 /* Modifiers that can exist in a type statement. */
5028 { GFC_DECL_BEGIN
= 0, DECL_ALLOCATABLE
= GFC_DECL_BEGIN
,
5029 DECL_IN
= INTENT_IN
, DECL_OUT
= INTENT_OUT
, DECL_INOUT
= INTENT_INOUT
,
5030 DECL_DIMENSION
, DECL_EXTERNAL
,
5031 DECL_INTRINSIC
, DECL_OPTIONAL
,
5032 DECL_PARAMETER
, DECL_POINTER
, DECL_PROTECTED
, DECL_PRIVATE
,
5033 DECL_STATIC
, DECL_AUTOMATIC
,
5034 DECL_PUBLIC
, DECL_SAVE
, DECL_TARGET
, DECL_VALUE
, DECL_VOLATILE
,
5035 DECL_IS_BIND_C
, DECL_CODIMENSION
, DECL_ASYNCHRONOUS
, DECL_CONTIGUOUS
,
5036 DECL_LEN
, DECL_KIND
, DECL_NONE
, GFC_DECL_END
/* Sentinel */
5039 /* GFC_DECL_END is the sentinel, index starts at 0. */
5040 #define NUM_DECL GFC_DECL_END
5042 /* Make sure that values from sym_intent are safe to be used here. */
5043 gcc_assert (INTENT_IN
> 0);
5045 locus start
, seen_at
[NUM_DECL
];
5052 gfc_clear_attr (¤t_attr
);
5053 start
= gfc_current_locus
;
5059 /* See if we get all of the keywords up to the final double colon. */
5060 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
5068 gfc_gobble_whitespace ();
5070 ch
= gfc_next_ascii_char ();
5073 /* This is the successful exit condition for the loop. */
5074 if (gfc_next_ascii_char () == ':')
5079 gfc_gobble_whitespace ();
5080 switch (gfc_peek_ascii_char ())
5083 gfc_next_ascii_char ();
5084 switch (gfc_next_ascii_char ())
5087 if (match_string_p ("locatable"))
5089 /* Matched "allocatable". */
5090 d
= DECL_ALLOCATABLE
;
5095 if (match_string_p ("ynchronous"))
5097 /* Matched "asynchronous". */
5098 d
= DECL_ASYNCHRONOUS
;
5103 if (match_string_p ("tomatic"))
5105 /* Matched "automatic". */
5113 /* Try and match the bind(c). */
5114 m
= gfc_match_bind_c (NULL
, true);
5117 else if (m
== MATCH_ERROR
)
5122 gfc_next_ascii_char ();
5123 if ('o' != gfc_next_ascii_char ())
5125 switch (gfc_next_ascii_char ())
5128 if (match_string_p ("imension"))
5130 d
= DECL_CODIMENSION
;
5135 if (match_string_p ("tiguous"))
5137 d
= DECL_CONTIGUOUS
;
5144 if (match_string_p ("dimension"))
5149 if (match_string_p ("external"))
5154 if (match_string_p ("int"))
5156 ch
= gfc_next_ascii_char ();
5159 if (match_string_p ("nt"))
5161 /* Matched "intent". */
5162 d
= match_intent_spec ();
5163 if (d
== INTENT_UNKNOWN
)
5172 if (match_string_p ("insic"))
5174 /* Matched "intrinsic". */
5182 if (match_string_p ("kind"))
5187 if (match_string_p ("len"))
5192 if (match_string_p ("optional"))
5197 gfc_next_ascii_char ();
5198 switch (gfc_next_ascii_char ())
5201 if (match_string_p ("rameter"))
5203 /* Matched "parameter". */
5209 if (match_string_p ("inter"))
5211 /* Matched "pointer". */
5217 ch
= gfc_next_ascii_char ();
5220 if (match_string_p ("vate"))
5222 /* Matched "private". */
5228 if (match_string_p ("tected"))
5230 /* Matched "protected". */
5237 if (match_string_p ("blic"))
5239 /* Matched "public". */
5247 gfc_next_ascii_char ();
5248 switch (gfc_next_ascii_char ())
5251 if (match_string_p ("ve"))
5253 /* Matched "save". */
5259 if (match_string_p ("atic"))
5261 /* Matched "static". */
5269 if (match_string_p ("target"))
5274 gfc_next_ascii_char ();
5275 ch
= gfc_next_ascii_char ();
5278 if (match_string_p ("lue"))
5280 /* Matched "value". */
5286 if (match_string_p ("latile"))
5288 /* Matched "volatile". */
5296 /* No double colon and no recognizable decl_type, so assume that
5297 we've been looking at something else the whole time. */
5304 /* Check to make sure any parens are paired up correctly. */
5305 if (gfc_match_parens () == MATCH_ERROR
)
5312 seen_at
[d
] = gfc_current_locus
;
5314 if (d
== DECL_DIMENSION
|| d
== DECL_CODIMENSION
)
5316 gfc_array_spec
*as
= NULL
;
5318 m
= gfc_match_array_spec (&as
, d
== DECL_DIMENSION
,
5319 d
== DECL_CODIMENSION
);
5321 if (current_as
== NULL
)
5323 else if (m
== MATCH_YES
)
5325 if (!merge_array_spec (as
, current_as
, false))
5332 if (d
== DECL_CODIMENSION
)
5333 gfc_error ("Missing codimension specification at %C");
5335 gfc_error ("Missing dimension specification at %C");
5339 if (m
== MATCH_ERROR
)
5344 /* Since we've seen a double colon, we have to be looking at an
5345 attr-spec. This means that we can now issue errors. */
5346 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
5351 case DECL_ALLOCATABLE
:
5352 attr
= "ALLOCATABLE";
5354 case DECL_ASYNCHRONOUS
:
5355 attr
= "ASYNCHRONOUS";
5357 case DECL_CODIMENSION
:
5358 attr
= "CODIMENSION";
5360 case DECL_CONTIGUOUS
:
5361 attr
= "CONTIGUOUS";
5363 case DECL_DIMENSION
:
5370 attr
= "INTENT (IN)";
5373 attr
= "INTENT (OUT)";
5376 attr
= "INTENT (IN OUT)";
5378 case DECL_INTRINSIC
:
5390 case DECL_PARAMETER
:
5396 case DECL_PROTECTED
:
5411 case DECL_AUTOMATIC
:
5417 case DECL_IS_BIND_C
:
5427 attr
= NULL
; /* This shouldn't happen. */
5430 gfc_error ("Duplicate %s attribute at %L", attr
, &seen_at
[d
]);
5435 /* Now that we've dealt with duplicate attributes, add the attributes
5436 to the current attribute. */
5437 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
5444 if ((d
== DECL_STATIC
|| d
== DECL_AUTOMATIC
)
5445 && !flag_dec_static
)
5447 gfc_error ("%s at %L is a DEC extension, enable with "
5449 d
== DECL_STATIC
? "STATIC" : "AUTOMATIC", &seen_at
[d
]);
5453 /* Allow SAVE with STATIC, but don't complain. */
5454 if (d
== DECL_STATIC
&& seen
[DECL_SAVE
])
5457 if (gfc_comp_struct (gfc_current_state ())
5458 && d
!= DECL_DIMENSION
&& d
!= DECL_CODIMENSION
5459 && d
!= DECL_POINTER
&& d
!= DECL_PRIVATE
5460 && d
!= DECL_PUBLIC
&& d
!= DECL_CONTIGUOUS
&& d
!= DECL_NONE
)
5462 bool is_derived
= gfc_current_state () == COMP_DERIVED
;
5463 if (d
== DECL_ALLOCATABLE
)
5465 if (!gfc_notify_std (GFC_STD_F2003
, is_derived
5466 ? G_("ALLOCATABLE attribute at %C in a "
5468 : G_("ALLOCATABLE attribute at %C in a "
5469 "STRUCTURE definition")))
5475 else if (d
== DECL_KIND
)
5477 if (!gfc_notify_std (GFC_STD_F2003
, is_derived
5478 ? G_("KIND attribute at %C in a "
5480 : G_("KIND attribute at %C in a "
5481 "STRUCTURE definition")))
5486 if (current_ts
.type
!= BT_INTEGER
)
5488 gfc_error ("Component with KIND attribute at %C must be "
5493 if (current_ts
.kind
!= gfc_default_integer_kind
)
5495 gfc_error ("Component with KIND attribute at %C must be "
5496 "default integer kind (%d)",
5497 gfc_default_integer_kind
);
5502 else if (d
== DECL_LEN
)
5504 if (!gfc_notify_std (GFC_STD_F2003
, is_derived
5505 ? G_("LEN attribute at %C in a "
5507 : G_("LEN attribute at %C in a "
5508 "STRUCTURE definition")))
5513 if (current_ts
.type
!= BT_INTEGER
)
5515 gfc_error ("Component with LEN attribute at %C must be "
5520 if (current_ts
.kind
!= gfc_default_integer_kind
)
5522 gfc_error ("Component with LEN attribute at %C must be "
5523 "default integer kind (%d)",
5524 gfc_default_integer_kind
);
5531 gfc_error (is_derived
? G_("Attribute at %L is not allowed in a "
5533 : G_("Attribute at %L is not allowed in a "
5534 "STRUCTURE definition"), &seen_at
[d
]);
5540 if ((d
== DECL_PRIVATE
|| d
== DECL_PUBLIC
)
5541 && gfc_current_state () != COMP_MODULE
)
5543 if (d
== DECL_PRIVATE
)
5547 if (gfc_current_state () == COMP_DERIVED
5548 && gfc_state_stack
->previous
5549 && gfc_state_stack
->previous
->state
== COMP_MODULE
)
5551 if (!gfc_notify_std (GFC_STD_F2003
, "Attribute %s "
5552 "at %L in a TYPE definition", attr
,
5561 gfc_error ("%s attribute at %L is not allowed outside of the "
5562 "specification part of a module", attr
, &seen_at
[d
]);
5568 if (gfc_current_state () != COMP_DERIVED
5569 && (d
== DECL_KIND
|| d
== DECL_LEN
))
5571 gfc_error ("Attribute at %L is not allowed outside a TYPE "
5572 "definition", &seen_at
[d
]);
5579 case DECL_ALLOCATABLE
:
5580 t
= gfc_add_allocatable (¤t_attr
, &seen_at
[d
]);
5583 case DECL_ASYNCHRONOUS
:
5584 if (!gfc_notify_std (GFC_STD_F2003
, "ASYNCHRONOUS attribute at %C"))
5587 t
= gfc_add_asynchronous (¤t_attr
, NULL
, &seen_at
[d
]);
5590 case DECL_CODIMENSION
:
5591 t
= gfc_add_codimension (¤t_attr
, NULL
, &seen_at
[d
]);
5594 case DECL_CONTIGUOUS
:
5595 if (!gfc_notify_std (GFC_STD_F2008
, "CONTIGUOUS attribute at %C"))
5598 t
= gfc_add_contiguous (¤t_attr
, NULL
, &seen_at
[d
]);
5601 case DECL_DIMENSION
:
5602 t
= gfc_add_dimension (¤t_attr
, NULL
, &seen_at
[d
]);
5606 t
= gfc_add_external (¤t_attr
, &seen_at
[d
]);
5610 t
= gfc_add_intent (¤t_attr
, INTENT_IN
, &seen_at
[d
]);
5614 t
= gfc_add_intent (¤t_attr
, INTENT_OUT
, &seen_at
[d
]);
5618 t
= gfc_add_intent (¤t_attr
, INTENT_INOUT
, &seen_at
[d
]);
5621 case DECL_INTRINSIC
:
5622 t
= gfc_add_intrinsic (¤t_attr
, &seen_at
[d
]);
5626 t
= gfc_add_optional (¤t_attr
, &seen_at
[d
]);
5630 t
= gfc_add_kind (¤t_attr
, &seen_at
[d
]);
5634 t
= gfc_add_len (¤t_attr
, &seen_at
[d
]);
5637 case DECL_PARAMETER
:
5638 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, &seen_at
[d
]);
5642 t
= gfc_add_pointer (¤t_attr
, &seen_at
[d
]);
5645 case DECL_PROTECTED
:
5646 if (gfc_current_state () != COMP_MODULE
5647 || (gfc_current_ns
->proc_name
5648 && gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
))
5650 gfc_error ("PROTECTED at %C only allowed in specification "
5651 "part of a module");
5656 if (!gfc_notify_std (GFC_STD_F2003
, "PROTECTED attribute at %C"))
5659 t
= gfc_add_protected (¤t_attr
, NULL
, &seen_at
[d
]);
5663 t
= gfc_add_access (¤t_attr
, ACCESS_PRIVATE
, NULL
,
5668 t
= gfc_add_access (¤t_attr
, ACCESS_PUBLIC
, NULL
,
5674 t
= gfc_add_save (¤t_attr
, SAVE_EXPLICIT
, NULL
, &seen_at
[d
]);
5677 case DECL_AUTOMATIC
:
5678 t
= gfc_add_automatic (¤t_attr
, NULL
, &seen_at
[d
]);
5682 t
= gfc_add_target (¤t_attr
, &seen_at
[d
]);
5685 case DECL_IS_BIND_C
:
5686 t
= gfc_add_is_bind_c(¤t_attr
, NULL
, &seen_at
[d
], 0);
5690 if (!gfc_notify_std (GFC_STD_F2003
, "VALUE attribute at %C"))
5693 t
= gfc_add_value (¤t_attr
, NULL
, &seen_at
[d
]);
5697 if (!gfc_notify_std (GFC_STD_F2003
, "VOLATILE attribute at %C"))
5700 t
= gfc_add_volatile (¤t_attr
, NULL
, &seen_at
[d
]);
5704 gfc_internal_error ("match_attr_spec(): Bad attribute");
5714 /* Since Fortran 2008 module variables implicitly have the SAVE attribute. */
5715 if ((gfc_current_state () == COMP_MODULE
5716 || gfc_current_state () == COMP_SUBMODULE
)
5717 && !current_attr
.save
5718 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
5719 current_attr
.save
= SAVE_IMPLICIT
;
5725 gfc_current_locus
= start
;
5726 gfc_free_array_spec (current_as
);
5733 /* Set the binding label, dest_label, either with the binding label
5734 stored in the given gfc_typespec, ts, or if none was provided, it
5735 will be the symbol name in all lower case, as required by the draft
5736 (J3/04-007, section 15.4.1). If a binding label was given and
5737 there is more than one argument (num_idents), it is an error. */
5740 set_binding_label (const char **dest_label
, const char *sym_name
,
5743 if (num_idents
> 1 && has_name_equals
)
5745 gfc_error ("Multiple identifiers provided with "
5746 "single NAME= specifier at %C");
5750 if (curr_binding_label
)
5751 /* Binding label given; store in temp holder till have sym. */
5752 *dest_label
= curr_binding_label
;
5755 /* No binding label given, and the NAME= specifier did not exist,
5756 which means there was no NAME="". */
5757 if (sym_name
!= NULL
&& has_name_equals
== 0)
5758 *dest_label
= IDENTIFIER_POINTER (get_identifier (sym_name
));
5765 /* Set the status of the given common block as being BIND(C) or not,
5766 depending on the given parameter, is_bind_c. */
5769 set_com_block_bind_c (gfc_common_head
*com_block
, int is_bind_c
)
5771 com_block
->is_bind_c
= is_bind_c
;
5776 /* Verify that the given gfc_typespec is for a C interoperable type. */
5779 gfc_verify_c_interop (gfc_typespec
*ts
)
5781 if (ts
->type
== BT_DERIVED
&& ts
->u
.derived
!= NULL
)
5782 return (ts
->u
.derived
->ts
.is_c_interop
|| ts
->u
.derived
->attr
.is_bind_c
)
5784 else if (ts
->type
== BT_CLASS
)
5786 else if (ts
->is_c_interop
!= 1 && ts
->type
!= BT_ASSUMED
)
5793 /* Verify that the variables of a given common block, which has been
5794 defined with the attribute specifier bind(c), to be of a C
5795 interoperable type. Errors will be reported here, if
5799 verify_com_block_vars_c_interop (gfc_common_head
*com_block
)
5801 gfc_symbol
*curr_sym
= NULL
;
5804 curr_sym
= com_block
->head
;
5806 /* Make sure we have at least one symbol. */
5807 if (curr_sym
== NULL
)
5810 /* Here we know we have a symbol, so we'll execute this loop
5814 /* The second to last param, 1, says this is in a common block. */
5815 retval
= verify_bind_c_sym (curr_sym
, &(curr_sym
->ts
), 1, com_block
);
5816 curr_sym
= curr_sym
->common_next
;
5817 } while (curr_sym
!= NULL
);
5823 /* Verify that a given BIND(C) symbol is C interoperable. If it is not,
5824 an appropriate error message is reported. */
5827 verify_bind_c_sym (gfc_symbol
*tmp_sym
, gfc_typespec
*ts
,
5828 int is_in_common
, gfc_common_head
*com_block
)
5830 bool bind_c_function
= false;
5833 if (tmp_sym
->attr
.function
&& tmp_sym
->attr
.is_bind_c
)
5834 bind_c_function
= true;
5836 if (tmp_sym
->attr
.function
&& tmp_sym
->result
!= NULL
)
5838 tmp_sym
= tmp_sym
->result
;
5839 /* Make sure it wasn't an implicitly typed result. */
5840 if (tmp_sym
->attr
.implicit_type
&& warn_c_binding_type
)
5842 gfc_warning (OPT_Wc_binding_type
,
5843 "Implicitly declared BIND(C) function %qs at "
5844 "%L may not be C interoperable", tmp_sym
->name
,
5845 &tmp_sym
->declared_at
);
5846 tmp_sym
->ts
.f90_type
= tmp_sym
->ts
.type
;
5847 /* Mark it as C interoperable to prevent duplicate warnings. */
5848 tmp_sym
->ts
.is_c_interop
= 1;
5849 tmp_sym
->attr
.is_c_interop
= 1;
5853 /* Here, we know we have the bind(c) attribute, so if we have
5854 enough type info, then verify that it's a C interop kind.
5855 The info could be in the symbol already, or possibly still in
5856 the given ts (current_ts), so look in both. */
5857 if (tmp_sym
->ts
.type
!= BT_UNKNOWN
|| ts
->type
!= BT_UNKNOWN
)
5859 if (!gfc_verify_c_interop (&(tmp_sym
->ts
)))
5861 /* See if we're dealing with a sym in a common block or not. */
5862 if (is_in_common
== 1 && warn_c_binding_type
)
5864 gfc_warning (OPT_Wc_binding_type
,
5865 "Variable %qs in common block %qs at %L "
5866 "may not be a C interoperable "
5867 "kind though common block %qs is BIND(C)",
5868 tmp_sym
->name
, com_block
->name
,
5869 &(tmp_sym
->declared_at
), com_block
->name
);
5873 if (tmp_sym
->ts
.type
== BT_DERIVED
|| ts
->type
== BT_DERIVED
)
5874 gfc_error ("Type declaration %qs at %L is not C "
5875 "interoperable but it is BIND(C)",
5876 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5877 else if (warn_c_binding_type
)
5878 gfc_warning (OPT_Wc_binding_type
, "Variable %qs at %L "
5879 "may not be a C interoperable "
5880 "kind but it is BIND(C)",
5881 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5885 /* Variables declared w/in a common block can't be bind(c)
5886 since there's no way for C to see these variables, so there's
5887 semantically no reason for the attribute. */
5888 if (is_in_common
== 1 && tmp_sym
->attr
.is_bind_c
== 1)
5890 gfc_error ("Variable %qs in common block %qs at "
5891 "%L cannot be declared with BIND(C) "
5892 "since it is not a global",
5893 tmp_sym
->name
, com_block
->name
,
5894 &(tmp_sym
->declared_at
));
5898 /* Scalar variables that are bind(c) cannot have the pointer
5899 or allocatable attributes. */
5900 if (tmp_sym
->attr
.is_bind_c
== 1)
5902 if (tmp_sym
->attr
.pointer
== 1)
5904 gfc_error ("Variable %qs at %L cannot have both the "
5905 "POINTER and BIND(C) attributes",
5906 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5910 if (tmp_sym
->attr
.allocatable
== 1)
5912 gfc_error ("Variable %qs at %L cannot have both the "
5913 "ALLOCATABLE and BIND(C) attributes",
5914 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5920 /* If it is a BIND(C) function, make sure the return value is a
5921 scalar value. The previous tests in this function made sure
5922 the type is interoperable. */
5923 if (bind_c_function
&& tmp_sym
->as
!= NULL
)
5924 gfc_error ("Return type of BIND(C) function %qs at %L cannot "
5925 "be an array", tmp_sym
->name
, &(tmp_sym
->declared_at
));
5927 /* BIND(C) functions cannot return a character string. */
5928 if (bind_c_function
&& tmp_sym
->ts
.type
== BT_CHARACTER
)
5929 if (tmp_sym
->ts
.u
.cl
== NULL
|| tmp_sym
->ts
.u
.cl
->length
== NULL
5930 || tmp_sym
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
5931 || mpz_cmp_si (tmp_sym
->ts
.u
.cl
->length
->value
.integer
, 1) != 0)
5932 gfc_error ("Return type of BIND(C) function %qs of character "
5933 "type at %L must have length 1", tmp_sym
->name
,
5934 &(tmp_sym
->declared_at
));
5937 /* See if the symbol has been marked as private. If it has, make sure
5938 there is no binding label and warn the user if there is one. */
5939 if (tmp_sym
->attr
.access
== ACCESS_PRIVATE
5940 && tmp_sym
->binding_label
)
5941 /* Use gfc_warning_now because we won't say that the symbol fails
5942 just because of this. */
5943 gfc_warning_now (0, "Symbol %qs at %L is marked PRIVATE but has been "
5944 "given the binding label %qs", tmp_sym
->name
,
5945 &(tmp_sym
->declared_at
), tmp_sym
->binding_label
);
5951 /* Set the appropriate fields for a symbol that's been declared as
5952 BIND(C) (the is_bind_c flag and the binding label), and verify that
5953 the type is C interoperable. Errors are reported by the functions
5954 used to set/test these fields. */
5957 set_verify_bind_c_sym (gfc_symbol
*tmp_sym
, int num_idents
)
5961 /* TODO: Do we need to make sure the vars aren't marked private? */
5963 /* Set the is_bind_c bit in symbol_attribute. */
5964 gfc_add_is_bind_c (&(tmp_sym
->attr
), tmp_sym
->name
, &gfc_current_locus
, 0);
5966 if (!set_binding_label (&tmp_sym
->binding_label
, tmp_sym
->name
, num_idents
))
5973 /* Set the fields marking the given common block as BIND(C), including
5974 a binding label, and report any errors encountered. */
5977 set_verify_bind_c_com_block (gfc_common_head
*com_block
, int num_idents
)
5981 /* destLabel, common name, typespec (which may have binding label). */
5982 if (!set_binding_label (&com_block
->binding_label
, com_block
->name
,
5986 /* Set the given common block (com_block) to being bind(c) (1). */
5987 set_com_block_bind_c (com_block
, 1);
5993 /* Retrieve the list of one or more identifiers that the given bind(c)
5994 attribute applies to. */
5997 get_bind_c_idents (void)
5999 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6001 gfc_symbol
*tmp_sym
= NULL
;
6003 gfc_common_head
*com_block
= NULL
;
6005 if (gfc_match_name (name
) == MATCH_YES
)
6007 found_id
= MATCH_YES
;
6008 gfc_get_ha_symbol (name
, &tmp_sym
);
6010 else if (gfc_match_common_name (name
) == MATCH_YES
)
6012 found_id
= MATCH_YES
;
6013 com_block
= gfc_get_common (name
, 0);
6017 gfc_error ("Need either entity or common block name for "
6018 "attribute specification statement at %C");
6022 /* Save the current identifier and look for more. */
6025 /* Increment the number of identifiers found for this spec stmt. */
6028 /* Make sure we have a sym or com block, and verify that it can
6029 be bind(c). Set the appropriate field(s) and look for more
6031 if (tmp_sym
!= NULL
|| com_block
!= NULL
)
6033 if (tmp_sym
!= NULL
)
6035 if (!set_verify_bind_c_sym (tmp_sym
, num_idents
))
6040 if (!set_verify_bind_c_com_block (com_block
, num_idents
))
6044 /* Look to see if we have another identifier. */
6046 if (gfc_match_eos () == MATCH_YES
)
6047 found_id
= MATCH_NO
;
6048 else if (gfc_match_char (',') != MATCH_YES
)
6049 found_id
= MATCH_NO
;
6050 else if (gfc_match_name (name
) == MATCH_YES
)
6052 found_id
= MATCH_YES
;
6053 gfc_get_ha_symbol (name
, &tmp_sym
);
6055 else if (gfc_match_common_name (name
) == MATCH_YES
)
6057 found_id
= MATCH_YES
;
6058 com_block
= gfc_get_common (name
, 0);
6062 gfc_error ("Missing entity or common block name for "
6063 "attribute specification statement at %C");
6069 gfc_internal_error ("Missing symbol");
6071 } while (found_id
== MATCH_YES
);
6073 /* if we get here we were successful */
6078 /* Try and match a BIND(C) attribute specification statement. */
6081 gfc_match_bind_c_stmt (void)
6083 match found_match
= MATCH_NO
;
6088 /* This may not be necessary. */
6090 /* Clear the temporary binding label holder. */
6091 curr_binding_label
= NULL
;
6093 /* Look for the bind(c). */
6094 found_match
= gfc_match_bind_c (NULL
, true);
6096 if (found_match
== MATCH_YES
)
6098 if (!gfc_notify_std (GFC_STD_F2003
, "BIND(C) statement at %C"))
6101 /* Look for the :: now, but it is not required. */
6104 /* Get the identifier(s) that needs to be updated. This may need to
6105 change to hand the flag(s) for the attr specified so all identifiers
6106 found can have all appropriate parts updated (assuming that the same
6107 spec stmt can have multiple attrs, such as both bind(c) and
6109 if (!get_bind_c_idents ())
6110 /* Error message should have printed already. */
6118 /* Match a data declaration statement. */
6121 gfc_match_data_decl (void)
6127 type_param_spec_list
= NULL
;
6128 decl_type_param_list
= NULL
;
6130 num_idents_on_line
= 0;
6132 m
= gfc_match_decl_type_spec (¤t_ts
, 0);
6136 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
6137 && !gfc_comp_struct (gfc_current_state ()))
6139 sym
= gfc_use_derived (current_ts
.u
.derived
);
6147 current_ts
.u
.derived
= sym
;
6150 m
= match_attr_spec ();
6151 if (m
== MATCH_ERROR
)
6157 if (current_ts
.type
== BT_CLASS
6158 && current_ts
.u
.derived
->attr
.unlimited_polymorphic
)
6161 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
6162 && current_ts
.u
.derived
->components
== NULL
6163 && !current_ts
.u
.derived
->attr
.zero_comp
)
6166 if (current_attr
.pointer
&& gfc_comp_struct (gfc_current_state ()))
6169 if (current_attr
.allocatable
&& gfc_current_state () == COMP_DERIVED
)
6172 gfc_find_symbol (current_ts
.u
.derived
->name
,
6173 current_ts
.u
.derived
->ns
, 1, &sym
);
6175 /* Any symbol that we find had better be a type definition
6176 which has its components defined, or be a structure definition
6177 actively being parsed. */
6178 if (sym
!= NULL
&& gfc_fl_struct (sym
->attr
.flavor
)
6179 && (current_ts
.u
.derived
->components
!= NULL
6180 || current_ts
.u
.derived
->attr
.zero_comp
6181 || current_ts
.u
.derived
== gfc_new_block
))
6184 gfc_error ("Derived type at %C has not been previously defined "
6185 "and so cannot appear in a derived type definition");
6191 /* If we have an old-style character declaration, and no new-style
6192 attribute specifications, then there a comma is optional between
6193 the type specification and the variable list. */
6194 if (m
== MATCH_NO
&& current_ts
.type
== BT_CHARACTER
&& old_char_selector
)
6195 gfc_match_char (',');
6197 /* Give the types/attributes to symbols that follow. Give the element
6198 a number so that repeat character length expressions can be copied. */
6202 num_idents_on_line
++;
6203 m
= variable_decl (elem
++);
6204 if (m
== MATCH_ERROR
)
6209 if (gfc_match_eos () == MATCH_YES
)
6211 if (gfc_match_char (',') != MATCH_YES
)
6215 if (!gfc_error_flag_test ())
6217 /* An anonymous structure declaration is unambiguous; if we matched one
6218 according to gfc_match_structure_decl, we need to return MATCH_YES
6219 here to avoid confusing the remaining matchers, even if there was an
6220 error during variable_decl. We must flush any such errors. Note this
6221 causes the parser to gracefully continue parsing the remaining input
6222 as a structure body, which likely follows. */
6223 if (current_ts
.type
== BT_DERIVED
&& current_ts
.u
.derived
6224 && gfc_fl_struct (current_ts
.u
.derived
->attr
.flavor
))
6226 gfc_error_now ("Syntax error in anonymous structure declaration"
6228 /* Skip the bad variable_decl and line up for the start of the
6230 gfc_error_recovery ();
6235 gfc_error ("Syntax error in data declaration at %C");
6240 gfc_free_data_all (gfc_current_ns
);
6243 if (saved_kind_expr
)
6244 gfc_free_expr (saved_kind_expr
);
6245 if (type_param_spec_list
)
6246 gfc_free_actual_arglist (type_param_spec_list
);
6247 if (decl_type_param_list
)
6248 gfc_free_actual_arglist (decl_type_param_list
);
6249 saved_kind_expr
= NULL
;
6250 gfc_free_array_spec (current_as
);
6256 in_module_or_interface(void)
6258 if (gfc_current_state () == COMP_MODULE
6259 || gfc_current_state () == COMP_SUBMODULE
6260 || gfc_current_state () == COMP_INTERFACE
)
6263 if (gfc_state_stack
->state
== COMP_CONTAINS
6264 || gfc_state_stack
->state
== COMP_FUNCTION
6265 || gfc_state_stack
->state
== COMP_SUBROUTINE
)
6268 for (p
= gfc_state_stack
->previous
; p
; p
= p
->previous
)
6270 if (p
->state
== COMP_MODULE
|| p
->state
== COMP_SUBMODULE
6271 || p
->state
== COMP_INTERFACE
)
6278 /* Match a prefix associated with a function or subroutine
6279 declaration. If the typespec pointer is nonnull, then a typespec
6280 can be matched. Note that if nothing matches, MATCH_YES is
6281 returned (the null string was matched). */
6284 gfc_match_prefix (gfc_typespec
*ts
)
6290 gfc_clear_attr (¤t_attr
);
6292 seen_impure
= false;
6294 gcc_assert (!gfc_matching_prefix
);
6295 gfc_matching_prefix
= true;
6299 found_prefix
= false;
6301 /* MODULE is a prefix like PURE, ELEMENTAL, etc., having a
6302 corresponding attribute seems natural and distinguishes these
6303 procedures from procedure types of PROC_MODULE, which these are
6305 if (gfc_match ("module% ") == MATCH_YES
)
6307 if (!gfc_notify_std (GFC_STD_F2008
, "MODULE prefix at %C"))
6310 if (!in_module_or_interface ())
6312 gfc_error ("MODULE prefix at %C found outside of a module, "
6313 "submodule, or interface");
6317 current_attr
.module_procedure
= 1;
6318 found_prefix
= true;
6321 if (!seen_type
&& ts
!= NULL
)
6324 m
= gfc_match_decl_type_spec (ts
, 0);
6325 if (m
== MATCH_ERROR
)
6327 if (m
== MATCH_YES
&& gfc_match_space () == MATCH_YES
)
6330 found_prefix
= true;
6334 if (gfc_match ("elemental% ") == MATCH_YES
)
6336 if (!gfc_add_elemental (¤t_attr
, NULL
))
6339 found_prefix
= true;
6342 if (gfc_match ("pure% ") == MATCH_YES
)
6344 if (!gfc_add_pure (¤t_attr
, NULL
))
6347 found_prefix
= true;
6350 if (gfc_match ("recursive% ") == MATCH_YES
)
6352 if (!gfc_add_recursive (¤t_attr
, NULL
))
6355 found_prefix
= true;
6358 /* IMPURE is a somewhat special case, as it needs not set an actual
6359 attribute but rather only prevents ELEMENTAL routines from being
6360 automatically PURE. */
6361 if (gfc_match ("impure% ") == MATCH_YES
)
6363 if (!gfc_notify_std (GFC_STD_F2008
, "IMPURE procedure at %C"))
6367 found_prefix
= true;
6370 while (found_prefix
);
6372 /* IMPURE and PURE must not both appear, of course. */
6373 if (seen_impure
&& current_attr
.pure
)
6375 gfc_error ("PURE and IMPURE must not appear both at %C");
6379 /* If IMPURE it not seen but the procedure is ELEMENTAL, mark it as PURE. */
6380 if (!seen_impure
&& current_attr
.elemental
&& !current_attr
.pure
)
6382 if (!gfc_add_pure (¤t_attr
, NULL
))
6386 /* At this point, the next item is not a prefix. */
6387 gcc_assert (gfc_matching_prefix
);
6389 gfc_matching_prefix
= false;
6393 gcc_assert (gfc_matching_prefix
);
6394 gfc_matching_prefix
= false;
6399 /* Copy attributes matched by gfc_match_prefix() to attributes on a symbol. */
6402 copy_prefix (symbol_attribute
*dest
, locus
*where
)
6404 if (dest
->module_procedure
)
6406 if (current_attr
.elemental
)
6407 dest
->elemental
= 1;
6409 if (current_attr
.pure
)
6412 if (current_attr
.recursive
)
6413 dest
->recursive
= 1;
6415 /* Module procedures are unusual in that the 'dest' is copied from
6416 the interface declaration. However, this is an oportunity to
6417 check that the submodule declaration is compliant with the
6419 if (dest
->elemental
&& !current_attr
.elemental
)
6421 gfc_error ("ELEMENTAL prefix in MODULE PROCEDURE interface is "
6422 "missing at %L", where
);
6426 if (dest
->pure
&& !current_attr
.pure
)
6428 gfc_error ("PURE prefix in MODULE PROCEDURE interface is "
6429 "missing at %L", where
);
6433 if (dest
->recursive
&& !current_attr
.recursive
)
6435 gfc_error ("RECURSIVE prefix in MODULE PROCEDURE interface is "
6436 "missing at %L", where
);
6443 if (current_attr
.elemental
&& !gfc_add_elemental (dest
, where
))
6446 if (current_attr
.pure
&& !gfc_add_pure (dest
, where
))
6449 if (current_attr
.recursive
&& !gfc_add_recursive (dest
, where
))
6456 /* Match a formal argument list or, if typeparam is true, a
6457 type_param_name_list. */
6460 gfc_match_formal_arglist (gfc_symbol
*progname
, int st_flag
,
6461 int null_flag
, bool typeparam
)
6463 gfc_formal_arglist
*head
, *tail
, *p
, *q
;
6464 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6467 gfc_formal_arglist
*formal
= NULL
;
6471 /* Keep the interface formal argument list and null it so that the
6472 matching for the new declaration can be done. The numbers and
6473 names of the arguments are checked here. The interface formal
6474 arguments are retained in formal_arglist and the characteristics
6475 are compared in resolve.c(resolve_fl_procedure). See the remark
6476 in get_proc_name about the eventual need to copy the formal_arglist
6477 and populate the formal namespace of the interface symbol. */
6478 if (progname
->attr
.module_procedure
6479 && progname
->attr
.host_assoc
)
6481 formal
= progname
->formal
;
6482 progname
->formal
= NULL
;
6485 if (gfc_match_char ('(') != MATCH_YES
)
6492 if (gfc_match_char (')') == MATCH_YES
)
6496 gfc_error_now ("A type parameter list is required at %C");
6506 if (gfc_match_char ('*') == MATCH_YES
)
6509 if (!typeparam
&& !gfc_notify_std (GFC_STD_F95_OBS
,
6510 "Alternate-return argument at %C"))
6516 gfc_error_now ("A parameter name is required at %C");
6520 m
= gfc_match_name (name
);
6524 gfc_error_now ("A parameter name is required at %C");
6528 if (!typeparam
&& gfc_get_symbol (name
, NULL
, &sym
))
6531 && gfc_get_symbol (name
, progname
->f2k_derived
, &sym
))
6535 p
= gfc_get_formal_arglist ();
6547 /* We don't add the VARIABLE flavor because the name could be a
6548 dummy procedure. We don't apply these attributes to formal
6549 arguments of statement functions. */
6550 if (sym
!= NULL
&& !st_flag
6551 && (!gfc_add_dummy(&sym
->attr
, sym
->name
, NULL
)
6552 || !gfc_missing_attr (&sym
->attr
, NULL
)))
6558 /* The name of a program unit can be in a different namespace,
6559 so check for it explicitly. After the statement is accepted,
6560 the name is checked for especially in gfc_get_symbol(). */
6561 if (gfc_new_block
!= NULL
&& sym
!= NULL
&& !typeparam
6562 && strcmp (sym
->name
, gfc_new_block
->name
) == 0)
6564 gfc_error ("Name %qs at %C is the name of the procedure",
6570 if (gfc_match_char (')') == MATCH_YES
)
6573 m
= gfc_match_char (',');
6577 gfc_error_now ("Expected parameter list in type declaration "
6580 gfc_error ("Unexpected junk in formal argument list at %C");
6586 /* Check for duplicate symbols in the formal argument list. */
6589 for (p
= head
; p
->next
; p
= p
->next
)
6594 for (q
= p
->next
; q
; q
= q
->next
)
6595 if (p
->sym
== q
->sym
)
6598 gfc_error_now ("Duplicate name %qs in parameter "
6599 "list at %C", p
->sym
->name
);
6601 gfc_error ("Duplicate symbol %qs in formal argument "
6602 "list at %C", p
->sym
->name
);
6610 if (!gfc_add_explicit_interface (progname
, IFSRC_DECL
, head
, NULL
))
6616 /* gfc_error_now used in following and return with MATCH_YES because
6617 doing otherwise results in a cascade of extraneous errors and in
6618 some cases an ICE in symbol.c(gfc_release_symbol). */
6619 if (progname
->attr
.module_procedure
&& progname
->attr
.host_assoc
)
6621 bool arg_count_mismatch
= false;
6623 if (!formal
&& head
)
6624 arg_count_mismatch
= true;
6626 /* Abbreviated module procedure declaration is not meant to have any
6627 formal arguments! */
6628 if (!progname
->abr_modproc_decl
&& formal
&& !head
)
6629 arg_count_mismatch
= true;
6631 for (p
= formal
, q
= head
; p
&& q
; p
= p
->next
, q
= q
->next
)
6633 if ((p
->next
!= NULL
&& q
->next
== NULL
)
6634 || (p
->next
== NULL
&& q
->next
!= NULL
))
6635 arg_count_mismatch
= true;
6636 else if ((p
->sym
== NULL
&& q
->sym
== NULL
)
6637 || strcmp (p
->sym
->name
, q
->sym
->name
) == 0)
6640 gfc_error_now ("Mismatch in MODULE PROCEDURE formal "
6641 "argument names (%s/%s) at %C",
6642 p
->sym
->name
, q
->sym
->name
);
6645 if (arg_count_mismatch
)
6646 gfc_error_now ("Mismatch in number of MODULE PROCEDURE "
6647 "formal arguments at %C");
6653 gfc_free_formal_arglist (head
);
6658 /* Match a RESULT specification following a function declaration or
6659 ENTRY statement. Also matches the end-of-statement. */
6662 match_result (gfc_symbol
*function
, gfc_symbol
**result
)
6664 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6668 if (gfc_match (" result (") != MATCH_YES
)
6671 m
= gfc_match_name (name
);
6675 /* Get the right paren, and that's it because there could be the
6676 bind(c) attribute after the result clause. */
6677 if (gfc_match_char (')') != MATCH_YES
)
6679 /* TODO: should report the missing right paren here. */
6683 if (strcmp (function
->name
, name
) == 0)
6685 gfc_error ("RESULT variable at %C must be different than function name");
6689 if (gfc_get_symbol (name
, NULL
, &r
))
6692 if (!gfc_add_result (&r
->attr
, r
->name
, NULL
))
6701 /* Match a function suffix, which could be a combination of a result
6702 clause and BIND(C), either one, or neither. The draft does not
6703 require them to come in a specific order. */
6706 gfc_match_suffix (gfc_symbol
*sym
, gfc_symbol
**result
)
6708 match is_bind_c
; /* Found bind(c). */
6709 match is_result
; /* Found result clause. */
6710 match found_match
; /* Status of whether we've found a good match. */
6711 char peek_char
; /* Character we're going to peek at. */
6712 bool allow_binding_name
;
6714 /* Initialize to having found nothing. */
6715 found_match
= MATCH_NO
;
6716 is_bind_c
= MATCH_NO
;
6717 is_result
= MATCH_NO
;
6719 /* Get the next char to narrow between result and bind(c). */
6720 gfc_gobble_whitespace ();
6721 peek_char
= gfc_peek_ascii_char ();
6723 /* C binding names are not allowed for internal procedures. */
6724 if (gfc_current_state () == COMP_CONTAINS
6725 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
6726 allow_binding_name
= false;
6728 allow_binding_name
= true;
6733 /* Look for result clause. */
6734 is_result
= match_result (sym
, result
);
6735 if (is_result
== MATCH_YES
)
6737 /* Now see if there is a bind(c) after it. */
6738 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
6739 /* We've found the result clause and possibly bind(c). */
6740 found_match
= MATCH_YES
;
6743 /* This should only be MATCH_ERROR. */
6744 found_match
= is_result
;
6747 /* Look for bind(c) first. */
6748 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
6749 if (is_bind_c
== MATCH_YES
)
6751 /* Now see if a result clause followed it. */
6752 is_result
= match_result (sym
, result
);
6753 found_match
= MATCH_YES
;
6757 /* Should only be a MATCH_ERROR if we get here after seeing 'b'. */
6758 found_match
= MATCH_ERROR
;
6762 gfc_error ("Unexpected junk after function declaration at %C");
6763 found_match
= MATCH_ERROR
;
6767 if (is_bind_c
== MATCH_YES
)
6769 /* Fortran 2008 draft allows BIND(C) for internal procedures. */
6770 if (gfc_current_state () == COMP_CONTAINS
6771 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
6772 && !gfc_notify_std (GFC_STD_F2008
, "BIND(C) attribute "
6773 "at %L may not be specified for an internal "
6774 "procedure", &gfc_current_locus
))
6777 if (!gfc_add_is_bind_c (&(sym
->attr
), sym
->name
, &gfc_current_locus
, 1))
6785 /* Procedure pointer return value without RESULT statement:
6786 Add "hidden" result variable named "ppr@". */
6789 add_hidden_procptr_result (gfc_symbol
*sym
)
6793 if (gfc_notification_std (GFC_STD_F2003
) == ERROR
)
6796 /* First usage case: PROCEDURE and EXTERNAL statements. */
6797 case1
= gfc_current_state () == COMP_FUNCTION
&& gfc_current_block ()
6798 && strcmp (gfc_current_block ()->name
, sym
->name
) == 0
6799 && sym
->attr
.external
;
6800 /* Second usage case: INTERFACE statements. */
6801 case2
= gfc_current_state () == COMP_INTERFACE
&& gfc_state_stack
->previous
6802 && gfc_state_stack
->previous
->state
== COMP_FUNCTION
6803 && strcmp (gfc_state_stack
->previous
->sym
->name
, sym
->name
) == 0;
6809 gfc_get_sym_tree ("ppr@", gfc_current_ns
, &stree
, false);
6813 gfc_get_sym_tree ("ppr@", gfc_current_ns
->parent
, &stree
, false);
6814 st2
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "ppr@");
6815 st2
->n
.sym
= stree
->n
.sym
;
6816 stree
->n
.sym
->refs
++;
6818 sym
->result
= stree
->n
.sym
;
6820 sym
->result
->attr
.proc_pointer
= sym
->attr
.proc_pointer
;
6821 sym
->result
->attr
.pointer
= sym
->attr
.pointer
;
6822 sym
->result
->attr
.external
= sym
->attr
.external
;
6823 sym
->result
->attr
.referenced
= sym
->attr
.referenced
;
6824 sym
->result
->ts
= sym
->ts
;
6825 sym
->attr
.proc_pointer
= 0;
6826 sym
->attr
.pointer
= 0;
6827 sym
->attr
.external
= 0;
6828 if (sym
->result
->attr
.external
&& sym
->result
->attr
.pointer
)
6830 sym
->result
->attr
.pointer
= 0;
6831 sym
->result
->attr
.proc_pointer
= 1;
6834 return gfc_add_result (&sym
->result
->attr
, sym
->result
->name
, NULL
);
6836 /* POINTER after PROCEDURE/EXTERNAL/INTERFACE statement. */
6837 else if (sym
->attr
.function
&& !sym
->attr
.external
&& sym
->attr
.pointer
6838 && sym
->result
&& sym
->result
!= sym
&& sym
->result
->attr
.external
6839 && sym
== gfc_current_ns
->proc_name
6840 && sym
== sym
->result
->ns
->proc_name
6841 && strcmp ("ppr@", sym
->result
->name
) == 0)
6843 sym
->result
->attr
.proc_pointer
= 1;
6844 sym
->attr
.pointer
= 0;
6852 /* Match the interface for a PROCEDURE declaration,
6853 including brackets (R1212). */
6856 match_procedure_interface (gfc_symbol
**proc_if
)
6860 locus old_loc
, entry_loc
;
6861 gfc_namespace
*old_ns
= gfc_current_ns
;
6862 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6864 old_loc
= entry_loc
= gfc_current_locus
;
6865 gfc_clear_ts (¤t_ts
);
6867 if (gfc_match (" (") != MATCH_YES
)
6869 gfc_current_locus
= entry_loc
;
6873 /* Get the type spec. for the procedure interface. */
6874 old_loc
= gfc_current_locus
;
6875 m
= gfc_match_decl_type_spec (¤t_ts
, 0);
6876 gfc_gobble_whitespace ();
6877 if (m
== MATCH_YES
|| (m
== MATCH_NO
&& gfc_peek_ascii_char () == ')'))
6880 if (m
== MATCH_ERROR
)
6883 /* Procedure interface is itself a procedure. */
6884 gfc_current_locus
= old_loc
;
6885 m
= gfc_match_name (name
);
6887 /* First look to see if it is already accessible in the current
6888 namespace because it is use associated or contained. */
6890 if (gfc_find_sym_tree (name
, NULL
, 0, &st
))
6893 /* If it is still not found, then try the parent namespace, if it
6894 exists and create the symbol there if it is still not found. */
6895 if (gfc_current_ns
->parent
)
6896 gfc_current_ns
= gfc_current_ns
->parent
;
6897 if (st
== NULL
&& gfc_get_ha_sym_tree (name
, &st
))
6900 gfc_current_ns
= old_ns
;
6901 *proc_if
= st
->n
.sym
;
6906 /* Resolve interface if possible. That way, attr.procedure is only set
6907 if it is declared by a later procedure-declaration-stmt, which is
6908 invalid per F08:C1216 (cf. resolve_procedure_interface). */
6909 while ((*proc_if
)->ts
.interface
6910 && *proc_if
!= (*proc_if
)->ts
.interface
)
6911 *proc_if
= (*proc_if
)->ts
.interface
;
6913 if ((*proc_if
)->attr
.flavor
== FL_UNKNOWN
6914 && (*proc_if
)->ts
.type
== BT_UNKNOWN
6915 && !gfc_add_flavor (&(*proc_if
)->attr
, FL_PROCEDURE
,
6916 (*proc_if
)->name
, NULL
))
6921 if (gfc_match (" )") != MATCH_YES
)
6923 gfc_current_locus
= entry_loc
;
6931 /* Match a PROCEDURE declaration (R1211). */
6934 match_procedure_decl (void)
6937 gfc_symbol
*sym
, *proc_if
= NULL
;
6939 gfc_expr
*initializer
= NULL
;
6941 /* Parse interface (with brackets). */
6942 m
= match_procedure_interface (&proc_if
);
6946 /* Parse attributes (with colons). */
6947 m
= match_attr_spec();
6948 if (m
== MATCH_ERROR
)
6951 if (proc_if
&& proc_if
->attr
.is_bind_c
&& !current_attr
.is_bind_c
)
6953 current_attr
.is_bind_c
= 1;
6954 has_name_equals
= 0;
6955 curr_binding_label
= NULL
;
6958 /* Get procedure symbols. */
6961 m
= gfc_match_symbol (&sym
, 0);
6964 else if (m
== MATCH_ERROR
)
6967 /* Add current_attr to the symbol attributes. */
6968 if (!gfc_copy_attr (&sym
->attr
, ¤t_attr
, NULL
))
6971 if (sym
->attr
.is_bind_c
)
6973 /* Check for C1218. */
6974 if (!proc_if
|| !proc_if
->attr
.is_bind_c
)
6976 gfc_error ("BIND(C) attribute at %C requires "
6977 "an interface with BIND(C)");
6980 /* Check for C1217. */
6981 if (has_name_equals
&& sym
->attr
.pointer
)
6983 gfc_error ("BIND(C) procedure with NAME may not have "
6984 "POINTER attribute at %C");
6987 if (has_name_equals
&& sym
->attr
.dummy
)
6989 gfc_error ("Dummy procedure at %C may not have "
6990 "BIND(C) attribute with NAME");
6993 /* Set binding label for BIND(C). */
6994 if (!set_binding_label (&sym
->binding_label
, sym
->name
, num
))
6998 if (!gfc_add_external (&sym
->attr
, NULL
))
7001 if (add_hidden_procptr_result (sym
))
7004 if (!gfc_add_proc (&sym
->attr
, sym
->name
, NULL
))
7007 /* Set interface. */
7008 if (proc_if
!= NULL
)
7010 if (sym
->ts
.type
!= BT_UNKNOWN
)
7012 gfc_error ("Procedure %qs at %L already has basic type of %s",
7013 sym
->name
, &gfc_current_locus
,
7014 gfc_basic_typename (sym
->ts
.type
));
7017 sym
->ts
.interface
= proc_if
;
7018 sym
->attr
.untyped
= 1;
7019 sym
->attr
.if_source
= IFSRC_IFBODY
;
7021 else if (current_ts
.type
!= BT_UNKNOWN
)
7023 if (!gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
7025 sym
->ts
.interface
= gfc_new_symbol ("", gfc_current_ns
);
7026 sym
->ts
.interface
->ts
= current_ts
;
7027 sym
->ts
.interface
->attr
.flavor
= FL_PROCEDURE
;
7028 sym
->ts
.interface
->attr
.function
= 1;
7029 sym
->attr
.function
= 1;
7030 sym
->attr
.if_source
= IFSRC_UNKNOWN
;
7033 if (gfc_match (" =>") == MATCH_YES
)
7035 if (!current_attr
.pointer
)
7037 gfc_error ("Initialization at %C isn't for a pointer variable");
7042 m
= match_pointer_init (&initializer
, 1);
7046 if (!add_init_expr_to_sym (sym
->name
, &initializer
, &gfc_current_locus
))
7051 if (gfc_match_eos () == MATCH_YES
)
7053 if (gfc_match_char (',') != MATCH_YES
)
7058 gfc_error ("Syntax error in PROCEDURE statement at %C");
7062 /* Free stuff up and return. */
7063 gfc_free_expr (initializer
);
7069 match_binding_attributes (gfc_typebound_proc
* ba
, bool generic
, bool ppc
);
7072 /* Match a procedure pointer component declaration (R445). */
7075 match_ppc_decl (void)
7078 gfc_symbol
*proc_if
= NULL
;
7082 gfc_expr
*initializer
= NULL
;
7083 gfc_typebound_proc
* tb
;
7084 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7086 /* Parse interface (with brackets). */
7087 m
= match_procedure_interface (&proc_if
);
7091 /* Parse attributes. */
7092 tb
= XCNEW (gfc_typebound_proc
);
7093 tb
->where
= gfc_current_locus
;
7094 m
= match_binding_attributes (tb
, false, true);
7095 if (m
== MATCH_ERROR
)
7098 gfc_clear_attr (¤t_attr
);
7099 current_attr
.procedure
= 1;
7100 current_attr
.proc_pointer
= 1;
7101 current_attr
.access
= tb
->access
;
7102 current_attr
.flavor
= FL_PROCEDURE
;
7104 /* Match the colons (required). */
7105 if (gfc_match (" ::") != MATCH_YES
)
7107 gfc_error ("Expected %<::%> after binding-attributes at %C");
7111 /* Check for C450. */
7112 if (!tb
->nopass
&& proc_if
== NULL
)
7114 gfc_error("NOPASS or explicit interface required at %C");
7118 if (!gfc_notify_std (GFC_STD_F2003
, "Procedure pointer component at %C"))
7121 /* Match PPC names. */
7125 m
= gfc_match_name (name
);
7128 else if (m
== MATCH_ERROR
)
7131 if (!gfc_add_component (gfc_current_block(), name
, &c
))
7134 /* Add current_attr to the symbol attributes. */
7135 if (!gfc_copy_attr (&c
->attr
, ¤t_attr
, NULL
))
7138 if (!gfc_add_external (&c
->attr
, NULL
))
7141 if (!gfc_add_proc (&c
->attr
, name
, NULL
))
7148 c
->tb
= XCNEW (gfc_typebound_proc
);
7149 c
->tb
->where
= gfc_current_locus
;
7153 /* Set interface. */
7154 if (proc_if
!= NULL
)
7156 c
->ts
.interface
= proc_if
;
7157 c
->attr
.untyped
= 1;
7158 c
->attr
.if_source
= IFSRC_IFBODY
;
7160 else if (ts
.type
!= BT_UNKNOWN
)
7163 c
->ts
.interface
= gfc_new_symbol ("", gfc_current_ns
);
7164 c
->ts
.interface
->result
= c
->ts
.interface
;
7165 c
->ts
.interface
->ts
= ts
;
7166 c
->ts
.interface
->attr
.flavor
= FL_PROCEDURE
;
7167 c
->ts
.interface
->attr
.function
= 1;
7168 c
->attr
.function
= 1;
7169 c
->attr
.if_source
= IFSRC_UNKNOWN
;
7172 if (gfc_match (" =>") == MATCH_YES
)
7174 m
= match_pointer_init (&initializer
, 1);
7177 gfc_free_expr (initializer
);
7180 c
->initializer
= initializer
;
7183 if (gfc_match_eos () == MATCH_YES
)
7185 if (gfc_match_char (',') != MATCH_YES
)
7190 gfc_error ("Syntax error in procedure pointer component at %C");
7195 /* Match a PROCEDURE declaration inside an interface (R1206). */
7198 match_procedure_in_interface (void)
7202 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7205 if (current_interface
.type
== INTERFACE_NAMELESS
7206 || current_interface
.type
== INTERFACE_ABSTRACT
)
7208 gfc_error ("PROCEDURE at %C must be in a generic interface");
7212 /* Check if the F2008 optional double colon appears. */
7213 gfc_gobble_whitespace ();
7214 old_locus
= gfc_current_locus
;
7215 if (gfc_match ("::") == MATCH_YES
)
7217 if (!gfc_notify_std (GFC_STD_F2008
, "double colon in "
7218 "MODULE PROCEDURE statement at %L", &old_locus
))
7222 gfc_current_locus
= old_locus
;
7226 m
= gfc_match_name (name
);
7229 else if (m
== MATCH_ERROR
)
7231 if (gfc_get_symbol (name
, gfc_current_ns
->parent
, &sym
))
7234 if (!gfc_add_interface (sym
))
7237 if (gfc_match_eos () == MATCH_YES
)
7239 if (gfc_match_char (',') != MATCH_YES
)
7246 gfc_error ("Syntax error in PROCEDURE statement at %C");
7251 /* General matcher for PROCEDURE declarations. */
7253 static match
match_procedure_in_type (void);
7256 gfc_match_procedure (void)
7260 switch (gfc_current_state ())
7265 case COMP_SUBMODULE
:
7266 case COMP_SUBROUTINE
:
7269 m
= match_procedure_decl ();
7271 case COMP_INTERFACE
:
7272 m
= match_procedure_in_interface ();
7275 m
= match_ppc_decl ();
7277 case COMP_DERIVED_CONTAINS
:
7278 m
= match_procedure_in_type ();
7287 if (!gfc_notify_std (GFC_STD_F2003
, "PROCEDURE statement at %C"))
7294 /* Warn if a matched procedure has the same name as an intrinsic; this is
7295 simply a wrapper around gfc_warn_intrinsic_shadow that interprets the current
7296 parser-state-stack to find out whether we're in a module. */
7299 do_warn_intrinsic_shadow (const gfc_symbol
* sym
, bool func
)
7303 in_module
= (gfc_state_stack
->previous
7304 && (gfc_state_stack
->previous
->state
== COMP_MODULE
7305 || gfc_state_stack
->previous
->state
== COMP_SUBMODULE
));
7307 gfc_warn_intrinsic_shadow (sym
, in_module
, func
);
7311 /* Match a function declaration. */
7314 gfc_match_function_decl (void)
7316 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7317 gfc_symbol
*sym
, *result
;
7321 match found_match
; /* Status returned by match func. */
7323 if (gfc_current_state () != COMP_NONE
7324 && gfc_current_state () != COMP_INTERFACE
7325 && gfc_current_state () != COMP_CONTAINS
)
7328 gfc_clear_ts (¤t_ts
);
7330 old_loc
= gfc_current_locus
;
7332 m
= gfc_match_prefix (¤t_ts
);
7335 gfc_current_locus
= old_loc
;
7339 if (gfc_match ("function% %n", name
) != MATCH_YES
)
7341 gfc_current_locus
= old_loc
;
7345 if (get_proc_name (name
, &sym
, false))
7348 if (add_hidden_procptr_result (sym
))
7351 if (current_attr
.module_procedure
)
7352 sym
->attr
.module_procedure
= 1;
7354 gfc_new_block
= sym
;
7356 m
= gfc_match_formal_arglist (sym
, 0, 0);
7359 gfc_error ("Expected formal argument list in function "
7360 "definition at %C");
7364 else if (m
== MATCH_ERROR
)
7369 /* According to the draft, the bind(c) and result clause can
7370 come in either order after the formal_arg_list (i.e., either
7371 can be first, both can exist together or by themselves or neither
7372 one). Therefore, the match_result can't match the end of the
7373 string, and check for the bind(c) or result clause in either order. */
7374 found_match
= gfc_match_eos ();
7376 /* Make sure that it isn't already declared as BIND(C). If it is, it
7377 must have been marked BIND(C) with a BIND(C) attribute and that is
7378 not allowed for procedures. */
7379 if (sym
->attr
.is_bind_c
== 1)
7381 sym
->attr
.is_bind_c
= 0;
7383 if (gfc_state_stack
->previous
7384 && gfc_state_stack
->previous
->state
!= COMP_SUBMODULE
)
7387 loc
= sym
->old_symbol
!= NULL
7388 ? sym
->old_symbol
->declared_at
: gfc_current_locus
;
7389 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7390 "variables or common blocks", &loc
);
7394 if (found_match
!= MATCH_YES
)
7396 /* If we haven't found the end-of-statement, look for a suffix. */
7397 suffix_match
= gfc_match_suffix (sym
, &result
);
7398 if (suffix_match
== MATCH_YES
)
7399 /* Need to get the eos now. */
7400 found_match
= gfc_match_eos ();
7402 found_match
= suffix_match
;
7405 /* F2018 C1550 (R1526) If MODULE appears in the prefix of a module
7406 subprogram and a binding label is specified, it shall be the
7407 same as the binding label specified in the corresponding module
7408 procedure interface body. */
7409 if (sym
->attr
.is_bind_c
&& sym
->attr
.module_procedure
&& sym
->old_symbol
7410 && strcmp (sym
->name
, sym
->old_symbol
->name
) == 0
7411 && sym
->binding_label
&& sym
->old_symbol
->binding_label
7412 && strcmp (sym
->binding_label
, sym
->old_symbol
->binding_label
) != 0)
7414 const char *null
= "NULL", *s1
, *s2
;
7415 s1
= sym
->binding_label
;
7417 s2
= sym
->old_symbol
->binding_label
;
7419 gfc_error ("Mismatch in BIND(C) names (%qs/%qs) at %C", s1
, s2
);
7420 sym
->refs
++; /* Needed to avoid an ICE in gfc_release_symbol */
7424 if(found_match
!= MATCH_YES
)
7428 /* Make changes to the symbol. */
7431 if (!gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
7434 if (!gfc_missing_attr (&sym
->attr
, NULL
))
7437 if (!copy_prefix (&sym
->attr
, &sym
->declared_at
))
7439 if(!sym
->attr
.module_procedure
)
7445 /* Delay matching the function characteristics until after the
7446 specification block by signalling kind=-1. */
7447 sym
->declared_at
= old_loc
;
7448 if (current_ts
.type
!= BT_UNKNOWN
)
7449 current_ts
.kind
= -1;
7451 current_ts
.kind
= 0;
7455 if (current_ts
.type
!= BT_UNKNOWN
7456 && !gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
7462 if (current_ts
.type
!= BT_UNKNOWN
7463 && !gfc_add_type (result
, ¤t_ts
, &gfc_current_locus
))
7465 sym
->result
= result
;
7468 /* Warn if this procedure has the same name as an intrinsic. */
7469 do_warn_intrinsic_shadow (sym
, true);
7475 gfc_current_locus
= old_loc
;
7480 /* This is mostly a copy of parse.c(add_global_procedure) but modified to
7481 pass the name of the entry, rather than the gfc_current_block name, and
7482 to return false upon finding an existing global entry. */
7485 add_global_entry (const char *name
, const char *binding_label
, bool sub
,
7489 enum gfc_symbol_type type
;
7491 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
7493 /* Only in Fortran 2003: For procedures with a binding label also the Fortran
7494 name is a global identifier. */
7495 if (!binding_label
|| gfc_notification_std (GFC_STD_F2008
))
7497 s
= gfc_get_gsymbol (name
, false);
7499 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= type
))
7501 gfc_global_used (s
, where
);
7510 s
->ns
= gfc_current_ns
;
7514 /* Don't add the symbol multiple times. */
7516 && (!gfc_notification_std (GFC_STD_F2008
)
7517 || strcmp (name
, binding_label
) != 0))
7519 s
= gfc_get_gsymbol (binding_label
, true);
7521 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= type
))
7523 gfc_global_used (s
, where
);
7530 s
->binding_label
= binding_label
;
7533 s
->ns
= gfc_current_ns
;
7541 /* Match an ENTRY statement. */
7544 gfc_match_entry (void)
7549 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7550 gfc_compile_state state
;
7554 bool module_procedure
;
7558 m
= gfc_match_name (name
);
7562 if (!gfc_notify_std (GFC_STD_F2008_OBS
, "ENTRY statement at %C"))
7565 state
= gfc_current_state ();
7566 if (state
!= COMP_SUBROUTINE
&& state
!= COMP_FUNCTION
)
7571 gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
7574 gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
7576 case COMP_SUBMODULE
:
7577 gfc_error ("ENTRY statement at %C cannot appear within a SUBMODULE");
7579 case COMP_BLOCK_DATA
:
7580 gfc_error ("ENTRY statement at %C cannot appear within "
7583 case COMP_INTERFACE
:
7584 gfc_error ("ENTRY statement at %C cannot appear within "
7587 case COMP_STRUCTURE
:
7588 gfc_error ("ENTRY statement at %C cannot appear within "
7589 "a STRUCTURE block");
7592 gfc_error ("ENTRY statement at %C cannot appear within "
7593 "a DERIVED TYPE block");
7596 gfc_error ("ENTRY statement at %C cannot appear within "
7597 "an IF-THEN block");
7600 case COMP_DO_CONCURRENT
:
7601 gfc_error ("ENTRY statement at %C cannot appear within "
7605 gfc_error ("ENTRY statement at %C cannot appear within "
7609 gfc_error ("ENTRY statement at %C cannot appear within "
7613 gfc_error ("ENTRY statement at %C cannot appear within "
7617 gfc_error ("ENTRY statement at %C cannot appear within "
7618 "a contained subprogram");
7621 gfc_error ("Unexpected ENTRY statement at %C");
7626 if ((state
== COMP_SUBROUTINE
|| state
== COMP_FUNCTION
)
7627 && gfc_state_stack
->previous
->state
== COMP_INTERFACE
)
7629 gfc_error ("ENTRY statement at %C cannot appear within an INTERFACE");
7633 module_procedure
= gfc_current_ns
->parent
!= NULL
7634 && gfc_current_ns
->parent
->proc_name
7635 && gfc_current_ns
->parent
->proc_name
->attr
.flavor
7638 if (gfc_current_ns
->parent
!= NULL
7639 && gfc_current_ns
->parent
->proc_name
7640 && !module_procedure
)
7642 gfc_error("ENTRY statement at %C cannot appear in a "
7643 "contained procedure");
7647 /* Module function entries need special care in get_proc_name
7648 because previous references within the function will have
7649 created symbols attached to the current namespace. */
7650 if (get_proc_name (name
, &entry
,
7651 gfc_current_ns
->parent
!= NULL
7652 && module_procedure
))
7655 proc
= gfc_current_block ();
7657 /* Make sure that it isn't already declared as BIND(C). If it is, it
7658 must have been marked BIND(C) with a BIND(C) attribute and that is
7659 not allowed for procedures. */
7660 if (entry
->attr
.is_bind_c
== 1)
7664 entry
->attr
.is_bind_c
= 0;
7666 loc
= entry
->old_symbol
!= NULL
7667 ? entry
->old_symbol
->declared_at
: gfc_current_locus
;
7668 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7669 "variables or common blocks", &loc
);
7672 /* Check what next non-whitespace character is so we can tell if there
7673 is the required parens if we have a BIND(C). */
7674 old_loc
= gfc_current_locus
;
7675 gfc_gobble_whitespace ();
7676 peek_char
= gfc_peek_ascii_char ();
7678 if (state
== COMP_SUBROUTINE
)
7680 m
= gfc_match_formal_arglist (entry
, 0, 1);
7684 /* Call gfc_match_bind_c with allow_binding_name = true as ENTRY can
7685 never be an internal procedure. */
7686 is_bind_c
= gfc_match_bind_c (entry
, true);
7687 if (is_bind_c
== MATCH_ERROR
)
7689 if (is_bind_c
== MATCH_YES
)
7691 if (peek_char
!= '(')
7693 gfc_error ("Missing required parentheses before BIND(C) at %C");
7697 if (!gfc_add_is_bind_c (&(entry
->attr
), entry
->name
,
7698 &(entry
->declared_at
), 1))
7703 if (!gfc_current_ns
->parent
7704 && !add_global_entry (name
, entry
->binding_label
, true,
7708 /* An entry in a subroutine. */
7709 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
7710 || !gfc_add_subroutine (&entry
->attr
, entry
->name
, NULL
))
7715 /* An entry in a function.
7716 We need to take special care because writing
7721 ENTRY f() RESULT (r)
7723 ENTRY f RESULT (r). */
7724 if (gfc_match_eos () == MATCH_YES
)
7726 gfc_current_locus
= old_loc
;
7727 /* Match the empty argument list, and add the interface to
7729 m
= gfc_match_formal_arglist (entry
, 0, 1);
7732 m
= gfc_match_formal_arglist (entry
, 0, 0);
7739 if (gfc_match_eos () == MATCH_YES
)
7741 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
7742 || !gfc_add_function (&entry
->attr
, entry
->name
, NULL
))
7745 entry
->result
= entry
;
7749 m
= gfc_match_suffix (entry
, &result
);
7751 gfc_syntax_error (ST_ENTRY
);
7757 if (!gfc_add_result (&result
->attr
, result
->name
, NULL
)
7758 || !gfc_add_entry (&entry
->attr
, result
->name
, NULL
)
7759 || !gfc_add_function (&entry
->attr
, result
->name
, NULL
))
7761 entry
->result
= result
;
7765 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
7766 || !gfc_add_function (&entry
->attr
, entry
->name
, NULL
))
7768 entry
->result
= entry
;
7772 if (!gfc_current_ns
->parent
7773 && !add_global_entry (name
, entry
->binding_label
, false,
7778 if (gfc_match_eos () != MATCH_YES
)
7780 gfc_syntax_error (ST_ENTRY
);
7784 /* F2018:C1546 An elemental procedure shall not have the BIND attribute. */
7785 if (proc
->attr
.elemental
&& entry
->attr
.is_bind_c
)
7787 gfc_error ("ENTRY statement at %L with BIND(C) prohibited in an "
7788 "elemental procedure", &entry
->declared_at
);
7792 entry
->attr
.recursive
= proc
->attr
.recursive
;
7793 entry
->attr
.elemental
= proc
->attr
.elemental
;
7794 entry
->attr
.pure
= proc
->attr
.pure
;
7796 el
= gfc_get_entry_list ();
7798 el
->next
= gfc_current_ns
->entries
;
7799 gfc_current_ns
->entries
= el
;
7801 el
->id
= el
->next
->id
+ 1;
7805 new_st
.op
= EXEC_ENTRY
;
7806 new_st
.ext
.entry
= el
;
7812 /* Match a subroutine statement, including optional prefixes. */
7815 gfc_match_subroutine (void)
7817 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7822 bool allow_binding_name
;
7825 if (gfc_current_state () != COMP_NONE
7826 && gfc_current_state () != COMP_INTERFACE
7827 && gfc_current_state () != COMP_CONTAINS
)
7830 m
= gfc_match_prefix (NULL
);
7834 m
= gfc_match ("subroutine% %n", name
);
7838 if (get_proc_name (name
, &sym
, false))
7841 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
7842 the symbol existed before. */
7843 sym
->declared_at
= gfc_current_locus
;
7845 if (current_attr
.module_procedure
)
7846 sym
->attr
.module_procedure
= 1;
7848 if (add_hidden_procptr_result (sym
))
7851 gfc_new_block
= sym
;
7853 /* Check what next non-whitespace character is so we can tell if there
7854 is the required parens if we have a BIND(C). */
7855 gfc_gobble_whitespace ();
7856 peek_char
= gfc_peek_ascii_char ();
7858 if (!gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
))
7861 if (gfc_match_formal_arglist (sym
, 0, 1) != MATCH_YES
)
7864 /* Make sure that it isn't already declared as BIND(C). If it is, it
7865 must have been marked BIND(C) with a BIND(C) attribute and that is
7866 not allowed for procedures. */
7867 if (sym
->attr
.is_bind_c
== 1)
7869 sym
->attr
.is_bind_c
= 0;
7871 if (gfc_state_stack
->previous
7872 && gfc_state_stack
->previous
->state
!= COMP_SUBMODULE
)
7875 loc
= sym
->old_symbol
!= NULL
7876 ? sym
->old_symbol
->declared_at
: gfc_current_locus
;
7877 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7878 "variables or common blocks", &loc
);
7882 /* C binding names are not allowed for internal procedures. */
7883 if (gfc_current_state () == COMP_CONTAINS
7884 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
7885 allow_binding_name
= false;
7887 allow_binding_name
= true;
7889 /* Here, we are just checking if it has the bind(c) attribute, and if
7890 so, then we need to make sure it's all correct. If it doesn't,
7891 we still need to continue matching the rest of the subroutine line. */
7892 gfc_gobble_whitespace ();
7893 loc
= gfc_current_locus
;
7894 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
7895 if (is_bind_c
== MATCH_ERROR
)
7897 /* There was an attempt at the bind(c), but it was wrong. An
7898 error message should have been printed w/in the gfc_match_bind_c
7899 so here we'll just return the MATCH_ERROR. */
7903 if (is_bind_c
== MATCH_YES
)
7905 gfc_formal_arglist
*arg
;
7907 /* The following is allowed in the Fortran 2008 draft. */
7908 if (gfc_current_state () == COMP_CONTAINS
7909 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
7910 && !gfc_notify_std (GFC_STD_F2008
, "BIND(C) attribute "
7911 "at %L may not be specified for an internal "
7912 "procedure", &gfc_current_locus
))
7915 if (peek_char
!= '(')
7917 gfc_error ("Missing required parentheses before BIND(C) at %C");
7921 /* F2018 C1550 (R1526) If MODULE appears in the prefix of a module
7922 subprogram and a binding label is specified, it shall be the
7923 same as the binding label specified in the corresponding module
7924 procedure interface body. */
7925 if (sym
->attr
.module_procedure
&& sym
->old_symbol
7926 && strcmp (sym
->name
, sym
->old_symbol
->name
) == 0
7927 && sym
->binding_label
&& sym
->old_symbol
->binding_label
7928 && strcmp (sym
->binding_label
, sym
->old_symbol
->binding_label
) != 0)
7930 const char *null
= "NULL", *s1
, *s2
;
7931 s1
= sym
->binding_label
;
7933 s2
= sym
->old_symbol
->binding_label
;
7935 gfc_error ("Mismatch in BIND(C) names (%qs/%qs) at %C", s1
, s2
);
7936 sym
->refs
++; /* Needed to avoid an ICE in gfc_release_symbol */
7940 /* Scan the dummy arguments for an alternate return. */
7941 for (arg
= sym
->formal
; arg
; arg
= arg
->next
)
7944 gfc_error ("Alternate return dummy argument cannot appear in a "
7945 "SUBROUTINE with the BIND(C) attribute at %L", &loc
);
7949 if (!gfc_add_is_bind_c (&(sym
->attr
), sym
->name
, &(sym
->declared_at
), 1))
7953 if (gfc_match_eos () != MATCH_YES
)
7955 gfc_syntax_error (ST_SUBROUTINE
);
7959 if (!copy_prefix (&sym
->attr
, &sym
->declared_at
))
7961 if(!sym
->attr
.module_procedure
)
7967 /* Warn if it has the same name as an intrinsic. */
7968 do_warn_intrinsic_shadow (sym
, false);
7974 /* Check that the NAME identifier in a BIND attribute or statement
7975 is conform to C identifier rules. */
7978 check_bind_name_identifier (char **name
)
7980 char *n
= *name
, *p
;
7982 /* Remove leading spaces. */
7986 /* On an empty string, free memory and set name to NULL. */
7994 /* Remove trailing spaces. */
7995 p
= n
+ strlen(n
) - 1;
7999 /* Insert the identifier into the symbol table. */
8004 /* Now check that identifier is valid under C rules. */
8007 gfc_error ("Invalid C identifier in NAME= specifier at %C");
8012 if (!(ISALNUM (*p
) || *p
== '_' || *p
== '$'))
8014 gfc_error ("Invalid C identifier in NAME= specifier at %C");
8022 /* Match a BIND(C) specifier, with the optional 'name=' specifier if
8023 given, and set the binding label in either the given symbol (if not
8024 NULL), or in the current_ts. The symbol may be NULL because we may
8025 encounter the BIND(C) before the declaration itself. Return
8026 MATCH_NO if what we're looking at isn't a BIND(C) specifier,
8027 MATCH_ERROR if it is a BIND(C) clause but an error was encountered,
8028 or MATCH_YES if the specifier was correct and the binding label and
8029 bind(c) fields were set correctly for the given symbol or the
8030 current_ts. If allow_binding_name is false, no binding name may be
8034 gfc_match_bind_c (gfc_symbol
*sym
, bool allow_binding_name
)
8036 char *binding_label
= NULL
;
8039 /* Initialize the flag that specifies whether we encountered a NAME=
8040 specifier or not. */
8041 has_name_equals
= 0;
8043 /* This much we have to be able to match, in this order, if
8044 there is a bind(c) label. */
8045 if (gfc_match (" bind ( c ") != MATCH_YES
)
8048 /* Now see if there is a binding label, or if we've reached the
8049 end of the bind(c) attribute without one. */
8050 if (gfc_match_char (',') == MATCH_YES
)
8052 if (gfc_match (" name = ") != MATCH_YES
)
8054 gfc_error ("Syntax error in NAME= specifier for binding label "
8056 /* should give an error message here */
8060 has_name_equals
= 1;
8062 if (gfc_match_init_expr (&e
) != MATCH_YES
)
8068 if (!gfc_simplify_expr(e
, 0))
8070 gfc_error ("NAME= specifier at %C should be a constant expression");
8075 if (e
->expr_type
!= EXPR_CONSTANT
|| e
->ts
.type
!= BT_CHARACTER
8076 || e
->ts
.kind
!= gfc_default_character_kind
|| e
->rank
!= 0)
8078 gfc_error ("NAME= specifier at %C should be a scalar of "
8079 "default character kind");
8084 // Get a C string from the Fortran string constant
8085 binding_label
= gfc_widechar_to_char (e
->value
.character
.string
,
8086 e
->value
.character
.length
);
8089 // Check that it is valid (old gfc_match_name_C)
8090 if (check_bind_name_identifier (&binding_label
) != MATCH_YES
)
8094 /* Get the required right paren. */
8095 if (gfc_match_char (')') != MATCH_YES
)
8097 gfc_error ("Missing closing paren for binding label at %C");
8101 if (has_name_equals
&& !allow_binding_name
)
8103 gfc_error ("No binding name is allowed in BIND(C) at %C");
8107 if (has_name_equals
&& sym
!= NULL
&& sym
->attr
.dummy
)
8109 gfc_error ("For dummy procedure %s, no binding name is "
8110 "allowed in BIND(C) at %C", sym
->name
);
8115 /* Save the binding label to the symbol. If sym is null, we're
8116 probably matching the typespec attributes of a declaration and
8117 haven't gotten the name yet, and therefore, no symbol yet. */
8121 sym
->binding_label
= binding_label
;
8123 curr_binding_label
= binding_label
;
8125 else if (allow_binding_name
)
8127 /* No binding label, but if symbol isn't null, we
8128 can set the label for it here.
8129 If name="" or allow_binding_name is false, no C binding name is
8131 if (sym
!= NULL
&& sym
->name
!= NULL
&& has_name_equals
== 0)
8132 sym
->binding_label
= IDENTIFIER_POINTER (get_identifier (sym
->name
));
8135 if (has_name_equals
&& gfc_current_state () == COMP_INTERFACE
8136 && current_interface
.type
== INTERFACE_ABSTRACT
)
8138 gfc_error ("NAME not allowed on BIND(C) for ABSTRACT INTERFACE at %C");
8146 /* Return nonzero if we're currently compiling a contained procedure. */
8149 contained_procedure (void)
8151 gfc_state_data
*s
= gfc_state_stack
;
8153 if ((s
->state
== COMP_SUBROUTINE
|| s
->state
== COMP_FUNCTION
)
8154 && s
->previous
!= NULL
&& s
->previous
->state
== COMP_CONTAINS
)
8160 /* Set the kind of each enumerator. The kind is selected such that it is
8161 interoperable with the corresponding C enumeration type, making
8162 sure that -fshort-enums is honored. */
8167 enumerator_history
*current_history
= NULL
;
8171 if (max_enum
== NULL
|| enum_history
== NULL
)
8174 if (!flag_short_enums
)
8180 kind
= gfc_integer_kinds
[i
++].kind
;
8182 while (kind
< gfc_c_int_kind
8183 && gfc_check_integer_range (max_enum
->initializer
->value
.integer
,
8186 current_history
= enum_history
;
8187 while (current_history
!= NULL
)
8189 current_history
->sym
->ts
.kind
= kind
;
8190 current_history
= current_history
->next
;
8195 /* Match any of the various end-block statements. Returns the type of
8196 END to the caller. The END INTERFACE, END IF, END DO, END SELECT
8197 and END BLOCK statements cannot be replaced by a single END statement. */
8200 gfc_match_end (gfc_statement
*st
)
8202 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8203 gfc_compile_state state
;
8205 const char *block_name
;
8209 gfc_namespace
*parent_ns
, *ns
, *prev_ns
;
8210 gfc_namespace
**nsp
;
8211 bool abreviated_modproc_decl
= false;
8212 bool got_matching_end
= false;
8214 old_loc
= gfc_current_locus
;
8215 if (gfc_match ("end") != MATCH_YES
)
8218 state
= gfc_current_state ();
8219 block_name
= gfc_current_block () == NULL
8220 ? NULL
: gfc_current_block ()->name
;
8224 case COMP_ASSOCIATE
:
8226 if (gfc_str_startswith (block_name
, "block@"))
8231 case COMP_DERIVED_CONTAINS
:
8232 state
= gfc_state_stack
->previous
->state
;
8233 block_name
= gfc_state_stack
->previous
->sym
== NULL
8234 ? NULL
: gfc_state_stack
->previous
->sym
->name
;
8235 abreviated_modproc_decl
= gfc_state_stack
->previous
->sym
8236 && gfc_state_stack
->previous
->sym
->abr_modproc_decl
;
8243 if (!abreviated_modproc_decl
)
8244 abreviated_modproc_decl
= gfc_current_block ()
8245 && gfc_current_block ()->abr_modproc_decl
;
8251 *st
= ST_END_PROGRAM
;
8252 target
= " program";
8256 case COMP_SUBROUTINE
:
8257 *st
= ST_END_SUBROUTINE
;
8258 if (!abreviated_modproc_decl
)
8259 target
= " subroutine";
8261 target
= " procedure";
8262 eos_ok
= !contained_procedure ();
8266 *st
= ST_END_FUNCTION
;
8267 if (!abreviated_modproc_decl
)
8268 target
= " function";
8270 target
= " procedure";
8271 eos_ok
= !contained_procedure ();
8274 case COMP_BLOCK_DATA
:
8275 *st
= ST_END_BLOCK_DATA
;
8276 target
= " block data";
8281 *st
= ST_END_MODULE
;
8286 case COMP_SUBMODULE
:
8287 *st
= ST_END_SUBMODULE
;
8288 target
= " submodule";
8292 case COMP_INTERFACE
:
8293 *st
= ST_END_INTERFACE
;
8294 target
= " interface";
8310 case COMP_STRUCTURE
:
8311 *st
= ST_END_STRUCTURE
;
8312 target
= " structure";
8317 case COMP_DERIVED_CONTAINS
:
8323 case COMP_ASSOCIATE
:
8324 *st
= ST_END_ASSOCIATE
;
8325 target
= " associate";
8342 case COMP_DO_CONCURRENT
:
8349 *st
= ST_END_CRITICAL
;
8350 target
= " critical";
8355 case COMP_SELECT_TYPE
:
8356 case COMP_SELECT_RANK
:
8357 *st
= ST_END_SELECT
;
8363 *st
= ST_END_FORALL
;
8378 last_initializer
= NULL
;
8380 gfc_free_enum_history ();
8384 gfc_error ("Unexpected END statement at %C");
8388 old_loc
= gfc_current_locus
;
8389 if (gfc_match_eos () == MATCH_YES
)
8391 if (!eos_ok
&& (*st
== ST_END_SUBROUTINE
|| *st
== ST_END_FUNCTION
))
8393 if (!gfc_notify_std (GFC_STD_F2008
, "END statement "
8394 "instead of %s statement at %L",
8395 abreviated_modproc_decl
? "END PROCEDURE"
8396 : gfc_ascii_statement(*st
), &old_loc
))
8401 /* We would have required END [something]. */
8402 gfc_error ("%s statement expected at %L",
8403 gfc_ascii_statement (*st
), &old_loc
);
8410 /* Verify that we've got the sort of end-block that we're expecting. */
8411 if (gfc_match (target
) != MATCH_YES
)
8413 gfc_error ("Expecting %s statement at %L", abreviated_modproc_decl
8414 ? "END PROCEDURE" : gfc_ascii_statement(*st
), &old_loc
);
8418 got_matching_end
= true;
8420 old_loc
= gfc_current_locus
;
8421 /* If we're at the end, make sure a block name wasn't required. */
8422 if (gfc_match_eos () == MATCH_YES
)
8425 if (*st
!= ST_ENDDO
&& *st
!= ST_ENDIF
&& *st
!= ST_END_SELECT
8426 && *st
!= ST_END_FORALL
&& *st
!= ST_END_WHERE
&& *st
!= ST_END_BLOCK
8427 && *st
!= ST_END_ASSOCIATE
&& *st
!= ST_END_CRITICAL
)
8433 gfc_error ("Expected block name of %qs in %s statement at %L",
8434 block_name
, gfc_ascii_statement (*st
), &old_loc
);
8439 /* END INTERFACE has a special handler for its several possible endings. */
8440 if (*st
== ST_END_INTERFACE
)
8441 return gfc_match_end_interface ();
8443 /* We haven't hit the end of statement, so what is left must be an
8445 m
= gfc_match_space ();
8447 m
= gfc_match_name (name
);
8450 gfc_error ("Expected terminating name at %C");
8454 if (block_name
== NULL
)
8457 /* We have to pick out the declared submodule name from the composite
8458 required by F2008:11.2.3 para 2, which ends in the declared name. */
8459 if (state
== COMP_SUBMODULE
)
8460 block_name
= strchr (block_name
, '.') + 1;
8462 if (strcmp (name
, block_name
) != 0 && strcmp (block_name
, "ppr@") != 0)
8464 gfc_error ("Expected label %qs for %s statement at %C", block_name
,
8465 gfc_ascii_statement (*st
));
8468 /* Procedure pointer as function result. */
8469 else if (strcmp (block_name
, "ppr@") == 0
8470 && strcmp (name
, gfc_current_block ()->ns
->proc_name
->name
) != 0)
8472 gfc_error ("Expected label %qs for %s statement at %C",
8473 gfc_current_block ()->ns
->proc_name
->name
,
8474 gfc_ascii_statement (*st
));
8478 if (gfc_match_eos () == MATCH_YES
)
8482 gfc_syntax_error (*st
);
8485 gfc_current_locus
= old_loc
;
8487 /* If we are missing an END BLOCK, we created a half-ready namespace.
8488 Remove it from the parent namespace's sibling list. */
8490 while (state
== COMP_BLOCK
&& !got_matching_end
)
8492 parent_ns
= gfc_current_ns
->parent
;
8494 nsp
= &(gfc_state_stack
->previous
->tail
->ext
.block
.ns
);
8500 if (ns
== gfc_current_ns
)
8502 if (prev_ns
== NULL
)
8505 prev_ns
->sibling
= ns
->sibling
;
8511 gfc_free_namespace (gfc_current_ns
);
8512 gfc_current_ns
= parent_ns
;
8513 gfc_state_stack
= gfc_state_stack
->previous
;
8514 state
= gfc_current_state ();
8522 /***************** Attribute declaration statements ****************/
8524 /* Set the attribute of a single variable. */
8529 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8532 /* Workaround -Wmaybe-uninitialized false positive during
8533 profiledbootstrap by initializing them. */
8534 gfc_symbol
*sym
= NULL
;
8540 m
= gfc_match_name (name
);
8544 if (find_special (name
, &sym
, false))
8547 if (!check_function_name (name
))
8553 var_locus
= gfc_current_locus
;
8555 /* Deal with possible array specification for certain attributes. */
8556 if (current_attr
.dimension
8557 || current_attr
.codimension
8558 || current_attr
.allocatable
8559 || current_attr
.pointer
8560 || current_attr
.target
)
8562 m
= gfc_match_array_spec (&as
, !current_attr
.codimension
,
8563 !current_attr
.dimension
8564 && !current_attr
.pointer
8565 && !current_attr
.target
);
8566 if (m
== MATCH_ERROR
)
8569 if (current_attr
.dimension
&& m
== MATCH_NO
)
8571 gfc_error ("Missing array specification at %L in DIMENSION "
8572 "statement", &var_locus
);
8577 if (current_attr
.dimension
&& sym
->value
)
8579 gfc_error ("Dimensions specified for %s at %L after its "
8580 "initialization", sym
->name
, &var_locus
);
8585 if (current_attr
.codimension
&& m
== MATCH_NO
)
8587 gfc_error ("Missing array specification at %L in CODIMENSION "
8588 "statement", &var_locus
);
8593 if ((current_attr
.allocatable
|| current_attr
.pointer
)
8594 && (m
== MATCH_YES
) && (as
->type
!= AS_DEFERRED
))
8596 gfc_error ("Array specification must be deferred at %L", &var_locus
);
8602 /* Update symbol table. DIMENSION attribute is set in
8603 gfc_set_array_spec(). For CLASS variables, this must be applied
8604 to the first component, or '_data' field. */
8605 if (sym
->ts
.type
== BT_CLASS
&& sym
->ts
.u
.derived
->attr
.is_class
)
8607 /* gfc_set_array_spec sets sym->attr not CLASS_DATA(sym)->attr. Check
8608 for duplicate attribute here. */
8609 if (CLASS_DATA(sym
)->attr
.dimension
== 1 && as
)
8611 gfc_error ("Duplicate DIMENSION attribute at %C");
8616 if (!gfc_copy_attr (&CLASS_DATA(sym
)->attr
, ¤t_attr
, &var_locus
))
8624 if (current_attr
.dimension
== 0 && current_attr
.codimension
== 0
8625 && !gfc_copy_attr (&sym
->attr
, ¤t_attr
, &var_locus
))
8632 if (sym
->ts
.type
== BT_CLASS
8633 && !gfc_build_class_symbol (&sym
->ts
, &sym
->attr
, &sym
->as
))
8639 if (!gfc_set_array_spec (sym
, as
, &var_locus
))
8645 if (sym
->attr
.cray_pointee
&& sym
->as
!= NULL
)
8647 /* Fix the array spec. */
8648 m
= gfc_mod_pointee_as (sym
->as
);
8649 if (m
== MATCH_ERROR
)
8653 if (!gfc_add_attribute (&sym
->attr
, &var_locus
))
8659 if ((current_attr
.external
|| current_attr
.intrinsic
)
8660 && sym
->attr
.flavor
!= FL_PROCEDURE
8661 && !gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, NULL
))
8667 add_hidden_procptr_result (sym
);
8672 gfc_free_array_spec (as
);
8677 /* Generic attribute declaration subroutine. Used for attributes that
8678 just have a list of names. */
8685 /* Gobble the optional double colon, by simply ignoring the result
8695 if (gfc_match_eos () == MATCH_YES
)
8701 if (gfc_match_char (',') != MATCH_YES
)
8703 gfc_error ("Unexpected character in variable list at %C");
8713 /* This routine matches Cray Pointer declarations of the form:
8714 pointer ( <pointer>, <pointee> )
8716 pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...
8717 The pointer, if already declared, should be an integer. Otherwise, we
8718 set it as BT_INTEGER with kind gfc_index_integer_kind. The pointee may
8719 be either a scalar, or an array declaration. No space is allocated for
8720 the pointee. For the statement
8721 pointer (ipt, ar(10))
8722 any subsequent uses of ar will be translated (in C-notation) as
8723 ar(i) => ((<type> *) ipt)(i)
8724 After gimplification, pointee variable will disappear in the code. */
8727 cray_pointer_decl (void)
8730 gfc_array_spec
*as
= NULL
;
8731 gfc_symbol
*cptr
; /* Pointer symbol. */
8732 gfc_symbol
*cpte
; /* Pointee symbol. */
8738 if (gfc_match_char ('(') != MATCH_YES
)
8740 gfc_error ("Expected %<(%> at %C");
8744 /* Match pointer. */
8745 var_locus
= gfc_current_locus
;
8746 gfc_clear_attr (¤t_attr
);
8747 gfc_add_cray_pointer (¤t_attr
, &var_locus
);
8748 current_ts
.type
= BT_INTEGER
;
8749 current_ts
.kind
= gfc_index_integer_kind
;
8751 m
= gfc_match_symbol (&cptr
, 0);
8754 gfc_error ("Expected variable name at %C");
8758 if (!gfc_add_cray_pointer (&cptr
->attr
, &var_locus
))
8761 gfc_set_sym_referenced (cptr
);
8763 if (cptr
->ts
.type
== BT_UNKNOWN
) /* Override the type, if necessary. */
8765 cptr
->ts
.type
= BT_INTEGER
;
8766 cptr
->ts
.kind
= gfc_index_integer_kind
;
8768 else if (cptr
->ts
.type
!= BT_INTEGER
)
8770 gfc_error ("Cray pointer at %C must be an integer");
8773 else if (cptr
->ts
.kind
< gfc_index_integer_kind
)
8774 gfc_warning (0, "Cray pointer at %C has %d bytes of precision;"
8775 " memory addresses require %d bytes",
8776 cptr
->ts
.kind
, gfc_index_integer_kind
);
8778 if (gfc_match_char (',') != MATCH_YES
)
8780 gfc_error ("Expected \",\" at %C");
8784 /* Match Pointee. */
8785 var_locus
= gfc_current_locus
;
8786 gfc_clear_attr (¤t_attr
);
8787 gfc_add_cray_pointee (¤t_attr
, &var_locus
);
8788 current_ts
.type
= BT_UNKNOWN
;
8789 current_ts
.kind
= 0;
8791 m
= gfc_match_symbol (&cpte
, 0);
8794 gfc_error ("Expected variable name at %C");
8798 /* Check for an optional array spec. */
8799 m
= gfc_match_array_spec (&as
, true, false);
8800 if (m
== MATCH_ERROR
)
8802 gfc_free_array_spec (as
);
8805 else if (m
== MATCH_NO
)
8807 gfc_free_array_spec (as
);
8811 if (!gfc_add_cray_pointee (&cpte
->attr
, &var_locus
))
8814 gfc_set_sym_referenced (cpte
);
8816 if (cpte
->as
== NULL
)
8818 if (!gfc_set_array_spec (cpte
, as
, &var_locus
))
8819 gfc_internal_error ("Cannot set Cray pointee array spec.");
8821 else if (as
!= NULL
)
8823 gfc_error ("Duplicate array spec for Cray pointee at %C");
8824 gfc_free_array_spec (as
);
8830 if (cpte
->as
!= NULL
)
8832 /* Fix array spec. */
8833 m
= gfc_mod_pointee_as (cpte
->as
);
8834 if (m
== MATCH_ERROR
)
8838 /* Point the Pointee at the Pointer. */
8839 cpte
->cp_pointer
= cptr
;
8841 if (gfc_match_char (')') != MATCH_YES
)
8843 gfc_error ("Expected \")\" at %C");
8846 m
= gfc_match_char (',');
8848 done
= true; /* Stop searching for more declarations. */
8852 if (m
== MATCH_ERROR
/* Failed when trying to find ',' above. */
8853 || gfc_match_eos () != MATCH_YES
)
8855 gfc_error ("Expected %<,%> or end of statement at %C");
8863 gfc_match_external (void)
8866 gfc_clear_attr (¤t_attr
);
8867 current_attr
.external
= 1;
8869 return attr_decl ();
8874 gfc_match_intent (void)
8878 /* This is not allowed within a BLOCK construct! */
8879 if (gfc_current_state () == COMP_BLOCK
)
8881 gfc_error ("INTENT is not allowed inside of BLOCK at %C");
8885 intent
= match_intent_spec ();
8886 if (intent
== INTENT_UNKNOWN
)
8889 gfc_clear_attr (¤t_attr
);
8890 current_attr
.intent
= intent
;
8892 return attr_decl ();
8897 gfc_match_intrinsic (void)
8900 gfc_clear_attr (¤t_attr
);
8901 current_attr
.intrinsic
= 1;
8903 return attr_decl ();
8908 gfc_match_optional (void)
8910 /* This is not allowed within a BLOCK construct! */
8911 if (gfc_current_state () == COMP_BLOCK
)
8913 gfc_error ("OPTIONAL is not allowed inside of BLOCK at %C");
8917 gfc_clear_attr (¤t_attr
);
8918 current_attr
.optional
= 1;
8920 return attr_decl ();
8925 gfc_match_pointer (void)
8927 gfc_gobble_whitespace ();
8928 if (gfc_peek_ascii_char () == '(')
8930 if (!flag_cray_pointer
)
8932 gfc_error ("Cray pointer declaration at %C requires "
8933 "%<-fcray-pointer%> flag");
8936 return cray_pointer_decl ();
8940 gfc_clear_attr (¤t_attr
);
8941 current_attr
.pointer
= 1;
8943 return attr_decl ();
8949 gfc_match_allocatable (void)
8951 gfc_clear_attr (¤t_attr
);
8952 current_attr
.allocatable
= 1;
8954 return attr_decl ();
8959 gfc_match_codimension (void)
8961 gfc_clear_attr (¤t_attr
);
8962 current_attr
.codimension
= 1;
8964 return attr_decl ();
8969 gfc_match_contiguous (void)
8971 if (!gfc_notify_std (GFC_STD_F2008
, "CONTIGUOUS statement at %C"))
8974 gfc_clear_attr (¤t_attr
);
8975 current_attr
.contiguous
= 1;
8977 return attr_decl ();
8982 gfc_match_dimension (void)
8984 gfc_clear_attr (¤t_attr
);
8985 current_attr
.dimension
= 1;
8987 return attr_decl ();
8992 gfc_match_target (void)
8994 gfc_clear_attr (¤t_attr
);
8995 current_attr
.target
= 1;
8997 return attr_decl ();
9001 /* Match the list of entities being specified in a PUBLIC or PRIVATE
9005 access_attr_decl (gfc_statement st
)
9007 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9008 interface_type type
;
9010 gfc_symbol
*sym
, *dt_sym
;
9011 gfc_intrinsic_op op
;
9013 gfc_access access
= (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
9015 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
9020 m
= gfc_match_generic_spec (&type
, name
, &op
);
9023 if (m
== MATCH_ERROR
)
9028 case INTERFACE_NAMELESS
:
9029 case INTERFACE_ABSTRACT
:
9032 case INTERFACE_GENERIC
:
9033 case INTERFACE_DTIO
:
9035 if (gfc_get_symbol (name
, NULL
, &sym
))
9038 if (type
== INTERFACE_DTIO
9039 && gfc_current_ns
->proc_name
9040 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
9041 && sym
->attr
.flavor
== FL_UNKNOWN
)
9042 sym
->attr
.flavor
= FL_PROCEDURE
;
9044 if (!gfc_add_access (&sym
->attr
, access
, sym
->name
, NULL
))
9047 if (sym
->attr
.generic
&& (dt_sym
= gfc_find_dt_in_generic (sym
))
9048 && !gfc_add_access (&dt_sym
->attr
, access
, sym
->name
, NULL
))
9053 case INTERFACE_INTRINSIC_OP
:
9054 if (gfc_current_ns
->operator_access
[op
] == ACCESS_UNKNOWN
)
9056 gfc_intrinsic_op other_op
;
9058 gfc_current_ns
->operator_access
[op
] = access
;
9060 /* Handle the case if there is another op with the same
9061 function, for INTRINSIC_EQ vs. INTRINSIC_EQ_OS and so on. */
9062 other_op
= gfc_equivalent_op (op
);
9064 if (other_op
!= INTRINSIC_NONE
)
9065 gfc_current_ns
->operator_access
[other_op
] = access
;
9069 gfc_error ("Access specification of the %s operator at %C has "
9070 "already been specified", gfc_op2string (op
));
9076 case INTERFACE_USER_OP
:
9077 uop
= gfc_get_uop (name
);
9079 if (uop
->access
== ACCESS_UNKNOWN
)
9081 uop
->access
= access
;
9085 gfc_error ("Access specification of the .%s. operator at %C "
9086 "has already been specified", uop
->name
);
9093 if (gfc_match_char (',') == MATCH_NO
)
9097 if (gfc_match_eos () != MATCH_YES
)
9102 gfc_syntax_error (st
);
9110 gfc_match_protected (void)
9116 /* PROTECTED has already been seen, but must be followed by whitespace
9118 c
= gfc_peek_ascii_char ();
9119 if (!gfc_is_whitespace (c
) && c
!= ':')
9122 if (!gfc_current_ns
->proc_name
9123 || gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
9125 gfc_error ("PROTECTED at %C only allowed in specification "
9126 "part of a module");
9133 if (!gfc_notify_std (GFC_STD_F2003
, "PROTECTED statement at %C"))
9136 /* PROTECTED has an entity-list. */
9137 if (gfc_match_eos () == MATCH_YES
)
9142 m
= gfc_match_symbol (&sym
, 0);
9146 if (!gfc_add_protected (&sym
->attr
, sym
->name
, &gfc_current_locus
))
9158 if (gfc_match_eos () == MATCH_YES
)
9160 if (gfc_match_char (',') != MATCH_YES
)
9167 gfc_error ("Syntax error in PROTECTED statement at %C");
9172 /* The PRIVATE statement is a bit weird in that it can be an attribute
9173 declaration, but also works as a standalone statement inside of a
9174 type declaration or a module. */
9177 gfc_match_private (gfc_statement
*st
)
9179 gfc_state_data
*prev
;
9181 if (gfc_match ("private") != MATCH_YES
)
9184 /* Try matching PRIVATE without an access-list. */
9185 if (gfc_match_eos () == MATCH_YES
)
9187 prev
= gfc_state_stack
->previous
;
9188 if (gfc_current_state () != COMP_MODULE
9189 && !(gfc_current_state () == COMP_DERIVED
9190 && prev
&& prev
->state
== COMP_MODULE
)
9191 && !(gfc_current_state () == COMP_DERIVED_CONTAINS
9192 && prev
->previous
&& prev
->previous
->state
== COMP_MODULE
))
9194 gfc_error ("PRIVATE statement at %C is only allowed in the "
9195 "specification part of a module");
9203 /* At this point in free-form source code, PRIVATE must be followed
9204 by whitespace or ::. */
9205 if (gfc_current_form
== FORM_FREE
)
9207 char c
= gfc_peek_ascii_char ();
9208 if (!gfc_is_whitespace (c
) && c
!= ':')
9212 prev
= gfc_state_stack
->previous
;
9213 if (gfc_current_state () != COMP_MODULE
9214 && !(gfc_current_state () == COMP_DERIVED
9215 && prev
&& prev
->state
== COMP_MODULE
)
9216 && !(gfc_current_state () == COMP_DERIVED_CONTAINS
9217 && prev
->previous
&& prev
->previous
->state
== COMP_MODULE
))
9219 gfc_error ("PRIVATE statement at %C is only allowed in the "
9220 "specification part of a module");
9225 return access_attr_decl (ST_PRIVATE
);
9230 gfc_match_public (gfc_statement
*st
)
9232 if (gfc_match ("public") != MATCH_YES
)
9235 /* Try matching PUBLIC without an access-list. */
9236 if (gfc_match_eos () == MATCH_YES
)
9238 if (gfc_current_state () != COMP_MODULE
)
9240 gfc_error ("PUBLIC statement at %C is only allowed in the "
9241 "specification part of a module");
9249 /* At this point in free-form source code, PUBLIC must be followed
9250 by whitespace or ::. */
9251 if (gfc_current_form
== FORM_FREE
)
9253 char c
= gfc_peek_ascii_char ();
9254 if (!gfc_is_whitespace (c
) && c
!= ':')
9258 if (gfc_current_state () != COMP_MODULE
)
9260 gfc_error ("PUBLIC statement at %C is only allowed in the "
9261 "specification part of a module");
9266 return access_attr_decl (ST_PUBLIC
);
9270 /* Workhorse for gfc_match_parameter. */
9280 m
= gfc_match_symbol (&sym
, 0);
9282 gfc_error ("Expected variable name at %C in PARAMETER statement");
9287 if (gfc_match_char ('=') == MATCH_NO
)
9289 gfc_error ("Expected = sign in PARAMETER statement at %C");
9293 m
= gfc_match_init_expr (&init
);
9295 gfc_error ("Expected expression at %C in PARAMETER statement");
9299 if (sym
->ts
.type
== BT_UNKNOWN
9300 && !gfc_set_default_type (sym
, 1, NULL
))
9306 if (!gfc_check_assign_symbol (sym
, NULL
, init
)
9307 || !gfc_add_flavor (&sym
->attr
, FL_PARAMETER
, sym
->name
, NULL
))
9315 gfc_error ("Initializing already initialized variable at %C");
9320 t
= add_init_expr_to_sym (sym
->name
, &init
, &gfc_current_locus
);
9321 return (t
) ? MATCH_YES
: MATCH_ERROR
;
9324 gfc_free_expr (init
);
9329 /* Match a parameter statement, with the weird syntax that these have. */
9332 gfc_match_parameter (void)
9334 const char *term
= " )%t";
9337 if (gfc_match_char ('(') == MATCH_NO
)
9339 /* With legacy PARAMETER statements, don't expect a terminating ')'. */
9340 if (!gfc_notify_std (GFC_STD_LEGACY
, "PARAMETER without '()' at %C"))
9351 if (gfc_match (term
) == MATCH_YES
)
9354 if (gfc_match_char (',') != MATCH_YES
)
9356 gfc_error ("Unexpected characters in PARAMETER statement at %C");
9367 gfc_match_automatic (void)
9371 bool seen_symbol
= false;
9373 if (!flag_dec_static
)
9375 gfc_error ("%s at %C is a DEC extension, enable with "
9386 m
= gfc_match_symbol (&sym
, 0);
9396 if (!gfc_add_automatic (&sym
->attr
, sym
->name
, &gfc_current_locus
))
9402 if (gfc_match_eos () == MATCH_YES
)
9404 if (gfc_match_char (',') != MATCH_YES
)
9410 gfc_error ("Expected entity-list in AUTOMATIC statement at %C");
9417 gfc_error ("Syntax error in AUTOMATIC statement at %C");
9423 gfc_match_static (void)
9427 bool seen_symbol
= false;
9429 if (!flag_dec_static
)
9431 gfc_error ("%s at %C is a DEC extension, enable with "
9441 m
= gfc_match_symbol (&sym
, 0);
9451 if (!gfc_add_save (&sym
->attr
, SAVE_EXPLICIT
, sym
->name
,
9452 &gfc_current_locus
))
9458 if (gfc_match_eos () == MATCH_YES
)
9460 if (gfc_match_char (',') != MATCH_YES
)
9466 gfc_error ("Expected entity-list in STATIC statement at %C");
9473 gfc_error ("Syntax error in STATIC statement at %C");
9478 /* Save statements have a special syntax. */
9481 gfc_match_save (void)
9483 char n
[GFC_MAX_SYMBOL_LEN
+1];
9488 if (gfc_match_eos () == MATCH_YES
)
9490 if (gfc_current_ns
->seen_save
)
9492 if (!gfc_notify_std (GFC_STD_LEGACY
, "Blanket SAVE statement at %C "
9493 "follows previous SAVE statement"))
9497 gfc_current_ns
->save_all
= gfc_current_ns
->seen_save
= 1;
9501 if (gfc_current_ns
->save_all
)
9503 if (!gfc_notify_std (GFC_STD_LEGACY
, "SAVE statement at %C follows "
9504 "blanket SAVE statement"))
9512 m
= gfc_match_symbol (&sym
, 0);
9516 if (!gfc_add_save (&sym
->attr
, SAVE_EXPLICIT
, sym
->name
,
9517 &gfc_current_locus
))
9528 m
= gfc_match (" / %n /", &n
);
9529 if (m
== MATCH_ERROR
)
9534 c
= gfc_get_common (n
, 0);
9537 gfc_current_ns
->seen_save
= 1;
9540 if (gfc_match_eos () == MATCH_YES
)
9542 if (gfc_match_char (',') != MATCH_YES
)
9549 if (gfc_current_ns
->seen_save
)
9551 gfc_error ("Syntax error in SAVE statement at %C");
9560 gfc_match_value (void)
9565 /* This is not allowed within a BLOCK construct! */
9566 if (gfc_current_state () == COMP_BLOCK
)
9568 gfc_error ("VALUE is not allowed inside of BLOCK at %C");
9572 if (!gfc_notify_std (GFC_STD_F2003
, "VALUE statement at %C"))
9575 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
9580 if (gfc_match_eos () == MATCH_YES
)
9585 m
= gfc_match_symbol (&sym
, 0);
9589 if (!gfc_add_value (&sym
->attr
, sym
->name
, &gfc_current_locus
))
9601 if (gfc_match_eos () == MATCH_YES
)
9603 if (gfc_match_char (',') != MATCH_YES
)
9610 gfc_error ("Syntax error in VALUE statement at %C");
9616 gfc_match_volatile (void)
9622 if (!gfc_notify_std (GFC_STD_F2003
, "VOLATILE statement at %C"))
9625 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
9630 if (gfc_match_eos () == MATCH_YES
)
9635 /* VOLATILE is special because it can be added to host-associated
9636 symbols locally. Except for coarrays. */
9637 m
= gfc_match_symbol (&sym
, 1);
9641 name
= XCNEWVAR (char, strlen (sym
->name
) + 1);
9642 strcpy (name
, sym
->name
);
9643 if (!check_function_name (name
))
9645 /* F2008, C560+C561. VOLATILE for host-/use-associated variable or
9646 for variable in a BLOCK which is defined outside of the BLOCK. */
9647 if (sym
->ns
!= gfc_current_ns
&& sym
->attr
.codimension
)
9649 gfc_error ("Specifying VOLATILE for coarray variable %qs at "
9650 "%C, which is use-/host-associated", sym
->name
);
9653 if (!gfc_add_volatile (&sym
->attr
, sym
->name
, &gfc_current_locus
))
9665 if (gfc_match_eos () == MATCH_YES
)
9667 if (gfc_match_char (',') != MATCH_YES
)
9674 gfc_error ("Syntax error in VOLATILE statement at %C");
9680 gfc_match_asynchronous (void)
9686 if (!gfc_notify_std (GFC_STD_F2003
, "ASYNCHRONOUS statement at %C"))
9689 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
9694 if (gfc_match_eos () == MATCH_YES
)
9699 /* ASYNCHRONOUS is special because it can be added to host-associated
9701 m
= gfc_match_symbol (&sym
, 1);
9705 name
= XCNEWVAR (char, strlen (sym
->name
) + 1);
9706 strcpy (name
, sym
->name
);
9707 if (!check_function_name (name
))
9709 if (!gfc_add_asynchronous (&sym
->attr
, sym
->name
, &gfc_current_locus
))
9721 if (gfc_match_eos () == MATCH_YES
)
9723 if (gfc_match_char (',') != MATCH_YES
)
9730 gfc_error ("Syntax error in ASYNCHRONOUS statement at %C");
9735 /* Match a module procedure statement in a submodule. */
9738 gfc_match_submod_proc (void)
9740 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9741 gfc_symbol
*sym
, *fsym
;
9743 gfc_formal_arglist
*formal
, *head
, *tail
;
9745 if (gfc_current_state () != COMP_CONTAINS
9746 || !(gfc_state_stack
->previous
9747 && (gfc_state_stack
->previous
->state
== COMP_SUBMODULE
9748 || gfc_state_stack
->previous
->state
== COMP_MODULE
)))
9751 m
= gfc_match (" module% procedure% %n", name
);
9755 if (!gfc_notify_std (GFC_STD_F2008
, "MODULE PROCEDURE declaration "
9759 if (get_proc_name (name
, &sym
, false))
9762 /* Make sure that the result field is appropriately filled. */
9763 if (sym
->tlink
&& sym
->tlink
->attr
.function
)
9765 if (sym
->tlink
->result
&& sym
->tlink
->result
!= sym
->tlink
)
9767 sym
->result
= sym
->tlink
->result
;
9768 if (!sym
->result
->attr
.use_assoc
)
9770 gfc_symtree
*st
= gfc_new_symtree (&gfc_current_ns
->sym_root
,
9772 st
->n
.sym
= sym
->result
;
9773 sym
->result
->refs
++;
9780 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
9781 the symbol existed before. */
9782 sym
->declared_at
= gfc_current_locus
;
9784 if (!sym
->attr
.module_procedure
)
9787 /* Signal match_end to expect "end procedure". */
9788 sym
->abr_modproc_decl
= 1;
9790 /* Change from IFSRC_IFBODY coming from the interface declaration. */
9791 sym
->attr
.if_source
= IFSRC_DECL
;
9793 gfc_new_block
= sym
;
9795 /* Make a new formal arglist with the symbols in the procedure
9798 for (formal
= sym
->formal
; formal
&& formal
->sym
; formal
= formal
->next
)
9800 if (formal
== sym
->formal
)
9801 head
= tail
= gfc_get_formal_arglist ();
9804 tail
->next
= gfc_get_formal_arglist ();
9808 if (gfc_copy_dummy_sym (&fsym
, formal
->sym
, 0))
9812 gfc_set_sym_referenced (fsym
);
9815 /* The dummy symbols get cleaned up, when the formal_namespace of the
9816 interface declaration is cleared. This allows us to add the
9817 explicit interface as is done for other type of procedure. */
9818 if (!gfc_add_explicit_interface (sym
, IFSRC_DECL
, head
,
9819 &gfc_current_locus
))
9822 if (gfc_match_eos () != MATCH_YES
)
9824 /* Unset st->n.sym. Note: in reject_statement (), the symbol changes are
9825 undone, such that the st->n.sym->formal points to the original symbol;
9826 if now this namespace is finalized, the formal namespace is freed,
9827 but it might be still needed in the parent namespace. */
9828 gfc_symtree
*st
= gfc_find_symtree (gfc_current_ns
->sym_root
, sym
->name
);
9830 gfc_free_symbol (sym
->tlink
);
9833 gfc_syntax_error (ST_MODULE_PROC
);
9840 gfc_free_formal_arglist (head
);
9845 /* Match a module procedure statement. Note that we have to modify
9846 symbols in the parent's namespace because the current one was there
9847 to receive symbols that are in an interface's formal argument list. */
9850 gfc_match_modproc (void)
9852 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9856 gfc_namespace
*module_ns
;
9857 gfc_interface
*old_interface_head
, *interface
;
9859 if ((gfc_state_stack
->state
!= COMP_INTERFACE
9860 && gfc_state_stack
->state
!= COMP_CONTAINS
)
9861 || gfc_state_stack
->previous
== NULL
9862 || current_interface
.type
== INTERFACE_NAMELESS
9863 || current_interface
.type
== INTERFACE_ABSTRACT
)
9865 gfc_error ("MODULE PROCEDURE at %C must be in a generic module "
9870 module_ns
= gfc_current_ns
->parent
;
9871 for (; module_ns
; module_ns
= module_ns
->parent
)
9872 if (module_ns
->proc_name
->attr
.flavor
== FL_MODULE
9873 || module_ns
->proc_name
->attr
.flavor
== FL_PROGRAM
9874 || (module_ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
9875 && !module_ns
->proc_name
->attr
.contained
))
9878 if (module_ns
== NULL
)
9881 /* Store the current state of the interface. We will need it if we
9882 end up with a syntax error and need to recover. */
9883 old_interface_head
= gfc_current_interface_head ();
9885 /* Check if the F2008 optional double colon appears. */
9886 gfc_gobble_whitespace ();
9887 old_locus
= gfc_current_locus
;
9888 if (gfc_match ("::") == MATCH_YES
)
9890 if (!gfc_notify_std (GFC_STD_F2008
, "double colon in "
9891 "MODULE PROCEDURE statement at %L", &old_locus
))
9895 gfc_current_locus
= old_locus
;
9900 old_locus
= gfc_current_locus
;
9902 m
= gfc_match_name (name
);
9908 /* Check for syntax error before starting to add symbols to the
9909 current namespace. */
9910 if (gfc_match_eos () == MATCH_YES
)
9913 if (!last
&& gfc_match_char (',') != MATCH_YES
)
9916 /* Now we're sure the syntax is valid, we process this item
9918 if (gfc_get_symbol (name
, module_ns
, &sym
))
9921 if (sym
->attr
.intrinsic
)
9923 gfc_error ("Intrinsic procedure at %L cannot be a MODULE "
9924 "PROCEDURE", &old_locus
);
9928 if (sym
->attr
.proc
!= PROC_MODULE
9929 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
9932 if (!gfc_add_interface (sym
))
9935 sym
->attr
.mod_proc
= 1;
9936 sym
->declared_at
= old_locus
;
9945 /* Restore the previous state of the interface. */
9946 interface
= gfc_current_interface_head ();
9947 gfc_set_current_interface_head (old_interface_head
);
9949 /* Free the new interfaces. */
9950 while (interface
!= old_interface_head
)
9952 gfc_interface
*i
= interface
->next
;
9957 /* And issue a syntax error. */
9958 gfc_syntax_error (ST_MODULE_PROC
);
9963 /* Check a derived type that is being extended. */
9966 check_extended_derived_type (char *name
)
9968 gfc_symbol
*extended
;
9970 if (gfc_find_symbol (name
, gfc_current_ns
, 1, &extended
))
9972 gfc_error ("Ambiguous symbol in TYPE definition at %C");
9976 extended
= gfc_find_dt_in_generic (extended
);
9981 gfc_error ("Symbol %qs at %C has not been previously defined", name
);
9985 if (extended
->attr
.flavor
!= FL_DERIVED
)
9987 gfc_error ("%qs in EXTENDS expression at %C is not a "
9988 "derived type", name
);
9992 if (extended
->attr
.is_bind_c
)
9994 gfc_error ("%qs cannot be extended at %C because it "
9995 "is BIND(C)", extended
->name
);
9999 if (extended
->attr
.sequence
)
10001 gfc_error ("%qs cannot be extended at %C because it "
10002 "is a SEQUENCE type", extended
->name
);
10010 /* Match the optional attribute specifiers for a type declaration.
10011 Return MATCH_ERROR if an error is encountered in one of the handled
10012 attributes (public, private, bind(c)), MATCH_NO if what's found is
10013 not a handled attribute, and MATCH_YES otherwise. TODO: More error
10014 checking on attribute conflicts needs to be done. */
10017 gfc_get_type_attr_spec (symbol_attribute
*attr
, char *name
)
10019 /* See if the derived type is marked as private. */
10020 if (gfc_match (" , private") == MATCH_YES
)
10022 if (gfc_current_state () != COMP_MODULE
)
10024 gfc_error ("Derived type at %C can only be PRIVATE in the "
10025 "specification part of a module");
10026 return MATCH_ERROR
;
10029 if (!gfc_add_access (attr
, ACCESS_PRIVATE
, NULL
, NULL
))
10030 return MATCH_ERROR
;
10032 else if (gfc_match (" , public") == MATCH_YES
)
10034 if (gfc_current_state () != COMP_MODULE
)
10036 gfc_error ("Derived type at %C can only be PUBLIC in the "
10037 "specification part of a module");
10038 return MATCH_ERROR
;
10041 if (!gfc_add_access (attr
, ACCESS_PUBLIC
, NULL
, NULL
))
10042 return MATCH_ERROR
;
10044 else if (gfc_match (" , bind ( c )") == MATCH_YES
)
10046 /* If the type is defined to be bind(c) it then needs to make
10047 sure that all fields are interoperable. This will
10048 need to be a semantic check on the finished derived type.
10049 See 15.2.3 (lines 9-12) of F2003 draft. */
10050 if (!gfc_add_is_bind_c (attr
, NULL
, &gfc_current_locus
, 0))
10051 return MATCH_ERROR
;
10053 /* TODO: attr conflicts need to be checked, probably in symbol.c. */
10055 else if (gfc_match (" , abstract") == MATCH_YES
)
10057 if (!gfc_notify_std (GFC_STD_F2003
, "ABSTRACT type at %C"))
10058 return MATCH_ERROR
;
10060 if (!gfc_add_abstract (attr
, &gfc_current_locus
))
10061 return MATCH_ERROR
;
10063 else if (name
&& gfc_match (" , extends ( %n )", name
) == MATCH_YES
)
10065 if (!gfc_add_extension (attr
, &gfc_current_locus
))
10066 return MATCH_ERROR
;
10071 /* If we get here, something matched. */
10076 /* Common function for type declaration blocks similar to derived types, such
10077 as STRUCTURES and MAPs. Unlike derived types, a structure type
10078 does NOT have a generic symbol matching the name given by the user.
10079 STRUCTUREs can share names with variables and PARAMETERs so we must allow
10080 for the creation of an independent symbol.
10081 Other parameters are a message to prefix errors with, the name of the new
10082 type to be created, and the flavor to add to the resulting symbol. */
10085 get_struct_decl (const char *name
, sym_flavor fl
, locus
*decl
,
10086 gfc_symbol
**result
)
10091 gcc_assert (name
[0] == (char) TOUPPER (name
[0]));
10096 where
= gfc_current_locus
;
10098 if (gfc_get_symbol (name
, NULL
, &sym
))
10103 gfc_internal_error ("Failed to create structure type '%s' at %C", name
);
10107 if (sym
->components
!= NULL
|| sym
->attr
.zero_comp
)
10109 gfc_error ("Type definition of %qs at %C was already defined at %L",
10110 sym
->name
, &sym
->declared_at
);
10114 sym
->declared_at
= where
;
10116 if (sym
->attr
.flavor
!= fl
10117 && !gfc_add_flavor (&sym
->attr
, fl
, sym
->name
, NULL
))
10120 if (!sym
->hash_value
)
10121 /* Set the hash for the compound name for this type. */
10122 sym
->hash_value
= gfc_hash_value (sym
);
10124 /* Normally the type is expected to have been completely parsed by the time
10125 a field declaration with this type is seen. For unions, maps, and nested
10126 structure declarations, we need to indicate that it is okay that we
10127 haven't seen any components yet. This will be updated after the structure
10128 is fully parsed. */
10129 sym
->attr
.zero_comp
= 0;
10131 /* Structures always act like derived-types with the SEQUENCE attribute */
10132 gfc_add_sequence (&sym
->attr
, sym
->name
, NULL
);
10134 if (result
) *result
= sym
;
10140 /* Match the opening of a MAP block. Like a struct within a union in C;
10141 behaves identical to STRUCTURE blocks. */
10144 gfc_match_map (void)
10146 /* Counter used to give unique internal names to map structures. */
10147 static unsigned int gfc_map_id
= 0;
10148 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10152 old_loc
= gfc_current_locus
;
10154 if (gfc_match_eos () != MATCH_YES
)
10156 gfc_error ("Junk after MAP statement at %C");
10157 gfc_current_locus
= old_loc
;
10158 return MATCH_ERROR
;
10161 /* Map blocks are anonymous so we make up unique names for the symbol table
10162 which are invalid Fortran identifiers. */
10163 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "MM$%u", gfc_map_id
++);
10165 if (!get_struct_decl (name
, FL_STRUCT
, &old_loc
, &sym
))
10166 return MATCH_ERROR
;
10168 gfc_new_block
= sym
;
10174 /* Match the opening of a UNION block. */
10177 gfc_match_union (void)
10179 /* Counter used to give unique internal names to union types. */
10180 static unsigned int gfc_union_id
= 0;
10181 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10185 old_loc
= gfc_current_locus
;
10187 if (gfc_match_eos () != MATCH_YES
)
10189 gfc_error ("Junk after UNION statement at %C");
10190 gfc_current_locus
= old_loc
;
10191 return MATCH_ERROR
;
10194 /* Unions are anonymous so we make up unique names for the symbol table
10195 which are invalid Fortran identifiers. */
10196 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "UU$%u", gfc_union_id
++);
10198 if (!get_struct_decl (name
, FL_UNION
, &old_loc
, &sym
))
10199 return MATCH_ERROR
;
10201 gfc_new_block
= sym
;
10207 /* Match the beginning of a STRUCTURE declaration. This is similar to
10208 matching the beginning of a derived type declaration with a few
10209 twists. The resulting type symbol has no access control or other
10210 interesting attributes. */
10213 gfc_match_structure_decl (void)
10215 /* Counter used to give unique internal names to anonymous structures. */
10216 static unsigned int gfc_structure_id
= 0;
10217 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10222 if (!flag_dec_structure
)
10224 gfc_error ("%s at %C is a DEC extension, enable with "
10225 "%<-fdec-structure%>",
10227 return MATCH_ERROR
;
10232 m
= gfc_match (" /%n/", name
);
10233 if (m
!= MATCH_YES
)
10235 /* Non-nested structure declarations require a structure name. */
10236 if (!gfc_comp_struct (gfc_current_state ()))
10238 gfc_error ("Structure name expected in non-nested structure "
10239 "declaration at %C");
10240 return MATCH_ERROR
;
10242 /* This is an anonymous structure; make up a unique name for it
10243 (upper-case letters never make it to symbol names from the source).
10244 The important thing is initializing the type variable
10245 and setting gfc_new_symbol, which is immediately used by
10246 parse_structure () and variable_decl () to add components of
10248 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "SS$%u", gfc_structure_id
++);
10251 where
= gfc_current_locus
;
10252 /* No field list allowed after non-nested structure declaration. */
10253 if (!gfc_comp_struct (gfc_current_state ())
10254 && gfc_match_eos () != MATCH_YES
)
10256 gfc_error ("Junk after non-nested STRUCTURE statement at %C");
10257 return MATCH_ERROR
;
10260 /* Make sure the name is not the name of an intrinsic type. */
10261 if (gfc_is_intrinsic_typename (name
))
10263 gfc_error ("Structure name %qs at %C cannot be the same as an"
10264 " intrinsic type", name
);
10265 return MATCH_ERROR
;
10268 /* Store the actual type symbol for the structure with an upper-case first
10269 letter (an invalid Fortran identifier). */
10271 if (!get_struct_decl (gfc_dt_upper_string (name
), FL_STRUCT
, &where
, &sym
))
10272 return MATCH_ERROR
;
10274 gfc_new_block
= sym
;
10279 /* This function does some work to determine which matcher should be used to
10280 * match a statement beginning with "TYPE". This is used to disambiguate TYPE
10281 * as an alias for PRINT from derived type declarations, TYPE IS statements,
10282 * and [parameterized] derived type declarations. */
10285 gfc_match_type (gfc_statement
*st
)
10287 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10291 /* Requires -fdec. */
10295 m
= gfc_match ("type");
10296 if (m
!= MATCH_YES
)
10298 /* If we already have an error in the buffer, it is probably from failing to
10299 * match a derived type data declaration. Let it happen. */
10300 else if (gfc_error_flag_test ())
10303 old_loc
= gfc_current_locus
;
10306 /* If we see an attribute list before anything else it's definitely a derived
10307 * type declaration. */
10308 if (gfc_match (" ,") == MATCH_YES
|| gfc_match (" ::") == MATCH_YES
)
10311 /* By now "TYPE" has already been matched. If we do not see a name, this may
10312 * be something like "TYPE *" or "TYPE <fmt>". */
10313 m
= gfc_match_name (name
);
10314 if (m
!= MATCH_YES
)
10316 /* Let print match if it can, otherwise throw an error from
10317 * gfc_match_derived_decl. */
10318 gfc_current_locus
= old_loc
;
10319 if (gfc_match_print () == MATCH_YES
)
10327 /* Check for EOS. */
10328 if (gfc_match_eos () == MATCH_YES
)
10330 /* By now we have "TYPE <name> <EOS>". Check first if the name is an
10331 * intrinsic typename - if so let gfc_match_derived_decl dump an error.
10332 * Otherwise if gfc_match_derived_decl fails it's probably an existing
10333 * symbol which can be printed. */
10334 gfc_current_locus
= old_loc
;
10335 m
= gfc_match_derived_decl ();
10336 if (gfc_is_intrinsic_typename (name
) || m
== MATCH_YES
)
10338 *st
= ST_DERIVED_DECL
;
10344 /* Here we have "TYPE <name>". Check for <TYPE IS (> or a PDT declaration
10345 like <type name(parameter)>. */
10346 gfc_gobble_whitespace ();
10347 bool paren
= gfc_peek_ascii_char () == '(';
10350 if (strcmp ("is", name
) == 0)
10357 /* Treat TYPE... like PRINT... */
10358 gfc_current_locus
= old_loc
;
10360 return gfc_match_print ();
10363 gfc_current_locus
= old_loc
;
10364 *st
= ST_DERIVED_DECL
;
10365 return gfc_match_derived_decl ();
10368 gfc_current_locus
= old_loc
;
10370 return gfc_match_type_is ();
10374 /* Match the beginning of a derived type declaration. If a type name
10375 was the result of a function, then it is possible to have a symbol
10376 already to be known as a derived type yet have no components. */
10379 gfc_match_derived_decl (void)
10381 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10382 char parent
[GFC_MAX_SYMBOL_LEN
+ 1];
10383 symbol_attribute attr
;
10384 gfc_symbol
*sym
, *gensym
;
10385 gfc_symbol
*extended
;
10387 match is_type_attr_spec
= MATCH_NO
;
10388 bool seen_attr
= false;
10389 gfc_interface
*intr
= NULL
, *head
;
10390 bool parameterized_type
= false;
10391 bool seen_colons
= false;
10393 if (gfc_comp_struct (gfc_current_state ()))
10398 gfc_clear_attr (&attr
);
10403 is_type_attr_spec
= gfc_get_type_attr_spec (&attr
, parent
);
10404 if (is_type_attr_spec
== MATCH_ERROR
)
10405 return MATCH_ERROR
;
10406 if (is_type_attr_spec
== MATCH_YES
)
10408 } while (is_type_attr_spec
== MATCH_YES
);
10410 /* Deal with derived type extensions. The extension attribute has
10411 been added to 'attr' but now the parent type must be found and
10414 extended
= check_extended_derived_type (parent
);
10416 if (parent
[0] && !extended
)
10417 return MATCH_ERROR
;
10419 m
= gfc_match (" ::");
10420 if (m
== MATCH_YES
)
10422 seen_colons
= true;
10424 else if (seen_attr
)
10426 gfc_error ("Expected :: in TYPE definition at %C");
10427 return MATCH_ERROR
;
10430 /* In free source form, need to check for TYPE XXX as oppose to TYPEXXX.
10431 But, we need to simply return for TYPE(. */
10432 if (m
== MATCH_NO
&& gfc_current_form
== FORM_FREE
)
10434 char c
= gfc_peek_ascii_char ();
10437 if (!gfc_is_whitespace (c
))
10439 gfc_error ("Mangled derived type definition at %C");
10444 m
= gfc_match (" %n ", name
);
10445 if (m
!= MATCH_YES
)
10448 /* Make sure that we don't identify TYPE IS (...) as a parameterized
10449 derived type named 'is'.
10450 TODO Expand the check, when 'name' = "is" by matching " (tname) "
10451 and checking if this is a(n intrinsic) typename. This picks up
10452 misplaced TYPE IS statements such as in select_type_1.f03. */
10453 if (gfc_peek_ascii_char () == '(')
10455 if (gfc_current_state () == COMP_SELECT_TYPE
10456 || (!seen_colons
&& !strcmp (name
, "is")))
10458 parameterized_type
= true;
10461 m
= gfc_match_eos ();
10462 if (m
!= MATCH_YES
&& !parameterized_type
)
10465 /* Make sure the name is not the name of an intrinsic type. */
10466 if (gfc_is_intrinsic_typename (name
))
10468 gfc_error ("Type name %qs at %C cannot be the same as an intrinsic "
10470 return MATCH_ERROR
;
10473 if (gfc_get_symbol (name
, NULL
, &gensym
))
10474 return MATCH_ERROR
;
10476 if (!gensym
->attr
.generic
&& gensym
->ts
.type
!= BT_UNKNOWN
)
10478 if (gensym
->ts
.u
.derived
)
10479 gfc_error ("Derived type name %qs at %C already has a basic type "
10480 "of %s", gensym
->name
, gfc_typename (&gensym
->ts
));
10482 gfc_error ("Derived type name %qs at %C already has a basic type",
10484 return MATCH_ERROR
;
10487 if (!gensym
->attr
.generic
10488 && !gfc_add_generic (&gensym
->attr
, gensym
->name
, NULL
))
10489 return MATCH_ERROR
;
10491 if (!gensym
->attr
.function
10492 && !gfc_add_function (&gensym
->attr
, gensym
->name
, NULL
))
10493 return MATCH_ERROR
;
10495 if (gensym
->attr
.dummy
)
10497 gfc_error ("Dummy argument %qs at %L cannot be a derived type at %C",
10498 name
, &gensym
->declared_at
);
10499 return MATCH_ERROR
;
10502 sym
= gfc_find_dt_in_generic (gensym
);
10504 if (sym
&& (sym
->components
!= NULL
|| sym
->attr
.zero_comp
))
10506 gfc_error ("Derived type definition of %qs at %C has already been "
10507 "defined", sym
->name
);
10508 return MATCH_ERROR
;
10513 /* Use upper case to save the actual derived-type symbol. */
10514 gfc_get_symbol (gfc_dt_upper_string (gensym
->name
), NULL
, &sym
);
10515 sym
->name
= gfc_get_string ("%s", gensym
->name
);
10516 head
= gensym
->generic
;
10517 intr
= gfc_get_interface ();
10519 intr
->where
= gfc_current_locus
;
10520 intr
->sym
->declared_at
= gfc_current_locus
;
10522 gensym
->generic
= intr
;
10523 gensym
->attr
.if_source
= IFSRC_DECL
;
10526 /* The symbol may already have the derived attribute without the
10527 components. The ways this can happen is via a function
10528 definition, an INTRINSIC statement or a subtype in another
10529 derived type that is a pointer. The first part of the AND clause
10530 is true if the symbol is not the return value of a function. */
10531 if (sym
->attr
.flavor
!= FL_DERIVED
10532 && !gfc_add_flavor (&sym
->attr
, FL_DERIVED
, sym
->name
, NULL
))
10533 return MATCH_ERROR
;
10535 if (attr
.access
!= ACCESS_UNKNOWN
10536 && !gfc_add_access (&sym
->attr
, attr
.access
, sym
->name
, NULL
))
10537 return MATCH_ERROR
;
10538 else if (sym
->attr
.access
== ACCESS_UNKNOWN
10539 && gensym
->attr
.access
!= ACCESS_UNKNOWN
10540 && !gfc_add_access (&sym
->attr
, gensym
->attr
.access
,
10542 return MATCH_ERROR
;
10544 if (sym
->attr
.access
!= ACCESS_UNKNOWN
10545 && gensym
->attr
.access
== ACCESS_UNKNOWN
)
10546 gensym
->attr
.access
= sym
->attr
.access
;
10548 /* See if the derived type was labeled as bind(c). */
10549 if (attr
.is_bind_c
!= 0)
10550 sym
->attr
.is_bind_c
= attr
.is_bind_c
;
10552 /* Construct the f2k_derived namespace if it is not yet there. */
10553 if (!sym
->f2k_derived
)
10554 sym
->f2k_derived
= gfc_get_namespace (NULL
, 0);
10556 if (parameterized_type
)
10558 /* Ignore error or mismatches by going to the end of the statement
10559 in order to avoid the component declarations causing problems. */
10560 m
= gfc_match_formal_arglist (sym
, 0, 0, true);
10561 if (m
!= MATCH_YES
)
10562 gfc_error_recovery ();
10564 sym
->attr
.pdt_template
= 1;
10565 m
= gfc_match_eos ();
10566 if (m
!= MATCH_YES
)
10568 gfc_error_recovery ();
10569 gfc_error_now ("Garbage after PARAMETERIZED TYPE declaration at %C");
10573 if (extended
&& !sym
->components
)
10576 gfc_formal_arglist
*f
, *g
, *h
;
10578 /* Add the extended derived type as the first component. */
10579 gfc_add_component (sym
, parent
, &p
);
10581 gfc_set_sym_referenced (extended
);
10583 p
->ts
.type
= BT_DERIVED
;
10584 p
->ts
.u
.derived
= extended
;
10585 p
->initializer
= gfc_default_initializer (&p
->ts
);
10587 /* Set extension level. */
10588 if (extended
->attr
.extension
== 255)
10590 /* Since the extension field is 8 bit wide, we can only have
10591 up to 255 extension levels. */
10592 gfc_error ("Maximum extension level reached with type %qs at %L",
10593 extended
->name
, &extended
->declared_at
);
10594 return MATCH_ERROR
;
10596 sym
->attr
.extension
= extended
->attr
.extension
+ 1;
10598 /* Provide the links between the extended type and its extension. */
10599 if (!extended
->f2k_derived
)
10600 extended
->f2k_derived
= gfc_get_namespace (NULL
, 0);
10602 /* Copy the extended type-param-name-list from the extended type,
10603 append those of the extension and add the whole lot to the
10605 if (extended
->attr
.pdt_template
)
10608 sym
->attr
.pdt_template
= 1;
10609 for (f
= extended
->formal
; f
; f
= f
->next
)
10611 if (f
== extended
->formal
)
10613 g
= gfc_get_formal_arglist ();
10618 g
->next
= gfc_get_formal_arglist ();
10623 g
->next
= sym
->formal
;
10628 if (!sym
->hash_value
)
10629 /* Set the hash for the compound name for this type. */
10630 sym
->hash_value
= gfc_hash_value (sym
);
10632 /* Take over the ABSTRACT attribute. */
10633 sym
->attr
.abstract
= attr
.abstract
;
10635 gfc_new_block
= sym
;
10641 /* Cray Pointees can be declared as:
10642 pointer (ipt, a (n,m,...,*)) */
10645 gfc_mod_pointee_as (gfc_array_spec
*as
)
10647 as
->cray_pointee
= true; /* This will be useful to know later. */
10648 if (as
->type
== AS_ASSUMED_SIZE
)
10649 as
->cp_was_assumed
= true;
10650 else if (as
->type
== AS_ASSUMED_SHAPE
)
10652 gfc_error ("Cray Pointee at %C cannot be assumed shape array");
10653 return MATCH_ERROR
;
10659 /* Match the enum definition statement, here we are trying to match
10660 the first line of enum definition statement.
10661 Returns MATCH_YES if match is found. */
10664 gfc_match_enum (void)
10668 m
= gfc_match_eos ();
10669 if (m
!= MATCH_YES
)
10672 if (!gfc_notify_std (GFC_STD_F2003
, "ENUM and ENUMERATOR at %C"))
10673 return MATCH_ERROR
;
10679 /* Returns an initializer whose value is one higher than the value of the
10680 LAST_INITIALIZER argument. If the argument is NULL, the
10681 initializers value will be set to zero. The initializer's kind
10682 will be set to gfc_c_int_kind.
10684 If -fshort-enums is given, the appropriate kind will be selected
10685 later after all enumerators have been parsed. A warning is issued
10686 here if an initializer exceeds gfc_c_int_kind. */
10689 enum_initializer (gfc_expr
*last_initializer
, locus where
)
10692 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_c_int_kind
, &where
);
10694 mpz_init (result
->value
.integer
);
10696 if (last_initializer
!= NULL
)
10698 mpz_add_ui (result
->value
.integer
, last_initializer
->value
.integer
, 1);
10699 result
->where
= last_initializer
->where
;
10701 if (gfc_check_integer_range (result
->value
.integer
,
10702 gfc_c_int_kind
) != ARITH_OK
)
10704 gfc_error ("Enumerator exceeds the C integer type at %C");
10710 /* Control comes here, if it's the very first enumerator and no
10711 initializer has been given. It will be initialized to zero. */
10712 mpz_set_si (result
->value
.integer
, 0);
10719 /* Match a variable name with an optional initializer. When this
10720 subroutine is called, a variable is expected to be parsed next.
10721 Depending on what is happening at the moment, updates either the
10722 symbol table or the current interface. */
10725 enumerator_decl (void)
10727 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10728 gfc_expr
*initializer
;
10729 gfc_array_spec
*as
= NULL
;
10736 initializer
= NULL
;
10737 old_locus
= gfc_current_locus
;
10739 /* When we get here, we've just matched a list of attributes and
10740 maybe a type and a double colon. The next thing we expect to see
10741 is the name of the symbol. */
10742 m
= gfc_match_name (name
);
10743 if (m
!= MATCH_YES
)
10746 var_locus
= gfc_current_locus
;
10748 /* OK, we've successfully matched the declaration. Now put the
10749 symbol in the current namespace. If we fail to create the symbol,
10751 if (!build_sym (name
, NULL
, false, &as
, &var_locus
))
10757 /* The double colon must be present in order to have initializers.
10758 Otherwise the statement is ambiguous with an assignment statement. */
10761 if (gfc_match_char ('=') == MATCH_YES
)
10763 m
= gfc_match_init_expr (&initializer
);
10766 gfc_error ("Expected an initialization expression at %C");
10770 if (m
!= MATCH_YES
)
10775 /* If we do not have an initializer, the initialization value of the
10776 previous enumerator (stored in last_initializer) is incremented
10777 by 1 and is used to initialize the current enumerator. */
10778 if (initializer
== NULL
)
10779 initializer
= enum_initializer (last_initializer
, old_locus
);
10781 if (initializer
== NULL
|| initializer
->ts
.type
!= BT_INTEGER
)
10783 gfc_error ("ENUMERATOR %L not initialized with integer expression",
10789 /* Store this current initializer, for the next enumerator variable
10790 to be parsed. add_init_expr_to_sym() zeros initializer, so we
10791 use last_initializer below. */
10792 last_initializer
= initializer
;
10793 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
10795 /* Maintain enumerator history. */
10796 gfc_find_symbol (name
, NULL
, 0, &sym
);
10797 create_enum_history (sym
, last_initializer
);
10799 return (t
) ? MATCH_YES
: MATCH_ERROR
;
10802 /* Free stuff up and return. */
10803 gfc_free_expr (initializer
);
10809 /* Match the enumerator definition statement. */
10812 gfc_match_enumerator_def (void)
10817 gfc_clear_ts (¤t_ts
);
10819 m
= gfc_match (" enumerator");
10820 if (m
!= MATCH_YES
)
10823 m
= gfc_match (" :: ");
10824 if (m
== MATCH_ERROR
)
10827 colon_seen
= (m
== MATCH_YES
);
10829 if (gfc_current_state () != COMP_ENUM
)
10831 gfc_error ("ENUM definition statement expected before %C");
10832 gfc_free_enum_history ();
10833 return MATCH_ERROR
;
10836 (¤t_ts
)->type
= BT_INTEGER
;
10837 (¤t_ts
)->kind
= gfc_c_int_kind
;
10839 gfc_clear_attr (¤t_attr
);
10840 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, NULL
);
10849 m
= enumerator_decl ();
10850 if (m
== MATCH_ERROR
)
10852 gfc_free_enum_history ();
10858 if (gfc_match_eos () == MATCH_YES
)
10860 if (gfc_match_char (',') != MATCH_YES
)
10864 if (gfc_current_state () == COMP_ENUM
)
10866 gfc_free_enum_history ();
10867 gfc_error ("Syntax error in ENUMERATOR definition at %C");
10872 gfc_free_array_spec (current_as
);
10879 /* Match binding attributes. */
10882 match_binding_attributes (gfc_typebound_proc
* ba
, bool generic
, bool ppc
)
10884 bool found_passing
= false;
10885 bool seen_ptr
= false;
10886 match m
= MATCH_YES
;
10888 /* Initialize to defaults. Do so even before the MATCH_NO check so that in
10889 this case the defaults are in there. */
10890 ba
->access
= ACCESS_UNKNOWN
;
10891 ba
->pass_arg
= NULL
;
10892 ba
->pass_arg_num
= 0;
10894 ba
->non_overridable
= 0;
10898 /* If we find a comma, we believe there are binding attributes. */
10899 m
= gfc_match_char (',');
10905 /* Access specifier. */
10907 m
= gfc_match (" public");
10908 if (m
== MATCH_ERROR
)
10910 if (m
== MATCH_YES
)
10912 if (ba
->access
!= ACCESS_UNKNOWN
)
10914 gfc_error ("Duplicate access-specifier at %C");
10918 ba
->access
= ACCESS_PUBLIC
;
10922 m
= gfc_match (" private");
10923 if (m
== MATCH_ERROR
)
10925 if (m
== MATCH_YES
)
10927 if (ba
->access
!= ACCESS_UNKNOWN
)
10929 gfc_error ("Duplicate access-specifier at %C");
10933 ba
->access
= ACCESS_PRIVATE
;
10937 /* If inside GENERIC, the following is not allowed. */
10942 m
= gfc_match (" nopass");
10943 if (m
== MATCH_ERROR
)
10945 if (m
== MATCH_YES
)
10949 gfc_error ("Binding attributes already specify passing,"
10950 " illegal NOPASS at %C");
10954 found_passing
= true;
10959 /* PASS possibly including argument. */
10960 m
= gfc_match (" pass");
10961 if (m
== MATCH_ERROR
)
10963 if (m
== MATCH_YES
)
10965 char arg
[GFC_MAX_SYMBOL_LEN
+ 1];
10969 gfc_error ("Binding attributes already specify passing,"
10970 " illegal PASS at %C");
10974 m
= gfc_match (" ( %n )", arg
);
10975 if (m
== MATCH_ERROR
)
10977 if (m
== MATCH_YES
)
10978 ba
->pass_arg
= gfc_get_string ("%s", arg
);
10979 gcc_assert ((m
== MATCH_YES
) == (ba
->pass_arg
!= NULL
));
10981 found_passing
= true;
10988 /* POINTER flag. */
10989 m
= gfc_match (" pointer");
10990 if (m
== MATCH_ERROR
)
10992 if (m
== MATCH_YES
)
10996 gfc_error ("Duplicate POINTER attribute at %C");
11006 /* NON_OVERRIDABLE flag. */
11007 m
= gfc_match (" non_overridable");
11008 if (m
== MATCH_ERROR
)
11010 if (m
== MATCH_YES
)
11012 if (ba
->non_overridable
)
11014 gfc_error ("Duplicate NON_OVERRIDABLE at %C");
11018 ba
->non_overridable
= 1;
11022 /* DEFERRED flag. */
11023 m
= gfc_match (" deferred");
11024 if (m
== MATCH_ERROR
)
11026 if (m
== MATCH_YES
)
11030 gfc_error ("Duplicate DEFERRED at %C");
11041 /* Nothing matching found. */
11043 gfc_error ("Expected access-specifier at %C");
11045 gfc_error ("Expected binding attribute at %C");
11048 while (gfc_match_char (',') == MATCH_YES
);
11050 /* NON_OVERRIDABLE and DEFERRED exclude themselves. */
11051 if (ba
->non_overridable
&& ba
->deferred
)
11053 gfc_error ("NON_OVERRIDABLE and DEFERRED cannot both appear at %C");
11060 if (ba
->access
== ACCESS_UNKNOWN
)
11061 ba
->access
= ppc
? gfc_current_block()->component_access
11062 : gfc_typebound_default_access
;
11064 if (ppc
&& !seen_ptr
)
11066 gfc_error ("POINTER attribute is required for procedure pointer component"
11074 return MATCH_ERROR
;
11078 /* Match a PROCEDURE specific binding inside a derived type. */
11081 match_procedure_in_type (void)
11083 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
11084 char target_buf
[GFC_MAX_SYMBOL_LEN
+ 1];
11085 char* target
= NULL
, *ifc
= NULL
;
11086 gfc_typebound_proc tb
;
11090 gfc_symtree
* stree
;
11095 /* Check current state. */
11096 gcc_assert (gfc_state_stack
->state
== COMP_DERIVED_CONTAINS
);
11097 block
= gfc_state_stack
->previous
->sym
;
11098 gcc_assert (block
);
11100 /* Try to match PROCEDURE(interface). */
11101 if (gfc_match (" (") == MATCH_YES
)
11103 m
= gfc_match_name (target_buf
);
11104 if (m
== MATCH_ERROR
)
11106 if (m
!= MATCH_YES
)
11108 gfc_error ("Interface-name expected after %<(%> at %C");
11109 return MATCH_ERROR
;
11112 if (gfc_match (" )") != MATCH_YES
)
11114 gfc_error ("%<)%> expected at %C");
11115 return MATCH_ERROR
;
11121 /* Construct the data structure. */
11122 memset (&tb
, 0, sizeof (tb
));
11123 tb
.where
= gfc_current_locus
;
11125 /* Match binding attributes. */
11126 m
= match_binding_attributes (&tb
, false, false);
11127 if (m
== MATCH_ERROR
)
11129 seen_attrs
= (m
== MATCH_YES
);
11131 /* Check that attribute DEFERRED is given if an interface is specified. */
11132 if (tb
.deferred
&& !ifc
)
11134 gfc_error ("Interface must be specified for DEFERRED binding at %C");
11135 return MATCH_ERROR
;
11137 if (ifc
&& !tb
.deferred
)
11139 gfc_error ("PROCEDURE(interface) at %C should be declared DEFERRED");
11140 return MATCH_ERROR
;
11143 /* Match the colons. */
11144 m
= gfc_match (" ::");
11145 if (m
== MATCH_ERROR
)
11147 seen_colons
= (m
== MATCH_YES
);
11148 if (seen_attrs
&& !seen_colons
)
11150 gfc_error ("Expected %<::%> after binding-attributes at %C");
11151 return MATCH_ERROR
;
11154 /* Match the binding names. */
11157 m
= gfc_match_name (name
);
11158 if (m
== MATCH_ERROR
)
11162 gfc_error ("Expected binding name at %C");
11163 return MATCH_ERROR
;
11166 if (num
>1 && !gfc_notify_std (GFC_STD_F2008
, "PROCEDURE list at %C"))
11167 return MATCH_ERROR
;
11169 /* Try to match the '=> target', if it's there. */
11171 m
= gfc_match (" =>");
11172 if (m
== MATCH_ERROR
)
11174 if (m
== MATCH_YES
)
11178 gfc_error ("%<=> target%> is invalid for DEFERRED binding at %C");
11179 return MATCH_ERROR
;
11184 gfc_error ("%<::%> needed in PROCEDURE binding with explicit target"
11186 return MATCH_ERROR
;
11189 m
= gfc_match_name (target_buf
);
11190 if (m
== MATCH_ERROR
)
11194 gfc_error ("Expected binding target after %<=>%> at %C");
11195 return MATCH_ERROR
;
11197 target
= target_buf
;
11200 /* If no target was found, it has the same name as the binding. */
11204 /* Get the namespace to insert the symbols into. */
11205 ns
= block
->f2k_derived
;
11208 /* If the binding is DEFERRED, check that the containing type is ABSTRACT. */
11209 if (tb
.deferred
&& !block
->attr
.abstract
)
11211 gfc_error ("Type %qs containing DEFERRED binding at %C "
11212 "is not ABSTRACT", block
->name
);
11213 return MATCH_ERROR
;
11216 /* See if we already have a binding with this name in the symtree which
11217 would be an error. If a GENERIC already targeted this binding, it may
11218 be already there but then typebound is still NULL. */
11219 stree
= gfc_find_symtree (ns
->tb_sym_root
, name
);
11220 if (stree
&& stree
->n
.tb
)
11222 gfc_error ("There is already a procedure with binding name %qs for "
11223 "the derived type %qs at %C", name
, block
->name
);
11224 return MATCH_ERROR
;
11227 /* Insert it and set attributes. */
11231 stree
= gfc_new_symtree (&ns
->tb_sym_root
, name
);
11232 gcc_assert (stree
);
11234 stree
->n
.tb
= gfc_get_typebound_proc (&tb
);
11236 if (gfc_get_sym_tree (target
, gfc_current_ns
, &stree
->n
.tb
->u
.specific
,
11238 return MATCH_ERROR
;
11239 gfc_set_sym_referenced (stree
->n
.tb
->u
.specific
->n
.sym
);
11240 gfc_add_flavor(&stree
->n
.tb
->u
.specific
->n
.sym
->attr
, FL_PROCEDURE
,
11241 target
, &stree
->n
.tb
->u
.specific
->n
.sym
->declared_at
);
11243 if (gfc_match_eos () == MATCH_YES
)
11245 if (gfc_match_char (',') != MATCH_YES
)
11250 gfc_error ("Syntax error in PROCEDURE statement at %C");
11251 return MATCH_ERROR
;
11255 /* Match a GENERIC procedure binding inside a derived type. */
11258 gfc_match_generic (void)
11260 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
11261 char bind_name
[GFC_MAX_SYMBOL_LEN
+ 16]; /* Allow space for OPERATOR(...). */
11263 gfc_typebound_proc tbattr
; /* Used for match_binding_attributes. */
11264 gfc_typebound_proc
* tb
;
11266 interface_type op_type
;
11267 gfc_intrinsic_op op
;
11270 /* Check current state. */
11271 if (gfc_current_state () == COMP_DERIVED
)
11273 gfc_error ("GENERIC at %C must be inside a derived-type CONTAINS");
11274 return MATCH_ERROR
;
11276 if (gfc_current_state () != COMP_DERIVED_CONTAINS
)
11278 block
= gfc_state_stack
->previous
->sym
;
11279 ns
= block
->f2k_derived
;
11280 gcc_assert (block
&& ns
);
11282 memset (&tbattr
, 0, sizeof (tbattr
));
11283 tbattr
.where
= gfc_current_locus
;
11285 /* See if we get an access-specifier. */
11286 m
= match_binding_attributes (&tbattr
, true, false);
11287 if (m
== MATCH_ERROR
)
11290 /* Now the colons, those are required. */
11291 if (gfc_match (" ::") != MATCH_YES
)
11293 gfc_error ("Expected %<::%> at %C");
11297 /* Match the binding name; depending on type (operator / generic) format
11298 it for future error messages into bind_name. */
11300 m
= gfc_match_generic_spec (&op_type
, name
, &op
);
11301 if (m
== MATCH_ERROR
)
11302 return MATCH_ERROR
;
11305 gfc_error ("Expected generic name or operator descriptor at %C");
11311 case INTERFACE_GENERIC
:
11312 case INTERFACE_DTIO
:
11313 snprintf (bind_name
, sizeof (bind_name
), "%s", name
);
11316 case INTERFACE_USER_OP
:
11317 snprintf (bind_name
, sizeof (bind_name
), "OPERATOR(.%s.)", name
);
11320 case INTERFACE_INTRINSIC_OP
:
11321 snprintf (bind_name
, sizeof (bind_name
), "OPERATOR(%s)",
11322 gfc_op2string (op
));
11325 case INTERFACE_NAMELESS
:
11326 gfc_error ("Malformed GENERIC statement at %C");
11331 gcc_unreachable ();
11334 /* Match the required =>. */
11335 if (gfc_match (" =>") != MATCH_YES
)
11337 gfc_error ("Expected %<=>%> at %C");
11341 /* Try to find existing GENERIC binding with this name / for this operator;
11342 if there is something, check that it is another GENERIC and then extend
11343 it rather than building a new node. Otherwise, create it and put it
11344 at the right position. */
11348 case INTERFACE_DTIO
:
11349 case INTERFACE_USER_OP
:
11350 case INTERFACE_GENERIC
:
11352 const bool is_op
= (op_type
== INTERFACE_USER_OP
);
11355 st
= gfc_find_symtree (is_op
? ns
->tb_uop_root
: ns
->tb_sym_root
, name
);
11356 tb
= st
? st
->n
.tb
: NULL
;
11360 case INTERFACE_INTRINSIC_OP
:
11361 tb
= ns
->tb_op
[op
];
11365 gcc_unreachable ();
11370 if (!tb
->is_generic
)
11372 gcc_assert (op_type
== INTERFACE_GENERIC
);
11373 gfc_error ("There's already a non-generic procedure with binding name"
11374 " %qs for the derived type %qs at %C",
11375 bind_name
, block
->name
);
11379 if (tb
->access
!= tbattr
.access
)
11381 gfc_error ("Binding at %C must have the same access as already"
11382 " defined binding %qs", bind_name
);
11388 tb
= gfc_get_typebound_proc (NULL
);
11389 tb
->where
= gfc_current_locus
;
11390 tb
->access
= tbattr
.access
;
11391 tb
->is_generic
= 1;
11392 tb
->u
.generic
= NULL
;
11396 case INTERFACE_DTIO
:
11397 case INTERFACE_GENERIC
:
11398 case INTERFACE_USER_OP
:
11400 const bool is_op
= (op_type
== INTERFACE_USER_OP
);
11401 gfc_symtree
* st
= gfc_get_tbp_symtree (is_op
? &ns
->tb_uop_root
:
11402 &ns
->tb_sym_root
, name
);
11409 case INTERFACE_INTRINSIC_OP
:
11410 ns
->tb_op
[op
] = tb
;
11414 gcc_unreachable ();
11418 /* Now, match all following names as specific targets. */
11421 gfc_symtree
* target_st
;
11422 gfc_tbp_generic
* target
;
11424 m
= gfc_match_name (name
);
11425 if (m
== MATCH_ERROR
)
11429 gfc_error ("Expected specific binding name at %C");
11433 target_st
= gfc_get_tbp_symtree (&ns
->tb_sym_root
, name
);
11435 /* See if this is a duplicate specification. */
11436 for (target
= tb
->u
.generic
; target
; target
= target
->next
)
11437 if (target_st
== target
->specific_st
)
11439 gfc_error ("%qs already defined as specific binding for the"
11440 " generic %qs at %C", name
, bind_name
);
11444 target
= gfc_get_tbp_generic ();
11445 target
->specific_st
= target_st
;
11446 target
->specific
= NULL
;
11447 target
->next
= tb
->u
.generic
;
11448 target
->is_operator
= ((op_type
== INTERFACE_USER_OP
)
11449 || (op_type
== INTERFACE_INTRINSIC_OP
));
11450 tb
->u
.generic
= target
;
11452 while (gfc_match (" ,") == MATCH_YES
);
11454 /* Here should be the end. */
11455 if (gfc_match_eos () != MATCH_YES
)
11457 gfc_error ("Junk after GENERIC binding at %C");
11464 return MATCH_ERROR
;
11468 /* Match a FINAL declaration inside a derived type. */
11471 gfc_match_final_decl (void)
11473 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
11476 gfc_namespace
* module_ns
;
11480 if (gfc_current_form
== FORM_FREE
)
11482 char c
= gfc_peek_ascii_char ();
11483 if (!gfc_is_whitespace (c
) && c
!= ':')
11487 if (gfc_state_stack
->state
!= COMP_DERIVED_CONTAINS
)
11489 if (gfc_current_form
== FORM_FIXED
)
11492 gfc_error ("FINAL declaration at %C must be inside a derived type "
11493 "CONTAINS section");
11494 return MATCH_ERROR
;
11497 block
= gfc_state_stack
->previous
->sym
;
11498 gcc_assert (block
);
11500 if (!gfc_state_stack
->previous
|| !gfc_state_stack
->previous
->previous
11501 || gfc_state_stack
->previous
->previous
->state
!= COMP_MODULE
)
11503 gfc_error ("Derived type declaration with FINAL at %C must be in the"
11504 " specification part of a MODULE");
11505 return MATCH_ERROR
;
11508 module_ns
= gfc_current_ns
;
11509 gcc_assert (module_ns
);
11510 gcc_assert (module_ns
->proc_name
->attr
.flavor
== FL_MODULE
);
11512 /* Match optional ::, don't care about MATCH_YES or MATCH_NO. */
11513 if (gfc_match (" ::") == MATCH_ERROR
)
11514 return MATCH_ERROR
;
11516 /* Match the sequence of procedure names. */
11523 if (first
&& gfc_match_eos () == MATCH_YES
)
11525 gfc_error ("Empty FINAL at %C");
11526 return MATCH_ERROR
;
11529 m
= gfc_match_name (name
);
11532 gfc_error ("Expected module procedure name at %C");
11533 return MATCH_ERROR
;
11535 else if (m
!= MATCH_YES
)
11536 return MATCH_ERROR
;
11538 if (gfc_match_eos () == MATCH_YES
)
11540 if (!last
&& gfc_match_char (',') != MATCH_YES
)
11542 gfc_error ("Expected %<,%> at %C");
11543 return MATCH_ERROR
;
11546 if (gfc_get_symbol (name
, module_ns
, &sym
))
11548 gfc_error ("Unknown procedure name %qs at %C", name
);
11549 return MATCH_ERROR
;
11552 /* Mark the symbol as module procedure. */
11553 if (sym
->attr
.proc
!= PROC_MODULE
11554 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
11555 return MATCH_ERROR
;
11557 /* Check if we already have this symbol in the list, this is an error. */
11558 for (f
= block
->f2k_derived
->finalizers
; f
; f
= f
->next
)
11559 if (f
->proc_sym
== sym
)
11561 gfc_error ("%qs at %C is already defined as FINAL procedure",
11563 return MATCH_ERROR
;
11566 /* Add this symbol to the list of finalizers. */
11567 gcc_assert (block
->f2k_derived
);
11569 f
= XCNEW (gfc_finalizer
);
11571 f
->proc_tree
= NULL
;
11572 f
->where
= gfc_current_locus
;
11573 f
->next
= block
->f2k_derived
->finalizers
;
11574 block
->f2k_derived
->finalizers
= f
;
11584 const ext_attr_t ext_attr_list
[] = {
11585 { "dllimport", EXT_ATTR_DLLIMPORT
, "dllimport" },
11586 { "dllexport", EXT_ATTR_DLLEXPORT
, "dllexport" },
11587 { "cdecl", EXT_ATTR_CDECL
, "cdecl" },
11588 { "stdcall", EXT_ATTR_STDCALL
, "stdcall" },
11589 { "fastcall", EXT_ATTR_FASTCALL
, "fastcall" },
11590 { "no_arg_check", EXT_ATTR_NO_ARG_CHECK
, NULL
},
11591 { "deprecated", EXT_ATTR_DEPRECATED
, NULL
},
11592 { NULL
, EXT_ATTR_LAST
, NULL
}
11595 /* Match a !GCC$ ATTRIBUTES statement of the form:
11596 !GCC$ ATTRIBUTES attribute-list :: var-name [, var-name] ...
11597 When we come here, we have already matched the !GCC$ ATTRIBUTES string.
11599 TODO: We should support all GCC attributes using the same syntax for
11600 the attribute list, i.e. the list in C
11601 __attributes(( attribute-list ))
11603 !GCC$ ATTRIBUTES attribute-list ::
11604 Cf. c-parser.c's c_parser_attributes; the data can then directly be
11607 As there is absolutely no risk of confusion, we should never return
11610 gfc_match_gcc_attributes (void)
11612 symbol_attribute attr
;
11613 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
11618 gfc_clear_attr (&attr
);
11623 if (gfc_match_name (name
) != MATCH_YES
)
11624 return MATCH_ERROR
;
11626 for (id
= 0; id
< EXT_ATTR_LAST
; id
++)
11627 if (strcmp (name
, ext_attr_list
[id
].name
) == 0)
11630 if (id
== EXT_ATTR_LAST
)
11632 gfc_error ("Unknown attribute in !GCC$ ATTRIBUTES statement at %C");
11633 return MATCH_ERROR
;
11636 if (!gfc_add_ext_attribute (&attr
, (ext_attr_id_t
)id
, &gfc_current_locus
))
11637 return MATCH_ERROR
;
11639 gfc_gobble_whitespace ();
11640 ch
= gfc_next_ascii_char ();
11643 /* This is the successful exit condition for the loop. */
11644 if (gfc_next_ascii_char () == ':')
11654 if (gfc_match_eos () == MATCH_YES
)
11659 m
= gfc_match_name (name
);
11660 if (m
!= MATCH_YES
)
11663 if (find_special (name
, &sym
, true))
11664 return MATCH_ERROR
;
11666 sym
->attr
.ext_attr
|= attr
.ext_attr
;
11668 if (gfc_match_eos () == MATCH_YES
)
11671 if (gfc_match_char (',') != MATCH_YES
)
11678 gfc_error ("Syntax error in !GCC$ ATTRIBUTES statement at %C");
11679 return MATCH_ERROR
;
11683 /* Match a !GCC$ UNROLL statement of the form:
11686 The parameter n is the number of times we are supposed to unroll.
11688 When we come here, we have already matched the !GCC$ UNROLL string. */
11690 gfc_match_gcc_unroll (void)
11694 if (gfc_match_small_int (&value
) == MATCH_YES
)
11696 if (value
< 0 || value
> USHRT_MAX
)
11698 gfc_error ("%<GCC unroll%> directive requires a"
11699 " non-negative integral constant"
11700 " less than or equal to %u at %C",
11703 return MATCH_ERROR
;
11705 if (gfc_match_eos () == MATCH_YES
)
11707 directive_unroll
= value
== 0 ? 1 : value
;
11712 gfc_error ("Syntax error in !GCC$ UNROLL directive at %C");
11713 return MATCH_ERROR
;
11716 /* Match a !GCC$ builtin (b) attributes simd flags if('target') form:
11718 The parameter b is name of a middle-end built-in.
11719 FLAGS is optional and must be one of:
11723 IF('target') is optional and TARGET is a name of a multilib ABI.
11725 When we come here, we have already matched the !GCC$ builtin string. */
11728 gfc_match_gcc_builtin (void)
11730 char builtin
[GFC_MAX_SYMBOL_LEN
+ 1];
11731 char target
[GFC_MAX_SYMBOL_LEN
+ 1];
11733 if (gfc_match (" ( %n ) attributes simd", builtin
) != MATCH_YES
)
11734 return MATCH_ERROR
;
11736 gfc_simd_clause clause
= SIMD_NONE
;
11737 if (gfc_match (" ( notinbranch ) ") == MATCH_YES
)
11738 clause
= SIMD_NOTINBRANCH
;
11739 else if (gfc_match (" ( inbranch ) ") == MATCH_YES
)
11740 clause
= SIMD_INBRANCH
;
11742 if (gfc_match (" if ( '%n' ) ", target
) == MATCH_YES
)
11744 const char *abi
= targetm
.get_multilib_abi_name ();
11745 if (abi
== NULL
|| strcmp (abi
, target
) != 0)
11749 if (gfc_vectorized_builtins
== NULL
)
11750 gfc_vectorized_builtins
= new hash_map
<nofree_string_hash
, int> ();
11752 char *r
= XNEWVEC (char, strlen (builtin
) + 32);
11753 sprintf (r
, "__builtin_%s", builtin
);
11756 int &value
= gfc_vectorized_builtins
->get_or_insert (r
, &existed
);
11764 /* Match an !GCC$ IVDEP statement.
11765 When we come here, we have already matched the !GCC$ IVDEP string. */
11768 gfc_match_gcc_ivdep (void)
11770 if (gfc_match_eos () == MATCH_YES
)
11772 directive_ivdep
= true;
11776 gfc_error ("Syntax error in !GCC$ IVDEP directive at %C");
11777 return MATCH_ERROR
;
11780 /* Match an !GCC$ VECTOR statement.
11781 When we come here, we have already matched the !GCC$ VECTOR string. */
11784 gfc_match_gcc_vector (void)
11786 if (gfc_match_eos () == MATCH_YES
)
11788 directive_vector
= true;
11789 directive_novector
= false;
11793 gfc_error ("Syntax error in !GCC$ VECTOR directive at %C");
11794 return MATCH_ERROR
;
11797 /* Match an !GCC$ NOVECTOR statement.
11798 When we come here, we have already matched the !GCC$ NOVECTOR string. */
11801 gfc_match_gcc_novector (void)
11803 if (gfc_match_eos () == MATCH_YES
)
11805 directive_novector
= true;
11806 directive_vector
= false;
11810 gfc_error ("Syntax error in !GCC$ NOVECTOR directive at %C");
11811 return MATCH_ERROR
;