1 /* Declaration statement matcher
2 Copyright (C) 2002-2018 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
23 #include "coretypes.h"
27 #include "stringpool.h"
30 #include "constructor.h"
32 /* Macros to access allocate memory for gfc_data_variable,
33 gfc_data_value and gfc_data. */
34 #define gfc_get_data_variable() XCNEW (gfc_data_variable)
35 #define gfc_get_data_value() XCNEW (gfc_data_value)
36 #define gfc_get_data() XCNEW (gfc_data)
39 static bool set_binding_label (const char **, const char *, int);
42 /* This flag is set if an old-style length selector is matched
43 during a type-declaration statement. */
45 static int old_char_selector
;
47 /* When variables acquire types and attributes from a declaration
48 statement, they get them from the following static variables. The
49 first part of a declaration sets these variables and the second
50 part copies these into symbol structures. */
52 static gfc_typespec current_ts
;
54 static symbol_attribute current_attr
;
55 static gfc_array_spec
*current_as
;
56 static int colon_seen
;
59 /* The current binding label (if any). */
60 static const char* curr_binding_label
;
61 /* Need to know how many identifiers are on the current data declaration
62 line in case we're given the BIND(C) attribute with a NAME= specifier. */
63 static int num_idents_on_line
;
64 /* Need to know if a NAME= specifier was found during gfc_match_bind_c so we
65 can supply a name if the curr_binding_label is nil and NAME= was not. */
66 static int has_name_equals
= 0;
68 /* Initializer of the previous enumerator. */
70 static gfc_expr
*last_initializer
;
72 /* History of all the enumerators is maintained, so that
73 kind values of all the enumerators could be updated depending
74 upon the maximum initialized value. */
76 typedef struct enumerator_history
79 gfc_expr
*initializer
;
80 struct enumerator_history
*next
;
84 /* Header of enum history chain. */
86 static enumerator_history
*enum_history
= NULL
;
88 /* Pointer of enum history node containing largest initializer. */
90 static enumerator_history
*max_enum
= NULL
;
92 /* gfc_new_block points to the symbol of a newly matched block. */
94 gfc_symbol
*gfc_new_block
;
96 bool gfc_matching_function
;
98 /* Set upon parsing a !GCC$ unroll n directive for use in the next loop. */
99 int directive_unroll
= -1;
101 /* If a kind expression of a component of a parameterized derived type is
102 parameterized, temporarily store the expression here. */
103 static gfc_expr
*saved_kind_expr
= NULL
;
105 /* Used to store the parameter list arising in a PDT declaration and
106 in the typespec of a PDT variable or component. */
107 static gfc_actual_arglist
*decl_type_param_list
;
108 static gfc_actual_arglist
*type_param_spec_list
;
110 /********************* DATA statement subroutines *********************/
112 static bool in_match_data
= false;
115 gfc_in_match_data (void)
117 return in_match_data
;
121 set_in_match_data (bool set_value
)
123 in_match_data
= set_value
;
126 /* Free a gfc_data_variable structure and everything beneath it. */
129 free_variable (gfc_data_variable
*p
)
131 gfc_data_variable
*q
;
136 gfc_free_expr (p
->expr
);
137 gfc_free_iterator (&p
->iter
, 0);
138 free_variable (p
->list
);
144 /* Free a gfc_data_value structure and everything beneath it. */
147 free_value (gfc_data_value
*p
)
154 mpz_clear (p
->repeat
);
155 gfc_free_expr (p
->expr
);
161 /* Free a list of gfc_data structures. */
164 gfc_free_data (gfc_data
*p
)
171 free_variable (p
->var
);
172 free_value (p
->value
);
178 /* Free all data in a namespace. */
181 gfc_free_data_all (gfc_namespace
*ns
)
193 /* Reject data parsed since the last restore point was marked. */
196 gfc_reject_data (gfc_namespace
*ns
)
200 while (ns
->data
&& ns
->data
!= ns
->old_data
)
208 static match
var_element (gfc_data_variable
*);
210 /* Match a list of variables terminated by an iterator and a right
214 var_list (gfc_data_variable
*parent
)
216 gfc_data_variable
*tail
, var
;
219 m
= var_element (&var
);
220 if (m
== MATCH_ERROR
)
225 tail
= gfc_get_data_variable ();
232 if (gfc_match_char (',') != MATCH_YES
)
235 m
= gfc_match_iterator (&parent
->iter
, 1);
238 if (m
== MATCH_ERROR
)
241 m
= var_element (&var
);
242 if (m
== MATCH_ERROR
)
247 tail
->next
= gfc_get_data_variable ();
253 if (gfc_match_char (')') != MATCH_YES
)
258 gfc_syntax_error (ST_DATA
);
263 /* Match a single element in a data variable list, which can be a
264 variable-iterator list. */
267 var_element (gfc_data_variable
*new_var
)
272 memset (new_var
, 0, sizeof (gfc_data_variable
));
274 if (gfc_match_char ('(') == MATCH_YES
)
275 return var_list (new_var
);
277 m
= gfc_match_variable (&new_var
->expr
, 0);
281 sym
= new_var
->expr
->symtree
->n
.sym
;
283 /* Symbol should already have an associated type. */
284 if (!gfc_check_symbol_typed (sym
, gfc_current_ns
, false, gfc_current_locus
))
287 if (!sym
->attr
.function
&& gfc_current_ns
->parent
288 && gfc_current_ns
->parent
== sym
->ns
)
290 gfc_error ("Host associated variable %qs may not be in the DATA "
291 "statement at %C", sym
->name
);
295 if (gfc_current_state () != COMP_BLOCK_DATA
296 && sym
->attr
.in_common
297 && !gfc_notify_std (GFC_STD_GNU
, "initialization of "
298 "common block variable %qs in DATA statement at %C",
302 if (!gfc_add_data (&sym
->attr
, sym
->name
, &new_var
->expr
->where
))
309 /* Match the top-level list of data variables. */
312 top_var_list (gfc_data
*d
)
314 gfc_data_variable var
, *tail
, *new_var
;
321 m
= var_element (&var
);
324 if (m
== MATCH_ERROR
)
327 new_var
= gfc_get_data_variable ();
333 tail
->next
= new_var
;
337 if (gfc_match_char ('/') == MATCH_YES
)
339 if (gfc_match_char (',') != MATCH_YES
)
346 gfc_syntax_error (ST_DATA
);
347 gfc_free_data_all (gfc_current_ns
);
353 match_data_constant (gfc_expr
**result
)
355 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
356 gfc_symbol
*sym
, *dt_sym
= NULL
;
361 m
= gfc_match_literal_constant (&expr
, 1);
368 if (m
== MATCH_ERROR
)
371 m
= gfc_match_null (result
);
375 old_loc
= gfc_current_locus
;
377 /* Should this be a structure component, try to match it
378 before matching a name. */
379 m
= gfc_match_rvalue (result
);
380 if (m
== MATCH_ERROR
)
383 if (m
== MATCH_YES
&& (*result
)->expr_type
== EXPR_STRUCTURE
)
385 if (!gfc_simplify_expr (*result
, 0))
389 else if (m
== MATCH_YES
)
391 /* F2018:R845 data-stmt-constant is initial-data-target.
392 A data-stmt-constant shall be ... initial-data-target if and
393 only if the corresponding data-stmt-object has the POINTER
394 attribute. ... If data-stmt-constant is initial-data-target
395 the corresponding data statement object shall be
396 data-pointer-initialization compatible (7.5.4.6) with the initial
397 data target; the data statement object is initially associated
399 if ((*result
)->symtree
->n
.sym
->attr
.save
400 && (*result
)->symtree
->n
.sym
->attr
.target
)
402 gfc_free_expr (*result
);
405 gfc_current_locus
= old_loc
;
407 m
= gfc_match_name (name
);
411 if (gfc_find_symbol (name
, NULL
, 1, &sym
))
414 if (sym
&& sym
->attr
.generic
)
415 dt_sym
= gfc_find_dt_in_generic (sym
);
418 || (sym
->attr
.flavor
!= FL_PARAMETER
419 && (!dt_sym
|| !gfc_fl_struct (dt_sym
->attr
.flavor
))))
421 gfc_error ("Symbol %qs must be a PARAMETER in DATA statement at %C",
426 else if (dt_sym
&& gfc_fl_struct (dt_sym
->attr
.flavor
))
427 return gfc_match_structure_constructor (dt_sym
, result
);
429 /* Check to see if the value is an initialization array expression. */
430 if (sym
->value
->expr_type
== EXPR_ARRAY
)
432 gfc_current_locus
= old_loc
;
434 m
= gfc_match_init_expr (result
);
435 if (m
== MATCH_ERROR
)
440 if (!gfc_simplify_expr (*result
, 0))
443 if ((*result
)->expr_type
== EXPR_CONSTANT
)
447 gfc_error ("Invalid initializer %s in Data statement at %C", name
);
453 *result
= gfc_copy_expr (sym
->value
);
458 /* Match a list of values in a DATA statement. The leading '/' has
459 already been seen at this point. */
462 top_val_list (gfc_data
*data
)
464 gfc_data_value
*new_val
, *tail
;
472 m
= match_data_constant (&expr
);
475 if (m
== MATCH_ERROR
)
478 new_val
= gfc_get_data_value ();
479 mpz_init (new_val
->repeat
);
482 data
->value
= new_val
;
484 tail
->next
= new_val
;
488 if (expr
->ts
.type
!= BT_INTEGER
|| gfc_match_char ('*') != MATCH_YES
)
491 mpz_set_ui (tail
->repeat
, 1);
495 mpz_set (tail
->repeat
, expr
->value
.integer
);
496 gfc_free_expr (expr
);
498 m
= match_data_constant (&tail
->expr
);
501 if (m
== MATCH_ERROR
)
505 if (gfc_match_char ('/') == MATCH_YES
)
507 if (gfc_match_char (',') == MATCH_NO
)
514 gfc_syntax_error (ST_DATA
);
515 gfc_free_data_all (gfc_current_ns
);
520 /* Matches an old style initialization. */
523 match_old_style_init (const char *name
)
530 /* Set up data structure to hold initializers. */
531 gfc_find_sym_tree (name
, NULL
, 0, &st
);
534 newdata
= gfc_get_data ();
535 newdata
->var
= gfc_get_data_variable ();
536 newdata
->var
->expr
= gfc_get_variable_expr (st
);
537 newdata
->var
->expr
->where
= sym
->declared_at
;
538 newdata
->where
= gfc_current_locus
;
540 /* Match initial value list. This also eats the terminal '/'. */
541 m
= top_val_list (newdata
);
550 gfc_error ("Initialization at %C is not allowed in a PURE procedure");
554 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
556 /* Mark the variable as having appeared in a data statement. */
557 if (!gfc_add_data (&sym
->attr
, sym
->name
, &sym
->declared_at
))
563 /* Chain in namespace list of DATA initializers. */
564 newdata
->next
= gfc_current_ns
->data
;
565 gfc_current_ns
->data
= newdata
;
571 /* Match the stuff following a DATA statement. If ERROR_FLAG is set,
572 we are matching a DATA statement and are therefore issuing an error
573 if we encounter something unexpected, if not, we're trying to match
574 an old-style initialization expression of the form INTEGER I /2/. */
577 gfc_match_data (void)
582 /* Before parsing the rest of a DATA statement, check F2008:c1206. */
583 if ((gfc_current_state () == COMP_FUNCTION
584 || gfc_current_state () == COMP_SUBROUTINE
)
585 && gfc_state_stack
->previous
->state
== COMP_INTERFACE
)
587 gfc_error ("DATA statement at %C cannot appear within an INTERFACE");
591 set_in_match_data (true);
595 new_data
= gfc_get_data ();
596 new_data
->where
= gfc_current_locus
;
598 m
= top_var_list (new_data
);
602 if (new_data
->var
->iter
.var
603 && new_data
->var
->iter
.var
->ts
.type
== BT_INTEGER
604 && new_data
->var
->iter
.var
->symtree
->n
.sym
->attr
.implied_index
== 1
605 && new_data
->var
->list
606 && new_data
->var
->list
->expr
607 && new_data
->var
->list
->expr
->ts
.type
== BT_CHARACTER
608 && new_data
->var
->list
->expr
->ref
609 && new_data
->var
->list
->expr
->ref
->type
== REF_SUBSTRING
)
611 gfc_error ("Invalid substring in data-implied-do at %L in DATA "
612 "statement", &new_data
->var
->list
->expr
->where
);
616 m
= top_val_list (new_data
);
620 new_data
->next
= gfc_current_ns
->data
;
621 gfc_current_ns
->data
= new_data
;
623 if (gfc_match_eos () == MATCH_YES
)
626 gfc_match_char (','); /* Optional comma */
629 set_in_match_data (false);
633 gfc_error ("DATA statement at %C is not allowed in a PURE procedure");
636 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
641 set_in_match_data (false);
642 gfc_free_data (new_data
);
647 /************************ Declaration statements *********************/
650 /* Like gfc_match_init_expr, but matches a 'clist' (old-style initialization
651 list). The difference here is the expression is a list of constants
652 and is surrounded by '/'.
653 The typespec ts must match the typespec of the variable which the
654 clist is initializing.
655 The arrayspec tells whether this should match a list of constants
656 corresponding to array elements or a scalar (as == NULL). */
659 match_clist_expr (gfc_expr
**result
, gfc_typespec
*ts
, gfc_array_spec
*as
)
661 gfc_constructor_base array_head
= NULL
;
662 gfc_expr
*expr
= NULL
;
663 match m
= MATCH_ERROR
;
665 mpz_t repeat
, cons_size
, as_size
;
671 /* We have already matched '/' - now look for a constant list, as with
672 top_val_list from decl.c, but append the result to an array. */
673 if (gfc_match ("/") == MATCH_YES
)
675 gfc_error ("Empty old style initializer list at %C");
679 where
= gfc_current_locus
;
680 scalar
= !as
|| !as
->rank
;
682 if (!scalar
&& !spec_size (as
, &as_size
))
684 gfc_error ("Array in initializer list at %L must have an explicit shape",
685 as
->type
== AS_EXPLICIT
? &as
->upper
[0]->where
: &where
);
686 /* Nothing to cleanup yet. */
690 mpz_init_set_ui (repeat
, 0);
694 m
= match_data_constant (&expr
);
696 expr
= NULL
; /* match_data_constant may set expr to garbage */
699 if (m
== MATCH_ERROR
)
702 /* Found r in repeat spec r*c; look for the constant to repeat. */
703 if ( gfc_match_char ('*') == MATCH_YES
)
707 gfc_error ("Repeat spec invalid in scalar initializer at %C");
710 if (expr
->ts
.type
!= BT_INTEGER
)
712 gfc_error ("Repeat spec must be an integer at %C");
715 mpz_set (repeat
, expr
->value
.integer
);
716 gfc_free_expr (expr
);
719 m
= match_data_constant (&expr
);
723 gfc_error ("Expected data constant after repeat spec at %C");
728 /* No repeat spec, we matched the data constant itself. */
730 mpz_set_ui (repeat
, 1);
734 /* Add the constant initializer as many times as repeated. */
735 for (; mpz_cmp_ui (repeat
, 0) > 0; mpz_sub_ui (repeat
, repeat
, 1))
737 /* Make sure types of elements match */
738 if(ts
&& !gfc_compare_types (&expr
->ts
, ts
)
739 && !gfc_convert_type (expr
, ts
, 1))
742 gfc_constructor_append_expr (&array_head
,
743 gfc_copy_expr (expr
), &gfc_current_locus
);
746 gfc_free_expr (expr
);
750 /* For scalar initializers quit after one element. */
753 if(gfc_match_char ('/') != MATCH_YES
)
755 gfc_error ("End of scalar initializer expected at %C");
761 if (gfc_match_char ('/') == MATCH_YES
)
763 if (gfc_match_char (',') == MATCH_NO
)
767 /* If we break early from here out, we encountered an error. */
770 /* Set up expr as an array constructor. */
773 expr
= gfc_get_array_expr (ts
->type
, ts
->kind
, &where
);
775 expr
->value
.constructor
= array_head
;
777 expr
->rank
= as
->rank
;
778 expr
->shape
= gfc_get_shape (expr
->rank
);
780 /* Validate sizes. We built expr ourselves, so cons_size will be
781 constant (we fail above for non-constant expressions).
782 We still need to verify that the sizes match. */
783 gcc_assert (gfc_array_size (expr
, &cons_size
));
784 cmp
= mpz_cmp (cons_size
, as_size
);
786 gfc_error ("Not enough elements in array initializer at %C");
788 gfc_error ("Too many elements in array initializer at %C");
789 mpz_clear (cons_size
);
794 /* Make sure scalar types match. */
795 else if (!gfc_compare_types (&expr
->ts
, ts
)
796 && !gfc_convert_type (expr
, ts
, 1))
800 expr
->ts
.u
.cl
->length_from_typespec
= 1;
808 gfc_error ("Syntax error in old style initializer list at %C");
812 expr
->value
.constructor
= NULL
;
813 gfc_free_expr (expr
);
814 gfc_constructor_free (array_head
);
824 /* Auxiliary function to merge DIMENSION and CODIMENSION array specs. */
827 merge_array_spec (gfc_array_spec
*from
, gfc_array_spec
*to
, bool copy
)
831 if ((from
->type
== AS_ASSUMED_RANK
&& to
->corank
)
832 || (to
->type
== AS_ASSUMED_RANK
&& from
->corank
))
834 gfc_error ("The assumed-rank array at %C shall not have a codimension");
838 if (to
->rank
== 0 && from
->rank
> 0)
840 to
->rank
= from
->rank
;
841 to
->type
= from
->type
;
842 to
->cray_pointee
= from
->cray_pointee
;
843 to
->cp_was_assumed
= from
->cp_was_assumed
;
845 for (i
= 0; i
< to
->corank
; i
++)
847 /* Do not exceed the limits on lower[] and upper[]. gfortran
848 cleans up elsewhere. */
850 if (j
>= GFC_MAX_DIMENSIONS
)
853 to
->lower
[j
] = to
->lower
[i
];
854 to
->upper
[j
] = to
->upper
[i
];
856 for (i
= 0; i
< from
->rank
; i
++)
860 to
->lower
[i
] = gfc_copy_expr (from
->lower
[i
]);
861 to
->upper
[i
] = gfc_copy_expr (from
->upper
[i
]);
865 to
->lower
[i
] = from
->lower
[i
];
866 to
->upper
[i
] = from
->upper
[i
];
870 else if (to
->corank
== 0 && from
->corank
> 0)
872 to
->corank
= from
->corank
;
873 to
->cotype
= from
->cotype
;
875 for (i
= 0; i
< from
->corank
; i
++)
877 /* Do not exceed the limits on lower[] and upper[]. gfortran
878 cleans up elsewhere. */
880 if (j
>= GFC_MAX_DIMENSIONS
)
885 to
->lower
[j
] = gfc_copy_expr (from
->lower
[i
]);
886 to
->upper
[j
] = gfc_copy_expr (from
->upper
[i
]);
890 to
->lower
[j
] = from
->lower
[i
];
891 to
->upper
[j
] = from
->upper
[i
];
896 if (to
->rank
+ to
->corank
> GFC_MAX_DIMENSIONS
)
898 gfc_error ("Sum of array rank %d and corank %d at %C exceeds maximum "
899 "allowed dimensions of %d",
900 to
->rank
, to
->corank
, GFC_MAX_DIMENSIONS
);
901 to
->corank
= GFC_MAX_DIMENSIONS
- to
->rank
;
908 /* Match an intent specification. Since this can only happen after an
909 INTENT word, a legal intent-spec must follow. */
912 match_intent_spec (void)
915 if (gfc_match (" ( in out )") == MATCH_YES
)
917 if (gfc_match (" ( in )") == MATCH_YES
)
919 if (gfc_match (" ( out )") == MATCH_YES
)
922 gfc_error ("Bad INTENT specification at %C");
923 return INTENT_UNKNOWN
;
927 /* Matches a character length specification, which is either a
928 specification expression, '*', or ':'. */
931 char_len_param_value (gfc_expr
**expr
, bool *deferred
)
938 if (gfc_match_char ('*') == MATCH_YES
)
941 if (gfc_match_char (':') == MATCH_YES
)
943 if (!gfc_notify_std (GFC_STD_F2003
, "deferred type parameter at %C"))
951 m
= gfc_match_expr (expr
);
953 if (m
== MATCH_NO
|| m
== MATCH_ERROR
)
956 if (!gfc_expr_check_typed (*expr
, gfc_current_ns
, false))
959 if ((*expr
)->expr_type
== EXPR_FUNCTION
)
961 if ((*expr
)->ts
.type
== BT_INTEGER
962 || ((*expr
)->ts
.type
== BT_UNKNOWN
963 && strcmp((*expr
)->symtree
->name
, "null") != 0))
968 else if ((*expr
)->expr_type
== EXPR_CONSTANT
)
970 /* F2008, 4.4.3.1: The length is a type parameter; its kind is
971 processor dependent and its value is greater than or equal to zero.
972 F2008, 4.4.3.2: If the character length parameter value evaluates
973 to a negative value, the length of character entities declared
976 if ((*expr
)->ts
.type
== BT_INTEGER
)
978 if (mpz_cmp_si ((*expr
)->value
.integer
, 0) < 0)
979 mpz_set_si ((*expr
)->value
.integer
, 0);
984 else if ((*expr
)->expr_type
== EXPR_ARRAY
)
986 else if ((*expr
)->expr_type
== EXPR_VARIABLE
)
991 e
= gfc_copy_expr (*expr
);
993 /* This catches the invalid code "[character(m(2:3)) :: 'x', 'y']",
994 which causes an ICE if gfc_reduce_init_expr() is called. */
995 if (e
->ref
&& e
->ref
->type
== REF_ARRAY
996 && e
->ref
->u
.ar
.type
== AR_UNKNOWN
997 && e
->ref
->u
.ar
.dimen_type
[0] == DIMEN_RANGE
)
1000 t
= gfc_reduce_init_expr (e
);
1002 if (!t
&& e
->ts
.type
== BT_UNKNOWN
1003 && e
->symtree
->n
.sym
->attr
.untyped
== 1
1004 && (flag_implicit_none
1005 || e
->symtree
->n
.sym
->ns
->seen_implicit_none
== 1
1006 || e
->symtree
->n
.sym
->ns
->parent
->seen_implicit_none
== 1))
1012 if ((e
->ref
&& e
->ref
->type
== REF_ARRAY
1013 && e
->ref
->u
.ar
.type
!= AR_ELEMENT
)
1014 || (!e
->ref
&& e
->expr_type
== EXPR_ARRAY
))
1026 gfc_error ("Scalar INTEGER expression expected at %L", &(*expr
)->where
);
1031 /* A character length is a '*' followed by a literal integer or a
1032 char_len_param_value in parenthesis. */
1035 match_char_length (gfc_expr
**expr
, bool *deferred
, bool obsolescent_check
)
1041 m
= gfc_match_char ('*');
1045 m
= gfc_match_small_literal_int (&length
, NULL
);
1046 if (m
== MATCH_ERROR
)
1051 if (obsolescent_check
1052 && !gfc_notify_std (GFC_STD_F95_OBS
, "Old-style character length at %C"))
1054 *expr
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
, length
);
1058 if (gfc_match_char ('(') == MATCH_NO
)
1061 m
= char_len_param_value (expr
, deferred
);
1062 if (m
!= MATCH_YES
&& gfc_matching_function
)
1064 gfc_undo_symbols ();
1068 if (m
== MATCH_ERROR
)
1073 if (gfc_match_char (')') == MATCH_NO
)
1075 gfc_free_expr (*expr
);
1083 gfc_error ("Syntax error in character length specification at %C");
1088 /* Special subroutine for finding a symbol. Check if the name is found
1089 in the current name space. If not, and we're compiling a function or
1090 subroutine and the parent compilation unit is an interface, then check
1091 to see if the name we've been given is the name of the interface
1092 (located in another namespace). */
1095 find_special (const char *name
, gfc_symbol
**result
, bool allow_subroutine
)
1101 i
= gfc_get_sym_tree (name
, NULL
, &st
, allow_subroutine
);
1104 *result
= st
? st
->n
.sym
: NULL
;
1108 if (gfc_current_state () != COMP_SUBROUTINE
1109 && gfc_current_state () != COMP_FUNCTION
)
1112 s
= gfc_state_stack
->previous
;
1116 if (s
->state
!= COMP_INTERFACE
)
1119 goto end
; /* Nameless interface. */
1121 if (strcmp (name
, s
->sym
->name
) == 0)
1132 /* Special subroutine for getting a symbol node associated with a
1133 procedure name, used in SUBROUTINE and FUNCTION statements. The
1134 symbol is created in the parent using with symtree node in the
1135 child unit pointing to the symbol. If the current namespace has no
1136 parent, then the symbol is just created in the current unit. */
1139 get_proc_name (const char *name
, gfc_symbol
**result
, bool module_fcn_entry
)
1145 /* Module functions have to be left in their own namespace because
1146 they have potentially (almost certainly!) already been referenced.
1147 In this sense, they are rather like external functions. This is
1148 fixed up in resolve.c(resolve_entries), where the symbol name-
1149 space is set to point to the master function, so that the fake
1150 result mechanism can work. */
1151 if (module_fcn_entry
)
1153 /* Present if entry is declared to be a module procedure. */
1154 rc
= gfc_find_symbol (name
, gfc_current_ns
->parent
, 0, result
);
1156 if (*result
== NULL
)
1157 rc
= gfc_get_symbol (name
, NULL
, result
);
1158 else if (!gfc_get_symbol (name
, NULL
, &sym
) && sym
1159 && (*result
)->ts
.type
== BT_UNKNOWN
1160 && sym
->attr
.flavor
== FL_UNKNOWN
)
1161 /* Pick up the typespec for the entry, if declared in the function
1162 body. Note that this symbol is FL_UNKNOWN because it will
1163 only have appeared in a type declaration. The local symtree
1164 is set to point to the module symbol and a unique symtree
1165 to the local version. This latter ensures a correct clearing
1168 /* If the ENTRY proceeds its specification, we need to ensure
1169 that this does not raise a "has no IMPLICIT type" error. */
1170 if (sym
->ts
.type
== BT_UNKNOWN
)
1171 sym
->attr
.untyped
= 1;
1173 (*result
)->ts
= sym
->ts
;
1175 /* Put the symbol in the procedure namespace so that, should
1176 the ENTRY precede its specification, the specification
1178 (*result
)->ns
= gfc_current_ns
;
1180 gfc_find_sym_tree (name
, gfc_current_ns
, 0, &st
);
1181 st
->n
.sym
= *result
;
1182 st
= gfc_get_unique_symtree (gfc_current_ns
);
1188 rc
= gfc_get_symbol (name
, gfc_current_ns
->parent
, result
);
1194 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
1197 if (sym
->attr
.module_procedure
&& sym
->attr
.if_source
== IFSRC_IFBODY
)
1199 /* Create a partially populated interface symbol to carry the
1200 characteristics of the procedure and the result. */
1201 sym
->tlink
= gfc_new_symbol (name
, sym
->ns
);
1202 gfc_add_type (sym
->tlink
, &(sym
->ts
), &gfc_current_locus
);
1203 gfc_copy_attr (&sym
->tlink
->attr
, &sym
->attr
, NULL
);
1204 if (sym
->attr
.dimension
)
1205 sym
->tlink
->as
= gfc_copy_array_spec (sym
->as
);
1207 /* Ideally, at this point, a copy would be made of the formal
1208 arguments and their namespace. However, this does not appear
1209 to be necessary, albeit at the expense of not being able to
1210 use gfc_compare_interfaces directly. */
1212 if (sym
->result
&& sym
->result
!= sym
)
1214 sym
->tlink
->result
= sym
->result
;
1217 else if (sym
->result
)
1219 sym
->tlink
->result
= sym
->tlink
;
1222 else if (sym
&& !sym
->gfc_new
1223 && gfc_current_state () != COMP_INTERFACE
)
1225 /* Trap another encompassed procedure with the same name. All
1226 these conditions are necessary to avoid picking up an entry
1227 whose name clashes with that of the encompassing procedure;
1228 this is handled using gsymbols to register unique, globally
1229 accessible names. */
1230 if (sym
->attr
.flavor
!= 0
1231 && sym
->attr
.proc
!= 0
1232 && (sym
->attr
.subroutine
|| sym
->attr
.function
|| sym
->attr
.entry
)
1233 && sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
1234 gfc_error_now ("Procedure %qs at %C is already defined at %L",
1235 name
, &sym
->declared_at
);
1237 if (sym
->attr
.flavor
!= 0
1238 && sym
->attr
.entry
&& sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
1239 gfc_error_now ("Procedure %qs at %C is already defined at %L",
1240 name
, &sym
->declared_at
);
1242 if (sym
->attr
.external
&& sym
->attr
.procedure
1243 && gfc_current_state () == COMP_CONTAINS
)
1244 gfc_error_now ("Contained procedure %qs at %C clashes with "
1245 "procedure defined at %L",
1246 name
, &sym
->declared_at
);
1248 /* Trap a procedure with a name the same as interface in the
1249 encompassing scope. */
1250 if (sym
->attr
.generic
!= 0
1251 && (sym
->attr
.subroutine
|| sym
->attr
.function
)
1252 && !sym
->attr
.mod_proc
)
1253 gfc_error_now ("Name %qs at %C is already defined"
1254 " as a generic interface at %L",
1255 name
, &sym
->declared_at
);
1257 /* Trap declarations of attributes in encompassing scope. The
1258 signature for this is that ts.kind is set. Legitimate
1259 references only set ts.type. */
1260 if (sym
->ts
.kind
!= 0
1261 && !sym
->attr
.implicit_type
1262 && sym
->attr
.proc
== 0
1263 && gfc_current_ns
->parent
!= NULL
1264 && sym
->attr
.access
== 0
1265 && !module_fcn_entry
)
1266 gfc_error_now ("Procedure %qs at %C has an explicit interface "
1267 "from a previous declaration", name
);
1270 /* C1246 (R1225) MODULE shall appear only in the function-stmt or
1271 subroutine-stmt of a module subprogram or of a nonabstract interface
1272 body that is declared in the scoping unit of a module or submodule. */
1273 if (sym
->attr
.external
1274 && (sym
->attr
.subroutine
|| sym
->attr
.function
)
1275 && sym
->attr
.if_source
== IFSRC_IFBODY
1276 && !current_attr
.module_procedure
1277 && sym
->attr
.proc
== PROC_MODULE
1278 && gfc_state_stack
->state
== COMP_CONTAINS
)
1279 gfc_error_now ("Procedure %qs defined in interface body at %L "
1280 "clashes with internal procedure defined at %C",
1281 name
, &sym
->declared_at
);
1283 if (sym
&& !sym
->gfc_new
1284 && sym
->attr
.flavor
!= FL_UNKNOWN
1285 && sym
->attr
.referenced
== 0 && sym
->attr
.subroutine
== 1
1286 && gfc_state_stack
->state
== COMP_CONTAINS
1287 && gfc_state_stack
->previous
->state
== COMP_SUBROUTINE
)
1288 gfc_error_now ("Procedure %qs at %C is already defined at %L",
1289 name
, &sym
->declared_at
);
1291 if (gfc_current_ns
->parent
== NULL
|| *result
== NULL
)
1294 /* Module function entries will already have a symtree in
1295 the current namespace but will need one at module level. */
1296 if (module_fcn_entry
)
1298 /* Present if entry is declared to be a module procedure. */
1299 rc
= gfc_find_sym_tree (name
, gfc_current_ns
->parent
, 0, &st
);
1301 st
= gfc_new_symtree (&gfc_current_ns
->parent
->sym_root
, name
);
1304 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, name
);
1309 /* See if the procedure should be a module procedure. */
1311 if (((sym
->ns
->proc_name
!= NULL
1312 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
1313 && sym
->attr
.proc
!= PROC_MODULE
)
1314 || (module_fcn_entry
&& sym
->attr
.proc
!= PROC_MODULE
))
1315 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
1322 /* Verify that the given symbol representing a parameter is C
1323 interoperable, by checking to see if it was marked as such after
1324 its declaration. If the given symbol is not interoperable, a
1325 warning is reported, thus removing the need to return the status to
1326 the calling function. The standard does not require the user use
1327 one of the iso_c_binding named constants to declare an
1328 interoperable parameter, but we can't be sure if the param is C
1329 interop or not if the user doesn't. For example, integer(4) may be
1330 legal Fortran, but doesn't have meaning in C. It may interop with
1331 a number of the C types, which causes a problem because the
1332 compiler can't know which one. This code is almost certainly not
1333 portable, and the user will get what they deserve if the C type
1334 across platforms isn't always interoperable with integer(4). If
1335 the user had used something like integer(c_int) or integer(c_long),
1336 the compiler could have automatically handled the varying sizes
1337 across platforms. */
1340 gfc_verify_c_interop_param (gfc_symbol
*sym
)
1342 int is_c_interop
= 0;
1345 /* We check implicitly typed variables in symbol.c:gfc_set_default_type().
1346 Don't repeat the checks here. */
1347 if (sym
->attr
.implicit_type
)
1350 /* For subroutines or functions that are passed to a BIND(C) procedure,
1351 they're interoperable if they're BIND(C) and their params are all
1353 if (sym
->attr
.flavor
== FL_PROCEDURE
)
1355 if (sym
->attr
.is_bind_c
== 0)
1357 gfc_error_now ("Procedure %qs at %L must have the BIND(C) "
1358 "attribute to be C interoperable", sym
->name
,
1359 &(sym
->declared_at
));
1364 if (sym
->attr
.is_c_interop
== 1)
1365 /* We've already checked this procedure; don't check it again. */
1368 return verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
1373 /* See if we've stored a reference to a procedure that owns sym. */
1374 if (sym
->ns
!= NULL
&& sym
->ns
->proc_name
!= NULL
)
1376 if (sym
->ns
->proc_name
->attr
.is_bind_c
== 1)
1378 is_c_interop
= (gfc_verify_c_interop(&(sym
->ts
)) ? 1 : 0);
1380 if (is_c_interop
!= 1)
1382 /* Make personalized messages to give better feedback. */
1383 if (sym
->ts
.type
== BT_DERIVED
)
1384 gfc_error ("Variable %qs at %L is a dummy argument to the "
1385 "BIND(C) procedure %qs but is not C interoperable "
1386 "because derived type %qs is not C interoperable",
1387 sym
->name
, &(sym
->declared_at
),
1388 sym
->ns
->proc_name
->name
,
1389 sym
->ts
.u
.derived
->name
);
1390 else if (sym
->ts
.type
== BT_CLASS
)
1391 gfc_error ("Variable %qs at %L is a dummy argument to the "
1392 "BIND(C) procedure %qs but is not C interoperable "
1393 "because it is polymorphic",
1394 sym
->name
, &(sym
->declared_at
),
1395 sym
->ns
->proc_name
->name
);
1396 else if (warn_c_binding_type
)
1397 gfc_warning (OPT_Wc_binding_type
,
1398 "Variable %qs at %L is a dummy argument of the "
1399 "BIND(C) procedure %qs but may not be C "
1401 sym
->name
, &(sym
->declared_at
),
1402 sym
->ns
->proc_name
->name
);
1405 /* Character strings are only C interoperable if they have a
1407 if (sym
->ts
.type
== BT_CHARACTER
)
1409 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
1410 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
1411 || mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
1413 gfc_error ("Character argument %qs at %L "
1414 "must be length 1 because "
1415 "procedure %qs is BIND(C)",
1416 sym
->name
, &sym
->declared_at
,
1417 sym
->ns
->proc_name
->name
);
1422 /* We have to make sure that any param to a bind(c) routine does
1423 not have the allocatable, pointer, or optional attributes,
1424 according to J3/04-007, section 5.1. */
1425 if (sym
->attr
.allocatable
== 1
1426 && !gfc_notify_std (GFC_STD_F2018
, "Variable %qs at %L with "
1427 "ALLOCATABLE attribute in procedure %qs "
1428 "with BIND(C)", sym
->name
,
1429 &(sym
->declared_at
),
1430 sym
->ns
->proc_name
->name
))
1433 if (sym
->attr
.pointer
== 1
1434 && !gfc_notify_std (GFC_STD_F2018
, "Variable %qs at %L with "
1435 "POINTER attribute in procedure %qs "
1436 "with BIND(C)", sym
->name
,
1437 &(sym
->declared_at
),
1438 sym
->ns
->proc_name
->name
))
1441 if ((sym
->attr
.allocatable
|| sym
->attr
.pointer
) && !sym
->as
)
1443 gfc_error ("Scalar variable %qs at %L with POINTER or "
1444 "ALLOCATABLE in procedure %qs with BIND(C) is not yet"
1445 " supported", sym
->name
, &(sym
->declared_at
),
1446 sym
->ns
->proc_name
->name
);
1450 if (sym
->attr
.optional
== 1 && sym
->attr
.value
)
1452 gfc_error ("Variable %qs at %L cannot have both the OPTIONAL "
1453 "and the VALUE attribute because procedure %qs "
1454 "is BIND(C)", sym
->name
, &(sym
->declared_at
),
1455 sym
->ns
->proc_name
->name
);
1458 else if (sym
->attr
.optional
== 1
1459 && !gfc_notify_std (GFC_STD_F2018
, "Variable %qs "
1460 "at %L with OPTIONAL attribute in "
1461 "procedure %qs which is BIND(C)",
1462 sym
->name
, &(sym
->declared_at
),
1463 sym
->ns
->proc_name
->name
))
1466 /* Make sure that if it has the dimension attribute, that it is
1467 either assumed size or explicit shape. Deferred shape is already
1468 covered by the pointer/allocatable attribute. */
1469 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SHAPE
1470 && !gfc_notify_std (GFC_STD_F2018
, "Assumed-shape array %qs "
1471 "at %L as dummy argument to the BIND(C) "
1472 "procedure %qs at %L", sym
->name
,
1473 &(sym
->declared_at
),
1474 sym
->ns
->proc_name
->name
,
1475 &(sym
->ns
->proc_name
->declared_at
)))
1485 /* Function called by variable_decl() that adds a name to the symbol table. */
1488 build_sym (const char *name
, gfc_charlen
*cl
, bool cl_deferred
,
1489 gfc_array_spec
**as
, locus
*var_locus
)
1491 symbol_attribute attr
;
1496 /* Symbols in a submodule are host associated from the parent module or
1497 submodules. Therefore, they can be overridden by declarations in the
1498 submodule scope. Deal with this by attaching the existing symbol to
1499 a new symtree and recycling the old symtree with a new symbol... */
1500 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
1501 if (st
!= NULL
&& gfc_state_stack
->state
== COMP_SUBMODULE
1502 && st
->n
.sym
!= NULL
1503 && st
->n
.sym
->attr
.host_assoc
&& st
->n
.sym
->attr
.used_in_submodule
)
1505 gfc_symtree
*s
= gfc_get_unique_symtree (gfc_current_ns
);
1506 s
->n
.sym
= st
->n
.sym
;
1507 sym
= gfc_new_symbol (name
, gfc_current_ns
);
1512 gfc_set_sym_referenced (sym
);
1514 /* ...Otherwise generate a new symtree and new symbol. */
1515 else if (gfc_get_symbol (name
, NULL
, &sym
))
1518 /* Check if the name has already been defined as a type. The
1519 first letter of the symtree will be in upper case then. Of
1520 course, this is only necessary if the upper case letter is
1521 actually different. */
1523 upper
= TOUPPER(name
[0]);
1524 if (upper
!= name
[0])
1526 char u_name
[GFC_MAX_SYMBOL_LEN
+ 1];
1529 gcc_assert (strlen(name
) <= GFC_MAX_SYMBOL_LEN
);
1530 strcpy (u_name
, name
);
1533 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, u_name
);
1535 /* STRUCTURE types can alias symbol names */
1536 if (st
!= 0 && st
->n
.sym
->attr
.flavor
!= FL_STRUCT
)
1538 gfc_error ("Symbol %qs at %C also declared as a type at %L", name
,
1539 &st
->n
.sym
->declared_at
);
1544 /* Start updating the symbol table. Add basic type attribute if present. */
1545 if (current_ts
.type
!= BT_UNKNOWN
1546 && (sym
->attr
.implicit_type
== 0
1547 || !gfc_compare_types (&sym
->ts
, ¤t_ts
))
1548 && !gfc_add_type (sym
, ¤t_ts
, var_locus
))
1551 if (sym
->ts
.type
== BT_CHARACTER
)
1554 sym
->ts
.deferred
= cl_deferred
;
1557 /* Add dimension attribute if present. */
1558 if (!gfc_set_array_spec (sym
, *as
, var_locus
))
1562 /* Add attribute to symbol. The copy is so that we can reset the
1563 dimension attribute. */
1564 attr
= current_attr
;
1566 attr
.codimension
= 0;
1568 if (!gfc_copy_attr (&sym
->attr
, &attr
, var_locus
))
1571 /* Finish any work that may need to be done for the binding label,
1572 if it's a bind(c). The bind(c) attr is found before the symbol
1573 is made, and before the symbol name (for data decls), so the
1574 current_ts is holding the binding label, or nothing if the
1575 name= attr wasn't given. Therefore, test here if we're dealing
1576 with a bind(c) and make sure the binding label is set correctly. */
1577 if (sym
->attr
.is_bind_c
== 1)
1579 if (!sym
->binding_label
)
1581 /* Set the binding label and verify that if a NAME= was specified
1582 then only one identifier was in the entity-decl-list. */
1583 if (!set_binding_label (&sym
->binding_label
, sym
->name
,
1584 num_idents_on_line
))
1589 /* See if we know we're in a common block, and if it's a bind(c)
1590 common then we need to make sure we're an interoperable type. */
1591 if (sym
->attr
.in_common
== 1)
1593 /* Test the common block object. */
1594 if (sym
->common_block
!= NULL
&& sym
->common_block
->is_bind_c
== 1
1595 && sym
->ts
.is_c_interop
!= 1)
1597 gfc_error_now ("Variable %qs in common block %qs at %C "
1598 "must be declared with a C interoperable "
1599 "kind since common block %qs is BIND(C)",
1600 sym
->name
, sym
->common_block
->name
,
1601 sym
->common_block
->name
);
1606 sym
->attr
.implied_index
= 0;
1608 /* Use the parameter expressions for a parameterized derived type. */
1609 if ((sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
1610 && sym
->ts
.u
.derived
->attr
.pdt_type
&& type_param_spec_list
)
1611 sym
->param_list
= gfc_copy_actual_arglist (type_param_spec_list
);
1613 if (sym
->ts
.type
== BT_CLASS
)
1614 return gfc_build_class_symbol (&sym
->ts
, &sym
->attr
, &sym
->as
);
1620 /* Set character constant to the given length. The constant will be padded or
1621 truncated. If we're inside an array constructor without a typespec, we
1622 additionally check that all elements have the same length; check_len -1
1623 means no checking. */
1626 gfc_set_constant_character_len (gfc_charlen_t len
, gfc_expr
*expr
,
1627 gfc_charlen_t check_len
)
1632 if (expr
->ts
.type
!= BT_CHARACTER
)
1635 if (expr
->expr_type
!= EXPR_CONSTANT
)
1637 gfc_error_now ("CHARACTER length must be a constant at %L", &expr
->where
);
1641 slen
= expr
->value
.character
.length
;
1644 s
= gfc_get_wide_string (len
+ 1);
1645 memcpy (s
, expr
->value
.character
.string
,
1646 MIN (len
, slen
) * sizeof (gfc_char_t
));
1648 gfc_wide_memset (&s
[slen
], ' ', len
- slen
);
1650 if (warn_character_truncation
&& slen
> len
)
1651 gfc_warning_now (OPT_Wcharacter_truncation
,
1652 "CHARACTER expression at %L is being truncated "
1653 "(%ld/%ld)", &expr
->where
,
1654 (long) slen
, (long) len
);
1656 /* Apply the standard by 'hand' otherwise it gets cleared for
1658 if (check_len
!= -1 && slen
!= check_len
1659 && !(gfc_option
.allow_std
& GFC_STD_GNU
))
1660 gfc_error_now ("The CHARACTER elements of the array constructor "
1661 "at %L must have the same length (%ld/%ld)",
1662 &expr
->where
, (long) slen
,
1666 free (expr
->value
.character
.string
);
1667 expr
->value
.character
.string
= s
;
1668 expr
->value
.character
.length
= len
;
1673 /* Function to create and update the enumerator history
1674 using the information passed as arguments.
1675 Pointer "max_enum" is also updated, to point to
1676 enum history node containing largest initializer.
1678 SYM points to the symbol node of enumerator.
1679 INIT points to its enumerator value. */
1682 create_enum_history (gfc_symbol
*sym
, gfc_expr
*init
)
1684 enumerator_history
*new_enum_history
;
1685 gcc_assert (sym
!= NULL
&& init
!= NULL
);
1687 new_enum_history
= XCNEW (enumerator_history
);
1689 new_enum_history
->sym
= sym
;
1690 new_enum_history
->initializer
= init
;
1691 new_enum_history
->next
= NULL
;
1693 if (enum_history
== NULL
)
1695 enum_history
= new_enum_history
;
1696 max_enum
= enum_history
;
1700 new_enum_history
->next
= enum_history
;
1701 enum_history
= new_enum_history
;
1703 if (mpz_cmp (max_enum
->initializer
->value
.integer
,
1704 new_enum_history
->initializer
->value
.integer
) < 0)
1705 max_enum
= new_enum_history
;
1710 /* Function to free enum kind history. */
1713 gfc_free_enum_history (void)
1715 enumerator_history
*current
= enum_history
;
1716 enumerator_history
*next
;
1718 while (current
!= NULL
)
1720 next
= current
->next
;
1725 enum_history
= NULL
;
1729 /* Function called by variable_decl() that adds an initialization
1730 expression to a symbol. */
1733 add_init_expr_to_sym (const char *name
, gfc_expr
**initp
, locus
*var_locus
)
1735 symbol_attribute attr
;
1740 if (find_special (name
, &sym
, false))
1745 /* If this symbol is confirming an implicit parameter type,
1746 then an initialization expression is not allowed. */
1747 if (attr
.flavor
== FL_PARAMETER
1748 && sym
->value
!= NULL
1751 gfc_error ("Initializer not allowed for PARAMETER %qs at %C",
1758 /* An initializer is required for PARAMETER declarations. */
1759 if (attr
.flavor
== FL_PARAMETER
)
1761 gfc_error ("PARAMETER at %L is missing an initializer", var_locus
);
1767 /* If a variable appears in a DATA block, it cannot have an
1771 gfc_error ("Variable %qs at %C with an initializer already "
1772 "appears in a DATA statement", sym
->name
);
1776 /* Check if the assignment can happen. This has to be put off
1777 until later for derived type variables and procedure pointers. */
1778 if (!gfc_bt_struct (sym
->ts
.type
) && !gfc_bt_struct (init
->ts
.type
)
1779 && sym
->ts
.type
!= BT_CLASS
&& init
->ts
.type
!= BT_CLASS
1780 && !sym
->attr
.proc_pointer
1781 && !gfc_check_assign_symbol (sym
, NULL
, init
))
1784 if (sym
->ts
.type
== BT_CHARACTER
&& sym
->ts
.u
.cl
1785 && init
->ts
.type
== BT_CHARACTER
)
1787 /* Update symbol character length according initializer. */
1788 if (!gfc_check_assign_symbol (sym
, NULL
, init
))
1791 if (sym
->ts
.u
.cl
->length
== NULL
)
1794 /* If there are multiple CHARACTER variables declared on the
1795 same line, we don't want them to share the same length. */
1796 sym
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1798 if (sym
->attr
.flavor
== FL_PARAMETER
)
1800 if (init
->expr_type
== EXPR_CONSTANT
)
1802 clen
= init
->value
.character
.length
;
1803 sym
->ts
.u
.cl
->length
1804 = gfc_get_int_expr (gfc_charlen_int_kind
,
1807 else if (init
->expr_type
== EXPR_ARRAY
)
1809 if (init
->ts
.u
.cl
&& init
->ts
.u
.cl
->length
)
1811 const gfc_expr
*length
= init
->ts
.u
.cl
->length
;
1812 if (length
->expr_type
!= EXPR_CONSTANT
)
1814 gfc_error ("Cannot initialize parameter array "
1816 "with variable length elements",
1820 clen
= mpz_get_si (length
->value
.integer
);
1822 else if (init
->value
.constructor
)
1825 c
= gfc_constructor_first (init
->value
.constructor
);
1826 clen
= c
->expr
->value
.character
.length
;
1830 sym
->ts
.u
.cl
->length
1831 = gfc_get_int_expr (gfc_charlen_int_kind
,
1834 else if (init
->ts
.u
.cl
&& init
->ts
.u
.cl
->length
)
1835 sym
->ts
.u
.cl
->length
=
1836 gfc_copy_expr (sym
->value
->ts
.u
.cl
->length
);
1839 /* Update initializer character length according symbol. */
1840 else if (sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1842 if (!gfc_specification_expr (sym
->ts
.u
.cl
->length
))
1845 int k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
,
1847 /* resolve_charlen will complain later on if the length
1848 is too large. Just skeep the initialization in that case. */
1849 if (mpz_cmp (sym
->ts
.u
.cl
->length
->value
.integer
,
1850 gfc_integer_kinds
[k
].huge
) <= 0)
1853 = gfc_mpz_get_hwi (sym
->ts
.u
.cl
->length
->value
.integer
);
1855 if (init
->expr_type
== EXPR_CONSTANT
)
1856 gfc_set_constant_character_len (len
, init
, -1);
1857 else if (init
->expr_type
== EXPR_ARRAY
)
1861 /* Build a new charlen to prevent simplification from
1862 deleting the length before it is resolved. */
1863 init
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1864 init
->ts
.u
.cl
->length
1865 = gfc_copy_expr (sym
->ts
.u
.cl
->length
);
1867 for (c
= gfc_constructor_first (init
->value
.constructor
);
1868 c
; c
= gfc_constructor_next (c
))
1869 gfc_set_constant_character_len (len
, c
->expr
, -1);
1875 /* If sym is implied-shape, set its upper bounds from init. */
1876 if (sym
->attr
.flavor
== FL_PARAMETER
&& sym
->attr
.dimension
1877 && sym
->as
->type
== AS_IMPLIED_SHAPE
)
1881 if (init
->rank
== 0)
1883 gfc_error ("Can't initialize implied-shape array at %L"
1884 " with scalar", &sym
->declared_at
);
1888 /* Shape should be present, we get an initialization expression. */
1889 gcc_assert (init
->shape
);
1891 for (dim
= 0; dim
< sym
->as
->rank
; ++dim
)
1894 gfc_expr
*e
, *lower
;
1896 lower
= sym
->as
->lower
[dim
];
1898 /* If the lower bound is an array element from another
1899 parameterized array, then it is marked with EXPR_VARIABLE and
1900 is an initialization expression. Try to reduce it. */
1901 if (lower
->expr_type
== EXPR_VARIABLE
)
1902 gfc_reduce_init_expr (lower
);
1904 if (lower
->expr_type
== EXPR_CONSTANT
)
1906 /* All dimensions must be without upper bound. */
1907 gcc_assert (!sym
->as
->upper
[dim
]);
1910 e
= gfc_get_constant_expr (BT_INTEGER
, k
, &sym
->declared_at
);
1911 mpz_add (e
->value
.integer
, lower
->value
.integer
,
1913 mpz_sub_ui (e
->value
.integer
, e
->value
.integer
, 1);
1914 sym
->as
->upper
[dim
] = e
;
1918 gfc_error ("Non-constant lower bound in implied-shape"
1919 " declaration at %L", &lower
->where
);
1924 sym
->as
->type
= AS_EXPLICIT
;
1927 /* Need to check if the expression we initialized this
1928 to was one of the iso_c_binding named constants. If so,
1929 and we're a parameter (constant), let it be iso_c.
1931 integer(c_int), parameter :: my_int = c_int
1932 integer(my_int) :: my_int_2
1933 If we mark my_int as iso_c (since we can see it's value
1934 is equal to one of the named constants), then my_int_2
1935 will be considered C interoperable. */
1936 if (sym
->ts
.type
!= BT_CHARACTER
&& !gfc_bt_struct (sym
->ts
.type
))
1938 sym
->ts
.is_iso_c
|= init
->ts
.is_iso_c
;
1939 sym
->ts
.is_c_interop
|= init
->ts
.is_c_interop
;
1940 /* attr bits needed for module files. */
1941 sym
->attr
.is_iso_c
|= init
->ts
.is_iso_c
;
1942 sym
->attr
.is_c_interop
|= init
->ts
.is_c_interop
;
1943 if (init
->ts
.is_iso_c
)
1944 sym
->ts
.f90_type
= init
->ts
.f90_type
;
1947 /* Add initializer. Make sure we keep the ranks sane. */
1948 if (sym
->attr
.dimension
&& init
->rank
== 0)
1953 if (sym
->attr
.flavor
== FL_PARAMETER
1954 && init
->expr_type
== EXPR_CONSTANT
1955 && spec_size (sym
->as
, &size
)
1956 && mpz_cmp_si (size
, 0) > 0)
1958 array
= gfc_get_array_expr (init
->ts
.type
, init
->ts
.kind
,
1960 for (n
= 0; n
< (int)mpz_get_si (size
); n
++)
1961 gfc_constructor_append_expr (&array
->value
.constructor
,
1964 : gfc_copy_expr (init
),
1967 array
->shape
= gfc_get_shape (sym
->as
->rank
);
1968 for (n
= 0; n
< sym
->as
->rank
; n
++)
1969 spec_dimen_size (sym
->as
, n
, &array
->shape
[n
]);
1974 init
->rank
= sym
->as
->rank
;
1978 if (sym
->attr
.save
== SAVE_NONE
)
1979 sym
->attr
.save
= SAVE_IMPLICIT
;
1987 /* Function called by variable_decl() that adds a name to a structure
1991 build_struct (const char *name
, gfc_charlen
*cl
, gfc_expr
**init
,
1992 gfc_array_spec
**as
)
1997 /* F03:C438/C439. If the current symbol is of the same derived type that we're
1998 constructing, it must have the pointer attribute. */
1999 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
2000 && current_ts
.u
.derived
== gfc_current_block ()
2001 && current_attr
.pointer
== 0)
2003 if (current_attr
.allocatable
2004 && !gfc_notify_std(GFC_STD_F2008
, "Component at %C "
2005 "must have the POINTER attribute"))
2009 else if (current_attr
.allocatable
== 0)
2011 gfc_error ("Component at %C must have the POINTER attribute");
2017 if (current_ts
.type
== BT_CLASS
2018 && !(current_attr
.pointer
|| current_attr
.allocatable
))
2020 gfc_error ("Component %qs with CLASS at %C must be allocatable "
2021 "or pointer", name
);
2025 if (gfc_current_block ()->attr
.pointer
&& (*as
)->rank
!= 0)
2027 if ((*as
)->type
!= AS_DEFERRED
&& (*as
)->type
!= AS_EXPLICIT
)
2029 gfc_error ("Array component of structure at %C must have explicit "
2030 "or deferred shape");
2035 /* If we are in a nested union/map definition, gfc_add_component will not
2036 properly find repeated components because:
2037 (i) gfc_add_component does a flat search, where components of unions
2038 and maps are implicity chained so nested components may conflict.
2039 (ii) Unions and maps are not linked as components of their parent
2040 structures until after they are parsed.
2041 For (i) we use gfc_find_component which searches recursively, and for (ii)
2042 we search each block directly from the parse stack until we find the top
2045 s
= gfc_state_stack
;
2046 if (s
->state
== COMP_UNION
|| s
->state
== COMP_MAP
)
2048 while (s
->state
== COMP_UNION
|| gfc_comp_struct (s
->state
))
2050 c
= gfc_find_component (s
->sym
, name
, true, true, NULL
);
2053 gfc_error_now ("Component %qs at %C already declared at %L",
2057 /* Break after we've searched the entire chain. */
2058 if (s
->state
== COMP_DERIVED
|| s
->state
== COMP_STRUCTURE
)
2064 if (!gfc_add_component (gfc_current_block(), name
, &c
))
2068 if (c
->ts
.type
== BT_CHARACTER
)
2071 if (c
->ts
.type
!= BT_CLASS
&& c
->ts
.type
!= BT_DERIVED
2072 && (c
->ts
.kind
== 0 || c
->ts
.type
== BT_CHARACTER
)
2073 && saved_kind_expr
!= NULL
)
2074 c
->kind_expr
= gfc_copy_expr (saved_kind_expr
);
2076 c
->attr
= current_attr
;
2078 c
->initializer
= *init
;
2085 c
->attr
.codimension
= 1;
2087 c
->attr
.dimension
= 1;
2091 gfc_apply_init (&c
->ts
, &c
->attr
, c
->initializer
);
2093 /* Check array components. */
2094 if (!c
->attr
.dimension
)
2097 if (c
->attr
.pointer
)
2099 if (c
->as
->type
!= AS_DEFERRED
)
2101 gfc_error ("Pointer array component of structure at %C must have a "
2106 else if (c
->attr
.allocatable
)
2108 if (c
->as
->type
!= AS_DEFERRED
)
2110 gfc_error ("Allocatable component of structure at %C must have a "
2117 if (c
->as
->type
!= AS_EXPLICIT
)
2119 gfc_error ("Array component of structure at %C must have an "
2126 if (c
->ts
.type
== BT_CLASS
)
2127 return gfc_build_class_symbol (&c
->ts
, &c
->attr
, &c
->as
);
2129 if (c
->attr
.pdt_kind
|| c
->attr
.pdt_len
)
2132 gfc_find_symbol (c
->name
, gfc_current_block ()->f2k_derived
,
2136 gfc_error ("Type parameter %qs at %C has no corresponding entry "
2137 "in the type parameter name list at %L",
2138 c
->name
, &gfc_current_block ()->declared_at
);
2142 sym
->attr
.pdt_kind
= c
->attr
.pdt_kind
;
2143 sym
->attr
.pdt_len
= c
->attr
.pdt_len
;
2145 sym
->value
= gfc_copy_expr (c
->initializer
);
2146 sym
->attr
.flavor
= FL_VARIABLE
;
2149 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
2150 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_template
2151 && decl_type_param_list
)
2152 c
->param_list
= gfc_copy_actual_arglist (decl_type_param_list
);
2158 /* Match a 'NULL()', and possibly take care of some side effects. */
2161 gfc_match_null (gfc_expr
**result
)
2164 match m
, m2
= MATCH_NO
;
2166 if ((m
= gfc_match (" null ( )")) == MATCH_ERROR
)
2172 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2174 if ((m2
= gfc_match (" null (")) != MATCH_YES
)
2177 old_loc
= gfc_current_locus
;
2178 if ((m2
= gfc_match (" %n ) ", name
)) == MATCH_ERROR
)
2181 && ((m2
= gfc_match (" mold = %n )", name
)) == MATCH_ERROR
))
2185 gfc_current_locus
= old_loc
;
2190 /* The NULL symbol now has to be/become an intrinsic function. */
2191 if (gfc_get_symbol ("null", NULL
, &sym
))
2193 gfc_error ("NULL() initialization at %C is ambiguous");
2197 gfc_intrinsic_symbol (sym
);
2199 if (sym
->attr
.proc
!= PROC_INTRINSIC
2200 && !(sym
->attr
.use_assoc
&& sym
->attr
.intrinsic
)
2201 && (!gfc_add_procedure(&sym
->attr
, PROC_INTRINSIC
, sym
->name
, NULL
)
2202 || !gfc_add_function (&sym
->attr
, sym
->name
, NULL
)))
2205 *result
= gfc_get_null_expr (&gfc_current_locus
);
2207 /* Invalid per F2008, C512. */
2208 if (m2
== MATCH_YES
)
2210 gfc_error ("NULL() initialization at %C may not have MOLD");
2218 /* Match the initialization expr for a data pointer or procedure pointer. */
2221 match_pointer_init (gfc_expr
**init
, int procptr
)
2225 if (gfc_pure (NULL
) && !gfc_comp_struct (gfc_state_stack
->state
))
2227 gfc_error ("Initialization of pointer at %C is not allowed in "
2228 "a PURE procedure");
2231 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
2233 /* Match NULL() initialization. */
2234 m
= gfc_match_null (init
);
2238 /* Match non-NULL initialization. */
2239 gfc_matching_ptr_assignment
= !procptr
;
2240 gfc_matching_procptr_assignment
= procptr
;
2241 m
= gfc_match_rvalue (init
);
2242 gfc_matching_ptr_assignment
= 0;
2243 gfc_matching_procptr_assignment
= 0;
2244 if (m
== MATCH_ERROR
)
2246 else if (m
== MATCH_NO
)
2248 gfc_error ("Error in pointer initialization at %C");
2252 if (!procptr
&& !gfc_resolve_expr (*init
))
2255 if (!gfc_notify_std (GFC_STD_F2008
, "non-NULL pointer "
2256 "initialization at %C"))
2264 check_function_name (char *name
)
2266 /* In functions that have a RESULT variable defined, the function name always
2267 refers to function calls. Therefore, the name is not allowed to appear in
2268 specification statements. When checking this, be careful about
2269 'hidden' procedure pointer results ('ppr@'). */
2271 if (gfc_current_state () == COMP_FUNCTION
)
2273 gfc_symbol
*block
= gfc_current_block ();
2274 if (block
&& block
->result
&& block
->result
!= block
2275 && strcmp (block
->result
->name
, "ppr@") != 0
2276 && strcmp (block
->name
, name
) == 0)
2278 gfc_error ("RESULT variable %qs at %L prohibits FUNCTION name %qs at %C "
2279 "from appearing in a specification statement",
2280 block
->result
->name
, &block
->result
->declared_at
, name
);
2289 /* Match a variable name with an optional initializer. When this
2290 subroutine is called, a variable is expected to be parsed next.
2291 Depending on what is happening at the moment, updates either the
2292 symbol table or the current interface. */
2295 variable_decl (int elem
)
2297 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2298 static unsigned int fill_id
= 0;
2299 gfc_expr
*initializer
, *char_len
;
2301 gfc_array_spec
*cp_as
; /* Extra copy for Cray Pointees. */
2313 /* When we get here, we've just matched a list of attributes and
2314 maybe a type and a double colon. The next thing we expect to see
2315 is the name of the symbol. */
2317 /* If we are parsing a structure with legacy support, we allow the symbol
2318 name to be '%FILL' which gives it an anonymous (inaccessible) name. */
2320 gfc_gobble_whitespace ();
2321 if (gfc_peek_ascii_char () == '%')
2323 gfc_next_ascii_char ();
2324 m
= gfc_match ("fill");
2329 m
= gfc_match_name (name
);
2337 if (gfc_current_state () != COMP_STRUCTURE
)
2339 if (flag_dec_structure
)
2340 gfc_error ("%qs not allowed outside STRUCTURE at %C", "%FILL");
2342 gfc_error ("%qs at %C is a DEC extension, enable with "
2343 "%<-fdec-structure%>", "%FILL");
2349 gfc_error ("%qs entity cannot have attributes at %C", "%FILL");
2353 /* %FILL components are given invalid fortran names. */
2354 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "%%FILL%u", fill_id
++);
2358 var_locus
= gfc_current_locus
;
2360 /* Now we could see the optional array spec. or character length. */
2361 m
= gfc_match_array_spec (&as
, true, true);
2362 if (m
== MATCH_ERROR
)
2366 as
= gfc_copy_array_spec (current_as
);
2368 && !merge_array_spec (current_as
, as
, true))
2374 if (flag_cray_pointer
)
2375 cp_as
= gfc_copy_array_spec (as
);
2377 /* At this point, we know for sure if the symbol is PARAMETER and can thus
2378 determine (and check) whether it can be implied-shape. If it
2379 was parsed as assumed-size, change it because PARAMETERs can not
2382 An explicit-shape-array cannot appear under several conditions.
2383 That check is done here as well. */
2386 if (as
->type
== AS_IMPLIED_SHAPE
&& current_attr
.flavor
!= FL_PARAMETER
)
2389 gfc_error ("Non-PARAMETER symbol %qs at %L can't be implied-shape",
2394 if (as
->type
== AS_ASSUMED_SIZE
&& as
->rank
== 1
2395 && current_attr
.flavor
== FL_PARAMETER
)
2396 as
->type
= AS_IMPLIED_SHAPE
;
2398 if (as
->type
== AS_IMPLIED_SHAPE
2399 && !gfc_notify_std (GFC_STD_F2008
, "Implied-shape array at %L",
2406 /* F2018:C830 (R816) An explicit-shape-spec whose bounds are not
2407 constant expressions shall appear only in a subprogram, derived
2408 type definition, BLOCK construct, or interface body. */
2409 if (as
->type
== AS_EXPLICIT
2410 && gfc_current_state () != COMP_BLOCK
2411 && gfc_current_state () != COMP_DERIVED
2412 && gfc_current_state () != COMP_FUNCTION
2413 && gfc_current_state () != COMP_INTERFACE
2414 && gfc_current_state () != COMP_SUBROUTINE
)
2417 bool not_constant
= false;
2419 for (int i
= 0; i
< as
->rank
; i
++)
2421 e
= gfc_copy_expr (as
->lower
[i
]);
2422 gfc_resolve_expr (e
);
2423 gfc_simplify_expr (e
, 0);
2424 if (e
&& (e
->expr_type
!= EXPR_CONSTANT
))
2426 not_constant
= true;
2431 e
= gfc_copy_expr (as
->upper
[i
]);
2432 gfc_resolve_expr (e
);
2433 gfc_simplify_expr (e
, 0);
2434 if (e
&& (e
->expr_type
!= EXPR_CONSTANT
))
2436 not_constant
= true;
2444 gfc_error ("Explicit shaped array with nonconstant bounds at %C");
2449 if (as
->type
== AS_EXPLICIT
)
2451 for (int i
= 0; i
< as
->rank
; i
++)
2455 if (e
->expr_type
!= EXPR_CONSTANT
)
2457 n
= gfc_copy_expr (e
);
2458 gfc_simplify_expr (n
, 1);
2459 if (n
->expr_type
== EXPR_CONSTANT
)
2460 gfc_replace_expr (e
, n
);
2465 if (e
->expr_type
!= EXPR_CONSTANT
)
2467 n
= gfc_copy_expr (e
);
2468 gfc_simplify_expr (n
, 1);
2469 if (n
->expr_type
== EXPR_CONSTANT
)
2470 gfc_replace_expr (e
, n
);
2480 cl_deferred
= false;
2482 if (current_ts
.type
== BT_CHARACTER
)
2484 switch (match_char_length (&char_len
, &cl_deferred
, false))
2487 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2489 cl
->length
= char_len
;
2492 /* Non-constant lengths need to be copied after the first
2493 element. Also copy assumed lengths. */
2496 && (current_ts
.u
.cl
->length
== NULL
2497 || current_ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
2499 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2500 cl
->length
= gfc_copy_expr (current_ts
.u
.cl
->length
);
2503 cl
= current_ts
.u
.cl
;
2505 cl_deferred
= current_ts
.deferred
;
2514 /* The dummy arguments and result of the abreviated form of MODULE
2515 PROCEDUREs, used in SUBMODULES should not be redefined. */
2516 if (gfc_current_ns
->proc_name
2517 && gfc_current_ns
->proc_name
->abr_modproc_decl
)
2519 gfc_find_symbol (name
, gfc_current_ns
, 1, &sym
);
2520 if (sym
!= NULL
&& (sym
->attr
.dummy
|| sym
->attr
.result
))
2523 gfc_error ("%qs at %C is a redefinition of the declaration "
2524 "in the corresponding interface for MODULE "
2525 "PROCEDURE %qs", sym
->name
,
2526 gfc_current_ns
->proc_name
->name
);
2531 /* %FILL components may not have initializers. */
2532 if (gfc_str_startswith (name
, "%FILL") && gfc_match_eos () != MATCH_YES
)
2534 gfc_error ("%qs entity cannot have an initializer at %C", "%FILL");
2539 /* If this symbol has already shown up in a Cray Pointer declaration,
2540 and this is not a component declaration,
2541 then we want to set the type & bail out. */
2542 if (flag_cray_pointer
&& !gfc_comp_struct (gfc_current_state ()))
2544 gfc_find_symbol (name
, gfc_current_ns
, 1, &sym
);
2545 if (sym
!= NULL
&& sym
->attr
.cray_pointee
)
2548 if (!gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
2554 /* Check to see if we have an array specification. */
2557 if (sym
->as
!= NULL
)
2559 gfc_error ("Duplicate array spec for Cray pointee at %C");
2560 gfc_free_array_spec (cp_as
);
2566 if (!gfc_set_array_spec (sym
, cp_as
, &var_locus
))
2567 gfc_internal_error ("Couldn't set pointee array spec.");
2569 /* Fix the array spec. */
2570 m
= gfc_mod_pointee_as (sym
->as
);
2571 if (m
== MATCH_ERROR
)
2579 gfc_free_array_spec (cp_as
);
2583 /* Procedure pointer as function result. */
2584 if (gfc_current_state () == COMP_FUNCTION
2585 && strcmp ("ppr@", gfc_current_block ()->name
) == 0
2586 && strcmp (name
, gfc_current_block ()->ns
->proc_name
->name
) == 0)
2587 strcpy (name
, "ppr@");
2589 if (gfc_current_state () == COMP_FUNCTION
2590 && strcmp (name
, gfc_current_block ()->name
) == 0
2591 && gfc_current_block ()->result
2592 && strcmp ("ppr@", gfc_current_block ()->result
->name
) == 0)
2593 strcpy (name
, "ppr@");
2595 /* OK, we've successfully matched the declaration. Now put the
2596 symbol in the current namespace, because it might be used in the
2597 optional initialization expression for this symbol, e.g. this is
2600 integer, parameter :: i = huge(i)
2602 This is only true for parameters or variables of a basic type.
2603 For components of derived types, it is not true, so we don't
2604 create a symbol for those yet. If we fail to create the symbol,
2606 if (!gfc_comp_struct (gfc_current_state ())
2607 && !build_sym (name
, cl
, cl_deferred
, &as
, &var_locus
))
2613 if (!check_function_name (name
))
2619 /* We allow old-style initializations of the form
2620 integer i /2/, j(4) /3*3, 1/
2621 (if no colon has been seen). These are different from data
2622 statements in that initializers are only allowed to apply to the
2623 variable immediately preceding, i.e.
2625 is not allowed. Therefore we have to do some work manually, that
2626 could otherwise be left to the matchers for DATA statements. */
2628 if (!colon_seen
&& gfc_match (" /") == MATCH_YES
)
2630 if (!gfc_notify_std (GFC_STD_GNU
, "Old-style "
2631 "initialization at %C"))
2634 /* Allow old style initializations for components of STRUCTUREs and MAPs
2635 but not components of derived types. */
2636 else if (gfc_current_state () == COMP_DERIVED
)
2638 gfc_error ("Invalid old style initialization for derived type "
2644 /* For structure components, read the initializer as a special
2645 expression and let the rest of this function apply the initializer
2647 else if (gfc_comp_struct (gfc_current_state ()))
2649 m
= match_clist_expr (&initializer
, ¤t_ts
, as
);
2651 gfc_error ("Syntax error in old style initialization of %s at %C",
2657 /* Otherwise we treat the old style initialization just like a
2658 DATA declaration for the current variable. */
2660 return match_old_style_init (name
);
2663 /* The double colon must be present in order to have initializers.
2664 Otherwise the statement is ambiguous with an assignment statement. */
2667 if (gfc_match (" =>") == MATCH_YES
)
2669 if (!current_attr
.pointer
)
2671 gfc_error ("Initialization at %C isn't for a pointer variable");
2676 m
= match_pointer_init (&initializer
, 0);
2680 else if (gfc_match_char ('=') == MATCH_YES
)
2682 if (current_attr
.pointer
)
2684 gfc_error ("Pointer initialization at %C requires %<=>%>, "
2690 m
= gfc_match_init_expr (&initializer
);
2693 gfc_error ("Expected an initialization expression at %C");
2697 if (current_attr
.flavor
!= FL_PARAMETER
&& gfc_pure (NULL
)
2698 && !gfc_comp_struct (gfc_state_stack
->state
))
2700 gfc_error ("Initialization of variable at %C is not allowed in "
2701 "a PURE procedure");
2705 if (current_attr
.flavor
!= FL_PARAMETER
2706 && !gfc_comp_struct (gfc_state_stack
->state
))
2707 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
2714 if (initializer
!= NULL
&& current_attr
.allocatable
2715 && gfc_comp_struct (gfc_current_state ()))
2717 gfc_error ("Initialization of allocatable component at %C is not "
2723 if (gfc_current_state () == COMP_DERIVED
2724 && gfc_current_block ()->attr
.pdt_template
)
2727 gfc_find_symbol (name
, gfc_current_block ()->f2k_derived
,
2729 if (!param
&& (current_attr
.pdt_kind
|| current_attr
.pdt_len
))
2731 gfc_error ("The component with KIND or LEN attribute at %C does not "
2732 "not appear in the type parameter list at %L",
2733 &gfc_current_block ()->declared_at
);
2737 else if (param
&& !(current_attr
.pdt_kind
|| current_attr
.pdt_len
))
2739 gfc_error ("The component at %C that appears in the type parameter "
2740 "list at %L has neither the KIND nor LEN attribute",
2741 &gfc_current_block ()->declared_at
);
2745 else if (as
&& (current_attr
.pdt_kind
|| current_attr
.pdt_len
))
2747 gfc_error ("The component at %C which is a type parameter must be "
2752 else if (param
&& initializer
)
2753 param
->value
= gfc_copy_expr (initializer
);
2756 /* Add the initializer. Note that it is fine if initializer is
2757 NULL here, because we sometimes also need to check if a
2758 declaration *must* have an initialization expression. */
2759 if (!gfc_comp_struct (gfc_current_state ()))
2760 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
2763 if (current_ts
.type
== BT_DERIVED
2764 && !current_attr
.pointer
&& !initializer
)
2765 initializer
= gfc_default_initializer (¤t_ts
);
2766 t
= build_struct (name
, cl
, &initializer
, &as
);
2768 /* If we match a nested structure definition we expect to see the
2769 * body even if the variable declarations blow up, so we need to keep
2770 * the structure declaration around. */
2771 if (gfc_new_block
&& gfc_new_block
->attr
.flavor
== FL_STRUCT
)
2772 gfc_commit_symbol (gfc_new_block
);
2775 m
= (t
) ? MATCH_YES
: MATCH_ERROR
;
2778 /* Free stuff up and return. */
2779 gfc_free_expr (initializer
);
2780 gfc_free_array_spec (as
);
2786 /* Match an extended-f77 "TYPESPEC*bytesize"-style kind specification.
2787 This assumes that the byte size is equal to the kind number for
2788 non-COMPLEX types, and equal to twice the kind number for COMPLEX. */
2791 gfc_match_old_kind_spec (gfc_typespec
*ts
)
2796 if (gfc_match_char ('*') != MATCH_YES
)
2799 m
= gfc_match_small_literal_int (&ts
->kind
, NULL
);
2803 original_kind
= ts
->kind
;
2805 /* Massage the kind numbers for complex types. */
2806 if (ts
->type
== BT_COMPLEX
)
2810 gfc_error ("Old-style type declaration %s*%d not supported at %C",
2811 gfc_basic_typename (ts
->type
), original_kind
);
2818 if (ts
->type
== BT_INTEGER
&& ts
->kind
== 4 && flag_integer4_kind
== 8)
2821 if (ts
->type
== BT_REAL
|| ts
->type
== BT_COMPLEX
)
2825 if (flag_real4_kind
== 8)
2827 if (flag_real4_kind
== 10)
2829 if (flag_real4_kind
== 16)
2835 if (flag_real8_kind
== 4)
2837 if (flag_real8_kind
== 10)
2839 if (flag_real8_kind
== 16)
2844 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
2846 gfc_error ("Old-style type declaration %s*%d not supported at %C",
2847 gfc_basic_typename (ts
->type
), original_kind
);
2851 if (!gfc_notify_std (GFC_STD_GNU
,
2852 "Nonstandard type declaration %s*%d at %C",
2853 gfc_basic_typename(ts
->type
), original_kind
))
2860 /* Match a kind specification. Since kinds are generally optional, we
2861 usually return MATCH_NO if something goes wrong. If a "kind="
2862 string is found, then we know we have an error. */
2865 gfc_match_kind_spec (gfc_typespec
*ts
, bool kind_expr_only
)
2875 saved_kind_expr
= NULL
;
2877 where
= loc
= gfc_current_locus
;
2882 if (gfc_match_char ('(') == MATCH_NO
)
2885 /* Also gobbles optional text. */
2886 if (gfc_match (" kind = ") == MATCH_YES
)
2889 loc
= gfc_current_locus
;
2893 n
= gfc_match_init_expr (&e
);
2895 if (gfc_derived_parameter_expr (e
))
2898 saved_kind_expr
= gfc_copy_expr (e
);
2899 goto close_brackets
;
2904 if (gfc_matching_function
)
2906 /* The function kind expression might include use associated or
2907 imported parameters and try again after the specification
2909 if (gfc_match_char (')') != MATCH_YES
)
2911 gfc_error ("Missing right parenthesis at %C");
2917 gfc_undo_symbols ();
2922 /* ....or else, the match is real. */
2924 gfc_error ("Expected initialization expression at %C");
2932 gfc_error ("Expected scalar initialization expression at %C");
2937 if (gfc_extract_int (e
, &ts
->kind
, 1))
2943 /* Before throwing away the expression, let's see if we had a
2944 C interoperable kind (and store the fact). */
2945 if (e
->ts
.is_c_interop
== 1)
2947 /* Mark this as C interoperable if being declared with one
2948 of the named constants from iso_c_binding. */
2949 ts
->is_c_interop
= e
->ts
.is_iso_c
;
2950 ts
->f90_type
= e
->ts
.f90_type
;
2952 ts
->interop_kind
= e
->symtree
->n
.sym
;
2958 /* Ignore errors to this point, if we've gotten here. This means
2959 we ignore the m=MATCH_ERROR from above. */
2960 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
2962 gfc_error ("Kind %d not supported for type %s at %C", ts
->kind
,
2963 gfc_basic_typename (ts
->type
));
2964 gfc_current_locus
= where
;
2968 /* Warn if, e.g., c_int is used for a REAL variable, but not
2969 if, e.g., c_double is used for COMPLEX as the standard
2970 explicitly says that the kind type parameter for complex and real
2971 variable is the same, i.e. c_float == c_float_complex. */
2972 if (ts
->f90_type
!= BT_UNKNOWN
&& ts
->f90_type
!= ts
->type
2973 && !((ts
->f90_type
== BT_REAL
&& ts
->type
== BT_COMPLEX
)
2974 || (ts
->f90_type
== BT_COMPLEX
&& ts
->type
== BT_REAL
)))
2975 gfc_warning_now (0, "C kind type parameter is for type %s but type at %L "
2976 "is %s", gfc_basic_typename (ts
->f90_type
), &where
,
2977 gfc_basic_typename (ts
->type
));
2981 gfc_gobble_whitespace ();
2982 if ((c
= gfc_next_ascii_char ()) != ')'
2983 && (ts
->type
!= BT_CHARACTER
|| c
!= ','))
2985 if (ts
->type
== BT_CHARACTER
)
2986 gfc_error ("Missing right parenthesis or comma at %C");
2988 gfc_error ("Missing right parenthesis at %C");
2992 /* All tests passed. */
2995 if(m
== MATCH_ERROR
)
2996 gfc_current_locus
= where
;
2998 if (ts
->type
== BT_INTEGER
&& ts
->kind
== 4 && flag_integer4_kind
== 8)
3001 if (ts
->type
== BT_REAL
|| ts
->type
== BT_COMPLEX
)
3005 if (flag_real4_kind
== 8)
3007 if (flag_real4_kind
== 10)
3009 if (flag_real4_kind
== 16)
3015 if (flag_real8_kind
== 4)
3017 if (flag_real8_kind
== 10)
3019 if (flag_real8_kind
== 16)
3024 /* Return what we know from the test(s). */
3029 gfc_current_locus
= where
;
3035 match_char_kind (int * kind
, int * is_iso_c
)
3044 where
= gfc_current_locus
;
3046 n
= gfc_match_init_expr (&e
);
3048 if (n
!= MATCH_YES
&& gfc_matching_function
)
3050 /* The expression might include use-associated or imported
3051 parameters and try again after the specification
3054 gfc_undo_symbols ();
3059 gfc_error ("Expected initialization expression at %C");
3065 gfc_error ("Expected scalar initialization expression at %C");
3070 if (gfc_derived_parameter_expr (e
))
3072 saved_kind_expr
= e
;
3077 fail
= gfc_extract_int (e
, kind
, 1);
3078 *is_iso_c
= e
->ts
.is_iso_c
;
3087 /* Ignore errors to this point, if we've gotten here. This means
3088 we ignore the m=MATCH_ERROR from above. */
3089 if (gfc_validate_kind (BT_CHARACTER
, *kind
, true) < 0)
3091 gfc_error ("Kind %d is not supported for CHARACTER at %C", *kind
);
3095 /* All tests passed. */
3098 if (m
== MATCH_ERROR
)
3099 gfc_current_locus
= where
;
3101 /* Return what we know from the test(s). */
3106 gfc_current_locus
= where
;
3111 /* Match the various kind/length specifications in a CHARACTER
3112 declaration. We don't return MATCH_NO. */
3115 gfc_match_char_spec (gfc_typespec
*ts
)
3117 int kind
, seen_length
, is_iso_c
;
3129 /* Try the old-style specification first. */
3130 old_char_selector
= 0;
3132 m
= match_char_length (&len
, &deferred
, true);
3136 old_char_selector
= 1;
3141 m
= gfc_match_char ('(');
3144 m
= MATCH_YES
; /* Character without length is a single char. */
3148 /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ). */
3149 if (gfc_match (" kind =") == MATCH_YES
)
3151 m
= match_char_kind (&kind
, &is_iso_c
);
3153 if (m
== MATCH_ERROR
)
3158 if (gfc_match (" , len =") == MATCH_NO
)
3161 m
= char_len_param_value (&len
, &deferred
);
3164 if (m
== MATCH_ERROR
)
3171 /* Try to match "LEN = <len-param>" or "LEN = <len-param>, KIND = <int>". */
3172 if (gfc_match (" len =") == MATCH_YES
)
3174 m
= char_len_param_value (&len
, &deferred
);
3177 if (m
== MATCH_ERROR
)
3181 if (gfc_match_char (')') == MATCH_YES
)
3184 if (gfc_match (" , kind =") != MATCH_YES
)
3187 if (match_char_kind (&kind
, &is_iso_c
) == MATCH_ERROR
)
3193 /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ). */
3194 m
= char_len_param_value (&len
, &deferred
);
3197 if (m
== MATCH_ERROR
)
3201 m
= gfc_match_char (')');
3205 if (gfc_match_char (',') != MATCH_YES
)
3208 gfc_match (" kind ="); /* Gobble optional text. */
3210 m
= match_char_kind (&kind
, &is_iso_c
);
3211 if (m
== MATCH_ERROR
)
3217 /* Require a right-paren at this point. */
3218 m
= gfc_match_char (')');
3223 gfc_error ("Syntax error in CHARACTER declaration at %C");
3225 gfc_free_expr (len
);
3229 /* Deal with character functions after USE and IMPORT statements. */
3230 if (gfc_matching_function
)
3232 gfc_free_expr (len
);
3233 gfc_undo_symbols ();
3239 gfc_free_expr (len
);
3243 /* Do some final massaging of the length values. */
3244 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
3246 if (seen_length
== 0)
3247 cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
, 1);
3250 /* If gfortran ends up here, then len may be reducible to a constant.
3251 Try to do that here. If it does not reduce, simply assign len to
3252 charlen. A complication occurs with user-defined generic functions,
3253 which are not resolved. Use a private namespace to deal with
3254 generic functions. */
3256 if (len
&& len
->expr_type
!= EXPR_CONSTANT
)
3258 gfc_namespace
*old_ns
;
3261 old_ns
= gfc_current_ns
;
3262 gfc_current_ns
= gfc_get_namespace (NULL
, 0);
3264 e
= gfc_copy_expr (len
);
3265 gfc_reduce_init_expr (e
);
3266 if (e
->expr_type
== EXPR_CONSTANT
)
3268 gfc_replace_expr (len
, e
);
3269 if (mpz_cmp_si (len
->value
.integer
, 0) < 0)
3270 mpz_set_ui (len
->value
.integer
, 0);
3275 gfc_free_namespace (gfc_current_ns
);
3276 gfc_current_ns
= old_ns
;
3283 ts
->kind
= kind
== 0 ? gfc_default_character_kind
: kind
;
3284 ts
->deferred
= deferred
;
3286 /* We have to know if it was a C interoperable kind so we can
3287 do accurate type checking of bind(c) procs, etc. */
3289 /* Mark this as C interoperable if being declared with one
3290 of the named constants from iso_c_binding. */
3291 ts
->is_c_interop
= is_iso_c
;
3292 else if (len
!= NULL
)
3293 /* Here, we might have parsed something such as: character(c_char)
3294 In this case, the parsing code above grabs the c_char when
3295 looking for the length (line 1690, roughly). it's the last
3296 testcase for parsing the kind params of a character variable.
3297 However, it's not actually the length. this seems like it
3299 To see if the user used a C interop kind, test the expr
3300 of the so called length, and see if it's C interoperable. */
3301 ts
->is_c_interop
= len
->ts
.is_iso_c
;
3307 /* Matches a RECORD declaration. */
3310 match_record_decl (char *name
)
3313 old_loc
= gfc_current_locus
;
3316 m
= gfc_match (" record /");
3319 if (!flag_dec_structure
)
3321 gfc_current_locus
= old_loc
;
3322 gfc_error ("RECORD at %C is an extension, enable it with "
3326 m
= gfc_match (" %n/", name
);
3331 gfc_current_locus
= old_loc
;
3332 if (flag_dec_structure
3333 && (gfc_match (" record% ") == MATCH_YES
3334 || gfc_match (" record%t") == MATCH_YES
))
3335 gfc_error ("Structure name expected after RECORD at %C");
3343 /* This function uses the gfc_actual_arglist 'type_param_spec_list' as a source
3344 of expressions to substitute into the possibly parameterized expression
3345 'e'. Using a list is inefficient but should not be too bad since the
3346 number of type parameters is not likely to be large. */
3348 insert_parameter_exprs (gfc_expr
* e
, gfc_symbol
* sym ATTRIBUTE_UNUSED
,
3351 gfc_actual_arglist
*param
;
3354 if (e
->expr_type
!= EXPR_VARIABLE
)
3357 gcc_assert (e
->symtree
);
3358 if (e
->symtree
->n
.sym
->attr
.pdt_kind
3359 || (*f
!= 0 && e
->symtree
->n
.sym
->attr
.pdt_len
))
3361 for (param
= type_param_spec_list
; param
; param
= param
->next
)
3362 if (strcmp (e
->symtree
->n
.sym
->name
, param
->name
) == 0)
3367 copy
= gfc_copy_expr (param
->expr
);
3378 gfc_insert_kind_parameter_exprs (gfc_expr
*e
)
3380 return gfc_traverse_expr (e
, NULL
, &insert_parameter_exprs
, 0);
3385 gfc_insert_parameter_exprs (gfc_expr
*e
, gfc_actual_arglist
*param_list
)
3387 gfc_actual_arglist
*old_param_spec_list
= type_param_spec_list
;
3388 type_param_spec_list
= param_list
;
3389 return gfc_traverse_expr (e
, NULL
, &insert_parameter_exprs
, 1);
3390 type_param_spec_list
= NULL
;
3391 type_param_spec_list
= old_param_spec_list
;
3394 /* Determines the instance of a parameterized derived type to be used by
3395 matching determining the values of the kind parameters and using them
3396 in the name of the instance. If the instance exists, it is used, otherwise
3397 a new derived type is created. */
3399 gfc_get_pdt_instance (gfc_actual_arglist
*param_list
, gfc_symbol
**sym
,
3400 gfc_actual_arglist
**ext_param_list
)
3402 /* The PDT template symbol. */
3403 gfc_symbol
*pdt
= *sym
;
3404 /* The symbol for the parameter in the template f2k_namespace. */
3406 /* The hoped for instance of the PDT. */
3407 gfc_symbol
*instance
;
3408 /* The list of parameters appearing in the PDT declaration. */
3409 gfc_formal_arglist
*type_param_name_list
;
3410 /* Used to store the parameter specification list during recursive calls. */
3411 gfc_actual_arglist
*old_param_spec_list
;
3412 /* Pointers to the parameter specification being used. */
3413 gfc_actual_arglist
*actual_param
;
3414 gfc_actual_arglist
*tail
= NULL
;
3415 /* Used to build up the name of the PDT instance. The prefix uses 4
3416 characters and each KIND parameter 2 more. Allow 8 of the latter. */
3417 char name
[GFC_MAX_SYMBOL_LEN
+ 21];
3419 bool name_seen
= (param_list
== NULL
);
3420 bool assumed_seen
= false;
3421 bool deferred_seen
= false;
3422 bool spec_error
= false;
3424 gfc_expr
*kind_expr
;
3425 gfc_component
*c1
, *c2
;
3428 type_param_spec_list
= NULL
;
3430 type_param_name_list
= pdt
->formal
;
3431 actual_param
= param_list
;
3432 sprintf (name
, "Pdt%s", pdt
->name
);
3434 /* Run through the parameter name list and pick up the actual
3435 parameter values or use the default values in the PDT declaration. */
3436 for (; type_param_name_list
;
3437 type_param_name_list
= type_param_name_list
->next
)
3439 if (actual_param
&& actual_param
->spec_type
!= SPEC_EXPLICIT
)
3441 if (actual_param
->spec_type
== SPEC_ASSUMED
)
3442 spec_error
= deferred_seen
;
3444 spec_error
= assumed_seen
;
3448 gfc_error ("The type parameter spec list at %C cannot contain "
3449 "both ASSUMED and DEFERRED parameters");
3454 if (actual_param
&& actual_param
->name
)
3456 param
= type_param_name_list
->sym
;
3458 if (!param
|| !param
->name
)
3461 c1
= gfc_find_component (pdt
, param
->name
, false, true, NULL
);
3462 /* An error should already have been thrown in resolve.c
3463 (resolve_fl_derived0). */
3464 if (!pdt
->attr
.use_assoc
&& !c1
)
3470 if (!actual_param
&& !(c1
&& c1
->initializer
))
3472 gfc_error ("The type parameter spec list at %C does not contain "
3473 "enough parameter expressions");
3476 else if (!actual_param
&& c1
&& c1
->initializer
)
3477 kind_expr
= gfc_copy_expr (c1
->initializer
);
3478 else if (actual_param
&& actual_param
->spec_type
== SPEC_EXPLICIT
)
3479 kind_expr
= gfc_copy_expr (actual_param
->expr
);
3483 actual_param
= param_list
;
3484 for (;actual_param
; actual_param
= actual_param
->next
)
3485 if (actual_param
->name
3486 && strcmp (actual_param
->name
, param
->name
) == 0)
3488 if (actual_param
&& actual_param
->spec_type
== SPEC_EXPLICIT
)
3489 kind_expr
= gfc_copy_expr (actual_param
->expr
);
3492 if (c1
->initializer
)
3493 kind_expr
= gfc_copy_expr (c1
->initializer
);
3494 else if (!(actual_param
&& param
->attr
.pdt_len
))
3496 gfc_error ("The derived parameter %qs at %C does not "
3497 "have a default value", param
->name
);
3503 /* Store the current parameter expressions in a temporary actual
3504 arglist 'list' so that they can be substituted in the corresponding
3505 expressions in the PDT instance. */
3506 if (type_param_spec_list
== NULL
)
3508 type_param_spec_list
= gfc_get_actual_arglist ();
3509 tail
= type_param_spec_list
;
3513 tail
->next
= gfc_get_actual_arglist ();
3516 tail
->name
= param
->name
;
3520 /* Try simplification even for LEN expressions. */
3521 gfc_resolve_expr (kind_expr
);
3522 gfc_simplify_expr (kind_expr
, 1);
3523 /* Variable expressions seem to default to BT_PROCEDURE.
3524 TODO find out why this is and fix it. */
3525 if (kind_expr
->ts
.type
!= BT_INTEGER
3526 && kind_expr
->ts
.type
!= BT_PROCEDURE
)
3528 gfc_error ("The parameter expression at %C must be of "
3529 "INTEGER type and not %s type",
3530 gfc_basic_typename (kind_expr
->ts
.type
));
3534 tail
->expr
= gfc_copy_expr (kind_expr
);
3538 tail
->spec_type
= actual_param
->spec_type
;
3540 if (!param
->attr
.pdt_kind
)
3542 if (!name_seen
&& actual_param
)
3543 actual_param
= actual_param
->next
;
3546 gfc_free_expr (kind_expr
);
3553 && (actual_param
->spec_type
== SPEC_ASSUMED
3554 || actual_param
->spec_type
== SPEC_DEFERRED
))
3556 gfc_error ("The KIND parameter %qs at %C cannot either be "
3557 "ASSUMED or DEFERRED", param
->name
);
3561 if (!kind_expr
|| !gfc_is_constant_expr (kind_expr
))
3563 gfc_error ("The value for the KIND parameter %qs at %C does not "
3564 "reduce to a constant expression", param
->name
);
3568 gfc_extract_int (kind_expr
, &kind_value
);
3569 sprintf (name
+ strlen (name
), "_%d", kind_value
);
3571 if (!name_seen
&& actual_param
)
3572 actual_param
= actual_param
->next
;
3573 gfc_free_expr (kind_expr
);
3576 if (!name_seen
&& actual_param
)
3578 gfc_error ("The type parameter spec list at %C contains too many "
3579 "parameter expressions");
3583 /* Now we search for the PDT instance 'name'. If it doesn't exist, we
3584 build it, using 'pdt' as a template. */
3585 if (gfc_get_symbol (name
, pdt
->ns
, &instance
))
3587 gfc_error ("Parameterized derived type at %C is ambiguous");
3593 if (instance
->attr
.flavor
== FL_DERIVED
3594 && instance
->attr
.pdt_type
)
3598 *ext_param_list
= type_param_spec_list
;
3600 gfc_commit_symbols ();
3604 /* Start building the new instance of the parameterized type. */
3605 gfc_copy_attr (&instance
->attr
, &pdt
->attr
, &pdt
->declared_at
);
3606 instance
->attr
.pdt_template
= 0;
3607 instance
->attr
.pdt_type
= 1;
3608 instance
->declared_at
= gfc_current_locus
;
3610 /* Add the components, replacing the parameters in all expressions
3611 with the expressions for their values in 'type_param_spec_list'. */
3612 c1
= pdt
->components
;
3613 tail
= type_param_spec_list
;
3614 for (; c1
; c1
= c1
->next
)
3616 gfc_add_component (instance
, c1
->name
, &c2
);
3619 c2
->attr
= c1
->attr
;
3621 /* The order of declaration of the type_specs might not be the
3622 same as that of the components. */
3623 if (c1
->attr
.pdt_kind
|| c1
->attr
.pdt_len
)
3625 for (tail
= type_param_spec_list
; tail
; tail
= tail
->next
)
3626 if (strcmp (c1
->name
, tail
->name
) == 0)
3630 /* Deal with type extension by recursively calling this function
3631 to obtain the instance of the extended type. */
3632 if (gfc_current_state () != COMP_DERIVED
3633 && c1
== pdt
->components
3634 && (c1
->ts
.type
== BT_DERIVED
|| c1
->ts
.type
== BT_CLASS
)
3635 && c1
->ts
.u
.derived
&& c1
->ts
.u
.derived
->attr
.pdt_template
3636 && gfc_get_derived_super_type (*sym
) == c2
->ts
.u
.derived
)
3638 gfc_formal_arglist
*f
;
3640 old_param_spec_list
= type_param_spec_list
;
3642 /* Obtain a spec list appropriate to the extended type..*/
3643 actual_param
= gfc_copy_actual_arglist (type_param_spec_list
);
3644 type_param_spec_list
= actual_param
;
3645 for (f
= c1
->ts
.u
.derived
->formal
; f
&& f
->next
; f
= f
->next
)
3646 actual_param
= actual_param
->next
;
3649 gfc_free_actual_arglist (actual_param
->next
);
3650 actual_param
->next
= NULL
;
3653 /* Now obtain the PDT instance for the extended type. */
3654 c2
->param_list
= type_param_spec_list
;
3655 m
= gfc_get_pdt_instance (type_param_spec_list
, &c2
->ts
.u
.derived
,
3657 type_param_spec_list
= old_param_spec_list
;
3659 c2
->ts
.u
.derived
->refs
++;
3660 gfc_set_sym_referenced (c2
->ts
.u
.derived
);
3662 /* Set extension level. */
3663 if (c2
->ts
.u
.derived
->attr
.extension
== 255)
3665 /* Since the extension field is 8 bit wide, we can only have
3666 up to 255 extension levels. */
3667 gfc_error ("Maximum extension level reached with type %qs at %L",
3668 c2
->ts
.u
.derived
->name
,
3669 &c2
->ts
.u
.derived
->declared_at
);
3672 instance
->attr
.extension
= c2
->ts
.u
.derived
->attr
.extension
+ 1;
3677 /* Set the component kind using the parameterized expression. */
3678 if ((c1
->ts
.kind
== 0 || c1
->ts
.type
== BT_CHARACTER
)
3679 && c1
->kind_expr
!= NULL
)
3681 gfc_expr
*e
= gfc_copy_expr (c1
->kind_expr
);
3682 gfc_insert_kind_parameter_exprs (e
);
3683 gfc_simplify_expr (e
, 1);
3684 gfc_extract_int (e
, &c2
->ts
.kind
);
3686 if (gfc_validate_kind (c2
->ts
.type
, c2
->ts
.kind
, true) < 0)
3688 gfc_error ("Kind %d not supported for type %s at %C",
3689 c2
->ts
.kind
, gfc_basic_typename (c2
->ts
.type
));
3694 /* Similarly, set the string length if parameterized. */
3695 if (c1
->ts
.type
== BT_CHARACTER
3696 && c1
->ts
.u
.cl
->length
3697 && gfc_derived_parameter_expr (c1
->ts
.u
.cl
->length
))
3700 e
= gfc_copy_expr (c1
->ts
.u
.cl
->length
);
3701 gfc_insert_kind_parameter_exprs (e
);
3702 gfc_simplify_expr (e
, 1);
3703 c2
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
3704 c2
->ts
.u
.cl
->length
= e
;
3705 c2
->attr
.pdt_string
= 1;
3708 /* Set up either the KIND/LEN initializer, if constant,
3709 or the parameterized expression. Use the template
3710 initializer if one is not already set in this instance. */
3711 if (c2
->attr
.pdt_kind
|| c2
->attr
.pdt_len
)
3713 if (tail
&& tail
->expr
&& gfc_is_constant_expr (tail
->expr
))
3714 c2
->initializer
= gfc_copy_expr (tail
->expr
);
3715 else if (tail
&& tail
->expr
)
3717 c2
->param_list
= gfc_get_actual_arglist ();
3718 c2
->param_list
->name
= tail
->name
;
3719 c2
->param_list
->expr
= gfc_copy_expr (tail
->expr
);
3720 c2
->param_list
->next
= NULL
;
3723 if (!c2
->initializer
&& c1
->initializer
)
3724 c2
->initializer
= gfc_copy_expr (c1
->initializer
);
3727 /* Copy the array spec. */
3728 c2
->as
= gfc_copy_array_spec (c1
->as
);
3729 if (c1
->ts
.type
== BT_CLASS
)
3730 CLASS_DATA (c2
)->as
= gfc_copy_array_spec (CLASS_DATA (c1
)->as
);
3732 /* Determine if an array spec is parameterized. If so, substitute
3733 in the parameter expressions for the bounds and set the pdt_array
3734 attribute. Notice that this attribute must be unconditionally set
3735 if this is an array of parameterized character length. */
3736 if (c1
->as
&& c1
->as
->type
== AS_EXPLICIT
)
3738 bool pdt_array
= false;
3740 /* Are the bounds of the array parameterized? */
3741 for (i
= 0; i
< c1
->as
->rank
; i
++)
3743 if (gfc_derived_parameter_expr (c1
->as
->lower
[i
]))
3745 if (gfc_derived_parameter_expr (c1
->as
->upper
[i
]))
3749 /* If they are, free the expressions for the bounds and
3750 replace them with the template expressions with substitute
3752 for (i
= 0; pdt_array
&& i
< c1
->as
->rank
; i
++)
3755 e
= gfc_copy_expr (c1
->as
->lower
[i
]);
3756 gfc_insert_kind_parameter_exprs (e
);
3757 gfc_simplify_expr (e
, 1);
3758 gfc_free_expr (c2
->as
->lower
[i
]);
3759 c2
->as
->lower
[i
] = e
;
3760 e
= gfc_copy_expr (c1
->as
->upper
[i
]);
3761 gfc_insert_kind_parameter_exprs (e
);
3762 gfc_simplify_expr (e
, 1);
3763 gfc_free_expr (c2
->as
->upper
[i
]);
3764 c2
->as
->upper
[i
] = e
;
3766 c2
->attr
.pdt_array
= pdt_array
? 1 : c2
->attr
.pdt_string
;
3767 if (c1
->initializer
)
3769 c2
->initializer
= gfc_copy_expr (c1
->initializer
);
3770 gfc_insert_kind_parameter_exprs (c2
->initializer
);
3771 gfc_simplify_expr (c2
->initializer
, 1);
3775 /* Recurse into this function for PDT components. */
3776 if ((c1
->ts
.type
== BT_DERIVED
|| c1
->ts
.type
== BT_CLASS
)
3777 && c1
->ts
.u
.derived
&& c1
->ts
.u
.derived
->attr
.pdt_template
)
3779 gfc_actual_arglist
*params
;
3780 /* The component in the template has a list of specification
3781 expressions derived from its declaration. */
3782 params
= gfc_copy_actual_arglist (c1
->param_list
);
3783 actual_param
= params
;
3784 /* Substitute the template parameters with the expressions
3785 from the specification list. */
3786 for (;actual_param
; actual_param
= actual_param
->next
)
3787 gfc_insert_parameter_exprs (actual_param
->expr
,
3788 type_param_spec_list
);
3790 /* Now obtain the PDT instance for the component. */
3791 old_param_spec_list
= type_param_spec_list
;
3792 m
= gfc_get_pdt_instance (params
, &c2
->ts
.u
.derived
, NULL
);
3793 type_param_spec_list
= old_param_spec_list
;
3795 c2
->param_list
= params
;
3796 if (!(c2
->attr
.pointer
|| c2
->attr
.allocatable
))
3797 c2
->initializer
= gfc_default_initializer (&c2
->ts
);
3799 if (c2
->attr
.allocatable
)
3800 instance
->attr
.alloc_comp
= 1;
3804 gfc_commit_symbol (instance
);
3806 *ext_param_list
= type_param_spec_list
;
3811 gfc_free_actual_arglist (type_param_spec_list
);
3816 /* Matches a declaration-type-spec (F03:R502). If successful, sets the ts
3817 structure to the matched specification. This is necessary for FUNCTION and
3818 IMPLICIT statements.
3820 If implicit_flag is nonzero, then we don't check for the optional
3821 kind specification. Not doing so is needed for matching an IMPLICIT
3822 statement correctly. */
3825 gfc_match_decl_type_spec (gfc_typespec
*ts
, int implicit_flag
)
3827 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3828 gfc_symbol
*sym
, *dt_sym
;
3831 bool seen_deferred_kind
, matched_type
;
3832 const char *dt_name
;
3834 decl_type_param_list
= NULL
;
3836 /* A belt and braces check that the typespec is correctly being treated
3837 as a deferred characteristic association. */
3838 seen_deferred_kind
= (gfc_current_state () == COMP_FUNCTION
)
3839 && (gfc_current_block ()->result
->ts
.kind
== -1)
3840 && (ts
->kind
== -1);
3842 if (seen_deferred_kind
)
3845 /* Clear the current binding label, in case one is given. */
3846 curr_binding_label
= NULL
;
3848 if (gfc_match (" byte") == MATCH_YES
)
3850 if (!gfc_notify_std (GFC_STD_GNU
, "BYTE type at %C"))
3853 if (gfc_validate_kind (BT_INTEGER
, 1, true) < 0)
3855 gfc_error ("BYTE type used at %C "
3856 "is not available on the target machine");
3860 ts
->type
= BT_INTEGER
;
3866 m
= gfc_match (" type (");
3867 matched_type
= (m
== MATCH_YES
);
3870 gfc_gobble_whitespace ();
3871 if (gfc_peek_ascii_char () == '*')
3873 if ((m
= gfc_match ("*)")) != MATCH_YES
)
3875 if (gfc_comp_struct (gfc_current_state ()))
3877 gfc_error ("Assumed type at %C is not allowed for components");
3880 if (!gfc_notify_std (GFC_STD_F2018
, "Assumed type at %C"))
3882 ts
->type
= BT_ASSUMED
;
3886 m
= gfc_match ("%n", name
);
3887 matched_type
= (m
== MATCH_YES
);
3890 if ((matched_type
&& strcmp ("integer", name
) == 0)
3891 || (!matched_type
&& gfc_match (" integer") == MATCH_YES
))
3893 ts
->type
= BT_INTEGER
;
3894 ts
->kind
= gfc_default_integer_kind
;
3898 if ((matched_type
&& strcmp ("character", name
) == 0)
3899 || (!matched_type
&& gfc_match (" character") == MATCH_YES
))
3902 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
3903 "intrinsic-type-spec at %C"))
3906 ts
->type
= BT_CHARACTER
;
3907 if (implicit_flag
== 0)
3908 m
= gfc_match_char_spec (ts
);
3912 if (matched_type
&& m
== MATCH_YES
&& gfc_match_char (')') != MATCH_YES
)
3918 if ((matched_type
&& strcmp ("real", name
) == 0)
3919 || (!matched_type
&& gfc_match (" real") == MATCH_YES
))
3922 ts
->kind
= gfc_default_real_kind
;
3927 && (strcmp ("doubleprecision", name
) == 0
3928 || (strcmp ("double", name
) == 0
3929 && gfc_match (" precision") == MATCH_YES
)))
3930 || (!matched_type
&& gfc_match (" double precision") == MATCH_YES
))
3933 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
3934 "intrinsic-type-spec at %C"))
3936 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
3940 ts
->kind
= gfc_default_double_kind
;
3944 if ((matched_type
&& strcmp ("complex", name
) == 0)
3945 || (!matched_type
&& gfc_match (" complex") == MATCH_YES
))
3947 ts
->type
= BT_COMPLEX
;
3948 ts
->kind
= gfc_default_complex_kind
;
3953 && (strcmp ("doublecomplex", name
) == 0
3954 || (strcmp ("double", name
) == 0
3955 && gfc_match (" complex") == MATCH_YES
)))
3956 || (!matched_type
&& gfc_match (" double complex") == MATCH_YES
))
3958 if (!gfc_notify_std (GFC_STD_GNU
, "DOUBLE COMPLEX at %C"))
3962 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
3963 "intrinsic-type-spec at %C"))
3966 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
3969 ts
->type
= BT_COMPLEX
;
3970 ts
->kind
= gfc_default_double_kind
;
3974 if ((matched_type
&& strcmp ("logical", name
) == 0)
3975 || (!matched_type
&& gfc_match (" logical") == MATCH_YES
))
3977 ts
->type
= BT_LOGICAL
;
3978 ts
->kind
= gfc_default_logical_kind
;
3984 m
= gfc_match_actual_arglist (1, &decl_type_param_list
, true);
3985 if (m
== MATCH_ERROR
)
3988 m
= gfc_match_char (')');
3992 m
= match_record_decl (name
);
3994 if (matched_type
|| m
== MATCH_YES
)
3996 ts
->type
= BT_DERIVED
;
3997 /* We accept record/s/ or type(s) where s is a structure, but we
3998 * don't need all the extra derived-type stuff for structures. */
3999 if (gfc_find_symbol (gfc_dt_upper_string (name
), NULL
, 1, &sym
))
4001 gfc_error ("Type name %qs at %C is ambiguous", name
);
4005 if (sym
&& sym
->attr
.flavor
== FL_DERIVED
4006 && sym
->attr
.pdt_template
4007 && gfc_current_state () != COMP_DERIVED
)
4009 m
= gfc_get_pdt_instance (decl_type_param_list
, &sym
, NULL
);
4012 gcc_assert (!sym
->attr
.pdt_template
&& sym
->attr
.pdt_type
);
4013 ts
->u
.derived
= sym
;
4014 strcpy (name
, gfc_dt_lower_string (sym
->name
));
4017 if (sym
&& sym
->attr
.flavor
== FL_STRUCT
)
4019 ts
->u
.derived
= sym
;
4022 /* Actually a derived type. */
4027 /* Match nested STRUCTURE declarations; only valid within another
4028 structure declaration. */
4029 if (flag_dec_structure
4030 && (gfc_current_state () == COMP_STRUCTURE
4031 || gfc_current_state () == COMP_MAP
))
4033 m
= gfc_match (" structure");
4036 m
= gfc_match_structure_decl ();
4039 /* gfc_new_block is updated by match_structure_decl. */
4040 ts
->type
= BT_DERIVED
;
4041 ts
->u
.derived
= gfc_new_block
;
4045 if (m
== MATCH_ERROR
)
4049 /* Match CLASS declarations. */
4050 m
= gfc_match (" class ( * )");
4051 if (m
== MATCH_ERROR
)
4053 else if (m
== MATCH_YES
)
4057 ts
->type
= BT_CLASS
;
4058 gfc_find_symbol ("STAR", gfc_current_ns
, 1, &upe
);
4061 upe
= gfc_new_symbol ("STAR", gfc_current_ns
);
4062 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "STAR");
4064 gfc_set_sym_referenced (upe
);
4066 upe
->ts
.type
= BT_VOID
;
4067 upe
->attr
.unlimited_polymorphic
= 1;
4068 /* This is essential to force the construction of
4069 unlimited polymorphic component class containers. */
4070 upe
->attr
.zero_comp
= 1;
4071 if (!gfc_add_flavor (&upe
->attr
, FL_DERIVED
, NULL
,
4072 &gfc_current_locus
))
4077 st
= gfc_get_tbp_symtree (&gfc_current_ns
->sym_root
, "STAR");
4081 ts
->u
.derived
= upe
;
4085 m
= gfc_match (" class (");
4088 m
= gfc_match ("%n", name
);
4094 ts
->type
= BT_CLASS
;
4096 if (!gfc_notify_std (GFC_STD_F2003
, "CLASS statement at %C"))
4099 m
= gfc_match_actual_arglist (1, &decl_type_param_list
, true);
4100 if (m
== MATCH_ERROR
)
4103 m
= gfc_match_char (')');
4108 /* Defer association of the derived type until the end of the
4109 specification block. However, if the derived type can be
4110 found, add it to the typespec. */
4111 if (gfc_matching_function
)
4113 ts
->u
.derived
= NULL
;
4114 if (gfc_current_state () != COMP_INTERFACE
4115 && !gfc_find_symbol (name
, NULL
, 1, &sym
) && sym
)
4117 sym
= gfc_find_dt_in_generic (sym
);
4118 ts
->u
.derived
= sym
;
4123 /* Search for the name but allow the components to be defined later. If
4124 type = -1, this typespec has been seen in a function declaration but
4125 the type could not be accessed at that point. The actual derived type is
4126 stored in a symtree with the first letter of the name capitalized; the
4127 symtree with the all lower-case name contains the associated
4128 generic function. */
4129 dt_name
= gfc_dt_upper_string (name
);
4134 gfc_get_ha_symbol (name
, &sym
);
4135 if (sym
->generic
&& gfc_find_symbol (dt_name
, NULL
, 0, &dt_sym
))
4137 gfc_error ("Type name %qs at %C is ambiguous", name
);
4140 if (sym
->generic
&& !dt_sym
)
4141 dt_sym
= gfc_find_dt_in_generic (sym
);
4143 /* Host associated PDTs can get confused with their constructors
4144 because they ar instantiated in the template's namespace. */
4147 if (gfc_find_symbol (dt_name
, NULL
, 1, &dt_sym
))
4149 gfc_error ("Type name %qs at %C is ambiguous", name
);
4152 if (dt_sym
&& !dt_sym
->attr
.pdt_type
)
4156 else if (ts
->kind
== -1)
4158 int iface
= gfc_state_stack
->previous
->state
!= COMP_INTERFACE
4159 || gfc_current_ns
->has_import_set
;
4160 gfc_find_symbol (name
, NULL
, iface
, &sym
);
4161 if (sym
&& sym
->generic
&& gfc_find_symbol (dt_name
, NULL
, 1, &dt_sym
))
4163 gfc_error ("Type name %qs at %C is ambiguous", name
);
4166 if (sym
&& sym
->generic
&& !dt_sym
)
4167 dt_sym
= gfc_find_dt_in_generic (sym
);
4174 if ((sym
->attr
.flavor
!= FL_UNKNOWN
&& sym
->attr
.flavor
!= FL_STRUCT
4175 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.generic
))
4176 || sym
->attr
.subroutine
)
4178 gfc_error ("Type name %qs at %C conflicts with previously declared "
4179 "entity at %L, which has the same name", name
,
4184 if (sym
&& sym
->attr
.flavor
== FL_DERIVED
4185 && sym
->attr
.pdt_template
4186 && gfc_current_state () != COMP_DERIVED
)
4188 m
= gfc_get_pdt_instance (decl_type_param_list
, &sym
, NULL
);
4191 gcc_assert (!sym
->attr
.pdt_template
&& sym
->attr
.pdt_type
);
4192 ts
->u
.derived
= sym
;
4193 strcpy (name
, gfc_dt_lower_string (sym
->name
));
4196 gfc_save_symbol_data (sym
);
4197 gfc_set_sym_referenced (sym
);
4198 if (!sym
->attr
.generic
4199 && !gfc_add_generic (&sym
->attr
, sym
->name
, NULL
))
4202 if (!sym
->attr
.function
4203 && !gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
4206 if (dt_sym
&& dt_sym
->attr
.flavor
== FL_DERIVED
4207 && dt_sym
->attr
.pdt_template
4208 && gfc_current_state () != COMP_DERIVED
)
4210 m
= gfc_get_pdt_instance (decl_type_param_list
, &dt_sym
, NULL
);
4213 gcc_assert (!dt_sym
->attr
.pdt_template
&& dt_sym
->attr
.pdt_type
);
4218 gfc_interface
*intr
, *head
;
4220 /* Use upper case to save the actual derived-type symbol. */
4221 gfc_get_symbol (dt_name
, NULL
, &dt_sym
);
4222 dt_sym
->name
= gfc_get_string ("%s", sym
->name
);
4223 head
= sym
->generic
;
4224 intr
= gfc_get_interface ();
4226 intr
->where
= gfc_current_locus
;
4228 sym
->generic
= intr
;
4229 sym
->attr
.if_source
= IFSRC_DECL
;
4232 gfc_save_symbol_data (dt_sym
);
4234 gfc_set_sym_referenced (dt_sym
);
4236 if (dt_sym
->attr
.flavor
!= FL_DERIVED
&& dt_sym
->attr
.flavor
!= FL_STRUCT
4237 && !gfc_add_flavor (&dt_sym
->attr
, FL_DERIVED
, sym
->name
, NULL
))
4240 ts
->u
.derived
= dt_sym
;
4246 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
4247 "intrinsic-type-spec at %C"))
4250 /* For all types except double, derived and character, look for an
4251 optional kind specifier. MATCH_NO is actually OK at this point. */
4252 if (implicit_flag
== 1)
4254 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
4260 if (gfc_current_form
== FORM_FREE
)
4262 c
= gfc_peek_ascii_char ();
4263 if (!gfc_is_whitespace (c
) && c
!= '*' && c
!= '('
4264 && c
!= ':' && c
!= ',')
4266 if (matched_type
&& c
== ')')
4268 gfc_next_ascii_char ();
4275 m
= gfc_match_kind_spec (ts
, false);
4276 if (m
== MATCH_NO
&& ts
->type
!= BT_CHARACTER
)
4278 m
= gfc_match_old_kind_spec (ts
);
4279 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) == -1)
4283 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
4286 /* Defer association of the KIND expression of function results
4287 until after USE and IMPORT statements. */
4288 if ((gfc_current_state () == COMP_NONE
&& gfc_error_flag_test ())
4289 || gfc_matching_function
)
4293 m
= MATCH_YES
; /* No kind specifier found. */
4299 /* Match an IMPLICIT NONE statement. Actually, this statement is
4300 already matched in parse.c, or we would not end up here in the
4301 first place. So the only thing we need to check, is if there is
4302 trailing garbage. If not, the match is successful. */
4305 gfc_match_implicit_none (void)
4309 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4311 bool external
= false;
4312 locus cur_loc
= gfc_current_locus
;
4314 if (gfc_current_ns
->seen_implicit_none
4315 || gfc_current_ns
->has_implicit_none_export
)
4317 gfc_error ("Duplicate IMPLICIT NONE statement at %C");
4321 gfc_gobble_whitespace ();
4322 c
= gfc_peek_ascii_char ();
4325 (void) gfc_next_ascii_char ();
4326 if (!gfc_notify_std (GFC_STD_F2018
, "IMPORT NONE with spec list at %C"))
4329 gfc_gobble_whitespace ();
4330 if (gfc_peek_ascii_char () == ')')
4332 (void) gfc_next_ascii_char ();
4338 m
= gfc_match (" %n", name
);
4342 if (strcmp (name
, "type") == 0)
4344 else if (strcmp (name
, "external") == 0)
4349 gfc_gobble_whitespace ();
4350 c
= gfc_next_ascii_char ();
4361 if (gfc_match_eos () != MATCH_YES
)
4364 gfc_set_implicit_none (type
, external
, &cur_loc
);
4370 /* Match the letter range(s) of an IMPLICIT statement. */
4373 match_implicit_range (void)
4379 cur_loc
= gfc_current_locus
;
4381 gfc_gobble_whitespace ();
4382 c
= gfc_next_ascii_char ();
4385 gfc_error ("Missing character range in IMPLICIT at %C");
4392 gfc_gobble_whitespace ();
4393 c1
= gfc_next_ascii_char ();
4397 gfc_gobble_whitespace ();
4398 c
= gfc_next_ascii_char ();
4403 inner
= 0; /* Fall through. */
4410 gfc_gobble_whitespace ();
4411 c2
= gfc_next_ascii_char ();
4415 gfc_gobble_whitespace ();
4416 c
= gfc_next_ascii_char ();
4418 if ((c
!= ',') && (c
!= ')'))
4431 gfc_error ("Letters must be in alphabetic order in "
4432 "IMPLICIT statement at %C");
4436 /* See if we can add the newly matched range to the pending
4437 implicits from this IMPLICIT statement. We do not check for
4438 conflicts with whatever earlier IMPLICIT statements may have
4439 set. This is done when we've successfully finished matching
4441 if (!gfc_add_new_implicit_range (c1
, c2
))
4448 gfc_syntax_error (ST_IMPLICIT
);
4450 gfc_current_locus
= cur_loc
;
4455 /* Match an IMPLICIT statement, storing the types for
4456 gfc_set_implicit() if the statement is accepted by the parser.
4457 There is a strange looking, but legal syntactic construction
4458 possible. It looks like:
4460 IMPLICIT INTEGER (a-b) (c-d)
4462 This is legal if "a-b" is a constant expression that happens to
4463 equal one of the legal kinds for integers. The real problem
4464 happens with an implicit specification that looks like:
4466 IMPLICIT INTEGER (a-b)
4468 In this case, a typespec matcher that is "greedy" (as most of the
4469 matchers are) gobbles the character range as a kindspec, leaving
4470 nothing left. We therefore have to go a bit more slowly in the
4471 matching process by inhibiting the kindspec checking during
4472 typespec matching and checking for a kind later. */
4475 gfc_match_implicit (void)
4482 if (gfc_current_ns
->seen_implicit_none
)
4484 gfc_error ("IMPLICIT statement at %C following an IMPLICIT NONE (type) "
4491 /* We don't allow empty implicit statements. */
4492 if (gfc_match_eos () == MATCH_YES
)
4494 gfc_error ("Empty IMPLICIT statement at %C");
4500 /* First cleanup. */
4501 gfc_clear_new_implicit ();
4503 /* A basic type is mandatory here. */
4504 m
= gfc_match_decl_type_spec (&ts
, 1);
4505 if (m
== MATCH_ERROR
)
4510 cur_loc
= gfc_current_locus
;
4511 m
= match_implicit_range ();
4515 /* We may have <TYPE> (<RANGE>). */
4516 gfc_gobble_whitespace ();
4517 c
= gfc_peek_ascii_char ();
4518 if (c
== ',' || c
== '\n' || c
== ';' || c
== '!')
4520 /* Check for CHARACTER with no length parameter. */
4521 if (ts
.type
== BT_CHARACTER
&& !ts
.u
.cl
)
4523 ts
.kind
= gfc_default_character_kind
;
4524 ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4525 ts
.u
.cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
,
4529 /* Record the Successful match. */
4530 if (!gfc_merge_new_implicit (&ts
))
4533 c
= gfc_next_ascii_char ();
4534 else if (gfc_match_eos () == MATCH_ERROR
)
4539 gfc_current_locus
= cur_loc
;
4542 /* Discard the (incorrectly) matched range. */
4543 gfc_clear_new_implicit ();
4545 /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
4546 if (ts
.type
== BT_CHARACTER
)
4547 m
= gfc_match_char_spec (&ts
);
4550 m
= gfc_match_kind_spec (&ts
, false);
4553 m
= gfc_match_old_kind_spec (&ts
);
4554 if (m
== MATCH_ERROR
)
4560 if (m
== MATCH_ERROR
)
4563 m
= match_implicit_range ();
4564 if (m
== MATCH_ERROR
)
4569 gfc_gobble_whitespace ();
4570 c
= gfc_next_ascii_char ();
4571 if (c
!= ',' && gfc_match_eos () != MATCH_YES
)
4574 if (!gfc_merge_new_implicit (&ts
))
4582 gfc_syntax_error (ST_IMPLICIT
);
4590 gfc_match_import (void)
4592 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4597 if (gfc_current_ns
->proc_name
== NULL
4598 || gfc_current_ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
4600 gfc_error ("IMPORT statement at %C only permitted in "
4601 "an INTERFACE body");
4605 if (gfc_current_ns
->proc_name
->attr
.module_procedure
)
4607 gfc_error ("F2008: C1210 IMPORT statement at %C is not permitted "
4608 "in a module procedure interface body");
4612 if (!gfc_notify_std (GFC_STD_F2003
, "IMPORT statement at %C"))
4615 if (gfc_match_eos () == MATCH_YES
)
4617 /* All host variables should be imported. */
4618 gfc_current_ns
->has_import_set
= 1;
4622 if (gfc_match (" ::") == MATCH_YES
)
4624 if (gfc_match_eos () == MATCH_YES
)
4626 gfc_error ("Expecting list of named entities at %C");
4634 m
= gfc_match (" %n", name
);
4638 if (gfc_current_ns
->parent
!= NULL
4639 && gfc_find_symbol (name
, gfc_current_ns
->parent
, 1, &sym
))
4641 gfc_error ("Type name %qs at %C is ambiguous", name
);
4644 else if (!sym
&& gfc_current_ns
->proc_name
->ns
->parent
!= NULL
4645 && gfc_find_symbol (name
,
4646 gfc_current_ns
->proc_name
->ns
->parent
,
4649 gfc_error ("Type name %qs at %C is ambiguous", name
);
4655 gfc_error ("Cannot IMPORT %qs from host scoping unit "
4656 "at %C - does not exist.", name
);
4660 if (gfc_find_symtree (gfc_current_ns
->sym_root
, name
))
4662 gfc_warning (0, "%qs is already IMPORTed from host scoping unit "
4667 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, name
);
4670 sym
->attr
.imported
= 1;
4672 if (sym
->attr
.generic
&& (sym
= gfc_find_dt_in_generic (sym
)))
4674 /* The actual derived type is stored in a symtree with the first
4675 letter of the name capitalized; the symtree with the all
4676 lower-case name contains the associated generic function. */
4677 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
,
4678 gfc_dt_upper_string (name
));
4681 sym
->attr
.imported
= 1;
4694 if (gfc_match_eos () == MATCH_YES
)
4696 if (gfc_match_char (',') != MATCH_YES
)
4703 gfc_error ("Syntax error in IMPORT statement at %C");
4708 /* A minimal implementation of gfc_match without whitespace, escape
4709 characters or variable arguments. Returns true if the next
4710 characters match the TARGET template exactly. */
4713 match_string_p (const char *target
)
4717 for (p
= target
; *p
; p
++)
4718 if ((char) gfc_next_ascii_char () != *p
)
4723 /* Matches an attribute specification including array specs. If
4724 successful, leaves the variables current_attr and current_as
4725 holding the specification. Also sets the colon_seen variable for
4726 later use by matchers associated with initializations.
4728 This subroutine is a little tricky in the sense that we don't know
4729 if we really have an attr-spec until we hit the double colon.
4730 Until that time, we can only return MATCH_NO. This forces us to
4731 check for duplicate specification at this level. */
4734 match_attr_spec (void)
4736 /* Modifiers that can exist in a type statement. */
4738 { GFC_DECL_BEGIN
= 0, DECL_ALLOCATABLE
= GFC_DECL_BEGIN
,
4739 DECL_IN
= INTENT_IN
, DECL_OUT
= INTENT_OUT
, DECL_INOUT
= INTENT_INOUT
,
4740 DECL_DIMENSION
, DECL_EXTERNAL
,
4741 DECL_INTRINSIC
, DECL_OPTIONAL
,
4742 DECL_PARAMETER
, DECL_POINTER
, DECL_PROTECTED
, DECL_PRIVATE
,
4743 DECL_STATIC
, DECL_AUTOMATIC
,
4744 DECL_PUBLIC
, DECL_SAVE
, DECL_TARGET
, DECL_VALUE
, DECL_VOLATILE
,
4745 DECL_IS_BIND_C
, DECL_CODIMENSION
, DECL_ASYNCHRONOUS
, DECL_CONTIGUOUS
,
4746 DECL_LEN
, DECL_KIND
, DECL_NONE
, GFC_DECL_END
/* Sentinel */
4749 /* GFC_DECL_END is the sentinel, index starts at 0. */
4750 #define NUM_DECL GFC_DECL_END
4752 /* Make sure that values from sym_intent are safe to be used here. */
4753 gcc_assert (INTENT_IN
> 0);
4755 locus start
, seen_at
[NUM_DECL
];
4762 gfc_clear_attr (¤t_attr
);
4763 start
= gfc_current_locus
;
4769 /* See if we get all of the keywords up to the final double colon. */
4770 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
4778 gfc_gobble_whitespace ();
4780 ch
= gfc_next_ascii_char ();
4783 /* This is the successful exit condition for the loop. */
4784 if (gfc_next_ascii_char () == ':')
4789 gfc_gobble_whitespace ();
4790 switch (gfc_peek_ascii_char ())
4793 gfc_next_ascii_char ();
4794 switch (gfc_next_ascii_char ())
4797 if (match_string_p ("locatable"))
4799 /* Matched "allocatable". */
4800 d
= DECL_ALLOCATABLE
;
4805 if (match_string_p ("ynchronous"))
4807 /* Matched "asynchronous". */
4808 d
= DECL_ASYNCHRONOUS
;
4813 if (match_string_p ("tomatic"))
4815 /* Matched "automatic". */
4823 /* Try and match the bind(c). */
4824 m
= gfc_match_bind_c (NULL
, true);
4827 else if (m
== MATCH_ERROR
)
4832 gfc_next_ascii_char ();
4833 if ('o' != gfc_next_ascii_char ())
4835 switch (gfc_next_ascii_char ())
4838 if (match_string_p ("imension"))
4840 d
= DECL_CODIMENSION
;
4845 if (match_string_p ("tiguous"))
4847 d
= DECL_CONTIGUOUS
;
4854 if (match_string_p ("dimension"))
4859 if (match_string_p ("external"))
4864 if (match_string_p ("int"))
4866 ch
= gfc_next_ascii_char ();
4869 if (match_string_p ("nt"))
4871 /* Matched "intent". */
4872 d
= match_intent_spec ();
4873 if (d
== INTENT_UNKNOWN
)
4882 if (match_string_p ("insic"))
4884 /* Matched "intrinsic". */
4892 if (match_string_p ("kind"))
4897 if (match_string_p ("len"))
4902 if (match_string_p ("optional"))
4907 gfc_next_ascii_char ();
4908 switch (gfc_next_ascii_char ())
4911 if (match_string_p ("rameter"))
4913 /* Matched "parameter". */
4919 if (match_string_p ("inter"))
4921 /* Matched "pointer". */
4927 ch
= gfc_next_ascii_char ();
4930 if (match_string_p ("vate"))
4932 /* Matched "private". */
4938 if (match_string_p ("tected"))
4940 /* Matched "protected". */
4947 if (match_string_p ("blic"))
4949 /* Matched "public". */
4957 gfc_next_ascii_char ();
4958 switch (gfc_next_ascii_char ())
4961 if (match_string_p ("ve"))
4963 /* Matched "save". */
4969 if (match_string_p ("atic"))
4971 /* Matched "static". */
4979 if (match_string_p ("target"))
4984 gfc_next_ascii_char ();
4985 ch
= gfc_next_ascii_char ();
4988 if (match_string_p ("lue"))
4990 /* Matched "value". */
4996 if (match_string_p ("latile"))
4998 /* Matched "volatile". */
5006 /* No double colon and no recognizable decl_type, so assume that
5007 we've been looking at something else the whole time. */
5014 /* Check to make sure any parens are paired up correctly. */
5015 if (gfc_match_parens () == MATCH_ERROR
)
5022 seen_at
[d
] = gfc_current_locus
;
5024 if (d
== DECL_DIMENSION
|| d
== DECL_CODIMENSION
)
5026 gfc_array_spec
*as
= NULL
;
5028 m
= gfc_match_array_spec (&as
, d
== DECL_DIMENSION
,
5029 d
== DECL_CODIMENSION
);
5031 if (current_as
== NULL
)
5033 else if (m
== MATCH_YES
)
5035 if (!merge_array_spec (as
, current_as
, false))
5042 if (d
== DECL_CODIMENSION
)
5043 gfc_error ("Missing codimension specification at %C");
5045 gfc_error ("Missing dimension specification at %C");
5049 if (m
== MATCH_ERROR
)
5054 /* Since we've seen a double colon, we have to be looking at an
5055 attr-spec. This means that we can now issue errors. */
5056 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
5061 case DECL_ALLOCATABLE
:
5062 attr
= "ALLOCATABLE";
5064 case DECL_ASYNCHRONOUS
:
5065 attr
= "ASYNCHRONOUS";
5067 case DECL_CODIMENSION
:
5068 attr
= "CODIMENSION";
5070 case DECL_CONTIGUOUS
:
5071 attr
= "CONTIGUOUS";
5073 case DECL_DIMENSION
:
5080 attr
= "INTENT (IN)";
5083 attr
= "INTENT (OUT)";
5086 attr
= "INTENT (IN OUT)";
5088 case DECL_INTRINSIC
:
5100 case DECL_PARAMETER
:
5106 case DECL_PROTECTED
:
5121 case DECL_AUTOMATIC
:
5127 case DECL_IS_BIND_C
:
5137 attr
= NULL
; /* This shouldn't happen. */
5140 gfc_error ("Duplicate %s attribute at %L", attr
, &seen_at
[d
]);
5145 /* Now that we've dealt with duplicate attributes, add the attributes
5146 to the current attribute. */
5147 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
5154 if ((d
== DECL_STATIC
|| d
== DECL_AUTOMATIC
)
5155 && !flag_dec_static
)
5157 gfc_error ("%s at %L is a DEC extension, enable with "
5159 d
== DECL_STATIC
? "STATIC" : "AUTOMATIC", &seen_at
[d
]);
5163 /* Allow SAVE with STATIC, but don't complain. */
5164 if (d
== DECL_STATIC
&& seen
[DECL_SAVE
])
5167 if (gfc_current_state () == COMP_DERIVED
5168 && d
!= DECL_DIMENSION
&& d
!= DECL_CODIMENSION
5169 && d
!= DECL_POINTER
&& d
!= DECL_PRIVATE
5170 && d
!= DECL_PUBLIC
&& d
!= DECL_CONTIGUOUS
&& d
!= DECL_NONE
)
5172 if (d
== DECL_ALLOCATABLE
)
5174 if (!gfc_notify_std (GFC_STD_F2003
, "ALLOCATABLE "
5175 "attribute at %C in a TYPE definition"))
5181 else if (d
== DECL_KIND
)
5183 if (!gfc_notify_std (GFC_STD_F2003
, "KIND "
5184 "attribute at %C in a TYPE definition"))
5189 if (current_ts
.type
!= BT_INTEGER
)
5191 gfc_error ("Component with KIND attribute at %C must be "
5196 if (current_ts
.kind
!= gfc_default_integer_kind
)
5198 gfc_error ("Component with KIND attribute at %C must be "
5199 "default integer kind (%d)",
5200 gfc_default_integer_kind
);
5205 else if (d
== DECL_LEN
)
5207 if (!gfc_notify_std (GFC_STD_F2003
, "LEN "
5208 "attribute at %C in a TYPE definition"))
5213 if (current_ts
.type
!= BT_INTEGER
)
5215 gfc_error ("Component with LEN attribute at %C must be "
5220 if (current_ts
.kind
!= gfc_default_integer_kind
)
5222 gfc_error ("Component with LEN attribute at %C must be "
5223 "default integer kind (%d)",
5224 gfc_default_integer_kind
);
5231 gfc_error ("Attribute at %L is not allowed in a TYPE definition",
5238 if ((d
== DECL_PRIVATE
|| d
== DECL_PUBLIC
)
5239 && gfc_current_state () != COMP_MODULE
)
5241 if (d
== DECL_PRIVATE
)
5245 if (gfc_current_state () == COMP_DERIVED
5246 && gfc_state_stack
->previous
5247 && gfc_state_stack
->previous
->state
== COMP_MODULE
)
5249 if (!gfc_notify_std (GFC_STD_F2003
, "Attribute %s "
5250 "at %L in a TYPE definition", attr
,
5259 gfc_error ("%s attribute at %L is not allowed outside of the "
5260 "specification part of a module", attr
, &seen_at
[d
]);
5266 if (gfc_current_state () != COMP_DERIVED
5267 && (d
== DECL_KIND
|| d
== DECL_LEN
))
5269 gfc_error ("Attribute at %L is not allowed outside a TYPE "
5270 "definition", &seen_at
[d
]);
5277 case DECL_ALLOCATABLE
:
5278 t
= gfc_add_allocatable (¤t_attr
, &seen_at
[d
]);
5281 case DECL_ASYNCHRONOUS
:
5282 if (!gfc_notify_std (GFC_STD_F2003
, "ASYNCHRONOUS attribute at %C"))
5285 t
= gfc_add_asynchronous (¤t_attr
, NULL
, &seen_at
[d
]);
5288 case DECL_CODIMENSION
:
5289 t
= gfc_add_codimension (¤t_attr
, NULL
, &seen_at
[d
]);
5292 case DECL_CONTIGUOUS
:
5293 if (!gfc_notify_std (GFC_STD_F2008
, "CONTIGUOUS attribute at %C"))
5296 t
= gfc_add_contiguous (¤t_attr
, NULL
, &seen_at
[d
]);
5299 case DECL_DIMENSION
:
5300 t
= gfc_add_dimension (¤t_attr
, NULL
, &seen_at
[d
]);
5304 t
= gfc_add_external (¤t_attr
, &seen_at
[d
]);
5308 t
= gfc_add_intent (¤t_attr
, INTENT_IN
, &seen_at
[d
]);
5312 t
= gfc_add_intent (¤t_attr
, INTENT_OUT
, &seen_at
[d
]);
5316 t
= gfc_add_intent (¤t_attr
, INTENT_INOUT
, &seen_at
[d
]);
5319 case DECL_INTRINSIC
:
5320 t
= gfc_add_intrinsic (¤t_attr
, &seen_at
[d
]);
5324 t
= gfc_add_optional (¤t_attr
, &seen_at
[d
]);
5328 t
= gfc_add_kind (¤t_attr
, &seen_at
[d
]);
5332 t
= gfc_add_len (¤t_attr
, &seen_at
[d
]);
5335 case DECL_PARAMETER
:
5336 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, &seen_at
[d
]);
5340 t
= gfc_add_pointer (¤t_attr
, &seen_at
[d
]);
5343 case DECL_PROTECTED
:
5344 if (gfc_current_state () != COMP_MODULE
5345 || (gfc_current_ns
->proc_name
5346 && gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
))
5348 gfc_error ("PROTECTED at %C only allowed in specification "
5349 "part of a module");
5354 if (!gfc_notify_std (GFC_STD_F2003
, "PROTECTED attribute at %C"))
5357 t
= gfc_add_protected (¤t_attr
, NULL
, &seen_at
[d
]);
5361 t
= gfc_add_access (¤t_attr
, ACCESS_PRIVATE
, NULL
,
5366 t
= gfc_add_access (¤t_attr
, ACCESS_PUBLIC
, NULL
,
5372 t
= gfc_add_save (¤t_attr
, SAVE_EXPLICIT
, NULL
, &seen_at
[d
]);
5375 case DECL_AUTOMATIC
:
5376 t
= gfc_add_automatic (¤t_attr
, NULL
, &seen_at
[d
]);
5380 t
= gfc_add_target (¤t_attr
, &seen_at
[d
]);
5383 case DECL_IS_BIND_C
:
5384 t
= gfc_add_is_bind_c(¤t_attr
, NULL
, &seen_at
[d
], 0);
5388 if (!gfc_notify_std (GFC_STD_F2003
, "VALUE attribute at %C"))
5391 t
= gfc_add_value (¤t_attr
, NULL
, &seen_at
[d
]);
5395 if (!gfc_notify_std (GFC_STD_F2003
, "VOLATILE attribute at %C"))
5398 t
= gfc_add_volatile (¤t_attr
, NULL
, &seen_at
[d
]);
5402 gfc_internal_error ("match_attr_spec(): Bad attribute");
5412 /* Since Fortran 2008 module variables implicitly have the SAVE attribute. */
5413 if ((gfc_current_state () == COMP_MODULE
5414 || gfc_current_state () == COMP_SUBMODULE
)
5415 && !current_attr
.save
5416 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
5417 current_attr
.save
= SAVE_IMPLICIT
;
5423 gfc_current_locus
= start
;
5424 gfc_free_array_spec (current_as
);
5431 /* Set the binding label, dest_label, either with the binding label
5432 stored in the given gfc_typespec, ts, or if none was provided, it
5433 will be the symbol name in all lower case, as required by the draft
5434 (J3/04-007, section 15.4.1). If a binding label was given and
5435 there is more than one argument (num_idents), it is an error. */
5438 set_binding_label (const char **dest_label
, const char *sym_name
,
5441 if (num_idents
> 1 && has_name_equals
)
5443 gfc_error ("Multiple identifiers provided with "
5444 "single NAME= specifier at %C");
5448 if (curr_binding_label
)
5449 /* Binding label given; store in temp holder till have sym. */
5450 *dest_label
= curr_binding_label
;
5453 /* No binding label given, and the NAME= specifier did not exist,
5454 which means there was no NAME="". */
5455 if (sym_name
!= NULL
&& has_name_equals
== 0)
5456 *dest_label
= IDENTIFIER_POINTER (get_identifier (sym_name
));
5463 /* Set the status of the given common block as being BIND(C) or not,
5464 depending on the given parameter, is_bind_c. */
5467 set_com_block_bind_c (gfc_common_head
*com_block
, int is_bind_c
)
5469 com_block
->is_bind_c
= is_bind_c
;
5474 /* Verify that the given gfc_typespec is for a C interoperable type. */
5477 gfc_verify_c_interop (gfc_typespec
*ts
)
5479 if (ts
->type
== BT_DERIVED
&& ts
->u
.derived
!= NULL
)
5480 return (ts
->u
.derived
->ts
.is_c_interop
|| ts
->u
.derived
->attr
.is_bind_c
)
5482 else if (ts
->type
== BT_CLASS
)
5484 else if (ts
->is_c_interop
!= 1 && ts
->type
!= BT_ASSUMED
)
5491 /* Verify that the variables of a given common block, which has been
5492 defined with the attribute specifier bind(c), to be of a C
5493 interoperable type. Errors will be reported here, if
5497 verify_com_block_vars_c_interop (gfc_common_head
*com_block
)
5499 gfc_symbol
*curr_sym
= NULL
;
5502 curr_sym
= com_block
->head
;
5504 /* Make sure we have at least one symbol. */
5505 if (curr_sym
== NULL
)
5508 /* Here we know we have a symbol, so we'll execute this loop
5512 /* The second to last param, 1, says this is in a common block. */
5513 retval
= verify_bind_c_sym (curr_sym
, &(curr_sym
->ts
), 1, com_block
);
5514 curr_sym
= curr_sym
->common_next
;
5515 } while (curr_sym
!= NULL
);
5521 /* Verify that a given BIND(C) symbol is C interoperable. If it is not,
5522 an appropriate error message is reported. */
5525 verify_bind_c_sym (gfc_symbol
*tmp_sym
, gfc_typespec
*ts
,
5526 int is_in_common
, gfc_common_head
*com_block
)
5528 bool bind_c_function
= false;
5531 if (tmp_sym
->attr
.function
&& tmp_sym
->attr
.is_bind_c
)
5532 bind_c_function
= true;
5534 if (tmp_sym
->attr
.function
&& tmp_sym
->result
!= NULL
)
5536 tmp_sym
= tmp_sym
->result
;
5537 /* Make sure it wasn't an implicitly typed result. */
5538 if (tmp_sym
->attr
.implicit_type
&& warn_c_binding_type
)
5540 gfc_warning (OPT_Wc_binding_type
,
5541 "Implicitly declared BIND(C) function %qs at "
5542 "%L may not be C interoperable", tmp_sym
->name
,
5543 &tmp_sym
->declared_at
);
5544 tmp_sym
->ts
.f90_type
= tmp_sym
->ts
.type
;
5545 /* Mark it as C interoperable to prevent duplicate warnings. */
5546 tmp_sym
->ts
.is_c_interop
= 1;
5547 tmp_sym
->attr
.is_c_interop
= 1;
5551 /* Here, we know we have the bind(c) attribute, so if we have
5552 enough type info, then verify that it's a C interop kind.
5553 The info could be in the symbol already, or possibly still in
5554 the given ts (current_ts), so look in both. */
5555 if (tmp_sym
->ts
.type
!= BT_UNKNOWN
|| ts
->type
!= BT_UNKNOWN
)
5557 if (!gfc_verify_c_interop (&(tmp_sym
->ts
)))
5559 /* See if we're dealing with a sym in a common block or not. */
5560 if (is_in_common
== 1 && warn_c_binding_type
)
5562 gfc_warning (OPT_Wc_binding_type
,
5563 "Variable %qs in common block %qs at %L "
5564 "may not be a C interoperable "
5565 "kind though common block %qs is BIND(C)",
5566 tmp_sym
->name
, com_block
->name
,
5567 &(tmp_sym
->declared_at
), com_block
->name
);
5571 if (tmp_sym
->ts
.type
== BT_DERIVED
|| ts
->type
== BT_DERIVED
)
5572 gfc_error ("Type declaration %qs at %L is not C "
5573 "interoperable but it is BIND(C)",
5574 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5575 else if (warn_c_binding_type
)
5576 gfc_warning (OPT_Wc_binding_type
, "Variable %qs at %L "
5577 "may not be a C interoperable "
5578 "kind but it is BIND(C)",
5579 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5583 /* Variables declared w/in a common block can't be bind(c)
5584 since there's no way for C to see these variables, so there's
5585 semantically no reason for the attribute. */
5586 if (is_in_common
== 1 && tmp_sym
->attr
.is_bind_c
== 1)
5588 gfc_error ("Variable %qs in common block %qs at "
5589 "%L cannot be declared with BIND(C) "
5590 "since it is not a global",
5591 tmp_sym
->name
, com_block
->name
,
5592 &(tmp_sym
->declared_at
));
5596 /* Scalar variables that are bind(c) can not have the pointer
5597 or allocatable attributes. */
5598 if (tmp_sym
->attr
.is_bind_c
== 1)
5600 if (tmp_sym
->attr
.pointer
== 1)
5602 gfc_error ("Variable %qs at %L cannot have both the "
5603 "POINTER and BIND(C) attributes",
5604 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5608 if (tmp_sym
->attr
.allocatable
== 1)
5610 gfc_error ("Variable %qs at %L cannot have both the "
5611 "ALLOCATABLE and BIND(C) attributes",
5612 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5618 /* If it is a BIND(C) function, make sure the return value is a
5619 scalar value. The previous tests in this function made sure
5620 the type is interoperable. */
5621 if (bind_c_function
&& tmp_sym
->as
!= NULL
)
5622 gfc_error ("Return type of BIND(C) function %qs at %L cannot "
5623 "be an array", tmp_sym
->name
, &(tmp_sym
->declared_at
));
5625 /* BIND(C) functions can not return a character string. */
5626 if (bind_c_function
&& tmp_sym
->ts
.type
== BT_CHARACTER
)
5627 if (tmp_sym
->ts
.u
.cl
== NULL
|| tmp_sym
->ts
.u
.cl
->length
== NULL
5628 || tmp_sym
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
5629 || mpz_cmp_si (tmp_sym
->ts
.u
.cl
->length
->value
.integer
, 1) != 0)
5630 gfc_error ("Return type of BIND(C) function %qs at %L cannot "
5631 "be a character string", tmp_sym
->name
,
5632 &(tmp_sym
->declared_at
));
5635 /* See if the symbol has been marked as private. If it has, make sure
5636 there is no binding label and warn the user if there is one. */
5637 if (tmp_sym
->attr
.access
== ACCESS_PRIVATE
5638 && tmp_sym
->binding_label
)
5639 /* Use gfc_warning_now because we won't say that the symbol fails
5640 just because of this. */
5641 gfc_warning_now (0, "Symbol %qs at %L is marked PRIVATE but has been "
5642 "given the binding label %qs", tmp_sym
->name
,
5643 &(tmp_sym
->declared_at
), tmp_sym
->binding_label
);
5649 /* Set the appropriate fields for a symbol that's been declared as
5650 BIND(C) (the is_bind_c flag and the binding label), and verify that
5651 the type is C interoperable. Errors are reported by the functions
5652 used to set/test these fields. */
5655 set_verify_bind_c_sym (gfc_symbol
*tmp_sym
, int num_idents
)
5659 /* TODO: Do we need to make sure the vars aren't marked private? */
5661 /* Set the is_bind_c bit in symbol_attribute. */
5662 gfc_add_is_bind_c (&(tmp_sym
->attr
), tmp_sym
->name
, &gfc_current_locus
, 0);
5664 if (!set_binding_label (&tmp_sym
->binding_label
, tmp_sym
->name
, num_idents
))
5671 /* Set the fields marking the given common block as BIND(C), including
5672 a binding label, and report any errors encountered. */
5675 set_verify_bind_c_com_block (gfc_common_head
*com_block
, int num_idents
)
5679 /* destLabel, common name, typespec (which may have binding label). */
5680 if (!set_binding_label (&com_block
->binding_label
, com_block
->name
,
5684 /* Set the given common block (com_block) to being bind(c) (1). */
5685 set_com_block_bind_c (com_block
, 1);
5691 /* Retrieve the list of one or more identifiers that the given bind(c)
5692 attribute applies to. */
5695 get_bind_c_idents (void)
5697 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5699 gfc_symbol
*tmp_sym
= NULL
;
5701 gfc_common_head
*com_block
= NULL
;
5703 if (gfc_match_name (name
) == MATCH_YES
)
5705 found_id
= MATCH_YES
;
5706 gfc_get_ha_symbol (name
, &tmp_sym
);
5708 else if (match_common_name (name
) == MATCH_YES
)
5710 found_id
= MATCH_YES
;
5711 com_block
= gfc_get_common (name
, 0);
5715 gfc_error ("Need either entity or common block name for "
5716 "attribute specification statement at %C");
5720 /* Save the current identifier and look for more. */
5723 /* Increment the number of identifiers found for this spec stmt. */
5726 /* Make sure we have a sym or com block, and verify that it can
5727 be bind(c). Set the appropriate field(s) and look for more
5729 if (tmp_sym
!= NULL
|| com_block
!= NULL
)
5731 if (tmp_sym
!= NULL
)
5733 if (!set_verify_bind_c_sym (tmp_sym
, num_idents
))
5738 if (!set_verify_bind_c_com_block (com_block
, num_idents
))
5742 /* Look to see if we have another identifier. */
5744 if (gfc_match_eos () == MATCH_YES
)
5745 found_id
= MATCH_NO
;
5746 else if (gfc_match_char (',') != MATCH_YES
)
5747 found_id
= MATCH_NO
;
5748 else if (gfc_match_name (name
) == MATCH_YES
)
5750 found_id
= MATCH_YES
;
5751 gfc_get_ha_symbol (name
, &tmp_sym
);
5753 else if (match_common_name (name
) == MATCH_YES
)
5755 found_id
= MATCH_YES
;
5756 com_block
= gfc_get_common (name
, 0);
5760 gfc_error ("Missing entity or common block name for "
5761 "attribute specification statement at %C");
5767 gfc_internal_error ("Missing symbol");
5769 } while (found_id
== MATCH_YES
);
5771 /* if we get here we were successful */
5776 /* Try and match a BIND(C) attribute specification statement. */
5779 gfc_match_bind_c_stmt (void)
5781 match found_match
= MATCH_NO
;
5786 /* This may not be necessary. */
5788 /* Clear the temporary binding label holder. */
5789 curr_binding_label
= NULL
;
5791 /* Look for the bind(c). */
5792 found_match
= gfc_match_bind_c (NULL
, true);
5794 if (found_match
== MATCH_YES
)
5796 if (!gfc_notify_std (GFC_STD_F2003
, "BIND(C) statement at %C"))
5799 /* Look for the :: now, but it is not required. */
5802 /* Get the identifier(s) that needs to be updated. This may need to
5803 change to hand the flag(s) for the attr specified so all identifiers
5804 found can have all appropriate parts updated (assuming that the same
5805 spec stmt can have multiple attrs, such as both bind(c) and
5807 if (!get_bind_c_idents ())
5808 /* Error message should have printed already. */
5816 /* Match a data declaration statement. */
5819 gfc_match_data_decl (void)
5825 type_param_spec_list
= NULL
;
5826 decl_type_param_list
= NULL
;
5828 num_idents_on_line
= 0;
5830 m
= gfc_match_decl_type_spec (¤t_ts
, 0);
5834 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
5835 && !gfc_comp_struct (gfc_current_state ()))
5837 sym
= gfc_use_derived (current_ts
.u
.derived
);
5845 current_ts
.u
.derived
= sym
;
5848 m
= match_attr_spec ();
5849 if (m
== MATCH_ERROR
)
5855 if (current_ts
.type
== BT_CLASS
5856 && current_ts
.u
.derived
->attr
.unlimited_polymorphic
)
5859 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
5860 && current_ts
.u
.derived
->components
== NULL
5861 && !current_ts
.u
.derived
->attr
.zero_comp
)
5864 if (current_attr
.pointer
&& gfc_comp_struct (gfc_current_state ()))
5867 if (current_attr
.allocatable
&& gfc_current_state () == COMP_DERIVED
)
5870 gfc_find_symbol (current_ts
.u
.derived
->name
,
5871 current_ts
.u
.derived
->ns
, 1, &sym
);
5873 /* Any symbol that we find had better be a type definition
5874 which has its components defined, or be a structure definition
5875 actively being parsed. */
5876 if (sym
!= NULL
&& gfc_fl_struct (sym
->attr
.flavor
)
5877 && (current_ts
.u
.derived
->components
!= NULL
5878 || current_ts
.u
.derived
->attr
.zero_comp
5879 || current_ts
.u
.derived
== gfc_new_block
))
5882 gfc_error ("Derived type at %C has not been previously defined "
5883 "and so cannot appear in a derived type definition");
5889 /* If we have an old-style character declaration, and no new-style
5890 attribute specifications, then there a comma is optional between
5891 the type specification and the variable list. */
5892 if (m
== MATCH_NO
&& current_ts
.type
== BT_CHARACTER
&& old_char_selector
)
5893 gfc_match_char (',');
5895 /* Give the types/attributes to symbols that follow. Give the element
5896 a number so that repeat character length expressions can be copied. */
5900 num_idents_on_line
++;
5901 m
= variable_decl (elem
++);
5902 if (m
== MATCH_ERROR
)
5907 if (gfc_match_eos () == MATCH_YES
)
5909 if (gfc_match_char (',') != MATCH_YES
)
5913 if (!gfc_error_flag_test ())
5915 /* An anonymous structure declaration is unambiguous; if we matched one
5916 according to gfc_match_structure_decl, we need to return MATCH_YES
5917 here to avoid confusing the remaining matchers, even if there was an
5918 error during variable_decl. We must flush any such errors. Note this
5919 causes the parser to gracefully continue parsing the remaining input
5920 as a structure body, which likely follows. */
5921 if (current_ts
.type
== BT_DERIVED
&& current_ts
.u
.derived
5922 && gfc_fl_struct (current_ts
.u
.derived
->attr
.flavor
))
5924 gfc_error_now ("Syntax error in anonymous structure declaration"
5926 /* Skip the bad variable_decl and line up for the start of the
5928 gfc_error_recovery ();
5933 gfc_error ("Syntax error in data declaration at %C");
5938 gfc_free_data_all (gfc_current_ns
);
5941 if (saved_kind_expr
)
5942 gfc_free_expr (saved_kind_expr
);
5943 if (type_param_spec_list
)
5944 gfc_free_actual_arglist (type_param_spec_list
);
5945 if (decl_type_param_list
)
5946 gfc_free_actual_arglist (decl_type_param_list
);
5947 saved_kind_expr
= NULL
;
5948 gfc_free_array_spec (current_as
);
5954 /* Match a prefix associated with a function or subroutine
5955 declaration. If the typespec pointer is nonnull, then a typespec
5956 can be matched. Note that if nothing matches, MATCH_YES is
5957 returned (the null string was matched). */
5960 gfc_match_prefix (gfc_typespec
*ts
)
5966 gfc_clear_attr (¤t_attr
);
5968 seen_impure
= false;
5970 gcc_assert (!gfc_matching_prefix
);
5971 gfc_matching_prefix
= true;
5975 found_prefix
= false;
5977 /* MODULE is a prefix like PURE, ELEMENTAL, etc., having a
5978 corresponding attribute seems natural and distinguishes these
5979 procedures from procedure types of PROC_MODULE, which these are
5981 if (gfc_match ("module% ") == MATCH_YES
)
5983 if (!gfc_notify_std (GFC_STD_F2008
, "MODULE prefix at %C"))
5986 current_attr
.module_procedure
= 1;
5987 found_prefix
= true;
5990 if (!seen_type
&& ts
!= NULL
5991 && gfc_match_decl_type_spec (ts
, 0) == MATCH_YES
5992 && gfc_match_space () == MATCH_YES
)
5996 found_prefix
= true;
5999 if (gfc_match ("elemental% ") == MATCH_YES
)
6001 if (!gfc_add_elemental (¤t_attr
, NULL
))
6004 found_prefix
= true;
6007 if (gfc_match ("pure% ") == MATCH_YES
)
6009 if (!gfc_add_pure (¤t_attr
, NULL
))
6012 found_prefix
= true;
6015 if (gfc_match ("recursive% ") == MATCH_YES
)
6017 if (!gfc_add_recursive (¤t_attr
, NULL
))
6020 found_prefix
= true;
6023 /* IMPURE is a somewhat special case, as it needs not set an actual
6024 attribute but rather only prevents ELEMENTAL routines from being
6025 automatically PURE. */
6026 if (gfc_match ("impure% ") == MATCH_YES
)
6028 if (!gfc_notify_std (GFC_STD_F2008
, "IMPURE procedure at %C"))
6032 found_prefix
= true;
6035 while (found_prefix
);
6037 /* IMPURE and PURE must not both appear, of course. */
6038 if (seen_impure
&& current_attr
.pure
)
6040 gfc_error ("PURE and IMPURE must not appear both at %C");
6044 /* If IMPURE it not seen but the procedure is ELEMENTAL, mark it as PURE. */
6045 if (!seen_impure
&& current_attr
.elemental
&& !current_attr
.pure
)
6047 if (!gfc_add_pure (¤t_attr
, NULL
))
6051 /* At this point, the next item is not a prefix. */
6052 gcc_assert (gfc_matching_prefix
);
6054 gfc_matching_prefix
= false;
6058 gcc_assert (gfc_matching_prefix
);
6059 gfc_matching_prefix
= false;
6064 /* Copy attributes matched by gfc_match_prefix() to attributes on a symbol. */
6067 copy_prefix (symbol_attribute
*dest
, locus
*where
)
6069 if (dest
->module_procedure
)
6071 if (current_attr
.elemental
)
6072 dest
->elemental
= 1;
6074 if (current_attr
.pure
)
6077 if (current_attr
.recursive
)
6078 dest
->recursive
= 1;
6080 /* Module procedures are unusual in that the 'dest' is copied from
6081 the interface declaration. However, this is an oportunity to
6082 check that the submodule declaration is compliant with the
6084 if (dest
->elemental
&& !current_attr
.elemental
)
6086 gfc_error ("ELEMENTAL prefix in MODULE PROCEDURE interface is "
6087 "missing at %L", where
);
6091 if (dest
->pure
&& !current_attr
.pure
)
6093 gfc_error ("PURE prefix in MODULE PROCEDURE interface is "
6094 "missing at %L", where
);
6098 if (dest
->recursive
&& !current_attr
.recursive
)
6100 gfc_error ("RECURSIVE prefix in MODULE PROCEDURE interface is "
6101 "missing at %L", where
);
6108 if (current_attr
.elemental
&& !gfc_add_elemental (dest
, where
))
6111 if (current_attr
.pure
&& !gfc_add_pure (dest
, where
))
6114 if (current_attr
.recursive
&& !gfc_add_recursive (dest
, where
))
6121 /* Match a formal argument list or, if typeparam is true, a
6122 type_param_name_list. */
6125 gfc_match_formal_arglist (gfc_symbol
*progname
, int st_flag
,
6126 int null_flag
, bool typeparam
)
6128 gfc_formal_arglist
*head
, *tail
, *p
, *q
;
6129 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6132 gfc_formal_arglist
*formal
= NULL
;
6136 /* Keep the interface formal argument list and null it so that the
6137 matching for the new declaration can be done. The numbers and
6138 names of the arguments are checked here. The interface formal
6139 arguments are retained in formal_arglist and the characteristics
6140 are compared in resolve.c(resolve_fl_procedure). See the remark
6141 in get_proc_name about the eventual need to copy the formal_arglist
6142 and populate the formal namespace of the interface symbol. */
6143 if (progname
->attr
.module_procedure
6144 && progname
->attr
.host_assoc
)
6146 formal
= progname
->formal
;
6147 progname
->formal
= NULL
;
6150 if (gfc_match_char ('(') != MATCH_YES
)
6157 if (gfc_match_char (')') == MATCH_YES
)
6162 if (gfc_match_char ('*') == MATCH_YES
)
6165 if (!typeparam
&& !gfc_notify_std (GFC_STD_F95_OBS
,
6166 "Alternate-return argument at %C"))
6172 gfc_error_now ("A parameter name is required at %C");
6176 m
= gfc_match_name (name
);
6180 gfc_error_now ("A parameter name is required at %C");
6184 if (!typeparam
&& gfc_get_symbol (name
, NULL
, &sym
))
6187 && gfc_get_symbol (name
, progname
->f2k_derived
, &sym
))
6191 p
= gfc_get_formal_arglist ();
6203 /* We don't add the VARIABLE flavor because the name could be a
6204 dummy procedure. We don't apply these attributes to formal
6205 arguments of statement functions. */
6206 if (sym
!= NULL
&& !st_flag
6207 && (!gfc_add_dummy(&sym
->attr
, sym
->name
, NULL
)
6208 || !gfc_missing_attr (&sym
->attr
, NULL
)))
6214 /* The name of a program unit can be in a different namespace,
6215 so check for it explicitly. After the statement is accepted,
6216 the name is checked for especially in gfc_get_symbol(). */
6217 if (gfc_new_block
!= NULL
&& sym
!= NULL
&& !typeparam
6218 && strcmp (sym
->name
, gfc_new_block
->name
) == 0)
6220 gfc_error ("Name %qs at %C is the name of the procedure",
6226 if (gfc_match_char (')') == MATCH_YES
)
6229 m
= gfc_match_char (',');
6233 gfc_error_now ("Expected parameter list in type declaration "
6236 gfc_error ("Unexpected junk in formal argument list at %C");
6242 /* Check for duplicate symbols in the formal argument list. */
6245 for (p
= head
; p
->next
; p
= p
->next
)
6250 for (q
= p
->next
; q
; q
= q
->next
)
6251 if (p
->sym
== q
->sym
)
6254 gfc_error_now ("Duplicate name %qs in parameter "
6255 "list at %C", p
->sym
->name
);
6257 gfc_error ("Duplicate symbol %qs in formal argument "
6258 "list at %C", p
->sym
->name
);
6266 if (!gfc_add_explicit_interface (progname
, IFSRC_DECL
, head
, NULL
))
6272 /* gfc_error_now used in following and return with MATCH_YES because
6273 doing otherwise results in a cascade of extraneous errors and in
6274 some cases an ICE in symbol.c(gfc_release_symbol). */
6275 if (progname
->attr
.module_procedure
&& progname
->attr
.host_assoc
)
6277 bool arg_count_mismatch
= false;
6279 if (!formal
&& head
)
6280 arg_count_mismatch
= true;
6282 /* Abbreviated module procedure declaration is not meant to have any
6283 formal arguments! */
6284 if (!progname
->abr_modproc_decl
&& formal
&& !head
)
6285 arg_count_mismatch
= true;
6287 for (p
= formal
, q
= head
; p
&& q
; p
= p
->next
, q
= q
->next
)
6289 if ((p
->next
!= NULL
&& q
->next
== NULL
)
6290 || (p
->next
== NULL
&& q
->next
!= NULL
))
6291 arg_count_mismatch
= true;
6292 else if ((p
->sym
== NULL
&& q
->sym
== NULL
)
6293 || strcmp (p
->sym
->name
, q
->sym
->name
) == 0)
6296 gfc_error_now ("Mismatch in MODULE PROCEDURE formal "
6297 "argument names (%s/%s) at %C",
6298 p
->sym
->name
, q
->sym
->name
);
6301 if (arg_count_mismatch
)
6302 gfc_error_now ("Mismatch in number of MODULE PROCEDURE "
6303 "formal arguments at %C");
6309 gfc_free_formal_arglist (head
);
6314 /* Match a RESULT specification following a function declaration or
6315 ENTRY statement. Also matches the end-of-statement. */
6318 match_result (gfc_symbol
*function
, gfc_symbol
**result
)
6320 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6324 if (gfc_match (" result (") != MATCH_YES
)
6327 m
= gfc_match_name (name
);
6331 /* Get the right paren, and that's it because there could be the
6332 bind(c) attribute after the result clause. */
6333 if (gfc_match_char (')') != MATCH_YES
)
6335 /* TODO: should report the missing right paren here. */
6339 if (strcmp (function
->name
, name
) == 0)
6341 gfc_error ("RESULT variable at %C must be different than function name");
6345 if (gfc_get_symbol (name
, NULL
, &r
))
6348 if (!gfc_add_result (&r
->attr
, r
->name
, NULL
))
6357 /* Match a function suffix, which could be a combination of a result
6358 clause and BIND(C), either one, or neither. The draft does not
6359 require them to come in a specific order. */
6362 gfc_match_suffix (gfc_symbol
*sym
, gfc_symbol
**result
)
6364 match is_bind_c
; /* Found bind(c). */
6365 match is_result
; /* Found result clause. */
6366 match found_match
; /* Status of whether we've found a good match. */
6367 char peek_char
; /* Character we're going to peek at. */
6368 bool allow_binding_name
;
6370 /* Initialize to having found nothing. */
6371 found_match
= MATCH_NO
;
6372 is_bind_c
= MATCH_NO
;
6373 is_result
= MATCH_NO
;
6375 /* Get the next char to narrow between result and bind(c). */
6376 gfc_gobble_whitespace ();
6377 peek_char
= gfc_peek_ascii_char ();
6379 /* C binding names are not allowed for internal procedures. */
6380 if (gfc_current_state () == COMP_CONTAINS
6381 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
6382 allow_binding_name
= false;
6384 allow_binding_name
= true;
6389 /* Look for result clause. */
6390 is_result
= match_result (sym
, result
);
6391 if (is_result
== MATCH_YES
)
6393 /* Now see if there is a bind(c) after it. */
6394 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
6395 /* We've found the result clause and possibly bind(c). */
6396 found_match
= MATCH_YES
;
6399 /* This should only be MATCH_ERROR. */
6400 found_match
= is_result
;
6403 /* Look for bind(c) first. */
6404 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
6405 if (is_bind_c
== MATCH_YES
)
6407 /* Now see if a result clause followed it. */
6408 is_result
= match_result (sym
, result
);
6409 found_match
= MATCH_YES
;
6413 /* Should only be a MATCH_ERROR if we get here after seeing 'b'. */
6414 found_match
= MATCH_ERROR
;
6418 gfc_error ("Unexpected junk after function declaration at %C");
6419 found_match
= MATCH_ERROR
;
6423 if (is_bind_c
== MATCH_YES
)
6425 /* Fortran 2008 draft allows BIND(C) for internal procedures. */
6426 if (gfc_current_state () == COMP_CONTAINS
6427 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
6428 && !gfc_notify_std (GFC_STD_F2008
, "BIND(C) attribute "
6429 "at %L may not be specified for an internal "
6430 "procedure", &gfc_current_locus
))
6433 if (!gfc_add_is_bind_c (&(sym
->attr
), sym
->name
, &gfc_current_locus
, 1))
6441 /* Procedure pointer return value without RESULT statement:
6442 Add "hidden" result variable named "ppr@". */
6445 add_hidden_procptr_result (gfc_symbol
*sym
)
6449 if (gfc_notification_std (GFC_STD_F2003
) == ERROR
)
6452 /* First usage case: PROCEDURE and EXTERNAL statements. */
6453 case1
= gfc_current_state () == COMP_FUNCTION
&& gfc_current_block ()
6454 && strcmp (gfc_current_block ()->name
, sym
->name
) == 0
6455 && sym
->attr
.external
;
6456 /* Second usage case: INTERFACE statements. */
6457 case2
= gfc_current_state () == COMP_INTERFACE
&& gfc_state_stack
->previous
6458 && gfc_state_stack
->previous
->state
== COMP_FUNCTION
6459 && strcmp (gfc_state_stack
->previous
->sym
->name
, sym
->name
) == 0;
6465 gfc_get_sym_tree ("ppr@", gfc_current_ns
, &stree
, false);
6469 gfc_get_sym_tree ("ppr@", gfc_current_ns
->parent
, &stree
, false);
6470 st2
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "ppr@");
6471 st2
->n
.sym
= stree
->n
.sym
;
6472 stree
->n
.sym
->refs
++;
6474 sym
->result
= stree
->n
.sym
;
6476 sym
->result
->attr
.proc_pointer
= sym
->attr
.proc_pointer
;
6477 sym
->result
->attr
.pointer
= sym
->attr
.pointer
;
6478 sym
->result
->attr
.external
= sym
->attr
.external
;
6479 sym
->result
->attr
.referenced
= sym
->attr
.referenced
;
6480 sym
->result
->ts
= sym
->ts
;
6481 sym
->attr
.proc_pointer
= 0;
6482 sym
->attr
.pointer
= 0;
6483 sym
->attr
.external
= 0;
6484 if (sym
->result
->attr
.external
&& sym
->result
->attr
.pointer
)
6486 sym
->result
->attr
.pointer
= 0;
6487 sym
->result
->attr
.proc_pointer
= 1;
6490 return gfc_add_result (&sym
->result
->attr
, sym
->result
->name
, NULL
);
6492 /* POINTER after PROCEDURE/EXTERNAL/INTERFACE statement. */
6493 else if (sym
->attr
.function
&& !sym
->attr
.external
&& sym
->attr
.pointer
6494 && sym
->result
&& sym
->result
!= sym
&& sym
->result
->attr
.external
6495 && sym
== gfc_current_ns
->proc_name
6496 && sym
== sym
->result
->ns
->proc_name
6497 && strcmp ("ppr@", sym
->result
->name
) == 0)
6499 sym
->result
->attr
.proc_pointer
= 1;
6500 sym
->attr
.pointer
= 0;
6508 /* Match the interface for a PROCEDURE declaration,
6509 including brackets (R1212). */
6512 match_procedure_interface (gfc_symbol
**proc_if
)
6516 locus old_loc
, entry_loc
;
6517 gfc_namespace
*old_ns
= gfc_current_ns
;
6518 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6520 old_loc
= entry_loc
= gfc_current_locus
;
6521 gfc_clear_ts (¤t_ts
);
6523 if (gfc_match (" (") != MATCH_YES
)
6525 gfc_current_locus
= entry_loc
;
6529 /* Get the type spec. for the procedure interface. */
6530 old_loc
= gfc_current_locus
;
6531 m
= gfc_match_decl_type_spec (¤t_ts
, 0);
6532 gfc_gobble_whitespace ();
6533 if (m
== MATCH_YES
|| (m
== MATCH_NO
&& gfc_peek_ascii_char () == ')'))
6536 if (m
== MATCH_ERROR
)
6539 /* Procedure interface is itself a procedure. */
6540 gfc_current_locus
= old_loc
;
6541 m
= gfc_match_name (name
);
6543 /* First look to see if it is already accessible in the current
6544 namespace because it is use associated or contained. */
6546 if (gfc_find_sym_tree (name
, NULL
, 0, &st
))
6549 /* If it is still not found, then try the parent namespace, if it
6550 exists and create the symbol there if it is still not found. */
6551 if (gfc_current_ns
->parent
)
6552 gfc_current_ns
= gfc_current_ns
->parent
;
6553 if (st
== NULL
&& gfc_get_ha_sym_tree (name
, &st
))
6556 gfc_current_ns
= old_ns
;
6557 *proc_if
= st
->n
.sym
;
6562 /* Resolve interface if possible. That way, attr.procedure is only set
6563 if it is declared by a later procedure-declaration-stmt, which is
6564 invalid per F08:C1216 (cf. resolve_procedure_interface). */
6565 while ((*proc_if
)->ts
.interface
6566 && *proc_if
!= (*proc_if
)->ts
.interface
)
6567 *proc_if
= (*proc_if
)->ts
.interface
;
6569 if ((*proc_if
)->attr
.flavor
== FL_UNKNOWN
6570 && (*proc_if
)->ts
.type
== BT_UNKNOWN
6571 && !gfc_add_flavor (&(*proc_if
)->attr
, FL_PROCEDURE
,
6572 (*proc_if
)->name
, NULL
))
6577 if (gfc_match (" )") != MATCH_YES
)
6579 gfc_current_locus
= entry_loc
;
6587 /* Match a PROCEDURE declaration (R1211). */
6590 match_procedure_decl (void)
6593 gfc_symbol
*sym
, *proc_if
= NULL
;
6595 gfc_expr
*initializer
= NULL
;
6597 /* Parse interface (with brackets). */
6598 m
= match_procedure_interface (&proc_if
);
6602 /* Parse attributes (with colons). */
6603 m
= match_attr_spec();
6604 if (m
== MATCH_ERROR
)
6607 if (proc_if
&& proc_if
->attr
.is_bind_c
&& !current_attr
.is_bind_c
)
6609 current_attr
.is_bind_c
= 1;
6610 has_name_equals
= 0;
6611 curr_binding_label
= NULL
;
6614 /* Get procedure symbols. */
6617 m
= gfc_match_symbol (&sym
, 0);
6620 else if (m
== MATCH_ERROR
)
6623 /* Add current_attr to the symbol attributes. */
6624 if (!gfc_copy_attr (&sym
->attr
, ¤t_attr
, NULL
))
6627 if (sym
->attr
.is_bind_c
)
6629 /* Check for C1218. */
6630 if (!proc_if
|| !proc_if
->attr
.is_bind_c
)
6632 gfc_error ("BIND(C) attribute at %C requires "
6633 "an interface with BIND(C)");
6636 /* Check for C1217. */
6637 if (has_name_equals
&& sym
->attr
.pointer
)
6639 gfc_error ("BIND(C) procedure with NAME may not have "
6640 "POINTER attribute at %C");
6643 if (has_name_equals
&& sym
->attr
.dummy
)
6645 gfc_error ("Dummy procedure at %C may not have "
6646 "BIND(C) attribute with NAME");
6649 /* Set binding label for BIND(C). */
6650 if (!set_binding_label (&sym
->binding_label
, sym
->name
, num
))
6654 if (!gfc_add_external (&sym
->attr
, NULL
))
6657 if (add_hidden_procptr_result (sym
))
6660 if (!gfc_add_proc (&sym
->attr
, sym
->name
, NULL
))
6663 /* Set interface. */
6664 if (proc_if
!= NULL
)
6666 if (sym
->ts
.type
!= BT_UNKNOWN
)
6668 gfc_error ("Procedure %qs at %L already has basic type of %s",
6669 sym
->name
, &gfc_current_locus
,
6670 gfc_basic_typename (sym
->ts
.type
));
6673 sym
->ts
.interface
= proc_if
;
6674 sym
->attr
.untyped
= 1;
6675 sym
->attr
.if_source
= IFSRC_IFBODY
;
6677 else if (current_ts
.type
!= BT_UNKNOWN
)
6679 if (!gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
6681 sym
->ts
.interface
= gfc_new_symbol ("", gfc_current_ns
);
6682 sym
->ts
.interface
->ts
= current_ts
;
6683 sym
->ts
.interface
->attr
.flavor
= FL_PROCEDURE
;
6684 sym
->ts
.interface
->attr
.function
= 1;
6685 sym
->attr
.function
= 1;
6686 sym
->attr
.if_source
= IFSRC_UNKNOWN
;
6689 if (gfc_match (" =>") == MATCH_YES
)
6691 if (!current_attr
.pointer
)
6693 gfc_error ("Initialization at %C isn't for a pointer variable");
6698 m
= match_pointer_init (&initializer
, 1);
6702 if (!add_init_expr_to_sym (sym
->name
, &initializer
, &gfc_current_locus
))
6707 if (gfc_match_eos () == MATCH_YES
)
6709 if (gfc_match_char (',') != MATCH_YES
)
6714 gfc_error ("Syntax error in PROCEDURE statement at %C");
6718 /* Free stuff up and return. */
6719 gfc_free_expr (initializer
);
6725 match_binding_attributes (gfc_typebound_proc
* ba
, bool generic
, bool ppc
);
6728 /* Match a procedure pointer component declaration (R445). */
6731 match_ppc_decl (void)
6734 gfc_symbol
*proc_if
= NULL
;
6738 gfc_expr
*initializer
= NULL
;
6739 gfc_typebound_proc
* tb
;
6740 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6742 /* Parse interface (with brackets). */
6743 m
= match_procedure_interface (&proc_if
);
6747 /* Parse attributes. */
6748 tb
= XCNEW (gfc_typebound_proc
);
6749 tb
->where
= gfc_current_locus
;
6750 m
= match_binding_attributes (tb
, false, true);
6751 if (m
== MATCH_ERROR
)
6754 gfc_clear_attr (¤t_attr
);
6755 current_attr
.procedure
= 1;
6756 current_attr
.proc_pointer
= 1;
6757 current_attr
.access
= tb
->access
;
6758 current_attr
.flavor
= FL_PROCEDURE
;
6760 /* Match the colons (required). */
6761 if (gfc_match (" ::") != MATCH_YES
)
6763 gfc_error ("Expected %<::%> after binding-attributes at %C");
6767 /* Check for C450. */
6768 if (!tb
->nopass
&& proc_if
== NULL
)
6770 gfc_error("NOPASS or explicit interface required at %C");
6774 if (!gfc_notify_std (GFC_STD_F2003
, "Procedure pointer component at %C"))
6777 /* Match PPC names. */
6781 m
= gfc_match_name (name
);
6784 else if (m
== MATCH_ERROR
)
6787 if (!gfc_add_component (gfc_current_block(), name
, &c
))
6790 /* Add current_attr to the symbol attributes. */
6791 if (!gfc_copy_attr (&c
->attr
, ¤t_attr
, NULL
))
6794 if (!gfc_add_external (&c
->attr
, NULL
))
6797 if (!gfc_add_proc (&c
->attr
, name
, NULL
))
6804 c
->tb
= XCNEW (gfc_typebound_proc
);
6805 c
->tb
->where
= gfc_current_locus
;
6809 /* Set interface. */
6810 if (proc_if
!= NULL
)
6812 c
->ts
.interface
= proc_if
;
6813 c
->attr
.untyped
= 1;
6814 c
->attr
.if_source
= IFSRC_IFBODY
;
6816 else if (ts
.type
!= BT_UNKNOWN
)
6819 c
->ts
.interface
= gfc_new_symbol ("", gfc_current_ns
);
6820 c
->ts
.interface
->result
= c
->ts
.interface
;
6821 c
->ts
.interface
->ts
= ts
;
6822 c
->ts
.interface
->attr
.flavor
= FL_PROCEDURE
;
6823 c
->ts
.interface
->attr
.function
= 1;
6824 c
->attr
.function
= 1;
6825 c
->attr
.if_source
= IFSRC_UNKNOWN
;
6828 if (gfc_match (" =>") == MATCH_YES
)
6830 m
= match_pointer_init (&initializer
, 1);
6833 gfc_free_expr (initializer
);
6836 c
->initializer
= initializer
;
6839 if (gfc_match_eos () == MATCH_YES
)
6841 if (gfc_match_char (',') != MATCH_YES
)
6846 gfc_error ("Syntax error in procedure pointer component at %C");
6851 /* Match a PROCEDURE declaration inside an interface (R1206). */
6854 match_procedure_in_interface (void)
6858 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6861 if (current_interface
.type
== INTERFACE_NAMELESS
6862 || current_interface
.type
== INTERFACE_ABSTRACT
)
6864 gfc_error ("PROCEDURE at %C must be in a generic interface");
6868 /* Check if the F2008 optional double colon appears. */
6869 gfc_gobble_whitespace ();
6870 old_locus
= gfc_current_locus
;
6871 if (gfc_match ("::") == MATCH_YES
)
6873 if (!gfc_notify_std (GFC_STD_F2008
, "double colon in "
6874 "MODULE PROCEDURE statement at %L", &old_locus
))
6878 gfc_current_locus
= old_locus
;
6882 m
= gfc_match_name (name
);
6885 else if (m
== MATCH_ERROR
)
6887 if (gfc_get_symbol (name
, gfc_current_ns
->parent
, &sym
))
6890 if (!gfc_add_interface (sym
))
6893 if (gfc_match_eos () == MATCH_YES
)
6895 if (gfc_match_char (',') != MATCH_YES
)
6902 gfc_error ("Syntax error in PROCEDURE statement at %C");
6907 /* General matcher for PROCEDURE declarations. */
6909 static match
match_procedure_in_type (void);
6912 gfc_match_procedure (void)
6916 switch (gfc_current_state ())
6921 case COMP_SUBMODULE
:
6922 case COMP_SUBROUTINE
:
6925 m
= match_procedure_decl ();
6927 case COMP_INTERFACE
:
6928 m
= match_procedure_in_interface ();
6931 m
= match_ppc_decl ();
6933 case COMP_DERIVED_CONTAINS
:
6934 m
= match_procedure_in_type ();
6943 if (!gfc_notify_std (GFC_STD_F2003
, "PROCEDURE statement at %C"))
6950 /* Warn if a matched procedure has the same name as an intrinsic; this is
6951 simply a wrapper around gfc_warn_intrinsic_shadow that interprets the current
6952 parser-state-stack to find out whether we're in a module. */
6955 do_warn_intrinsic_shadow (const gfc_symbol
* sym
, bool func
)
6959 in_module
= (gfc_state_stack
->previous
6960 && (gfc_state_stack
->previous
->state
== COMP_MODULE
6961 || gfc_state_stack
->previous
->state
== COMP_SUBMODULE
));
6963 gfc_warn_intrinsic_shadow (sym
, in_module
, func
);
6967 /* Match a function declaration. */
6970 gfc_match_function_decl (void)
6972 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6973 gfc_symbol
*sym
, *result
;
6977 match found_match
; /* Status returned by match func. */
6979 if (gfc_current_state () != COMP_NONE
6980 && gfc_current_state () != COMP_INTERFACE
6981 && gfc_current_state () != COMP_CONTAINS
)
6984 gfc_clear_ts (¤t_ts
);
6986 old_loc
= gfc_current_locus
;
6988 m
= gfc_match_prefix (¤t_ts
);
6991 gfc_current_locus
= old_loc
;
6995 if (gfc_match ("function% %n", name
) != MATCH_YES
)
6997 gfc_current_locus
= old_loc
;
7001 if (get_proc_name (name
, &sym
, false))
7004 if (add_hidden_procptr_result (sym
))
7007 if (current_attr
.module_procedure
)
7008 sym
->attr
.module_procedure
= 1;
7010 gfc_new_block
= sym
;
7012 m
= gfc_match_formal_arglist (sym
, 0, 0);
7015 gfc_error ("Expected formal argument list in function "
7016 "definition at %C");
7020 else if (m
== MATCH_ERROR
)
7025 /* According to the draft, the bind(c) and result clause can
7026 come in either order after the formal_arg_list (i.e., either
7027 can be first, both can exist together or by themselves or neither
7028 one). Therefore, the match_result can't match the end of the
7029 string, and check for the bind(c) or result clause in either order. */
7030 found_match
= gfc_match_eos ();
7032 /* Make sure that it isn't already declared as BIND(C). If it is, it
7033 must have been marked BIND(C) with a BIND(C) attribute and that is
7034 not allowed for procedures. */
7035 if (sym
->attr
.is_bind_c
== 1)
7037 sym
->attr
.is_bind_c
= 0;
7038 if (sym
->old_symbol
!= NULL
)
7039 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7040 "variables or common blocks",
7041 &(sym
->old_symbol
->declared_at
));
7043 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7044 "variables or common blocks", &gfc_current_locus
);
7047 if (found_match
!= MATCH_YES
)
7049 /* If we haven't found the end-of-statement, look for a suffix. */
7050 suffix_match
= gfc_match_suffix (sym
, &result
);
7051 if (suffix_match
== MATCH_YES
)
7052 /* Need to get the eos now. */
7053 found_match
= gfc_match_eos ();
7055 found_match
= suffix_match
;
7058 if(found_match
!= MATCH_YES
)
7062 /* Make changes to the symbol. */
7065 if (!gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
7068 if (!gfc_missing_attr (&sym
->attr
, NULL
))
7071 if (!copy_prefix (&sym
->attr
, &sym
->declared_at
))
7073 if(!sym
->attr
.module_procedure
)
7079 /* Delay matching the function characteristics until after the
7080 specification block by signalling kind=-1. */
7081 sym
->declared_at
= old_loc
;
7082 if (current_ts
.type
!= BT_UNKNOWN
)
7083 current_ts
.kind
= -1;
7085 current_ts
.kind
= 0;
7089 if (current_ts
.type
!= BT_UNKNOWN
7090 && !gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
7096 if (current_ts
.type
!= BT_UNKNOWN
7097 && !gfc_add_type (result
, ¤t_ts
, &gfc_current_locus
))
7099 sym
->result
= result
;
7102 /* Warn if this procedure has the same name as an intrinsic. */
7103 do_warn_intrinsic_shadow (sym
, true);
7109 gfc_current_locus
= old_loc
;
7114 /* This is mostly a copy of parse.c(add_global_procedure) but modified to
7115 pass the name of the entry, rather than the gfc_current_block name, and
7116 to return false upon finding an existing global entry. */
7119 add_global_entry (const char *name
, const char *binding_label
, bool sub
,
7123 enum gfc_symbol_type type
;
7125 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
7127 /* Only in Fortran 2003: For procedures with a binding label also the Fortran
7128 name is a global identifier. */
7129 if (!binding_label
|| gfc_notification_std (GFC_STD_F2008
))
7131 s
= gfc_get_gsymbol (name
);
7133 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= type
))
7135 gfc_global_used (s
, where
);
7144 s
->ns
= gfc_current_ns
;
7148 /* Don't add the symbol multiple times. */
7150 && (!gfc_notification_std (GFC_STD_F2008
)
7151 || strcmp (name
, binding_label
) != 0))
7153 s
= gfc_get_gsymbol (binding_label
);
7155 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= type
))
7157 gfc_global_used (s
, where
);
7164 s
->binding_label
= binding_label
;
7167 s
->ns
= gfc_current_ns
;
7175 /* Match an ENTRY statement. */
7178 gfc_match_entry (void)
7183 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7184 gfc_compile_state state
;
7188 bool module_procedure
;
7192 m
= gfc_match_name (name
);
7196 if (!gfc_notify_std (GFC_STD_F2008_OBS
, "ENTRY statement at %C"))
7199 state
= gfc_current_state ();
7200 if (state
!= COMP_SUBROUTINE
&& state
!= COMP_FUNCTION
)
7205 gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
7208 gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
7210 case COMP_SUBMODULE
:
7211 gfc_error ("ENTRY statement at %C cannot appear within a SUBMODULE");
7213 case COMP_BLOCK_DATA
:
7214 gfc_error ("ENTRY statement at %C cannot appear within "
7217 case COMP_INTERFACE
:
7218 gfc_error ("ENTRY statement at %C cannot appear within "
7221 case COMP_STRUCTURE
:
7222 gfc_error ("ENTRY statement at %C cannot appear within "
7223 "a STRUCTURE block");
7226 gfc_error ("ENTRY statement at %C cannot appear within "
7227 "a DERIVED TYPE block");
7230 gfc_error ("ENTRY statement at %C cannot appear within "
7231 "an IF-THEN block");
7234 case COMP_DO_CONCURRENT
:
7235 gfc_error ("ENTRY statement at %C cannot appear within "
7239 gfc_error ("ENTRY statement at %C cannot appear within "
7243 gfc_error ("ENTRY statement at %C cannot appear within "
7247 gfc_error ("ENTRY statement at %C cannot appear within "
7251 gfc_error ("ENTRY statement at %C cannot appear within "
7252 "a contained subprogram");
7255 gfc_error ("Unexpected ENTRY statement at %C");
7260 if ((state
== COMP_SUBROUTINE
|| state
== COMP_FUNCTION
)
7261 && gfc_state_stack
->previous
->state
== COMP_INTERFACE
)
7263 gfc_error ("ENTRY statement at %C cannot appear within an INTERFACE");
7267 module_procedure
= gfc_current_ns
->parent
!= NULL
7268 && gfc_current_ns
->parent
->proc_name
7269 && gfc_current_ns
->parent
->proc_name
->attr
.flavor
7272 if (gfc_current_ns
->parent
!= NULL
7273 && gfc_current_ns
->parent
->proc_name
7274 && !module_procedure
)
7276 gfc_error("ENTRY statement at %C cannot appear in a "
7277 "contained procedure");
7281 /* Module function entries need special care in get_proc_name
7282 because previous references within the function will have
7283 created symbols attached to the current namespace. */
7284 if (get_proc_name (name
, &entry
,
7285 gfc_current_ns
->parent
!= NULL
7286 && module_procedure
))
7289 proc
= gfc_current_block ();
7291 /* Make sure that it isn't already declared as BIND(C). If it is, it
7292 must have been marked BIND(C) with a BIND(C) attribute and that is
7293 not allowed for procedures. */
7294 if (entry
->attr
.is_bind_c
== 1)
7296 entry
->attr
.is_bind_c
= 0;
7297 if (entry
->old_symbol
!= NULL
)
7298 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7299 "variables or common blocks",
7300 &(entry
->old_symbol
->declared_at
));
7302 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7303 "variables or common blocks", &gfc_current_locus
);
7306 /* Check what next non-whitespace character is so we can tell if there
7307 is the required parens if we have a BIND(C). */
7308 old_loc
= gfc_current_locus
;
7309 gfc_gobble_whitespace ();
7310 peek_char
= gfc_peek_ascii_char ();
7312 if (state
== COMP_SUBROUTINE
)
7314 m
= gfc_match_formal_arglist (entry
, 0, 1);
7318 /* Call gfc_match_bind_c with allow_binding_name = true as ENTRY can
7319 never be an internal procedure. */
7320 is_bind_c
= gfc_match_bind_c (entry
, true);
7321 if (is_bind_c
== MATCH_ERROR
)
7323 if (is_bind_c
== MATCH_YES
)
7325 if (peek_char
!= '(')
7327 gfc_error ("Missing required parentheses before BIND(C) at %C");
7330 if (!gfc_add_is_bind_c (&(entry
->attr
), entry
->name
,
7331 &(entry
->declared_at
), 1))
7335 if (!gfc_current_ns
->parent
7336 && !add_global_entry (name
, entry
->binding_label
, true,
7340 /* An entry in a subroutine. */
7341 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
7342 || !gfc_add_subroutine (&entry
->attr
, entry
->name
, NULL
))
7347 /* An entry in a function.
7348 We need to take special care because writing
7353 ENTRY f() RESULT (r)
7355 ENTRY f RESULT (r). */
7356 if (gfc_match_eos () == MATCH_YES
)
7358 gfc_current_locus
= old_loc
;
7359 /* Match the empty argument list, and add the interface to
7361 m
= gfc_match_formal_arglist (entry
, 0, 1);
7364 m
= gfc_match_formal_arglist (entry
, 0, 0);
7371 if (gfc_match_eos () == MATCH_YES
)
7373 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
7374 || !gfc_add_function (&entry
->attr
, entry
->name
, NULL
))
7377 entry
->result
= entry
;
7381 m
= gfc_match_suffix (entry
, &result
);
7383 gfc_syntax_error (ST_ENTRY
);
7389 if (!gfc_add_result (&result
->attr
, result
->name
, NULL
)
7390 || !gfc_add_entry (&entry
->attr
, result
->name
, NULL
)
7391 || !gfc_add_function (&entry
->attr
, result
->name
, NULL
))
7393 entry
->result
= result
;
7397 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
7398 || !gfc_add_function (&entry
->attr
, entry
->name
, NULL
))
7400 entry
->result
= entry
;
7404 if (!gfc_current_ns
->parent
7405 && !add_global_entry (name
, entry
->binding_label
, false,
7410 if (gfc_match_eos () != MATCH_YES
)
7412 gfc_syntax_error (ST_ENTRY
);
7416 entry
->attr
.recursive
= proc
->attr
.recursive
;
7417 entry
->attr
.elemental
= proc
->attr
.elemental
;
7418 entry
->attr
.pure
= proc
->attr
.pure
;
7420 el
= gfc_get_entry_list ();
7422 el
->next
= gfc_current_ns
->entries
;
7423 gfc_current_ns
->entries
= el
;
7425 el
->id
= el
->next
->id
+ 1;
7429 new_st
.op
= EXEC_ENTRY
;
7430 new_st
.ext
.entry
= el
;
7436 /* Match a subroutine statement, including optional prefixes. */
7439 gfc_match_subroutine (void)
7441 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7446 bool allow_binding_name
;
7448 if (gfc_current_state () != COMP_NONE
7449 && gfc_current_state () != COMP_INTERFACE
7450 && gfc_current_state () != COMP_CONTAINS
)
7453 m
= gfc_match_prefix (NULL
);
7457 m
= gfc_match ("subroutine% %n", name
);
7461 if (get_proc_name (name
, &sym
, false))
7464 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
7465 the symbol existed before. */
7466 sym
->declared_at
= gfc_current_locus
;
7468 if (current_attr
.module_procedure
)
7469 sym
->attr
.module_procedure
= 1;
7471 if (add_hidden_procptr_result (sym
))
7474 gfc_new_block
= sym
;
7476 /* Check what next non-whitespace character is so we can tell if there
7477 is the required parens if we have a BIND(C). */
7478 gfc_gobble_whitespace ();
7479 peek_char
= gfc_peek_ascii_char ();
7481 if (!gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
))
7484 if (gfc_match_formal_arglist (sym
, 0, 1) != MATCH_YES
)
7487 /* Make sure that it isn't already declared as BIND(C). If it is, it
7488 must have been marked BIND(C) with a BIND(C) attribute and that is
7489 not allowed for procedures. */
7490 if (sym
->attr
.is_bind_c
== 1)
7492 sym
->attr
.is_bind_c
= 0;
7493 if (sym
->old_symbol
!= NULL
)
7494 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7495 "variables or common blocks",
7496 &(sym
->old_symbol
->declared_at
));
7498 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7499 "variables or common blocks", &gfc_current_locus
);
7502 /* C binding names are not allowed for internal procedures. */
7503 if (gfc_current_state () == COMP_CONTAINS
7504 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
7505 allow_binding_name
= false;
7507 allow_binding_name
= true;
7509 /* Here, we are just checking if it has the bind(c) attribute, and if
7510 so, then we need to make sure it's all correct. If it doesn't,
7511 we still need to continue matching the rest of the subroutine line. */
7512 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
7513 if (is_bind_c
== MATCH_ERROR
)
7515 /* There was an attempt at the bind(c), but it was wrong. An
7516 error message should have been printed w/in the gfc_match_bind_c
7517 so here we'll just return the MATCH_ERROR. */
7521 if (is_bind_c
== MATCH_YES
)
7523 /* The following is allowed in the Fortran 2008 draft. */
7524 if (gfc_current_state () == COMP_CONTAINS
7525 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
7526 && !gfc_notify_std (GFC_STD_F2008
, "BIND(C) attribute "
7527 "at %L may not be specified for an internal "
7528 "procedure", &gfc_current_locus
))
7531 if (peek_char
!= '(')
7533 gfc_error ("Missing required parentheses before BIND(C) at %C");
7536 if (!gfc_add_is_bind_c (&(sym
->attr
), sym
->name
,
7537 &(sym
->declared_at
), 1))
7541 if (gfc_match_eos () != MATCH_YES
)
7543 gfc_syntax_error (ST_SUBROUTINE
);
7547 if (!copy_prefix (&sym
->attr
, &sym
->declared_at
))
7549 if(!sym
->attr
.module_procedure
)
7555 /* Warn if it has the same name as an intrinsic. */
7556 do_warn_intrinsic_shadow (sym
, false);
7562 /* Check that the NAME identifier in a BIND attribute or statement
7563 is conform to C identifier rules. */
7566 check_bind_name_identifier (char **name
)
7568 char *n
= *name
, *p
;
7570 /* Remove leading spaces. */
7574 /* On an empty string, free memory and set name to NULL. */
7582 /* Remove trailing spaces. */
7583 p
= n
+ strlen(n
) - 1;
7587 /* Insert the identifier into the symbol table. */
7592 /* Now check that identifier is valid under C rules. */
7595 gfc_error ("Invalid C identifier in NAME= specifier at %C");
7600 if (!(ISALNUM (*p
) || *p
== '_' || *p
== '$'))
7602 gfc_error ("Invalid C identifier in NAME= specifier at %C");
7610 /* Match a BIND(C) specifier, with the optional 'name=' specifier if
7611 given, and set the binding label in either the given symbol (if not
7612 NULL), or in the current_ts. The symbol may be NULL because we may
7613 encounter the BIND(C) before the declaration itself. Return
7614 MATCH_NO if what we're looking at isn't a BIND(C) specifier,
7615 MATCH_ERROR if it is a BIND(C) clause but an error was encountered,
7616 or MATCH_YES if the specifier was correct and the binding label and
7617 bind(c) fields were set correctly for the given symbol or the
7618 current_ts. If allow_binding_name is false, no binding name may be
7622 gfc_match_bind_c (gfc_symbol
*sym
, bool allow_binding_name
)
7624 char *binding_label
= NULL
;
7627 /* Initialize the flag that specifies whether we encountered a NAME=
7628 specifier or not. */
7629 has_name_equals
= 0;
7631 /* This much we have to be able to match, in this order, if
7632 there is a bind(c) label. */
7633 if (gfc_match (" bind ( c ") != MATCH_YES
)
7636 /* Now see if there is a binding label, or if we've reached the
7637 end of the bind(c) attribute without one. */
7638 if (gfc_match_char (',') == MATCH_YES
)
7640 if (gfc_match (" name = ") != MATCH_YES
)
7642 gfc_error ("Syntax error in NAME= specifier for binding label "
7644 /* should give an error message here */
7648 has_name_equals
= 1;
7650 if (gfc_match_init_expr (&e
) != MATCH_YES
)
7656 if (!gfc_simplify_expr(e
, 0))
7658 gfc_error ("NAME= specifier at %C should be a constant expression");
7663 if (e
->expr_type
!= EXPR_CONSTANT
|| e
->ts
.type
!= BT_CHARACTER
7664 || e
->ts
.kind
!= gfc_default_character_kind
|| e
->rank
!= 0)
7666 gfc_error ("NAME= specifier at %C should be a scalar of "
7667 "default character kind");
7672 // Get a C string from the Fortran string constant
7673 binding_label
= gfc_widechar_to_char (e
->value
.character
.string
,
7674 e
->value
.character
.length
);
7677 // Check that it is valid (old gfc_match_name_C)
7678 if (check_bind_name_identifier (&binding_label
) != MATCH_YES
)
7682 /* Get the required right paren. */
7683 if (gfc_match_char (')') != MATCH_YES
)
7685 gfc_error ("Missing closing paren for binding label at %C");
7689 if (has_name_equals
&& !allow_binding_name
)
7691 gfc_error ("No binding name is allowed in BIND(C) at %C");
7695 if (has_name_equals
&& sym
!= NULL
&& sym
->attr
.dummy
)
7697 gfc_error ("For dummy procedure %s, no binding name is "
7698 "allowed in BIND(C) at %C", sym
->name
);
7703 /* Save the binding label to the symbol. If sym is null, we're
7704 probably matching the typespec attributes of a declaration and
7705 haven't gotten the name yet, and therefore, no symbol yet. */
7709 sym
->binding_label
= binding_label
;
7711 curr_binding_label
= binding_label
;
7713 else if (allow_binding_name
)
7715 /* No binding label, but if symbol isn't null, we
7716 can set the label for it here.
7717 If name="" or allow_binding_name is false, no C binding name is
7719 if (sym
!= NULL
&& sym
->name
!= NULL
&& has_name_equals
== 0)
7720 sym
->binding_label
= IDENTIFIER_POINTER (get_identifier (sym
->name
));
7723 if (has_name_equals
&& gfc_current_state () == COMP_INTERFACE
7724 && current_interface
.type
== INTERFACE_ABSTRACT
)
7726 gfc_error ("NAME not allowed on BIND(C) for ABSTRACT INTERFACE at %C");
7734 /* Return nonzero if we're currently compiling a contained procedure. */
7737 contained_procedure (void)
7739 gfc_state_data
*s
= gfc_state_stack
;
7741 if ((s
->state
== COMP_SUBROUTINE
|| s
->state
== COMP_FUNCTION
)
7742 && s
->previous
!= NULL
&& s
->previous
->state
== COMP_CONTAINS
)
7748 /* Set the kind of each enumerator. The kind is selected such that it is
7749 interoperable with the corresponding C enumeration type, making
7750 sure that -fshort-enums is honored. */
7755 enumerator_history
*current_history
= NULL
;
7759 if (max_enum
== NULL
|| enum_history
== NULL
)
7762 if (!flag_short_enums
)
7768 kind
= gfc_integer_kinds
[i
++].kind
;
7770 while (kind
< gfc_c_int_kind
7771 && gfc_check_integer_range (max_enum
->initializer
->value
.integer
,
7774 current_history
= enum_history
;
7775 while (current_history
!= NULL
)
7777 current_history
->sym
->ts
.kind
= kind
;
7778 current_history
= current_history
->next
;
7783 /* Match any of the various end-block statements. Returns the type of
7784 END to the caller. The END INTERFACE, END IF, END DO, END SELECT
7785 and END BLOCK statements cannot be replaced by a single END statement. */
7788 gfc_match_end (gfc_statement
*st
)
7790 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7791 gfc_compile_state state
;
7793 const char *block_name
;
7797 gfc_namespace
*parent_ns
, *ns
, *prev_ns
;
7798 gfc_namespace
**nsp
;
7799 bool abreviated_modproc_decl
= false;
7800 bool got_matching_end
= false;
7802 old_loc
= gfc_current_locus
;
7803 if (gfc_match ("end") != MATCH_YES
)
7806 state
= gfc_current_state ();
7807 block_name
= gfc_current_block () == NULL
7808 ? NULL
: gfc_current_block ()->name
;
7812 case COMP_ASSOCIATE
:
7814 if (gfc_str_startswith (block_name
, "block@"))
7819 case COMP_DERIVED_CONTAINS
:
7820 state
= gfc_state_stack
->previous
->state
;
7821 block_name
= gfc_state_stack
->previous
->sym
== NULL
7822 ? NULL
: gfc_state_stack
->previous
->sym
->name
;
7823 abreviated_modproc_decl
= gfc_state_stack
->previous
->sym
7824 && gfc_state_stack
->previous
->sym
->abr_modproc_decl
;
7831 if (!abreviated_modproc_decl
)
7832 abreviated_modproc_decl
= gfc_current_block ()
7833 && gfc_current_block ()->abr_modproc_decl
;
7839 *st
= ST_END_PROGRAM
;
7840 target
= " program";
7844 case COMP_SUBROUTINE
:
7845 *st
= ST_END_SUBROUTINE
;
7846 if (!abreviated_modproc_decl
)
7847 target
= " subroutine";
7849 target
= " procedure";
7850 eos_ok
= !contained_procedure ();
7854 *st
= ST_END_FUNCTION
;
7855 if (!abreviated_modproc_decl
)
7856 target
= " function";
7858 target
= " procedure";
7859 eos_ok
= !contained_procedure ();
7862 case COMP_BLOCK_DATA
:
7863 *st
= ST_END_BLOCK_DATA
;
7864 target
= " block data";
7869 *st
= ST_END_MODULE
;
7874 case COMP_SUBMODULE
:
7875 *st
= ST_END_SUBMODULE
;
7876 target
= " submodule";
7880 case COMP_INTERFACE
:
7881 *st
= ST_END_INTERFACE
;
7882 target
= " interface";
7898 case COMP_STRUCTURE
:
7899 *st
= ST_END_STRUCTURE
;
7900 target
= " structure";
7905 case COMP_DERIVED_CONTAINS
:
7911 case COMP_ASSOCIATE
:
7912 *st
= ST_END_ASSOCIATE
;
7913 target
= " associate";
7930 case COMP_DO_CONCURRENT
:
7937 *st
= ST_END_CRITICAL
;
7938 target
= " critical";
7943 case COMP_SELECT_TYPE
:
7944 *st
= ST_END_SELECT
;
7950 *st
= ST_END_FORALL
;
7965 last_initializer
= NULL
;
7967 gfc_free_enum_history ();
7971 gfc_error ("Unexpected END statement at %C");
7975 old_loc
= gfc_current_locus
;
7976 if (gfc_match_eos () == MATCH_YES
)
7978 if (!eos_ok
&& (*st
== ST_END_SUBROUTINE
|| *st
== ST_END_FUNCTION
))
7980 if (!gfc_notify_std (GFC_STD_F2008
, "END statement "
7981 "instead of %s statement at %L",
7982 abreviated_modproc_decl
? "END PROCEDURE"
7983 : gfc_ascii_statement(*st
), &old_loc
))
7988 /* We would have required END [something]. */
7989 gfc_error ("%s statement expected at %L",
7990 gfc_ascii_statement (*st
), &old_loc
);
7997 /* Verify that we've got the sort of end-block that we're expecting. */
7998 if (gfc_match (target
) != MATCH_YES
)
8000 gfc_error ("Expecting %s statement at %L", abreviated_modproc_decl
8001 ? "END PROCEDURE" : gfc_ascii_statement(*st
), &old_loc
);
8005 got_matching_end
= true;
8007 old_loc
= gfc_current_locus
;
8008 /* If we're at the end, make sure a block name wasn't required. */
8009 if (gfc_match_eos () == MATCH_YES
)
8012 if (*st
!= ST_ENDDO
&& *st
!= ST_ENDIF
&& *st
!= ST_END_SELECT
8013 && *st
!= ST_END_FORALL
&& *st
!= ST_END_WHERE
&& *st
!= ST_END_BLOCK
8014 && *st
!= ST_END_ASSOCIATE
&& *st
!= ST_END_CRITICAL
)
8020 gfc_error ("Expected block name of %qs in %s statement at %L",
8021 block_name
, gfc_ascii_statement (*st
), &old_loc
);
8026 /* END INTERFACE has a special handler for its several possible endings. */
8027 if (*st
== ST_END_INTERFACE
)
8028 return gfc_match_end_interface ();
8030 /* We haven't hit the end of statement, so what is left must be an
8032 m
= gfc_match_space ();
8034 m
= gfc_match_name (name
);
8037 gfc_error ("Expected terminating name at %C");
8041 if (block_name
== NULL
)
8044 /* We have to pick out the declared submodule name from the composite
8045 required by F2008:11.2.3 para 2, which ends in the declared name. */
8046 if (state
== COMP_SUBMODULE
)
8047 block_name
= strchr (block_name
, '.') + 1;
8049 if (strcmp (name
, block_name
) != 0 && strcmp (block_name
, "ppr@") != 0)
8051 gfc_error ("Expected label %qs for %s statement at %C", block_name
,
8052 gfc_ascii_statement (*st
));
8055 /* Procedure pointer as function result. */
8056 else if (strcmp (block_name
, "ppr@") == 0
8057 && strcmp (name
, gfc_current_block ()->ns
->proc_name
->name
) != 0)
8059 gfc_error ("Expected label %qs for %s statement at %C",
8060 gfc_current_block ()->ns
->proc_name
->name
,
8061 gfc_ascii_statement (*st
));
8065 if (gfc_match_eos () == MATCH_YES
)
8069 gfc_syntax_error (*st
);
8072 gfc_current_locus
= old_loc
;
8074 /* If we are missing an END BLOCK, we created a half-ready namespace.
8075 Remove it from the parent namespace's sibling list. */
8077 while (state
== COMP_BLOCK
&& !got_matching_end
)
8079 parent_ns
= gfc_current_ns
->parent
;
8081 nsp
= &(gfc_state_stack
->previous
->tail
->ext
.block
.ns
);
8087 if (ns
== gfc_current_ns
)
8089 if (prev_ns
== NULL
)
8092 prev_ns
->sibling
= ns
->sibling
;
8098 gfc_free_namespace (gfc_current_ns
);
8099 gfc_current_ns
= parent_ns
;
8100 gfc_state_stack
= gfc_state_stack
->previous
;
8101 state
= gfc_current_state ();
8109 /***************** Attribute declaration statements ****************/
8111 /* Set the attribute of a single variable. */
8116 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8119 /* Workaround -Wmaybe-uninitialized false positive during
8120 profiledbootstrap by initializing them. */
8121 gfc_symbol
*sym
= NULL
;
8127 m
= gfc_match_name (name
);
8131 if (find_special (name
, &sym
, false))
8134 if (!check_function_name (name
))
8140 var_locus
= gfc_current_locus
;
8142 /* Deal with possible array specification for certain attributes. */
8143 if (current_attr
.dimension
8144 || current_attr
.codimension
8145 || current_attr
.allocatable
8146 || current_attr
.pointer
8147 || current_attr
.target
)
8149 m
= gfc_match_array_spec (&as
, !current_attr
.codimension
,
8150 !current_attr
.dimension
8151 && !current_attr
.pointer
8152 && !current_attr
.target
);
8153 if (m
== MATCH_ERROR
)
8156 if (current_attr
.dimension
&& m
== MATCH_NO
)
8158 gfc_error ("Missing array specification at %L in DIMENSION "
8159 "statement", &var_locus
);
8164 if (current_attr
.dimension
&& sym
->value
)
8166 gfc_error ("Dimensions specified for %s at %L after its "
8167 "initialization", sym
->name
, &var_locus
);
8172 if (current_attr
.codimension
&& m
== MATCH_NO
)
8174 gfc_error ("Missing array specification at %L in CODIMENSION "
8175 "statement", &var_locus
);
8180 if ((current_attr
.allocatable
|| current_attr
.pointer
)
8181 && (m
== MATCH_YES
) && (as
->type
!= AS_DEFERRED
))
8183 gfc_error ("Array specification must be deferred at %L", &var_locus
);
8189 /* Update symbol table. DIMENSION attribute is set in
8190 gfc_set_array_spec(). For CLASS variables, this must be applied
8191 to the first component, or '_data' field. */
8192 if (sym
->ts
.type
== BT_CLASS
&& sym
->ts
.u
.derived
->attr
.is_class
)
8194 if (!gfc_copy_attr (&CLASS_DATA(sym
)->attr
, ¤t_attr
, &var_locus
))
8202 if (current_attr
.dimension
== 0 && current_attr
.codimension
== 0
8203 && !gfc_copy_attr (&sym
->attr
, ¤t_attr
, &var_locus
))
8210 if (sym
->ts
.type
== BT_CLASS
8211 && !gfc_build_class_symbol (&sym
->ts
, &sym
->attr
, &sym
->as
))
8217 if (!gfc_set_array_spec (sym
, as
, &var_locus
))
8223 if (sym
->attr
.cray_pointee
&& sym
->as
!= NULL
)
8225 /* Fix the array spec. */
8226 m
= gfc_mod_pointee_as (sym
->as
);
8227 if (m
== MATCH_ERROR
)
8231 if (!gfc_add_attribute (&sym
->attr
, &var_locus
))
8237 if ((current_attr
.external
|| current_attr
.intrinsic
)
8238 && sym
->attr
.flavor
!= FL_PROCEDURE
8239 && !gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, NULL
))
8245 add_hidden_procptr_result (sym
);
8250 gfc_free_array_spec (as
);
8255 /* Generic attribute declaration subroutine. Used for attributes that
8256 just have a list of names. */
8263 /* Gobble the optional double colon, by simply ignoring the result
8273 if (gfc_match_eos () == MATCH_YES
)
8279 if (gfc_match_char (',') != MATCH_YES
)
8281 gfc_error ("Unexpected character in variable list at %C");
8291 /* This routine matches Cray Pointer declarations of the form:
8292 pointer ( <pointer>, <pointee> )
8294 pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...
8295 The pointer, if already declared, should be an integer. Otherwise, we
8296 set it as BT_INTEGER with kind gfc_index_integer_kind. The pointee may
8297 be either a scalar, or an array declaration. No space is allocated for
8298 the pointee. For the statement
8299 pointer (ipt, ar(10))
8300 any subsequent uses of ar will be translated (in C-notation) as
8301 ar(i) => ((<type> *) ipt)(i)
8302 After gimplification, pointee variable will disappear in the code. */
8305 cray_pointer_decl (void)
8308 gfc_array_spec
*as
= NULL
;
8309 gfc_symbol
*cptr
; /* Pointer symbol. */
8310 gfc_symbol
*cpte
; /* Pointee symbol. */
8316 if (gfc_match_char ('(') != MATCH_YES
)
8318 gfc_error ("Expected %<(%> at %C");
8322 /* Match pointer. */
8323 var_locus
= gfc_current_locus
;
8324 gfc_clear_attr (¤t_attr
);
8325 gfc_add_cray_pointer (¤t_attr
, &var_locus
);
8326 current_ts
.type
= BT_INTEGER
;
8327 current_ts
.kind
= gfc_index_integer_kind
;
8329 m
= gfc_match_symbol (&cptr
, 0);
8332 gfc_error ("Expected variable name at %C");
8336 if (!gfc_add_cray_pointer (&cptr
->attr
, &var_locus
))
8339 gfc_set_sym_referenced (cptr
);
8341 if (cptr
->ts
.type
== BT_UNKNOWN
) /* Override the type, if necessary. */
8343 cptr
->ts
.type
= BT_INTEGER
;
8344 cptr
->ts
.kind
= gfc_index_integer_kind
;
8346 else if (cptr
->ts
.type
!= BT_INTEGER
)
8348 gfc_error ("Cray pointer at %C must be an integer");
8351 else if (cptr
->ts
.kind
< gfc_index_integer_kind
)
8352 gfc_warning (0, "Cray pointer at %C has %d bytes of precision;"
8353 " memory addresses require %d bytes",
8354 cptr
->ts
.kind
, gfc_index_integer_kind
);
8356 if (gfc_match_char (',') != MATCH_YES
)
8358 gfc_error ("Expected \",\" at %C");
8362 /* Match Pointee. */
8363 var_locus
= gfc_current_locus
;
8364 gfc_clear_attr (¤t_attr
);
8365 gfc_add_cray_pointee (¤t_attr
, &var_locus
);
8366 current_ts
.type
= BT_UNKNOWN
;
8367 current_ts
.kind
= 0;
8369 m
= gfc_match_symbol (&cpte
, 0);
8372 gfc_error ("Expected variable name at %C");
8376 /* Check for an optional array spec. */
8377 m
= gfc_match_array_spec (&as
, true, false);
8378 if (m
== MATCH_ERROR
)
8380 gfc_free_array_spec (as
);
8383 else if (m
== MATCH_NO
)
8385 gfc_free_array_spec (as
);
8389 if (!gfc_add_cray_pointee (&cpte
->attr
, &var_locus
))
8392 gfc_set_sym_referenced (cpte
);
8394 if (cpte
->as
== NULL
)
8396 if (!gfc_set_array_spec (cpte
, as
, &var_locus
))
8397 gfc_internal_error ("Couldn't set Cray pointee array spec.");
8399 else if (as
!= NULL
)
8401 gfc_error ("Duplicate array spec for Cray pointee at %C");
8402 gfc_free_array_spec (as
);
8408 if (cpte
->as
!= NULL
)
8410 /* Fix array spec. */
8411 m
= gfc_mod_pointee_as (cpte
->as
);
8412 if (m
== MATCH_ERROR
)
8416 /* Point the Pointee at the Pointer. */
8417 cpte
->cp_pointer
= cptr
;
8419 if (gfc_match_char (')') != MATCH_YES
)
8421 gfc_error ("Expected \")\" at %C");
8424 m
= gfc_match_char (',');
8426 done
= true; /* Stop searching for more declarations. */
8430 if (m
== MATCH_ERROR
/* Failed when trying to find ',' above. */
8431 || gfc_match_eos () != MATCH_YES
)
8433 gfc_error ("Expected %<,%> or end of statement at %C");
8441 gfc_match_external (void)
8444 gfc_clear_attr (¤t_attr
);
8445 current_attr
.external
= 1;
8447 return attr_decl ();
8452 gfc_match_intent (void)
8456 /* This is not allowed within a BLOCK construct! */
8457 if (gfc_current_state () == COMP_BLOCK
)
8459 gfc_error ("INTENT is not allowed inside of BLOCK at %C");
8463 intent
= match_intent_spec ();
8464 if (intent
== INTENT_UNKNOWN
)
8467 gfc_clear_attr (¤t_attr
);
8468 current_attr
.intent
= intent
;
8470 return attr_decl ();
8475 gfc_match_intrinsic (void)
8478 gfc_clear_attr (¤t_attr
);
8479 current_attr
.intrinsic
= 1;
8481 return attr_decl ();
8486 gfc_match_optional (void)
8488 /* This is not allowed within a BLOCK construct! */
8489 if (gfc_current_state () == COMP_BLOCK
)
8491 gfc_error ("OPTIONAL is not allowed inside of BLOCK at %C");
8495 gfc_clear_attr (¤t_attr
);
8496 current_attr
.optional
= 1;
8498 return attr_decl ();
8503 gfc_match_pointer (void)
8505 gfc_gobble_whitespace ();
8506 if (gfc_peek_ascii_char () == '(')
8508 if (!flag_cray_pointer
)
8510 gfc_error ("Cray pointer declaration at %C requires -fcray-pointer "
8514 return cray_pointer_decl ();
8518 gfc_clear_attr (¤t_attr
);
8519 current_attr
.pointer
= 1;
8521 return attr_decl ();
8527 gfc_match_allocatable (void)
8529 gfc_clear_attr (¤t_attr
);
8530 current_attr
.allocatable
= 1;
8532 return attr_decl ();
8537 gfc_match_codimension (void)
8539 gfc_clear_attr (¤t_attr
);
8540 current_attr
.codimension
= 1;
8542 return attr_decl ();
8547 gfc_match_contiguous (void)
8549 if (!gfc_notify_std (GFC_STD_F2008
, "CONTIGUOUS statement at %C"))
8552 gfc_clear_attr (¤t_attr
);
8553 current_attr
.contiguous
= 1;
8555 return attr_decl ();
8560 gfc_match_dimension (void)
8562 gfc_clear_attr (¤t_attr
);
8563 current_attr
.dimension
= 1;
8565 return attr_decl ();
8570 gfc_match_target (void)
8572 gfc_clear_attr (¤t_attr
);
8573 current_attr
.target
= 1;
8575 return attr_decl ();
8579 /* Match the list of entities being specified in a PUBLIC or PRIVATE
8583 access_attr_decl (gfc_statement st
)
8585 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8586 interface_type type
;
8588 gfc_symbol
*sym
, *dt_sym
;
8589 gfc_intrinsic_op op
;
8592 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
8597 m
= gfc_match_generic_spec (&type
, name
, &op
);
8600 if (m
== MATCH_ERROR
)
8605 case INTERFACE_NAMELESS
:
8606 case INTERFACE_ABSTRACT
:
8609 case INTERFACE_GENERIC
:
8610 case INTERFACE_DTIO
:
8612 if (gfc_get_symbol (name
, NULL
, &sym
))
8615 if (type
== INTERFACE_DTIO
8616 && gfc_current_ns
->proc_name
8617 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
8618 && sym
->attr
.flavor
== FL_UNKNOWN
)
8619 sym
->attr
.flavor
= FL_PROCEDURE
;
8621 if (!gfc_add_access (&sym
->attr
,
8623 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
,
8627 if (sym
->attr
.generic
&& (dt_sym
= gfc_find_dt_in_generic (sym
))
8628 && !gfc_add_access (&dt_sym
->attr
,
8630 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
,
8636 case INTERFACE_INTRINSIC_OP
:
8637 if (gfc_current_ns
->operator_access
[op
] == ACCESS_UNKNOWN
)
8639 gfc_intrinsic_op other_op
;
8641 gfc_current_ns
->operator_access
[op
] =
8642 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
8644 /* Handle the case if there is another op with the same
8645 function, for INTRINSIC_EQ vs. INTRINSIC_EQ_OS and so on. */
8646 other_op
= gfc_equivalent_op (op
);
8648 if (other_op
!= INTRINSIC_NONE
)
8649 gfc_current_ns
->operator_access
[other_op
] =
8650 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
8655 gfc_error ("Access specification of the %s operator at %C has "
8656 "already been specified", gfc_op2string (op
));
8662 case INTERFACE_USER_OP
:
8663 uop
= gfc_get_uop (name
);
8665 if (uop
->access
== ACCESS_UNKNOWN
)
8667 uop
->access
= (st
== ST_PUBLIC
)
8668 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
8672 gfc_error ("Access specification of the .%s. operator at %C "
8673 "has already been specified", sym
->name
);
8680 if (gfc_match_char (',') == MATCH_NO
)
8684 if (gfc_match_eos () != MATCH_YES
)
8689 gfc_syntax_error (st
);
8697 gfc_match_protected (void)
8702 if (!gfc_current_ns
->proc_name
8703 || gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
8705 gfc_error ("PROTECTED at %C only allowed in specification "
8706 "part of a module");
8711 if (!gfc_notify_std (GFC_STD_F2003
, "PROTECTED statement at %C"))
8714 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
8719 if (gfc_match_eos () == MATCH_YES
)
8724 m
= gfc_match_symbol (&sym
, 0);
8728 if (!gfc_add_protected (&sym
->attr
, sym
->name
, &gfc_current_locus
))
8740 if (gfc_match_eos () == MATCH_YES
)
8742 if (gfc_match_char (',') != MATCH_YES
)
8749 gfc_error ("Syntax error in PROTECTED statement at %C");
8754 /* The PRIVATE statement is a bit weird in that it can be an attribute
8755 declaration, but also works as a standalone statement inside of a
8756 type declaration or a module. */
8759 gfc_match_private (gfc_statement
*st
)
8762 if (gfc_match ("private") != MATCH_YES
)
8765 if (gfc_current_state () != COMP_MODULE
8766 && !(gfc_current_state () == COMP_DERIVED
8767 && gfc_state_stack
->previous
8768 && gfc_state_stack
->previous
->state
== COMP_MODULE
)
8769 && !(gfc_current_state () == COMP_DERIVED_CONTAINS
8770 && gfc_state_stack
->previous
&& gfc_state_stack
->previous
->previous
8771 && gfc_state_stack
->previous
->previous
->state
== COMP_MODULE
))
8773 gfc_error ("PRIVATE statement at %C is only allowed in the "
8774 "specification part of a module");
8778 if (gfc_current_state () == COMP_DERIVED
)
8780 if (gfc_match_eos () == MATCH_YES
)
8786 gfc_syntax_error (ST_PRIVATE
);
8790 if (gfc_match_eos () == MATCH_YES
)
8797 return access_attr_decl (ST_PRIVATE
);
8802 gfc_match_public (gfc_statement
*st
)
8805 if (gfc_match ("public") != MATCH_YES
)
8808 if (gfc_current_state () != COMP_MODULE
)
8810 gfc_error ("PUBLIC statement at %C is only allowed in the "
8811 "specification part of a module");
8815 if (gfc_match_eos () == MATCH_YES
)
8822 return access_attr_decl (ST_PUBLIC
);
8826 /* Workhorse for gfc_match_parameter. */
8836 m
= gfc_match_symbol (&sym
, 0);
8838 gfc_error ("Expected variable name at %C in PARAMETER statement");
8843 if (gfc_match_char ('=') == MATCH_NO
)
8845 gfc_error ("Expected = sign in PARAMETER statement at %C");
8849 m
= gfc_match_init_expr (&init
);
8851 gfc_error ("Expected expression at %C in PARAMETER statement");
8855 if (sym
->ts
.type
== BT_UNKNOWN
8856 && !gfc_set_default_type (sym
, 1, NULL
))
8862 if (!gfc_check_assign_symbol (sym
, NULL
, init
)
8863 || !gfc_add_flavor (&sym
->attr
, FL_PARAMETER
, sym
->name
, NULL
))
8871 gfc_error ("Initializing already initialized variable at %C");
8876 t
= add_init_expr_to_sym (sym
->name
, &init
, &gfc_current_locus
);
8877 return (t
) ? MATCH_YES
: MATCH_ERROR
;
8880 gfc_free_expr (init
);
8885 /* Match a parameter statement, with the weird syntax that these have. */
8888 gfc_match_parameter (void)
8890 const char *term
= " )%t";
8893 if (gfc_match_char ('(') == MATCH_NO
)
8895 /* With legacy PARAMETER statements, don't expect a terminating ')'. */
8896 if (!gfc_notify_std (GFC_STD_LEGACY
, "PARAMETER without '()' at %C"))
8907 if (gfc_match (term
) == MATCH_YES
)
8910 if (gfc_match_char (',') != MATCH_YES
)
8912 gfc_error ("Unexpected characters in PARAMETER statement at %C");
8923 gfc_match_automatic (void)
8927 bool seen_symbol
= false;
8929 if (!flag_dec_static
)
8931 gfc_error ("%s at %C is a DEC extension, enable with "
8942 m
= gfc_match_symbol (&sym
, 0);
8952 if (!gfc_add_automatic (&sym
->attr
, sym
->name
, &gfc_current_locus
))
8958 if (gfc_match_eos () == MATCH_YES
)
8960 if (gfc_match_char (',') != MATCH_YES
)
8966 gfc_error ("Expected entity-list in AUTOMATIC statement at %C");
8973 gfc_error ("Syntax error in AUTOMATIC statement at %C");
8979 gfc_match_static (void)
8983 bool seen_symbol
= false;
8985 if (!flag_dec_static
)
8987 gfc_error ("%s at %C is a DEC extension, enable with "
8997 m
= gfc_match_symbol (&sym
, 0);
9007 if (!gfc_add_save (&sym
->attr
, SAVE_EXPLICIT
, sym
->name
,
9008 &gfc_current_locus
))
9014 if (gfc_match_eos () == MATCH_YES
)
9016 if (gfc_match_char (',') != MATCH_YES
)
9022 gfc_error ("Expected entity-list in STATIC statement at %C");
9029 gfc_error ("Syntax error in STATIC statement at %C");
9034 /* Save statements have a special syntax. */
9037 gfc_match_save (void)
9039 char n
[GFC_MAX_SYMBOL_LEN
+1];
9044 if (gfc_match_eos () == MATCH_YES
)
9046 if (gfc_current_ns
->seen_save
)
9048 if (!gfc_notify_std (GFC_STD_LEGACY
, "Blanket SAVE statement at %C "
9049 "follows previous SAVE statement"))
9053 gfc_current_ns
->save_all
= gfc_current_ns
->seen_save
= 1;
9057 if (gfc_current_ns
->save_all
)
9059 if (!gfc_notify_std (GFC_STD_LEGACY
, "SAVE statement at %C follows "
9060 "blanket SAVE statement"))
9068 m
= gfc_match_symbol (&sym
, 0);
9072 if (!gfc_add_save (&sym
->attr
, SAVE_EXPLICIT
, sym
->name
,
9073 &gfc_current_locus
))
9084 m
= gfc_match (" / %n /", &n
);
9085 if (m
== MATCH_ERROR
)
9090 c
= gfc_get_common (n
, 0);
9093 gfc_current_ns
->seen_save
= 1;
9096 if (gfc_match_eos () == MATCH_YES
)
9098 if (gfc_match_char (',') != MATCH_YES
)
9105 gfc_error ("Syntax error in SAVE statement at %C");
9111 gfc_match_value (void)
9116 /* This is not allowed within a BLOCK construct! */
9117 if (gfc_current_state () == COMP_BLOCK
)
9119 gfc_error ("VALUE is not allowed inside of BLOCK at %C");
9123 if (!gfc_notify_std (GFC_STD_F2003
, "VALUE statement at %C"))
9126 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
9131 if (gfc_match_eos () == MATCH_YES
)
9136 m
= gfc_match_symbol (&sym
, 0);
9140 if (!gfc_add_value (&sym
->attr
, sym
->name
, &gfc_current_locus
))
9152 if (gfc_match_eos () == MATCH_YES
)
9154 if (gfc_match_char (',') != MATCH_YES
)
9161 gfc_error ("Syntax error in VALUE statement at %C");
9167 gfc_match_volatile (void)
9173 if (!gfc_notify_std (GFC_STD_F2003
, "VOLATILE statement at %C"))
9176 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
9181 if (gfc_match_eos () == MATCH_YES
)
9186 /* VOLATILE is special because it can be added to host-associated
9187 symbols locally. Except for coarrays. */
9188 m
= gfc_match_symbol (&sym
, 1);
9192 name
= XCNEWVAR (char, strlen (sym
->name
) + 1);
9193 strcpy (name
, sym
->name
);
9194 if (!check_function_name (name
))
9196 /* F2008, C560+C561. VOLATILE for host-/use-associated variable or
9197 for variable in a BLOCK which is defined outside of the BLOCK. */
9198 if (sym
->ns
!= gfc_current_ns
&& sym
->attr
.codimension
)
9200 gfc_error ("Specifying VOLATILE for coarray variable %qs at "
9201 "%C, which is use-/host-associated", sym
->name
);
9204 if (!gfc_add_volatile (&sym
->attr
, sym
->name
, &gfc_current_locus
))
9216 if (gfc_match_eos () == MATCH_YES
)
9218 if (gfc_match_char (',') != MATCH_YES
)
9225 gfc_error ("Syntax error in VOLATILE statement at %C");
9231 gfc_match_asynchronous (void)
9237 if (!gfc_notify_std (GFC_STD_F2003
, "ASYNCHRONOUS statement at %C"))
9240 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
9245 if (gfc_match_eos () == MATCH_YES
)
9250 /* ASYNCHRONOUS is special because it can be added to host-associated
9252 m
= gfc_match_symbol (&sym
, 1);
9256 name
= XCNEWVAR (char, strlen (sym
->name
) + 1);
9257 strcpy (name
, sym
->name
);
9258 if (!check_function_name (name
))
9260 if (!gfc_add_asynchronous (&sym
->attr
, sym
->name
, &gfc_current_locus
))
9272 if (gfc_match_eos () == MATCH_YES
)
9274 if (gfc_match_char (',') != MATCH_YES
)
9281 gfc_error ("Syntax error in ASYNCHRONOUS statement at %C");
9286 /* Match a module procedure statement in a submodule. */
9289 gfc_match_submod_proc (void)
9291 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9292 gfc_symbol
*sym
, *fsym
;
9294 gfc_formal_arglist
*formal
, *head
, *tail
;
9296 if (gfc_current_state () != COMP_CONTAINS
9297 || !(gfc_state_stack
->previous
9298 && (gfc_state_stack
->previous
->state
== COMP_SUBMODULE
9299 || gfc_state_stack
->previous
->state
== COMP_MODULE
)))
9302 m
= gfc_match (" module% procedure% %n", name
);
9306 if (!gfc_notify_std (GFC_STD_F2008
, "MODULE PROCEDURE declaration "
9310 if (get_proc_name (name
, &sym
, false))
9313 /* Make sure that the result field is appropriately filled, even though
9314 the result symbol will be replaced later on. */
9315 if (sym
->tlink
&& sym
->tlink
->attr
.function
)
9317 if (sym
->tlink
->result
9318 && sym
->tlink
->result
!= sym
->tlink
)
9319 sym
->result
= sym
->tlink
->result
;
9324 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
9325 the symbol existed before. */
9326 sym
->declared_at
= gfc_current_locus
;
9328 if (!sym
->attr
.module_procedure
)
9331 /* Signal match_end to expect "end procedure". */
9332 sym
->abr_modproc_decl
= 1;
9334 /* Change from IFSRC_IFBODY coming from the interface declaration. */
9335 sym
->attr
.if_source
= IFSRC_DECL
;
9337 gfc_new_block
= sym
;
9339 /* Make a new formal arglist with the symbols in the procedure
9342 for (formal
= sym
->formal
; formal
&& formal
->sym
; formal
= formal
->next
)
9344 if (formal
== sym
->formal
)
9345 head
= tail
= gfc_get_formal_arglist ();
9348 tail
->next
= gfc_get_formal_arglist ();
9352 if (gfc_copy_dummy_sym (&fsym
, formal
->sym
, 0))
9356 gfc_set_sym_referenced (fsym
);
9359 /* The dummy symbols get cleaned up, when the formal_namespace of the
9360 interface declaration is cleared. This allows us to add the
9361 explicit interface as is done for other type of procedure. */
9362 if (!gfc_add_explicit_interface (sym
, IFSRC_DECL
, head
,
9363 &gfc_current_locus
))
9366 if (gfc_match_eos () != MATCH_YES
)
9368 gfc_syntax_error (ST_MODULE_PROC
);
9375 gfc_free_formal_arglist (head
);
9380 /* Match a module procedure statement. Note that we have to modify
9381 symbols in the parent's namespace because the current one was there
9382 to receive symbols that are in an interface's formal argument list. */
9385 gfc_match_modproc (void)
9387 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9391 gfc_namespace
*module_ns
;
9392 gfc_interface
*old_interface_head
, *interface
;
9394 if (gfc_state_stack
->state
!= COMP_INTERFACE
9395 || gfc_state_stack
->previous
== NULL
9396 || current_interface
.type
== INTERFACE_NAMELESS
9397 || current_interface
.type
== INTERFACE_ABSTRACT
)
9399 gfc_error ("MODULE PROCEDURE at %C must be in a generic module "
9404 module_ns
= gfc_current_ns
->parent
;
9405 for (; module_ns
; module_ns
= module_ns
->parent
)
9406 if (module_ns
->proc_name
->attr
.flavor
== FL_MODULE
9407 || module_ns
->proc_name
->attr
.flavor
== FL_PROGRAM
9408 || (module_ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
9409 && !module_ns
->proc_name
->attr
.contained
))
9412 if (module_ns
== NULL
)
9415 /* Store the current state of the interface. We will need it if we
9416 end up with a syntax error and need to recover. */
9417 old_interface_head
= gfc_current_interface_head ();
9419 /* Check if the F2008 optional double colon appears. */
9420 gfc_gobble_whitespace ();
9421 old_locus
= gfc_current_locus
;
9422 if (gfc_match ("::") == MATCH_YES
)
9424 if (!gfc_notify_std (GFC_STD_F2008
, "double colon in "
9425 "MODULE PROCEDURE statement at %L", &old_locus
))
9429 gfc_current_locus
= old_locus
;
9434 old_locus
= gfc_current_locus
;
9436 m
= gfc_match_name (name
);
9442 /* Check for syntax error before starting to add symbols to the
9443 current namespace. */
9444 if (gfc_match_eos () == MATCH_YES
)
9447 if (!last
&& gfc_match_char (',') != MATCH_YES
)
9450 /* Now we're sure the syntax is valid, we process this item
9452 if (gfc_get_symbol (name
, module_ns
, &sym
))
9455 if (sym
->attr
.intrinsic
)
9457 gfc_error ("Intrinsic procedure at %L cannot be a MODULE "
9458 "PROCEDURE", &old_locus
);
9462 if (sym
->attr
.proc
!= PROC_MODULE
9463 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
9466 if (!gfc_add_interface (sym
))
9469 sym
->attr
.mod_proc
= 1;
9470 sym
->declared_at
= old_locus
;
9479 /* Restore the previous state of the interface. */
9480 interface
= gfc_current_interface_head ();
9481 gfc_set_current_interface_head (old_interface_head
);
9483 /* Free the new interfaces. */
9484 while (interface
!= old_interface_head
)
9486 gfc_interface
*i
= interface
->next
;
9491 /* And issue a syntax error. */
9492 gfc_syntax_error (ST_MODULE_PROC
);
9497 /* Check a derived type that is being extended. */
9500 check_extended_derived_type (char *name
)
9502 gfc_symbol
*extended
;
9504 if (gfc_find_symbol (name
, gfc_current_ns
, 1, &extended
))
9506 gfc_error ("Ambiguous symbol in TYPE definition at %C");
9510 extended
= gfc_find_dt_in_generic (extended
);
9515 gfc_error ("Symbol %qs at %C has not been previously defined", name
);
9519 if (extended
->attr
.flavor
!= FL_DERIVED
)
9521 gfc_error ("%qs in EXTENDS expression at %C is not a "
9522 "derived type", name
);
9526 if (extended
->attr
.is_bind_c
)
9528 gfc_error ("%qs cannot be extended at %C because it "
9529 "is BIND(C)", extended
->name
);
9533 if (extended
->attr
.sequence
)
9535 gfc_error ("%qs cannot be extended at %C because it "
9536 "is a SEQUENCE type", extended
->name
);
9544 /* Match the optional attribute specifiers for a type declaration.
9545 Return MATCH_ERROR if an error is encountered in one of the handled
9546 attributes (public, private, bind(c)), MATCH_NO if what's found is
9547 not a handled attribute, and MATCH_YES otherwise. TODO: More error
9548 checking on attribute conflicts needs to be done. */
9551 gfc_get_type_attr_spec (symbol_attribute
*attr
, char *name
)
9553 /* See if the derived type is marked as private. */
9554 if (gfc_match (" , private") == MATCH_YES
)
9556 if (gfc_current_state () != COMP_MODULE
)
9558 gfc_error ("Derived type at %C can only be PRIVATE in the "
9559 "specification part of a module");
9563 if (!gfc_add_access (attr
, ACCESS_PRIVATE
, NULL
, NULL
))
9566 else if (gfc_match (" , public") == MATCH_YES
)
9568 if (gfc_current_state () != COMP_MODULE
)
9570 gfc_error ("Derived type at %C can only be PUBLIC in the "
9571 "specification part of a module");
9575 if (!gfc_add_access (attr
, ACCESS_PUBLIC
, NULL
, NULL
))
9578 else if (gfc_match (" , bind ( c )") == MATCH_YES
)
9580 /* If the type is defined to be bind(c) it then needs to make
9581 sure that all fields are interoperable. This will
9582 need to be a semantic check on the finished derived type.
9583 See 15.2.3 (lines 9-12) of F2003 draft. */
9584 if (!gfc_add_is_bind_c (attr
, NULL
, &gfc_current_locus
, 0))
9587 /* TODO: attr conflicts need to be checked, probably in symbol.c. */
9589 else if (gfc_match (" , abstract") == MATCH_YES
)
9591 if (!gfc_notify_std (GFC_STD_F2003
, "ABSTRACT type at %C"))
9594 if (!gfc_add_abstract (attr
, &gfc_current_locus
))
9597 else if (name
&& gfc_match (" , extends ( %n )", name
) == MATCH_YES
)
9599 if (!gfc_add_extension (attr
, &gfc_current_locus
))
9605 /* If we get here, something matched. */
9610 /* Common function for type declaration blocks similar to derived types, such
9611 as STRUCTURES and MAPs. Unlike derived types, a structure type
9612 does NOT have a generic symbol matching the name given by the user.
9613 STRUCTUREs can share names with variables and PARAMETERs so we must allow
9614 for the creation of an independent symbol.
9615 Other parameters are a message to prefix errors with, the name of the new
9616 type to be created, and the flavor to add to the resulting symbol. */
9619 get_struct_decl (const char *name
, sym_flavor fl
, locus
*decl
,
9620 gfc_symbol
**result
)
9625 gcc_assert (name
[0] == (char) TOUPPER (name
[0]));
9630 where
= gfc_current_locus
;
9632 if (gfc_get_symbol (name
, NULL
, &sym
))
9637 gfc_internal_error ("Failed to create structure type '%s' at %C", name
);
9641 if (sym
->components
!= NULL
|| sym
->attr
.zero_comp
)
9643 gfc_error ("Type definition of %qs at %C was already defined at %L",
9644 sym
->name
, &sym
->declared_at
);
9648 sym
->declared_at
= where
;
9650 if (sym
->attr
.flavor
!= fl
9651 && !gfc_add_flavor (&sym
->attr
, fl
, sym
->name
, NULL
))
9654 if (!sym
->hash_value
)
9655 /* Set the hash for the compound name for this type. */
9656 sym
->hash_value
= gfc_hash_value (sym
);
9658 /* Normally the type is expected to have been completely parsed by the time
9659 a field declaration with this type is seen. For unions, maps, and nested
9660 structure declarations, we need to indicate that it is okay that we
9661 haven't seen any components yet. This will be updated after the structure
9663 sym
->attr
.zero_comp
= 0;
9665 /* Structures always act like derived-types with the SEQUENCE attribute */
9666 gfc_add_sequence (&sym
->attr
, sym
->name
, NULL
);
9668 if (result
) *result
= sym
;
9674 /* Match the opening of a MAP block. Like a struct within a union in C;
9675 behaves identical to STRUCTURE blocks. */
9678 gfc_match_map (void)
9680 /* Counter used to give unique internal names to map structures. */
9681 static unsigned int gfc_map_id
= 0;
9682 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9686 old_loc
= gfc_current_locus
;
9688 if (gfc_match_eos () != MATCH_YES
)
9690 gfc_error ("Junk after MAP statement at %C");
9691 gfc_current_locus
= old_loc
;
9695 /* Map blocks are anonymous so we make up unique names for the symbol table
9696 which are invalid Fortran identifiers. */
9697 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "MM$%u", gfc_map_id
++);
9699 if (!get_struct_decl (name
, FL_STRUCT
, &old_loc
, &sym
))
9702 gfc_new_block
= sym
;
9708 /* Match the opening of a UNION block. */
9711 gfc_match_union (void)
9713 /* Counter used to give unique internal names to union types. */
9714 static unsigned int gfc_union_id
= 0;
9715 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9719 old_loc
= gfc_current_locus
;
9721 if (gfc_match_eos () != MATCH_YES
)
9723 gfc_error ("Junk after UNION statement at %C");
9724 gfc_current_locus
= old_loc
;
9728 /* Unions are anonymous so we make up unique names for the symbol table
9729 which are invalid Fortran identifiers. */
9730 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "UU$%u", gfc_union_id
++);
9732 if (!get_struct_decl (name
, FL_UNION
, &old_loc
, &sym
))
9735 gfc_new_block
= sym
;
9741 /* Match the beginning of a STRUCTURE declaration. This is similar to
9742 matching the beginning of a derived type declaration with a few
9743 twists. The resulting type symbol has no access control or other
9744 interesting attributes. */
9747 gfc_match_structure_decl (void)
9749 /* Counter used to give unique internal names to anonymous structures. */
9750 static unsigned int gfc_structure_id
= 0;
9751 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9756 if (!flag_dec_structure
)
9758 gfc_error ("%s at %C is a DEC extension, enable with "
9759 "%<-fdec-structure%>",
9766 m
= gfc_match (" /%n/", name
);
9769 /* Non-nested structure declarations require a structure name. */
9770 if (!gfc_comp_struct (gfc_current_state ()))
9772 gfc_error ("Structure name expected in non-nested structure "
9773 "declaration at %C");
9776 /* This is an anonymous structure; make up a unique name for it
9777 (upper-case letters never make it to symbol names from the source).
9778 The important thing is initializing the type variable
9779 and setting gfc_new_symbol, which is immediately used by
9780 parse_structure () and variable_decl () to add components of
9782 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "SS$%u", gfc_structure_id
++);
9785 where
= gfc_current_locus
;
9786 /* No field list allowed after non-nested structure declaration. */
9787 if (!gfc_comp_struct (gfc_current_state ())
9788 && gfc_match_eos () != MATCH_YES
)
9790 gfc_error ("Junk after non-nested STRUCTURE statement at %C");
9794 /* Make sure the name is not the name of an intrinsic type. */
9795 if (gfc_is_intrinsic_typename (name
))
9797 gfc_error ("Structure name %qs at %C cannot be the same as an"
9798 " intrinsic type", name
);
9802 /* Store the actual type symbol for the structure with an upper-case first
9803 letter (an invalid Fortran identifier). */
9805 if (!get_struct_decl (gfc_dt_upper_string (name
), FL_STRUCT
, &where
, &sym
))
9808 gfc_new_block
= sym
;
9813 /* This function does some work to determine which matcher should be used to
9814 * match a statement beginning with "TYPE". This is used to disambiguate TYPE
9815 * as an alias for PRINT from derived type declarations, TYPE IS statements,
9816 * and [parameterized] derived type declarations. */
9819 gfc_match_type (gfc_statement
*st
)
9821 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9825 /* Requires -fdec. */
9829 m
= gfc_match ("type");
9832 /* If we already have an error in the buffer, it is probably from failing to
9833 * match a derived type data declaration. Let it happen. */
9834 else if (gfc_error_flag_test ())
9837 old_loc
= gfc_current_locus
;
9840 /* If we see an attribute list before anything else it's definitely a derived
9841 * type declaration. */
9842 if (gfc_match (" ,") == MATCH_YES
|| gfc_match (" ::") == MATCH_YES
)
9845 /* By now "TYPE" has already been matched. If we do not see a name, this may
9846 * be something like "TYPE *" or "TYPE <fmt>". */
9847 m
= gfc_match_name (name
);
9850 /* Let print match if it can, otherwise throw an error from
9851 * gfc_match_derived_decl. */
9852 gfc_current_locus
= old_loc
;
9853 if (gfc_match_print () == MATCH_YES
)
9861 /* Check for EOS. */
9862 if (gfc_match_eos () == MATCH_YES
)
9864 /* By now we have "TYPE <name> <EOS>". Check first if the name is an
9865 * intrinsic typename - if so let gfc_match_derived_decl dump an error.
9866 * Otherwise if gfc_match_derived_decl fails it's probably an existing
9867 * symbol which can be printed. */
9868 gfc_current_locus
= old_loc
;
9869 m
= gfc_match_derived_decl ();
9870 if (gfc_is_intrinsic_typename (name
) || m
== MATCH_YES
)
9872 *st
= ST_DERIVED_DECL
;
9878 /* Here we have "TYPE <name>". Check for <TYPE IS (> or a PDT declaration
9879 like <type name(parameter)>. */
9880 gfc_gobble_whitespace ();
9881 bool paren
= gfc_peek_ascii_char () == '(';
9884 if (strcmp ("is", name
) == 0)
9891 /* Treat TYPE... like PRINT... */
9892 gfc_current_locus
= old_loc
;
9894 return gfc_match_print ();
9897 gfc_current_locus
= old_loc
;
9898 *st
= ST_DERIVED_DECL
;
9899 return gfc_match_derived_decl ();
9902 gfc_current_locus
= old_loc
;
9904 return gfc_match_type_is ();
9908 /* Match the beginning of a derived type declaration. If a type name
9909 was the result of a function, then it is possible to have a symbol
9910 already to be known as a derived type yet have no components. */
9913 gfc_match_derived_decl (void)
9915 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9916 char parent
[GFC_MAX_SYMBOL_LEN
+ 1];
9917 symbol_attribute attr
;
9918 gfc_symbol
*sym
, *gensym
;
9919 gfc_symbol
*extended
;
9921 match is_type_attr_spec
= MATCH_NO
;
9922 bool seen_attr
= false;
9923 gfc_interface
*intr
= NULL
, *head
;
9924 bool parameterized_type
= false;
9925 bool seen_colons
= false;
9927 if (gfc_comp_struct (gfc_current_state ()))
9932 gfc_clear_attr (&attr
);
9937 is_type_attr_spec
= gfc_get_type_attr_spec (&attr
, parent
);
9938 if (is_type_attr_spec
== MATCH_ERROR
)
9940 if (is_type_attr_spec
== MATCH_YES
)
9942 } while (is_type_attr_spec
== MATCH_YES
);
9944 /* Deal with derived type extensions. The extension attribute has
9945 been added to 'attr' but now the parent type must be found and
9948 extended
= check_extended_derived_type (parent
);
9950 if (parent
[0] && !extended
)
9953 m
= gfc_match (" ::");
9960 gfc_error ("Expected :: in TYPE definition at %C");
9964 m
= gfc_match (" %n ", name
);
9968 /* Make sure that we don't identify TYPE IS (...) as a parameterized
9969 derived type named 'is'.
9970 TODO Expand the check, when 'name' = "is" by matching " (tname) "
9971 and checking if this is a(n intrinsic) typename. his picks up
9972 misplaced TYPE IS statements such as in select_type_1.f03. */
9973 if (gfc_peek_ascii_char () == '(')
9975 if (gfc_current_state () == COMP_SELECT_TYPE
9976 || (!seen_colons
&& !strcmp (name
, "is")))
9978 parameterized_type
= true;
9981 m
= gfc_match_eos ();
9982 if (m
!= MATCH_YES
&& !parameterized_type
)
9985 /* Make sure the name is not the name of an intrinsic type. */
9986 if (gfc_is_intrinsic_typename (name
))
9988 gfc_error ("Type name %qs at %C cannot be the same as an intrinsic "
9993 if (gfc_get_symbol (name
, NULL
, &gensym
))
9996 if (!gensym
->attr
.generic
&& gensym
->ts
.type
!= BT_UNKNOWN
)
9998 if (gensym
->ts
.u
.derived
)
9999 gfc_error ("Derived type name %qs at %C already has a basic type "
10000 "of %s", gensym
->name
, gfc_typename (&gensym
->ts
));
10002 gfc_error ("Derived type name %qs at %C already has a basic type",
10004 return MATCH_ERROR
;
10007 if (!gensym
->attr
.generic
10008 && !gfc_add_generic (&gensym
->attr
, gensym
->name
, NULL
))
10009 return MATCH_ERROR
;
10011 if (!gensym
->attr
.function
10012 && !gfc_add_function (&gensym
->attr
, gensym
->name
, NULL
))
10013 return MATCH_ERROR
;
10015 sym
= gfc_find_dt_in_generic (gensym
);
10017 if (sym
&& (sym
->components
!= NULL
|| sym
->attr
.zero_comp
))
10019 gfc_error ("Derived type definition of %qs at %C has already been "
10020 "defined", sym
->name
);
10021 return MATCH_ERROR
;
10026 /* Use upper case to save the actual derived-type symbol. */
10027 gfc_get_symbol (gfc_dt_upper_string (gensym
->name
), NULL
, &sym
);
10028 sym
->name
= gfc_get_string ("%s", gensym
->name
);
10029 head
= gensym
->generic
;
10030 intr
= gfc_get_interface ();
10032 intr
->where
= gfc_current_locus
;
10033 intr
->sym
->declared_at
= gfc_current_locus
;
10035 gensym
->generic
= intr
;
10036 gensym
->attr
.if_source
= IFSRC_DECL
;
10039 /* The symbol may already have the derived attribute without the
10040 components. The ways this can happen is via a function
10041 definition, an INTRINSIC statement or a subtype in another
10042 derived type that is a pointer. The first part of the AND clause
10043 is true if the symbol is not the return value of a function. */
10044 if (sym
->attr
.flavor
!= FL_DERIVED
10045 && !gfc_add_flavor (&sym
->attr
, FL_DERIVED
, sym
->name
, NULL
))
10046 return MATCH_ERROR
;
10048 if (attr
.access
!= ACCESS_UNKNOWN
10049 && !gfc_add_access (&sym
->attr
, attr
.access
, sym
->name
, NULL
))
10050 return MATCH_ERROR
;
10051 else if (sym
->attr
.access
== ACCESS_UNKNOWN
10052 && gensym
->attr
.access
!= ACCESS_UNKNOWN
10053 && !gfc_add_access (&sym
->attr
, gensym
->attr
.access
,
10055 return MATCH_ERROR
;
10057 if (sym
->attr
.access
!= ACCESS_UNKNOWN
10058 && gensym
->attr
.access
== ACCESS_UNKNOWN
)
10059 gensym
->attr
.access
= sym
->attr
.access
;
10061 /* See if the derived type was labeled as bind(c). */
10062 if (attr
.is_bind_c
!= 0)
10063 sym
->attr
.is_bind_c
= attr
.is_bind_c
;
10065 /* Construct the f2k_derived namespace if it is not yet there. */
10066 if (!sym
->f2k_derived
)
10067 sym
->f2k_derived
= gfc_get_namespace (NULL
, 0);
10069 if (parameterized_type
)
10071 /* Ignore error or mismatches by going to the end of the statement
10072 in order to avoid the component declarations causing problems. */
10073 m
= gfc_match_formal_arglist (sym
, 0, 0, true);
10074 if (m
!= MATCH_YES
)
10075 gfc_error_recovery ();
10076 m
= gfc_match_eos ();
10077 if (m
!= MATCH_YES
)
10079 gfc_error_recovery ();
10080 gfc_error_now ("Garbage after PARAMETERIZED TYPE declaration at %C");
10082 sym
->attr
.pdt_template
= 1;
10085 if (extended
&& !sym
->components
)
10088 gfc_formal_arglist
*f
, *g
, *h
;
10090 /* Add the extended derived type as the first component. */
10091 gfc_add_component (sym
, parent
, &p
);
10093 gfc_set_sym_referenced (extended
);
10095 p
->ts
.type
= BT_DERIVED
;
10096 p
->ts
.u
.derived
= extended
;
10097 p
->initializer
= gfc_default_initializer (&p
->ts
);
10099 /* Set extension level. */
10100 if (extended
->attr
.extension
== 255)
10102 /* Since the extension field is 8 bit wide, we can only have
10103 up to 255 extension levels. */
10104 gfc_error ("Maximum extension level reached with type %qs at %L",
10105 extended
->name
, &extended
->declared_at
);
10106 return MATCH_ERROR
;
10108 sym
->attr
.extension
= extended
->attr
.extension
+ 1;
10110 /* Provide the links between the extended type and its extension. */
10111 if (!extended
->f2k_derived
)
10112 extended
->f2k_derived
= gfc_get_namespace (NULL
, 0);
10114 /* Copy the extended type-param-name-list from the extended type,
10115 append those of the extension and add the whole lot to the
10117 if (extended
->attr
.pdt_template
)
10120 sym
->attr
.pdt_template
= 1;
10121 for (f
= extended
->formal
; f
; f
= f
->next
)
10123 if (f
== extended
->formal
)
10125 g
= gfc_get_formal_arglist ();
10130 g
->next
= gfc_get_formal_arglist ();
10135 g
->next
= sym
->formal
;
10140 if (!sym
->hash_value
)
10141 /* Set the hash for the compound name for this type. */
10142 sym
->hash_value
= gfc_hash_value (sym
);
10144 /* Take over the ABSTRACT attribute. */
10145 sym
->attr
.abstract
= attr
.abstract
;
10147 gfc_new_block
= sym
;
10153 /* Cray Pointees can be declared as:
10154 pointer (ipt, a (n,m,...,*)) */
10157 gfc_mod_pointee_as (gfc_array_spec
*as
)
10159 as
->cray_pointee
= true; /* This will be useful to know later. */
10160 if (as
->type
== AS_ASSUMED_SIZE
)
10161 as
->cp_was_assumed
= true;
10162 else if (as
->type
== AS_ASSUMED_SHAPE
)
10164 gfc_error ("Cray Pointee at %C cannot be assumed shape array");
10165 return MATCH_ERROR
;
10171 /* Match the enum definition statement, here we are trying to match
10172 the first line of enum definition statement.
10173 Returns MATCH_YES if match is found. */
10176 gfc_match_enum (void)
10180 m
= gfc_match_eos ();
10181 if (m
!= MATCH_YES
)
10184 if (!gfc_notify_std (GFC_STD_F2003
, "ENUM and ENUMERATOR at %C"))
10185 return MATCH_ERROR
;
10191 /* Returns an initializer whose value is one higher than the value of the
10192 LAST_INITIALIZER argument. If the argument is NULL, the
10193 initializers value will be set to zero. The initializer's kind
10194 will be set to gfc_c_int_kind.
10196 If -fshort-enums is given, the appropriate kind will be selected
10197 later after all enumerators have been parsed. A warning is issued
10198 here if an initializer exceeds gfc_c_int_kind. */
10201 enum_initializer (gfc_expr
*last_initializer
, locus where
)
10204 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_c_int_kind
, &where
);
10206 mpz_init (result
->value
.integer
);
10208 if (last_initializer
!= NULL
)
10210 mpz_add_ui (result
->value
.integer
, last_initializer
->value
.integer
, 1);
10211 result
->where
= last_initializer
->where
;
10213 if (gfc_check_integer_range (result
->value
.integer
,
10214 gfc_c_int_kind
) != ARITH_OK
)
10216 gfc_error ("Enumerator exceeds the C integer type at %C");
10222 /* Control comes here, if it's the very first enumerator and no
10223 initializer has been given. It will be initialized to zero. */
10224 mpz_set_si (result
->value
.integer
, 0);
10231 /* Match a variable name with an optional initializer. When this
10232 subroutine is called, a variable is expected to be parsed next.
10233 Depending on what is happening at the moment, updates either the
10234 symbol table or the current interface. */
10237 enumerator_decl (void)
10239 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10240 gfc_expr
*initializer
;
10241 gfc_array_spec
*as
= NULL
;
10248 initializer
= NULL
;
10249 old_locus
= gfc_current_locus
;
10251 /* When we get here, we've just matched a list of attributes and
10252 maybe a type and a double colon. The next thing we expect to see
10253 is the name of the symbol. */
10254 m
= gfc_match_name (name
);
10255 if (m
!= MATCH_YES
)
10258 var_locus
= gfc_current_locus
;
10260 /* OK, we've successfully matched the declaration. Now put the
10261 symbol in the current namespace. If we fail to create the symbol,
10263 if (!build_sym (name
, NULL
, false, &as
, &var_locus
))
10269 /* The double colon must be present in order to have initializers.
10270 Otherwise the statement is ambiguous with an assignment statement. */
10273 if (gfc_match_char ('=') == MATCH_YES
)
10275 m
= gfc_match_init_expr (&initializer
);
10278 gfc_error ("Expected an initialization expression at %C");
10282 if (m
!= MATCH_YES
)
10287 /* If we do not have an initializer, the initialization value of the
10288 previous enumerator (stored in last_initializer) is incremented
10289 by 1 and is used to initialize the current enumerator. */
10290 if (initializer
== NULL
)
10291 initializer
= enum_initializer (last_initializer
, old_locus
);
10293 if (initializer
== NULL
|| initializer
->ts
.type
!= BT_INTEGER
)
10295 gfc_error ("ENUMERATOR %L not initialized with integer expression",
10301 /* Store this current initializer, for the next enumerator variable
10302 to be parsed. add_init_expr_to_sym() zeros initializer, so we
10303 use last_initializer below. */
10304 last_initializer
= initializer
;
10305 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
10307 /* Maintain enumerator history. */
10308 gfc_find_symbol (name
, NULL
, 0, &sym
);
10309 create_enum_history (sym
, last_initializer
);
10311 return (t
) ? MATCH_YES
: MATCH_ERROR
;
10314 /* Free stuff up and return. */
10315 gfc_free_expr (initializer
);
10321 /* Match the enumerator definition statement. */
10324 gfc_match_enumerator_def (void)
10329 gfc_clear_ts (¤t_ts
);
10331 m
= gfc_match (" enumerator");
10332 if (m
!= MATCH_YES
)
10335 m
= gfc_match (" :: ");
10336 if (m
== MATCH_ERROR
)
10339 colon_seen
= (m
== MATCH_YES
);
10341 if (gfc_current_state () != COMP_ENUM
)
10343 gfc_error ("ENUM definition statement expected before %C");
10344 gfc_free_enum_history ();
10345 return MATCH_ERROR
;
10348 (¤t_ts
)->type
= BT_INTEGER
;
10349 (¤t_ts
)->kind
= gfc_c_int_kind
;
10351 gfc_clear_attr (¤t_attr
);
10352 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, NULL
);
10361 m
= enumerator_decl ();
10362 if (m
== MATCH_ERROR
)
10364 gfc_free_enum_history ();
10370 if (gfc_match_eos () == MATCH_YES
)
10372 if (gfc_match_char (',') != MATCH_YES
)
10376 if (gfc_current_state () == COMP_ENUM
)
10378 gfc_free_enum_history ();
10379 gfc_error ("Syntax error in ENUMERATOR definition at %C");
10384 gfc_free_array_spec (current_as
);
10391 /* Match binding attributes. */
10394 match_binding_attributes (gfc_typebound_proc
* ba
, bool generic
, bool ppc
)
10396 bool found_passing
= false;
10397 bool seen_ptr
= false;
10398 match m
= MATCH_YES
;
10400 /* Initialize to defaults. Do so even before the MATCH_NO check so that in
10401 this case the defaults are in there. */
10402 ba
->access
= ACCESS_UNKNOWN
;
10403 ba
->pass_arg
= NULL
;
10404 ba
->pass_arg_num
= 0;
10406 ba
->non_overridable
= 0;
10410 /* If we find a comma, we believe there are binding attributes. */
10411 m
= gfc_match_char (',');
10417 /* Access specifier. */
10419 m
= gfc_match (" public");
10420 if (m
== MATCH_ERROR
)
10422 if (m
== MATCH_YES
)
10424 if (ba
->access
!= ACCESS_UNKNOWN
)
10426 gfc_error ("Duplicate access-specifier at %C");
10430 ba
->access
= ACCESS_PUBLIC
;
10434 m
= gfc_match (" private");
10435 if (m
== MATCH_ERROR
)
10437 if (m
== MATCH_YES
)
10439 if (ba
->access
!= ACCESS_UNKNOWN
)
10441 gfc_error ("Duplicate access-specifier at %C");
10445 ba
->access
= ACCESS_PRIVATE
;
10449 /* If inside GENERIC, the following is not allowed. */
10454 m
= gfc_match (" nopass");
10455 if (m
== MATCH_ERROR
)
10457 if (m
== MATCH_YES
)
10461 gfc_error ("Binding attributes already specify passing,"
10462 " illegal NOPASS at %C");
10466 found_passing
= true;
10471 /* PASS possibly including argument. */
10472 m
= gfc_match (" pass");
10473 if (m
== MATCH_ERROR
)
10475 if (m
== MATCH_YES
)
10477 char arg
[GFC_MAX_SYMBOL_LEN
+ 1];
10481 gfc_error ("Binding attributes already specify passing,"
10482 " illegal PASS at %C");
10486 m
= gfc_match (" ( %n )", arg
);
10487 if (m
== MATCH_ERROR
)
10489 if (m
== MATCH_YES
)
10490 ba
->pass_arg
= gfc_get_string ("%s", arg
);
10491 gcc_assert ((m
== MATCH_YES
) == (ba
->pass_arg
!= NULL
));
10493 found_passing
= true;
10500 /* POINTER flag. */
10501 m
= gfc_match (" pointer");
10502 if (m
== MATCH_ERROR
)
10504 if (m
== MATCH_YES
)
10508 gfc_error ("Duplicate POINTER attribute at %C");
10518 /* NON_OVERRIDABLE flag. */
10519 m
= gfc_match (" non_overridable");
10520 if (m
== MATCH_ERROR
)
10522 if (m
== MATCH_YES
)
10524 if (ba
->non_overridable
)
10526 gfc_error ("Duplicate NON_OVERRIDABLE at %C");
10530 ba
->non_overridable
= 1;
10534 /* DEFERRED flag. */
10535 m
= gfc_match (" deferred");
10536 if (m
== MATCH_ERROR
)
10538 if (m
== MATCH_YES
)
10542 gfc_error ("Duplicate DEFERRED at %C");
10553 /* Nothing matching found. */
10555 gfc_error ("Expected access-specifier at %C");
10557 gfc_error ("Expected binding attribute at %C");
10560 while (gfc_match_char (',') == MATCH_YES
);
10562 /* NON_OVERRIDABLE and DEFERRED exclude themselves. */
10563 if (ba
->non_overridable
&& ba
->deferred
)
10565 gfc_error ("NON_OVERRIDABLE and DEFERRED can't both appear at %C");
10572 if (ba
->access
== ACCESS_UNKNOWN
)
10573 ba
->access
= ppc
? gfc_current_block()->component_access
10574 : gfc_typebound_default_access
;
10576 if (ppc
&& !seen_ptr
)
10578 gfc_error ("POINTER attribute is required for procedure pointer component"
10586 return MATCH_ERROR
;
10590 /* Match a PROCEDURE specific binding inside a derived type. */
10593 match_procedure_in_type (void)
10595 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10596 char target_buf
[GFC_MAX_SYMBOL_LEN
+ 1];
10597 char* target
= NULL
, *ifc
= NULL
;
10598 gfc_typebound_proc tb
;
10602 gfc_symtree
* stree
;
10607 /* Check current state. */
10608 gcc_assert (gfc_state_stack
->state
== COMP_DERIVED_CONTAINS
);
10609 block
= gfc_state_stack
->previous
->sym
;
10610 gcc_assert (block
);
10612 /* Try to match PROCEDURE(interface). */
10613 if (gfc_match (" (") == MATCH_YES
)
10615 m
= gfc_match_name (target_buf
);
10616 if (m
== MATCH_ERROR
)
10618 if (m
!= MATCH_YES
)
10620 gfc_error ("Interface-name expected after %<(%> at %C");
10621 return MATCH_ERROR
;
10624 if (gfc_match (" )") != MATCH_YES
)
10626 gfc_error ("%<)%> expected at %C");
10627 return MATCH_ERROR
;
10633 /* Construct the data structure. */
10634 memset (&tb
, 0, sizeof (tb
));
10635 tb
.where
= gfc_current_locus
;
10637 /* Match binding attributes. */
10638 m
= match_binding_attributes (&tb
, false, false);
10639 if (m
== MATCH_ERROR
)
10641 seen_attrs
= (m
== MATCH_YES
);
10643 /* Check that attribute DEFERRED is given if an interface is specified. */
10644 if (tb
.deferred
&& !ifc
)
10646 gfc_error ("Interface must be specified for DEFERRED binding at %C");
10647 return MATCH_ERROR
;
10649 if (ifc
&& !tb
.deferred
)
10651 gfc_error ("PROCEDURE(interface) at %C should be declared DEFERRED");
10652 return MATCH_ERROR
;
10655 /* Match the colons. */
10656 m
= gfc_match (" ::");
10657 if (m
== MATCH_ERROR
)
10659 seen_colons
= (m
== MATCH_YES
);
10660 if (seen_attrs
&& !seen_colons
)
10662 gfc_error ("Expected %<::%> after binding-attributes at %C");
10663 return MATCH_ERROR
;
10666 /* Match the binding names. */
10669 m
= gfc_match_name (name
);
10670 if (m
== MATCH_ERROR
)
10674 gfc_error ("Expected binding name at %C");
10675 return MATCH_ERROR
;
10678 if (num
>1 && !gfc_notify_std (GFC_STD_F2008
, "PROCEDURE list at %C"))
10679 return MATCH_ERROR
;
10681 /* Try to match the '=> target', if it's there. */
10683 m
= gfc_match (" =>");
10684 if (m
== MATCH_ERROR
)
10686 if (m
== MATCH_YES
)
10690 gfc_error ("%<=> target%> is invalid for DEFERRED binding at %C");
10691 return MATCH_ERROR
;
10696 gfc_error ("%<::%> needed in PROCEDURE binding with explicit target"
10698 return MATCH_ERROR
;
10701 m
= gfc_match_name (target_buf
);
10702 if (m
== MATCH_ERROR
)
10706 gfc_error ("Expected binding target after %<=>%> at %C");
10707 return MATCH_ERROR
;
10709 target
= target_buf
;
10712 /* If no target was found, it has the same name as the binding. */
10716 /* Get the namespace to insert the symbols into. */
10717 ns
= block
->f2k_derived
;
10720 /* If the binding is DEFERRED, check that the containing type is ABSTRACT. */
10721 if (tb
.deferred
&& !block
->attr
.abstract
)
10723 gfc_error ("Type %qs containing DEFERRED binding at %C "
10724 "is not ABSTRACT", block
->name
);
10725 return MATCH_ERROR
;
10728 /* See if we already have a binding with this name in the symtree which
10729 would be an error. If a GENERIC already targeted this binding, it may
10730 be already there but then typebound is still NULL. */
10731 stree
= gfc_find_symtree (ns
->tb_sym_root
, name
);
10732 if (stree
&& stree
->n
.tb
)
10734 gfc_error ("There is already a procedure with binding name %qs for "
10735 "the derived type %qs at %C", name
, block
->name
);
10736 return MATCH_ERROR
;
10739 /* Insert it and set attributes. */
10743 stree
= gfc_new_symtree (&ns
->tb_sym_root
, name
);
10744 gcc_assert (stree
);
10746 stree
->n
.tb
= gfc_get_typebound_proc (&tb
);
10748 if (gfc_get_sym_tree (target
, gfc_current_ns
, &stree
->n
.tb
->u
.specific
,
10750 return MATCH_ERROR
;
10751 gfc_set_sym_referenced (stree
->n
.tb
->u
.specific
->n
.sym
);
10752 gfc_add_flavor(&stree
->n
.tb
->u
.specific
->n
.sym
->attr
, FL_PROCEDURE
,
10753 target
, &stree
->n
.tb
->u
.specific
->n
.sym
->declared_at
);
10755 if (gfc_match_eos () == MATCH_YES
)
10757 if (gfc_match_char (',') != MATCH_YES
)
10762 gfc_error ("Syntax error in PROCEDURE statement at %C");
10763 return MATCH_ERROR
;
10767 /* Match a GENERIC procedure binding inside a derived type. */
10770 gfc_match_generic (void)
10772 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10773 char bind_name
[GFC_MAX_SYMBOL_LEN
+ 16]; /* Allow space for OPERATOR(...). */
10775 gfc_typebound_proc tbattr
; /* Used for match_binding_attributes. */
10776 gfc_typebound_proc
* tb
;
10778 interface_type op_type
;
10779 gfc_intrinsic_op op
;
10782 /* Check current state. */
10783 if (gfc_current_state () == COMP_DERIVED
)
10785 gfc_error ("GENERIC at %C must be inside a derived-type CONTAINS");
10786 return MATCH_ERROR
;
10788 if (gfc_current_state () != COMP_DERIVED_CONTAINS
)
10790 block
= gfc_state_stack
->previous
->sym
;
10791 ns
= block
->f2k_derived
;
10792 gcc_assert (block
&& ns
);
10794 memset (&tbattr
, 0, sizeof (tbattr
));
10795 tbattr
.where
= gfc_current_locus
;
10797 /* See if we get an access-specifier. */
10798 m
= match_binding_attributes (&tbattr
, true, false);
10799 if (m
== MATCH_ERROR
)
10802 /* Now the colons, those are required. */
10803 if (gfc_match (" ::") != MATCH_YES
)
10805 gfc_error ("Expected %<::%> at %C");
10809 /* Match the binding name; depending on type (operator / generic) format
10810 it for future error messages into bind_name. */
10812 m
= gfc_match_generic_spec (&op_type
, name
, &op
);
10813 if (m
== MATCH_ERROR
)
10814 return MATCH_ERROR
;
10817 gfc_error ("Expected generic name or operator descriptor at %C");
10823 case INTERFACE_GENERIC
:
10824 case INTERFACE_DTIO
:
10825 snprintf (bind_name
, sizeof (bind_name
), "%s", name
);
10828 case INTERFACE_USER_OP
:
10829 snprintf (bind_name
, sizeof (bind_name
), "OPERATOR(.%s.)", name
);
10832 case INTERFACE_INTRINSIC_OP
:
10833 snprintf (bind_name
, sizeof (bind_name
), "OPERATOR(%s)",
10834 gfc_op2string (op
));
10837 case INTERFACE_NAMELESS
:
10838 gfc_error ("Malformed GENERIC statement at %C");
10843 gcc_unreachable ();
10846 /* Match the required =>. */
10847 if (gfc_match (" =>") != MATCH_YES
)
10849 gfc_error ("Expected %<=>%> at %C");
10853 /* Try to find existing GENERIC binding with this name / for this operator;
10854 if there is something, check that it is another GENERIC and then extend
10855 it rather than building a new node. Otherwise, create it and put it
10856 at the right position. */
10860 case INTERFACE_DTIO
:
10861 case INTERFACE_USER_OP
:
10862 case INTERFACE_GENERIC
:
10864 const bool is_op
= (op_type
== INTERFACE_USER_OP
);
10867 st
= gfc_find_symtree (is_op
? ns
->tb_uop_root
: ns
->tb_sym_root
, name
);
10868 tb
= st
? st
->n
.tb
: NULL
;
10872 case INTERFACE_INTRINSIC_OP
:
10873 tb
= ns
->tb_op
[op
];
10877 gcc_unreachable ();
10882 if (!tb
->is_generic
)
10884 gcc_assert (op_type
== INTERFACE_GENERIC
);
10885 gfc_error ("There's already a non-generic procedure with binding name"
10886 " %qs for the derived type %qs at %C",
10887 bind_name
, block
->name
);
10891 if (tb
->access
!= tbattr
.access
)
10893 gfc_error ("Binding at %C must have the same access as already"
10894 " defined binding %qs", bind_name
);
10900 tb
= gfc_get_typebound_proc (NULL
);
10901 tb
->where
= gfc_current_locus
;
10902 tb
->access
= tbattr
.access
;
10903 tb
->is_generic
= 1;
10904 tb
->u
.generic
= NULL
;
10908 case INTERFACE_DTIO
:
10909 case INTERFACE_GENERIC
:
10910 case INTERFACE_USER_OP
:
10912 const bool is_op
= (op_type
== INTERFACE_USER_OP
);
10913 gfc_symtree
* st
= gfc_get_tbp_symtree (is_op
? &ns
->tb_uop_root
:
10914 &ns
->tb_sym_root
, name
);
10921 case INTERFACE_INTRINSIC_OP
:
10922 ns
->tb_op
[op
] = tb
;
10926 gcc_unreachable ();
10930 /* Now, match all following names as specific targets. */
10933 gfc_symtree
* target_st
;
10934 gfc_tbp_generic
* target
;
10936 m
= gfc_match_name (name
);
10937 if (m
== MATCH_ERROR
)
10941 gfc_error ("Expected specific binding name at %C");
10945 target_st
= gfc_get_tbp_symtree (&ns
->tb_sym_root
, name
);
10947 /* See if this is a duplicate specification. */
10948 for (target
= tb
->u
.generic
; target
; target
= target
->next
)
10949 if (target_st
== target
->specific_st
)
10951 gfc_error ("%qs already defined as specific binding for the"
10952 " generic %qs at %C", name
, bind_name
);
10956 target
= gfc_get_tbp_generic ();
10957 target
->specific_st
= target_st
;
10958 target
->specific
= NULL
;
10959 target
->next
= tb
->u
.generic
;
10960 target
->is_operator
= ((op_type
== INTERFACE_USER_OP
)
10961 || (op_type
== INTERFACE_INTRINSIC_OP
));
10962 tb
->u
.generic
= target
;
10964 while (gfc_match (" ,") == MATCH_YES
);
10966 /* Here should be the end. */
10967 if (gfc_match_eos () != MATCH_YES
)
10969 gfc_error ("Junk after GENERIC binding at %C");
10976 return MATCH_ERROR
;
10980 /* Match a FINAL declaration inside a derived type. */
10983 gfc_match_final_decl (void)
10985 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10988 gfc_namespace
* module_ns
;
10992 if (gfc_current_form
== FORM_FREE
)
10994 char c
= gfc_peek_ascii_char ();
10995 if (!gfc_is_whitespace (c
) && c
!= ':')
10999 if (gfc_state_stack
->state
!= COMP_DERIVED_CONTAINS
)
11001 if (gfc_current_form
== FORM_FIXED
)
11004 gfc_error ("FINAL declaration at %C must be inside a derived type "
11005 "CONTAINS section");
11006 return MATCH_ERROR
;
11009 block
= gfc_state_stack
->previous
->sym
;
11010 gcc_assert (block
);
11012 if (!gfc_state_stack
->previous
|| !gfc_state_stack
->previous
->previous
11013 || gfc_state_stack
->previous
->previous
->state
!= COMP_MODULE
)
11015 gfc_error ("Derived type declaration with FINAL at %C must be in the"
11016 " specification part of a MODULE");
11017 return MATCH_ERROR
;
11020 module_ns
= gfc_current_ns
;
11021 gcc_assert (module_ns
);
11022 gcc_assert (module_ns
->proc_name
->attr
.flavor
== FL_MODULE
);
11024 /* Match optional ::, don't care about MATCH_YES or MATCH_NO. */
11025 if (gfc_match (" ::") == MATCH_ERROR
)
11026 return MATCH_ERROR
;
11028 /* Match the sequence of procedure names. */
11035 if (first
&& gfc_match_eos () == MATCH_YES
)
11037 gfc_error ("Empty FINAL at %C");
11038 return MATCH_ERROR
;
11041 m
= gfc_match_name (name
);
11044 gfc_error ("Expected module procedure name at %C");
11045 return MATCH_ERROR
;
11047 else if (m
!= MATCH_YES
)
11048 return MATCH_ERROR
;
11050 if (gfc_match_eos () == MATCH_YES
)
11052 if (!last
&& gfc_match_char (',') != MATCH_YES
)
11054 gfc_error ("Expected %<,%> at %C");
11055 return MATCH_ERROR
;
11058 if (gfc_get_symbol (name
, module_ns
, &sym
))
11060 gfc_error ("Unknown procedure name %qs at %C", name
);
11061 return MATCH_ERROR
;
11064 /* Mark the symbol as module procedure. */
11065 if (sym
->attr
.proc
!= PROC_MODULE
11066 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
11067 return MATCH_ERROR
;
11069 /* Check if we already have this symbol in the list, this is an error. */
11070 for (f
= block
->f2k_derived
->finalizers
; f
; f
= f
->next
)
11071 if (f
->proc_sym
== sym
)
11073 gfc_error ("%qs at %C is already defined as FINAL procedure",
11075 return MATCH_ERROR
;
11078 /* Add this symbol to the list of finalizers. */
11079 gcc_assert (block
->f2k_derived
);
11081 f
= XCNEW (gfc_finalizer
);
11083 f
->proc_tree
= NULL
;
11084 f
->where
= gfc_current_locus
;
11085 f
->next
= block
->f2k_derived
->finalizers
;
11086 block
->f2k_derived
->finalizers
= f
;
11096 const ext_attr_t ext_attr_list
[] = {
11097 { "dllimport", EXT_ATTR_DLLIMPORT
, "dllimport" },
11098 { "dllexport", EXT_ATTR_DLLEXPORT
, "dllexport" },
11099 { "cdecl", EXT_ATTR_CDECL
, "cdecl" },
11100 { "stdcall", EXT_ATTR_STDCALL
, "stdcall" },
11101 { "fastcall", EXT_ATTR_FASTCALL
, "fastcall" },
11102 { "no_arg_check", EXT_ATTR_NO_ARG_CHECK
, NULL
},
11103 { NULL
, EXT_ATTR_LAST
, NULL
}
11106 /* Match a !GCC$ ATTRIBUTES statement of the form:
11107 !GCC$ ATTRIBUTES attribute-list :: var-name [, var-name] ...
11108 When we come here, we have already matched the !GCC$ ATTRIBUTES string.
11110 TODO: We should support all GCC attributes using the same syntax for
11111 the attribute list, i.e. the list in C
11112 __attributes(( attribute-list ))
11114 !GCC$ ATTRIBUTES attribute-list ::
11115 Cf. c-parser.c's c_parser_attributes; the data can then directly be
11118 As there is absolutely no risk of confusion, we should never return
11121 gfc_match_gcc_attributes (void)
11123 symbol_attribute attr
;
11124 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
11129 gfc_clear_attr (&attr
);
11134 if (gfc_match_name (name
) != MATCH_YES
)
11135 return MATCH_ERROR
;
11137 for (id
= 0; id
< EXT_ATTR_LAST
; id
++)
11138 if (strcmp (name
, ext_attr_list
[id
].name
) == 0)
11141 if (id
== EXT_ATTR_LAST
)
11143 gfc_error ("Unknown attribute in !GCC$ ATTRIBUTES statement at %C");
11144 return MATCH_ERROR
;
11147 if (!gfc_add_ext_attribute (&attr
, (ext_attr_id_t
)id
, &gfc_current_locus
))
11148 return MATCH_ERROR
;
11150 gfc_gobble_whitespace ();
11151 ch
= gfc_next_ascii_char ();
11154 /* This is the successful exit condition for the loop. */
11155 if (gfc_next_ascii_char () == ':')
11165 if (gfc_match_eos () == MATCH_YES
)
11170 m
= gfc_match_name (name
);
11171 if (m
!= MATCH_YES
)
11174 if (find_special (name
, &sym
, true))
11175 return MATCH_ERROR
;
11177 sym
->attr
.ext_attr
|= attr
.ext_attr
;
11179 if (gfc_match_eos () == MATCH_YES
)
11182 if (gfc_match_char (',') != MATCH_YES
)
11189 gfc_error ("Syntax error in !GCC$ ATTRIBUTES statement at %C");
11190 return MATCH_ERROR
;
11194 /* Match a !GCC$ UNROLL statement of the form:
11197 The parameter n is the number of times we are supposed to unroll.
11199 When we come here, we have already matched the !GCC$ UNROLL string. */
11201 gfc_match_gcc_unroll (void)
11205 if (gfc_match_small_int (&value
) == MATCH_YES
)
11207 if (value
< 0 || value
> USHRT_MAX
)
11209 gfc_error ("%<GCC unroll%> directive requires a"
11210 " non-negative integral constant"
11211 " less than or equal to %u at %C",
11214 return MATCH_ERROR
;
11216 if (gfc_match_eos () == MATCH_YES
)
11218 directive_unroll
= value
== 0 ? 1 : value
;
11223 gfc_error ("Syntax error in !GCC$ UNROLL directive at %C");
11224 return MATCH_ERROR
;