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 (strncmp (name
, "%FILL", 5) == 0 && 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
5868 && current_ts
.u
.derived
== gfc_current_block ())
5871 gfc_find_symbol (current_ts
.u
.derived
->name
,
5872 current_ts
.u
.derived
->ns
, 1, &sym
);
5874 /* Any symbol that we find had better be a type definition
5875 which has its components defined, or be a structure definition
5876 actively being parsed. */
5877 if (sym
!= NULL
&& gfc_fl_struct (sym
->attr
.flavor
)
5878 && (current_ts
.u
.derived
->components
!= NULL
5879 || current_ts
.u
.derived
->attr
.zero_comp
5880 || current_ts
.u
.derived
== gfc_new_block
))
5883 gfc_error ("Derived type at %C has not been previously defined "
5884 "and so cannot appear in a derived type definition");
5890 /* If we have an old-style character declaration, and no new-style
5891 attribute specifications, then there a comma is optional between
5892 the type specification and the variable list. */
5893 if (m
== MATCH_NO
&& current_ts
.type
== BT_CHARACTER
&& old_char_selector
)
5894 gfc_match_char (',');
5896 /* Give the types/attributes to symbols that follow. Give the element
5897 a number so that repeat character length expressions can be copied. */
5901 num_idents_on_line
++;
5902 m
= variable_decl (elem
++);
5903 if (m
== MATCH_ERROR
)
5908 if (gfc_match_eos () == MATCH_YES
)
5910 if (gfc_match_char (',') != MATCH_YES
)
5914 if (!gfc_error_flag_test ())
5916 /* An anonymous structure declaration is unambiguous; if we matched one
5917 according to gfc_match_structure_decl, we need to return MATCH_YES
5918 here to avoid confusing the remaining matchers, even if there was an
5919 error during variable_decl. We must flush any such errors. Note this
5920 causes the parser to gracefully continue parsing the remaining input
5921 as a structure body, which likely follows. */
5922 if (current_ts
.type
== BT_DERIVED
&& current_ts
.u
.derived
5923 && gfc_fl_struct (current_ts
.u
.derived
->attr
.flavor
))
5925 gfc_error_now ("Syntax error in anonymous structure declaration"
5927 /* Skip the bad variable_decl and line up for the start of the
5929 gfc_error_recovery ();
5934 gfc_error ("Syntax error in data declaration at %C");
5939 gfc_free_data_all (gfc_current_ns
);
5942 if (saved_kind_expr
)
5943 gfc_free_expr (saved_kind_expr
);
5944 if (type_param_spec_list
)
5945 gfc_free_actual_arglist (type_param_spec_list
);
5946 if (decl_type_param_list
)
5947 gfc_free_actual_arglist (decl_type_param_list
);
5948 saved_kind_expr
= NULL
;
5949 gfc_free_array_spec (current_as
);
5955 /* Match a prefix associated with a function or subroutine
5956 declaration. If the typespec pointer is nonnull, then a typespec
5957 can be matched. Note that if nothing matches, MATCH_YES is
5958 returned (the null string was matched). */
5961 gfc_match_prefix (gfc_typespec
*ts
)
5967 gfc_clear_attr (¤t_attr
);
5969 seen_impure
= false;
5971 gcc_assert (!gfc_matching_prefix
);
5972 gfc_matching_prefix
= true;
5976 found_prefix
= false;
5978 /* MODULE is a prefix like PURE, ELEMENTAL, etc., having a
5979 corresponding attribute seems natural and distinguishes these
5980 procedures from procedure types of PROC_MODULE, which these are
5982 if (gfc_match ("module% ") == MATCH_YES
)
5984 if (!gfc_notify_std (GFC_STD_F2008
, "MODULE prefix at %C"))
5987 current_attr
.module_procedure
= 1;
5988 found_prefix
= true;
5991 if (!seen_type
&& ts
!= NULL
5992 && gfc_match_decl_type_spec (ts
, 0) == MATCH_YES
5993 && gfc_match_space () == MATCH_YES
)
5997 found_prefix
= true;
6000 if (gfc_match ("elemental% ") == MATCH_YES
)
6002 if (!gfc_add_elemental (¤t_attr
, NULL
))
6005 found_prefix
= true;
6008 if (gfc_match ("pure% ") == MATCH_YES
)
6010 if (!gfc_add_pure (¤t_attr
, NULL
))
6013 found_prefix
= true;
6016 if (gfc_match ("recursive% ") == MATCH_YES
)
6018 if (!gfc_add_recursive (¤t_attr
, NULL
))
6021 found_prefix
= true;
6024 /* IMPURE is a somewhat special case, as it needs not set an actual
6025 attribute but rather only prevents ELEMENTAL routines from being
6026 automatically PURE. */
6027 if (gfc_match ("impure% ") == MATCH_YES
)
6029 if (!gfc_notify_std (GFC_STD_F2008
, "IMPURE procedure at %C"))
6033 found_prefix
= true;
6036 while (found_prefix
);
6038 /* IMPURE and PURE must not both appear, of course. */
6039 if (seen_impure
&& current_attr
.pure
)
6041 gfc_error ("PURE and IMPURE must not appear both at %C");
6045 /* If IMPURE it not seen but the procedure is ELEMENTAL, mark it as PURE. */
6046 if (!seen_impure
&& current_attr
.elemental
&& !current_attr
.pure
)
6048 if (!gfc_add_pure (¤t_attr
, NULL
))
6052 /* At this point, the next item is not a prefix. */
6053 gcc_assert (gfc_matching_prefix
);
6055 gfc_matching_prefix
= false;
6059 gcc_assert (gfc_matching_prefix
);
6060 gfc_matching_prefix
= false;
6065 /* Copy attributes matched by gfc_match_prefix() to attributes on a symbol. */
6068 copy_prefix (symbol_attribute
*dest
, locus
*where
)
6070 if (dest
->module_procedure
)
6072 if (current_attr
.elemental
)
6073 dest
->elemental
= 1;
6075 if (current_attr
.pure
)
6078 if (current_attr
.recursive
)
6079 dest
->recursive
= 1;
6081 /* Module procedures are unusual in that the 'dest' is copied from
6082 the interface declaration. However, this is an oportunity to
6083 check that the submodule declaration is compliant with the
6085 if (dest
->elemental
&& !current_attr
.elemental
)
6087 gfc_error ("ELEMENTAL prefix in MODULE PROCEDURE interface is "
6088 "missing at %L", where
);
6092 if (dest
->pure
&& !current_attr
.pure
)
6094 gfc_error ("PURE prefix in MODULE PROCEDURE interface is "
6095 "missing at %L", where
);
6099 if (dest
->recursive
&& !current_attr
.recursive
)
6101 gfc_error ("RECURSIVE prefix in MODULE PROCEDURE interface is "
6102 "missing at %L", where
);
6109 if (current_attr
.elemental
&& !gfc_add_elemental (dest
, where
))
6112 if (current_attr
.pure
&& !gfc_add_pure (dest
, where
))
6115 if (current_attr
.recursive
&& !gfc_add_recursive (dest
, where
))
6122 /* Match a formal argument list or, if typeparam is true, a
6123 type_param_name_list. */
6126 gfc_match_formal_arglist (gfc_symbol
*progname
, int st_flag
,
6127 int null_flag
, bool typeparam
)
6129 gfc_formal_arglist
*head
, *tail
, *p
, *q
;
6130 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6133 gfc_formal_arglist
*formal
= NULL
;
6137 /* Keep the interface formal argument list and null it so that the
6138 matching for the new declaration can be done. The numbers and
6139 names of the arguments are checked here. The interface formal
6140 arguments are retained in formal_arglist and the characteristics
6141 are compared in resolve.c(resolve_fl_procedure). See the remark
6142 in get_proc_name about the eventual need to copy the formal_arglist
6143 and populate the formal namespace of the interface symbol. */
6144 if (progname
->attr
.module_procedure
6145 && progname
->attr
.host_assoc
)
6147 formal
= progname
->formal
;
6148 progname
->formal
= NULL
;
6151 if (gfc_match_char ('(') != MATCH_YES
)
6158 if (gfc_match_char (')') == MATCH_YES
)
6163 if (gfc_match_char ('*') == MATCH_YES
)
6166 if (!typeparam
&& !gfc_notify_std (GFC_STD_F95_OBS
,
6167 "Alternate-return argument at %C"))
6173 gfc_error_now ("A parameter name is required at %C");
6177 m
= gfc_match_name (name
);
6181 gfc_error_now ("A parameter name is required at %C");
6185 if (!typeparam
&& gfc_get_symbol (name
, NULL
, &sym
))
6188 && gfc_get_symbol (name
, progname
->f2k_derived
, &sym
))
6192 p
= gfc_get_formal_arglist ();
6204 /* We don't add the VARIABLE flavor because the name could be a
6205 dummy procedure. We don't apply these attributes to formal
6206 arguments of statement functions. */
6207 if (sym
!= NULL
&& !st_flag
6208 && (!gfc_add_dummy(&sym
->attr
, sym
->name
, NULL
)
6209 || !gfc_missing_attr (&sym
->attr
, NULL
)))
6215 /* The name of a program unit can be in a different namespace,
6216 so check for it explicitly. After the statement is accepted,
6217 the name is checked for especially in gfc_get_symbol(). */
6218 if (gfc_new_block
!= NULL
&& sym
!= NULL
&& !typeparam
6219 && strcmp (sym
->name
, gfc_new_block
->name
) == 0)
6221 gfc_error ("Name %qs at %C is the name of the procedure",
6227 if (gfc_match_char (')') == MATCH_YES
)
6230 m
= gfc_match_char (',');
6234 gfc_error_now ("Expected parameter list in type declaration "
6237 gfc_error ("Unexpected junk in formal argument list at %C");
6243 /* Check for duplicate symbols in the formal argument list. */
6246 for (p
= head
; p
->next
; p
= p
->next
)
6251 for (q
= p
->next
; q
; q
= q
->next
)
6252 if (p
->sym
== q
->sym
)
6255 gfc_error_now ("Duplicate name %qs in parameter "
6256 "list at %C", p
->sym
->name
);
6258 gfc_error ("Duplicate symbol %qs in formal argument "
6259 "list at %C", p
->sym
->name
);
6267 if (!gfc_add_explicit_interface (progname
, IFSRC_DECL
, head
, NULL
))
6273 /* gfc_error_now used in following and return with MATCH_YES because
6274 doing otherwise results in a cascade of extraneous errors and in
6275 some cases an ICE in symbol.c(gfc_release_symbol). */
6276 if (progname
->attr
.module_procedure
&& progname
->attr
.host_assoc
)
6278 bool arg_count_mismatch
= false;
6280 if (!formal
&& head
)
6281 arg_count_mismatch
= true;
6283 /* Abbreviated module procedure declaration is not meant to have any
6284 formal arguments! */
6285 if (!progname
->abr_modproc_decl
&& formal
&& !head
)
6286 arg_count_mismatch
= true;
6288 for (p
= formal
, q
= head
; p
&& q
; p
= p
->next
, q
= q
->next
)
6290 if ((p
->next
!= NULL
&& q
->next
== NULL
)
6291 || (p
->next
== NULL
&& q
->next
!= NULL
))
6292 arg_count_mismatch
= true;
6293 else if ((p
->sym
== NULL
&& q
->sym
== NULL
)
6294 || strcmp (p
->sym
->name
, q
->sym
->name
) == 0)
6297 gfc_error_now ("Mismatch in MODULE PROCEDURE formal "
6298 "argument names (%s/%s) at %C",
6299 p
->sym
->name
, q
->sym
->name
);
6302 if (arg_count_mismatch
)
6303 gfc_error_now ("Mismatch in number of MODULE PROCEDURE "
6304 "formal arguments at %C");
6310 gfc_free_formal_arglist (head
);
6315 /* Match a RESULT specification following a function declaration or
6316 ENTRY statement. Also matches the end-of-statement. */
6319 match_result (gfc_symbol
*function
, gfc_symbol
**result
)
6321 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6325 if (gfc_match (" result (") != MATCH_YES
)
6328 m
= gfc_match_name (name
);
6332 /* Get the right paren, and that's it because there could be the
6333 bind(c) attribute after the result clause. */
6334 if (gfc_match_char (')') != MATCH_YES
)
6336 /* TODO: should report the missing right paren here. */
6340 if (strcmp (function
->name
, name
) == 0)
6342 gfc_error ("RESULT variable at %C must be different than function name");
6346 if (gfc_get_symbol (name
, NULL
, &r
))
6349 if (!gfc_add_result (&r
->attr
, r
->name
, NULL
))
6358 /* Match a function suffix, which could be a combination of a result
6359 clause and BIND(C), either one, or neither. The draft does not
6360 require them to come in a specific order. */
6363 gfc_match_suffix (gfc_symbol
*sym
, gfc_symbol
**result
)
6365 match is_bind_c
; /* Found bind(c). */
6366 match is_result
; /* Found result clause. */
6367 match found_match
; /* Status of whether we've found a good match. */
6368 char peek_char
; /* Character we're going to peek at. */
6369 bool allow_binding_name
;
6371 /* Initialize to having found nothing. */
6372 found_match
= MATCH_NO
;
6373 is_bind_c
= MATCH_NO
;
6374 is_result
= MATCH_NO
;
6376 /* Get the next char to narrow between result and bind(c). */
6377 gfc_gobble_whitespace ();
6378 peek_char
= gfc_peek_ascii_char ();
6380 /* C binding names are not allowed for internal procedures. */
6381 if (gfc_current_state () == COMP_CONTAINS
6382 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
6383 allow_binding_name
= false;
6385 allow_binding_name
= true;
6390 /* Look for result clause. */
6391 is_result
= match_result (sym
, result
);
6392 if (is_result
== MATCH_YES
)
6394 /* Now see if there is a bind(c) after it. */
6395 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
6396 /* We've found the result clause and possibly bind(c). */
6397 found_match
= MATCH_YES
;
6400 /* This should only be MATCH_ERROR. */
6401 found_match
= is_result
;
6404 /* Look for bind(c) first. */
6405 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
6406 if (is_bind_c
== MATCH_YES
)
6408 /* Now see if a result clause followed it. */
6409 is_result
= match_result (sym
, result
);
6410 found_match
= MATCH_YES
;
6414 /* Should only be a MATCH_ERROR if we get here after seeing 'b'. */
6415 found_match
= MATCH_ERROR
;
6419 gfc_error ("Unexpected junk after function declaration at %C");
6420 found_match
= MATCH_ERROR
;
6424 if (is_bind_c
== MATCH_YES
)
6426 /* Fortran 2008 draft allows BIND(C) for internal procedures. */
6427 if (gfc_current_state () == COMP_CONTAINS
6428 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
6429 && !gfc_notify_std (GFC_STD_F2008
, "BIND(C) attribute "
6430 "at %L may not be specified for an internal "
6431 "procedure", &gfc_current_locus
))
6434 if (!gfc_add_is_bind_c (&(sym
->attr
), sym
->name
, &gfc_current_locus
, 1))
6442 /* Procedure pointer return value without RESULT statement:
6443 Add "hidden" result variable named "ppr@". */
6446 add_hidden_procptr_result (gfc_symbol
*sym
)
6450 if (gfc_notification_std (GFC_STD_F2003
) == ERROR
)
6453 /* First usage case: PROCEDURE and EXTERNAL statements. */
6454 case1
= gfc_current_state () == COMP_FUNCTION
&& gfc_current_block ()
6455 && strcmp (gfc_current_block ()->name
, sym
->name
) == 0
6456 && sym
->attr
.external
;
6457 /* Second usage case: INTERFACE statements. */
6458 case2
= gfc_current_state () == COMP_INTERFACE
&& gfc_state_stack
->previous
6459 && gfc_state_stack
->previous
->state
== COMP_FUNCTION
6460 && strcmp (gfc_state_stack
->previous
->sym
->name
, sym
->name
) == 0;
6466 gfc_get_sym_tree ("ppr@", gfc_current_ns
, &stree
, false);
6470 gfc_get_sym_tree ("ppr@", gfc_current_ns
->parent
, &stree
, false);
6471 st2
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "ppr@");
6472 st2
->n
.sym
= stree
->n
.sym
;
6473 stree
->n
.sym
->refs
++;
6475 sym
->result
= stree
->n
.sym
;
6477 sym
->result
->attr
.proc_pointer
= sym
->attr
.proc_pointer
;
6478 sym
->result
->attr
.pointer
= sym
->attr
.pointer
;
6479 sym
->result
->attr
.external
= sym
->attr
.external
;
6480 sym
->result
->attr
.referenced
= sym
->attr
.referenced
;
6481 sym
->result
->ts
= sym
->ts
;
6482 sym
->attr
.proc_pointer
= 0;
6483 sym
->attr
.pointer
= 0;
6484 sym
->attr
.external
= 0;
6485 if (sym
->result
->attr
.external
&& sym
->result
->attr
.pointer
)
6487 sym
->result
->attr
.pointer
= 0;
6488 sym
->result
->attr
.proc_pointer
= 1;
6491 return gfc_add_result (&sym
->result
->attr
, sym
->result
->name
, NULL
);
6493 /* POINTER after PROCEDURE/EXTERNAL/INTERFACE statement. */
6494 else if (sym
->attr
.function
&& !sym
->attr
.external
&& sym
->attr
.pointer
6495 && sym
->result
&& sym
->result
!= sym
&& sym
->result
->attr
.external
6496 && sym
== gfc_current_ns
->proc_name
6497 && sym
== sym
->result
->ns
->proc_name
6498 && strcmp ("ppr@", sym
->result
->name
) == 0)
6500 sym
->result
->attr
.proc_pointer
= 1;
6501 sym
->attr
.pointer
= 0;
6509 /* Match the interface for a PROCEDURE declaration,
6510 including brackets (R1212). */
6513 match_procedure_interface (gfc_symbol
**proc_if
)
6517 locus old_loc
, entry_loc
;
6518 gfc_namespace
*old_ns
= gfc_current_ns
;
6519 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6521 old_loc
= entry_loc
= gfc_current_locus
;
6522 gfc_clear_ts (¤t_ts
);
6524 if (gfc_match (" (") != MATCH_YES
)
6526 gfc_current_locus
= entry_loc
;
6530 /* Get the type spec. for the procedure interface. */
6531 old_loc
= gfc_current_locus
;
6532 m
= gfc_match_decl_type_spec (¤t_ts
, 0);
6533 gfc_gobble_whitespace ();
6534 if (m
== MATCH_YES
|| (m
== MATCH_NO
&& gfc_peek_ascii_char () == ')'))
6537 if (m
== MATCH_ERROR
)
6540 /* Procedure interface is itself a procedure. */
6541 gfc_current_locus
= old_loc
;
6542 m
= gfc_match_name (name
);
6544 /* First look to see if it is already accessible in the current
6545 namespace because it is use associated or contained. */
6547 if (gfc_find_sym_tree (name
, NULL
, 0, &st
))
6550 /* If it is still not found, then try the parent namespace, if it
6551 exists and create the symbol there if it is still not found. */
6552 if (gfc_current_ns
->parent
)
6553 gfc_current_ns
= gfc_current_ns
->parent
;
6554 if (st
== NULL
&& gfc_get_ha_sym_tree (name
, &st
))
6557 gfc_current_ns
= old_ns
;
6558 *proc_if
= st
->n
.sym
;
6563 /* Resolve interface if possible. That way, attr.procedure is only set
6564 if it is declared by a later procedure-declaration-stmt, which is
6565 invalid per F08:C1216 (cf. resolve_procedure_interface). */
6566 while ((*proc_if
)->ts
.interface
6567 && *proc_if
!= (*proc_if
)->ts
.interface
)
6568 *proc_if
= (*proc_if
)->ts
.interface
;
6570 if ((*proc_if
)->attr
.flavor
== FL_UNKNOWN
6571 && (*proc_if
)->ts
.type
== BT_UNKNOWN
6572 && !gfc_add_flavor (&(*proc_if
)->attr
, FL_PROCEDURE
,
6573 (*proc_if
)->name
, NULL
))
6578 if (gfc_match (" )") != MATCH_YES
)
6580 gfc_current_locus
= entry_loc
;
6588 /* Match a PROCEDURE declaration (R1211). */
6591 match_procedure_decl (void)
6594 gfc_symbol
*sym
, *proc_if
= NULL
;
6596 gfc_expr
*initializer
= NULL
;
6598 /* Parse interface (with brackets). */
6599 m
= match_procedure_interface (&proc_if
);
6603 /* Parse attributes (with colons). */
6604 m
= match_attr_spec();
6605 if (m
== MATCH_ERROR
)
6608 if (proc_if
&& proc_if
->attr
.is_bind_c
&& !current_attr
.is_bind_c
)
6610 current_attr
.is_bind_c
= 1;
6611 has_name_equals
= 0;
6612 curr_binding_label
= NULL
;
6615 /* Get procedure symbols. */
6618 m
= gfc_match_symbol (&sym
, 0);
6621 else if (m
== MATCH_ERROR
)
6624 /* Add current_attr to the symbol attributes. */
6625 if (!gfc_copy_attr (&sym
->attr
, ¤t_attr
, NULL
))
6628 if (sym
->attr
.is_bind_c
)
6630 /* Check for C1218. */
6631 if (!proc_if
|| !proc_if
->attr
.is_bind_c
)
6633 gfc_error ("BIND(C) attribute at %C requires "
6634 "an interface with BIND(C)");
6637 /* Check for C1217. */
6638 if (has_name_equals
&& sym
->attr
.pointer
)
6640 gfc_error ("BIND(C) procedure with NAME may not have "
6641 "POINTER attribute at %C");
6644 if (has_name_equals
&& sym
->attr
.dummy
)
6646 gfc_error ("Dummy procedure at %C may not have "
6647 "BIND(C) attribute with NAME");
6650 /* Set binding label for BIND(C). */
6651 if (!set_binding_label (&sym
->binding_label
, sym
->name
, num
))
6655 if (!gfc_add_external (&sym
->attr
, NULL
))
6658 if (add_hidden_procptr_result (sym
))
6661 if (!gfc_add_proc (&sym
->attr
, sym
->name
, NULL
))
6664 /* Set interface. */
6665 if (proc_if
!= NULL
)
6667 if (sym
->ts
.type
!= BT_UNKNOWN
)
6669 gfc_error ("Procedure %qs at %L already has basic type of %s",
6670 sym
->name
, &gfc_current_locus
,
6671 gfc_basic_typename (sym
->ts
.type
));
6674 sym
->ts
.interface
= proc_if
;
6675 sym
->attr
.untyped
= 1;
6676 sym
->attr
.if_source
= IFSRC_IFBODY
;
6678 else if (current_ts
.type
!= BT_UNKNOWN
)
6680 if (!gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
6682 sym
->ts
.interface
= gfc_new_symbol ("", gfc_current_ns
);
6683 sym
->ts
.interface
->ts
= current_ts
;
6684 sym
->ts
.interface
->attr
.flavor
= FL_PROCEDURE
;
6685 sym
->ts
.interface
->attr
.function
= 1;
6686 sym
->attr
.function
= 1;
6687 sym
->attr
.if_source
= IFSRC_UNKNOWN
;
6690 if (gfc_match (" =>") == MATCH_YES
)
6692 if (!current_attr
.pointer
)
6694 gfc_error ("Initialization at %C isn't for a pointer variable");
6699 m
= match_pointer_init (&initializer
, 1);
6703 if (!add_init_expr_to_sym (sym
->name
, &initializer
, &gfc_current_locus
))
6708 if (gfc_match_eos () == MATCH_YES
)
6710 if (gfc_match_char (',') != MATCH_YES
)
6715 gfc_error ("Syntax error in PROCEDURE statement at %C");
6719 /* Free stuff up and return. */
6720 gfc_free_expr (initializer
);
6726 match_binding_attributes (gfc_typebound_proc
* ba
, bool generic
, bool ppc
);
6729 /* Match a procedure pointer component declaration (R445). */
6732 match_ppc_decl (void)
6735 gfc_symbol
*proc_if
= NULL
;
6739 gfc_expr
*initializer
= NULL
;
6740 gfc_typebound_proc
* tb
;
6741 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6743 /* Parse interface (with brackets). */
6744 m
= match_procedure_interface (&proc_if
);
6748 /* Parse attributes. */
6749 tb
= XCNEW (gfc_typebound_proc
);
6750 tb
->where
= gfc_current_locus
;
6751 m
= match_binding_attributes (tb
, false, true);
6752 if (m
== MATCH_ERROR
)
6755 gfc_clear_attr (¤t_attr
);
6756 current_attr
.procedure
= 1;
6757 current_attr
.proc_pointer
= 1;
6758 current_attr
.access
= tb
->access
;
6759 current_attr
.flavor
= FL_PROCEDURE
;
6761 /* Match the colons (required). */
6762 if (gfc_match (" ::") != MATCH_YES
)
6764 gfc_error ("Expected %<::%> after binding-attributes at %C");
6768 /* Check for C450. */
6769 if (!tb
->nopass
&& proc_if
== NULL
)
6771 gfc_error("NOPASS or explicit interface required at %C");
6775 if (!gfc_notify_std (GFC_STD_F2003
, "Procedure pointer component at %C"))
6778 /* Match PPC names. */
6782 m
= gfc_match_name (name
);
6785 else if (m
== MATCH_ERROR
)
6788 if (!gfc_add_component (gfc_current_block(), name
, &c
))
6791 /* Add current_attr to the symbol attributes. */
6792 if (!gfc_copy_attr (&c
->attr
, ¤t_attr
, NULL
))
6795 if (!gfc_add_external (&c
->attr
, NULL
))
6798 if (!gfc_add_proc (&c
->attr
, name
, NULL
))
6805 c
->tb
= XCNEW (gfc_typebound_proc
);
6806 c
->tb
->where
= gfc_current_locus
;
6810 /* Set interface. */
6811 if (proc_if
!= NULL
)
6813 c
->ts
.interface
= proc_if
;
6814 c
->attr
.untyped
= 1;
6815 c
->attr
.if_source
= IFSRC_IFBODY
;
6817 else if (ts
.type
!= BT_UNKNOWN
)
6820 c
->ts
.interface
= gfc_new_symbol ("", gfc_current_ns
);
6821 c
->ts
.interface
->result
= c
->ts
.interface
;
6822 c
->ts
.interface
->ts
= ts
;
6823 c
->ts
.interface
->attr
.flavor
= FL_PROCEDURE
;
6824 c
->ts
.interface
->attr
.function
= 1;
6825 c
->attr
.function
= 1;
6826 c
->attr
.if_source
= IFSRC_UNKNOWN
;
6829 if (gfc_match (" =>") == MATCH_YES
)
6831 m
= match_pointer_init (&initializer
, 1);
6834 gfc_free_expr (initializer
);
6837 c
->initializer
= initializer
;
6840 if (gfc_match_eos () == MATCH_YES
)
6842 if (gfc_match_char (',') != MATCH_YES
)
6847 gfc_error ("Syntax error in procedure pointer component at %C");
6852 /* Match a PROCEDURE declaration inside an interface (R1206). */
6855 match_procedure_in_interface (void)
6859 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6862 if (current_interface
.type
== INTERFACE_NAMELESS
6863 || current_interface
.type
== INTERFACE_ABSTRACT
)
6865 gfc_error ("PROCEDURE at %C must be in a generic interface");
6869 /* Check if the F2008 optional double colon appears. */
6870 gfc_gobble_whitespace ();
6871 old_locus
= gfc_current_locus
;
6872 if (gfc_match ("::") == MATCH_YES
)
6874 if (!gfc_notify_std (GFC_STD_F2008
, "double colon in "
6875 "MODULE PROCEDURE statement at %L", &old_locus
))
6879 gfc_current_locus
= old_locus
;
6883 m
= gfc_match_name (name
);
6886 else if (m
== MATCH_ERROR
)
6888 if (gfc_get_symbol (name
, gfc_current_ns
->parent
, &sym
))
6891 if (!gfc_add_interface (sym
))
6894 if (gfc_match_eos () == MATCH_YES
)
6896 if (gfc_match_char (',') != MATCH_YES
)
6903 gfc_error ("Syntax error in PROCEDURE statement at %C");
6908 /* General matcher for PROCEDURE declarations. */
6910 static match
match_procedure_in_type (void);
6913 gfc_match_procedure (void)
6917 switch (gfc_current_state ())
6922 case COMP_SUBMODULE
:
6923 case COMP_SUBROUTINE
:
6926 m
= match_procedure_decl ();
6928 case COMP_INTERFACE
:
6929 m
= match_procedure_in_interface ();
6932 m
= match_ppc_decl ();
6934 case COMP_DERIVED_CONTAINS
:
6935 m
= match_procedure_in_type ();
6944 if (!gfc_notify_std (GFC_STD_F2003
, "PROCEDURE statement at %C"))
6951 /* Warn if a matched procedure has the same name as an intrinsic; this is
6952 simply a wrapper around gfc_warn_intrinsic_shadow that interprets the current
6953 parser-state-stack to find out whether we're in a module. */
6956 do_warn_intrinsic_shadow (const gfc_symbol
* sym
, bool func
)
6960 in_module
= (gfc_state_stack
->previous
6961 && (gfc_state_stack
->previous
->state
== COMP_MODULE
6962 || gfc_state_stack
->previous
->state
== COMP_SUBMODULE
));
6964 gfc_warn_intrinsic_shadow (sym
, in_module
, func
);
6968 /* Match a function declaration. */
6971 gfc_match_function_decl (void)
6973 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6974 gfc_symbol
*sym
, *result
;
6978 match found_match
; /* Status returned by match func. */
6980 if (gfc_current_state () != COMP_NONE
6981 && gfc_current_state () != COMP_INTERFACE
6982 && gfc_current_state () != COMP_CONTAINS
)
6985 gfc_clear_ts (¤t_ts
);
6987 old_loc
= gfc_current_locus
;
6989 m
= gfc_match_prefix (¤t_ts
);
6992 gfc_current_locus
= old_loc
;
6996 if (gfc_match ("function% %n", name
) != MATCH_YES
)
6998 gfc_current_locus
= old_loc
;
7002 if (get_proc_name (name
, &sym
, false))
7005 if (add_hidden_procptr_result (sym
))
7008 if (current_attr
.module_procedure
)
7009 sym
->attr
.module_procedure
= 1;
7011 gfc_new_block
= sym
;
7013 m
= gfc_match_formal_arglist (sym
, 0, 0);
7016 gfc_error ("Expected formal argument list in function "
7017 "definition at %C");
7021 else if (m
== MATCH_ERROR
)
7026 /* According to the draft, the bind(c) and result clause can
7027 come in either order after the formal_arg_list (i.e., either
7028 can be first, both can exist together or by themselves or neither
7029 one). Therefore, the match_result can't match the end of the
7030 string, and check for the bind(c) or result clause in either order. */
7031 found_match
= gfc_match_eos ();
7033 /* Make sure that it isn't already declared as BIND(C). If it is, it
7034 must have been marked BIND(C) with a BIND(C) attribute and that is
7035 not allowed for procedures. */
7036 if (sym
->attr
.is_bind_c
== 1)
7038 sym
->attr
.is_bind_c
= 0;
7039 if (sym
->old_symbol
!= NULL
)
7040 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7041 "variables or common blocks",
7042 &(sym
->old_symbol
->declared_at
));
7044 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7045 "variables or common blocks", &gfc_current_locus
);
7048 if (found_match
!= MATCH_YES
)
7050 /* If we haven't found the end-of-statement, look for a suffix. */
7051 suffix_match
= gfc_match_suffix (sym
, &result
);
7052 if (suffix_match
== MATCH_YES
)
7053 /* Need to get the eos now. */
7054 found_match
= gfc_match_eos ();
7056 found_match
= suffix_match
;
7059 if(found_match
!= MATCH_YES
)
7063 /* Make changes to the symbol. */
7066 if (!gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
7069 if (!gfc_missing_attr (&sym
->attr
, NULL
))
7072 if (!copy_prefix (&sym
->attr
, &sym
->declared_at
))
7074 if(!sym
->attr
.module_procedure
)
7080 /* Delay matching the function characteristics until after the
7081 specification block by signalling kind=-1. */
7082 sym
->declared_at
= old_loc
;
7083 if (current_ts
.type
!= BT_UNKNOWN
)
7084 current_ts
.kind
= -1;
7086 current_ts
.kind
= 0;
7090 if (current_ts
.type
!= BT_UNKNOWN
7091 && !gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
7097 if (current_ts
.type
!= BT_UNKNOWN
7098 && !gfc_add_type (result
, ¤t_ts
, &gfc_current_locus
))
7100 sym
->result
= result
;
7103 /* Warn if this procedure has the same name as an intrinsic. */
7104 do_warn_intrinsic_shadow (sym
, true);
7110 gfc_current_locus
= old_loc
;
7115 /* This is mostly a copy of parse.c(add_global_procedure) but modified to
7116 pass the name of the entry, rather than the gfc_current_block name, and
7117 to return false upon finding an existing global entry. */
7120 add_global_entry (const char *name
, const char *binding_label
, bool sub
,
7124 enum gfc_symbol_type type
;
7126 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
7128 /* Only in Fortran 2003: For procedures with a binding label also the Fortran
7129 name is a global identifier. */
7130 if (!binding_label
|| gfc_notification_std (GFC_STD_F2008
))
7132 s
= gfc_get_gsymbol (name
);
7134 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= type
))
7136 gfc_global_used (s
, where
);
7145 s
->ns
= gfc_current_ns
;
7149 /* Don't add the symbol multiple times. */
7151 && (!gfc_notification_std (GFC_STD_F2008
)
7152 || strcmp (name
, binding_label
) != 0))
7154 s
= gfc_get_gsymbol (binding_label
);
7156 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= type
))
7158 gfc_global_used (s
, where
);
7165 s
->binding_label
= binding_label
;
7168 s
->ns
= gfc_current_ns
;
7176 /* Match an ENTRY statement. */
7179 gfc_match_entry (void)
7184 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7185 gfc_compile_state state
;
7189 bool module_procedure
;
7193 m
= gfc_match_name (name
);
7197 if (!gfc_notify_std (GFC_STD_F2008_OBS
, "ENTRY statement at %C"))
7200 state
= gfc_current_state ();
7201 if (state
!= COMP_SUBROUTINE
&& state
!= COMP_FUNCTION
)
7206 gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
7209 gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
7211 case COMP_SUBMODULE
:
7212 gfc_error ("ENTRY statement at %C cannot appear within a SUBMODULE");
7214 case COMP_BLOCK_DATA
:
7215 gfc_error ("ENTRY statement at %C cannot appear within "
7218 case COMP_INTERFACE
:
7219 gfc_error ("ENTRY statement at %C cannot appear within "
7222 case COMP_STRUCTURE
:
7223 gfc_error ("ENTRY statement at %C cannot appear within "
7224 "a STRUCTURE block");
7227 gfc_error ("ENTRY statement at %C cannot appear within "
7228 "a DERIVED TYPE block");
7231 gfc_error ("ENTRY statement at %C cannot appear within "
7232 "an IF-THEN block");
7235 case COMP_DO_CONCURRENT
:
7236 gfc_error ("ENTRY statement at %C cannot appear within "
7240 gfc_error ("ENTRY statement at %C cannot appear within "
7244 gfc_error ("ENTRY statement at %C cannot appear within "
7248 gfc_error ("ENTRY statement at %C cannot appear within "
7252 gfc_error ("ENTRY statement at %C cannot appear within "
7253 "a contained subprogram");
7256 gfc_error ("Unexpected ENTRY statement at %C");
7261 if ((state
== COMP_SUBROUTINE
|| state
== COMP_FUNCTION
)
7262 && gfc_state_stack
->previous
->state
== COMP_INTERFACE
)
7264 gfc_error ("ENTRY statement at %C cannot appear within an INTERFACE");
7268 module_procedure
= gfc_current_ns
->parent
!= NULL
7269 && gfc_current_ns
->parent
->proc_name
7270 && gfc_current_ns
->parent
->proc_name
->attr
.flavor
7273 if (gfc_current_ns
->parent
!= NULL
7274 && gfc_current_ns
->parent
->proc_name
7275 && !module_procedure
)
7277 gfc_error("ENTRY statement at %C cannot appear in a "
7278 "contained procedure");
7282 /* Module function entries need special care in get_proc_name
7283 because previous references within the function will have
7284 created symbols attached to the current namespace. */
7285 if (get_proc_name (name
, &entry
,
7286 gfc_current_ns
->parent
!= NULL
7287 && module_procedure
))
7290 proc
= gfc_current_block ();
7292 /* Make sure that it isn't already declared as BIND(C). If it is, it
7293 must have been marked BIND(C) with a BIND(C) attribute and that is
7294 not allowed for procedures. */
7295 if (entry
->attr
.is_bind_c
== 1)
7297 entry
->attr
.is_bind_c
= 0;
7298 if (entry
->old_symbol
!= NULL
)
7299 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7300 "variables or common blocks",
7301 &(entry
->old_symbol
->declared_at
));
7303 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7304 "variables or common blocks", &gfc_current_locus
);
7307 /* Check what next non-whitespace character is so we can tell if there
7308 is the required parens if we have a BIND(C). */
7309 old_loc
= gfc_current_locus
;
7310 gfc_gobble_whitespace ();
7311 peek_char
= gfc_peek_ascii_char ();
7313 if (state
== COMP_SUBROUTINE
)
7315 m
= gfc_match_formal_arglist (entry
, 0, 1);
7319 /* Call gfc_match_bind_c with allow_binding_name = true as ENTRY can
7320 never be an internal procedure. */
7321 is_bind_c
= gfc_match_bind_c (entry
, true);
7322 if (is_bind_c
== MATCH_ERROR
)
7324 if (is_bind_c
== MATCH_YES
)
7326 if (peek_char
!= '(')
7328 gfc_error ("Missing required parentheses before BIND(C) at %C");
7331 if (!gfc_add_is_bind_c (&(entry
->attr
), entry
->name
,
7332 &(entry
->declared_at
), 1))
7336 if (!gfc_current_ns
->parent
7337 && !add_global_entry (name
, entry
->binding_label
, true,
7341 /* An entry in a subroutine. */
7342 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
7343 || !gfc_add_subroutine (&entry
->attr
, entry
->name
, NULL
))
7348 /* An entry in a function.
7349 We need to take special care because writing
7354 ENTRY f() RESULT (r)
7356 ENTRY f RESULT (r). */
7357 if (gfc_match_eos () == MATCH_YES
)
7359 gfc_current_locus
= old_loc
;
7360 /* Match the empty argument list, and add the interface to
7362 m
= gfc_match_formal_arglist (entry
, 0, 1);
7365 m
= gfc_match_formal_arglist (entry
, 0, 0);
7372 if (gfc_match_eos () == MATCH_YES
)
7374 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
7375 || !gfc_add_function (&entry
->attr
, entry
->name
, NULL
))
7378 entry
->result
= entry
;
7382 m
= gfc_match_suffix (entry
, &result
);
7384 gfc_syntax_error (ST_ENTRY
);
7390 if (!gfc_add_result (&result
->attr
, result
->name
, NULL
)
7391 || !gfc_add_entry (&entry
->attr
, result
->name
, NULL
)
7392 || !gfc_add_function (&entry
->attr
, result
->name
, NULL
))
7394 entry
->result
= result
;
7398 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
7399 || !gfc_add_function (&entry
->attr
, entry
->name
, NULL
))
7401 entry
->result
= entry
;
7405 if (!gfc_current_ns
->parent
7406 && !add_global_entry (name
, entry
->binding_label
, false,
7411 if (gfc_match_eos () != MATCH_YES
)
7413 gfc_syntax_error (ST_ENTRY
);
7417 entry
->attr
.recursive
= proc
->attr
.recursive
;
7418 entry
->attr
.elemental
= proc
->attr
.elemental
;
7419 entry
->attr
.pure
= proc
->attr
.pure
;
7421 el
= gfc_get_entry_list ();
7423 el
->next
= gfc_current_ns
->entries
;
7424 gfc_current_ns
->entries
= el
;
7426 el
->id
= el
->next
->id
+ 1;
7430 new_st
.op
= EXEC_ENTRY
;
7431 new_st
.ext
.entry
= el
;
7437 /* Match a subroutine statement, including optional prefixes. */
7440 gfc_match_subroutine (void)
7442 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7447 bool allow_binding_name
;
7449 if (gfc_current_state () != COMP_NONE
7450 && gfc_current_state () != COMP_INTERFACE
7451 && gfc_current_state () != COMP_CONTAINS
)
7454 m
= gfc_match_prefix (NULL
);
7458 m
= gfc_match ("subroutine% %n", name
);
7462 if (get_proc_name (name
, &sym
, false))
7465 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
7466 the symbol existed before. */
7467 sym
->declared_at
= gfc_current_locus
;
7469 if (current_attr
.module_procedure
)
7470 sym
->attr
.module_procedure
= 1;
7472 if (add_hidden_procptr_result (sym
))
7475 gfc_new_block
= sym
;
7477 /* Check what next non-whitespace character is so we can tell if there
7478 is the required parens if we have a BIND(C). */
7479 gfc_gobble_whitespace ();
7480 peek_char
= gfc_peek_ascii_char ();
7482 if (!gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
))
7485 if (gfc_match_formal_arglist (sym
, 0, 1) != MATCH_YES
)
7488 /* Make sure that it isn't already declared as BIND(C). If it is, it
7489 must have been marked BIND(C) with a BIND(C) attribute and that is
7490 not allowed for procedures. */
7491 if (sym
->attr
.is_bind_c
== 1)
7493 sym
->attr
.is_bind_c
= 0;
7494 if (sym
->old_symbol
!= NULL
)
7495 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7496 "variables or common blocks",
7497 &(sym
->old_symbol
->declared_at
));
7499 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7500 "variables or common blocks", &gfc_current_locus
);
7503 /* C binding names are not allowed for internal procedures. */
7504 if (gfc_current_state () == COMP_CONTAINS
7505 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
7506 allow_binding_name
= false;
7508 allow_binding_name
= true;
7510 /* Here, we are just checking if it has the bind(c) attribute, and if
7511 so, then we need to make sure it's all correct. If it doesn't,
7512 we still need to continue matching the rest of the subroutine line. */
7513 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
7514 if (is_bind_c
== MATCH_ERROR
)
7516 /* There was an attempt at the bind(c), but it was wrong. An
7517 error message should have been printed w/in the gfc_match_bind_c
7518 so here we'll just return the MATCH_ERROR. */
7522 if (is_bind_c
== MATCH_YES
)
7524 /* The following is allowed in the Fortran 2008 draft. */
7525 if (gfc_current_state () == COMP_CONTAINS
7526 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
7527 && !gfc_notify_std (GFC_STD_F2008
, "BIND(C) attribute "
7528 "at %L may not be specified for an internal "
7529 "procedure", &gfc_current_locus
))
7532 if (peek_char
!= '(')
7534 gfc_error ("Missing required parentheses before BIND(C) at %C");
7537 if (!gfc_add_is_bind_c (&(sym
->attr
), sym
->name
,
7538 &(sym
->declared_at
), 1))
7542 if (gfc_match_eos () != MATCH_YES
)
7544 gfc_syntax_error (ST_SUBROUTINE
);
7548 if (!copy_prefix (&sym
->attr
, &sym
->declared_at
))
7550 if(!sym
->attr
.module_procedure
)
7556 /* Warn if it has the same name as an intrinsic. */
7557 do_warn_intrinsic_shadow (sym
, false);
7563 /* Check that the NAME identifier in a BIND attribute or statement
7564 is conform to C identifier rules. */
7567 check_bind_name_identifier (char **name
)
7569 char *n
= *name
, *p
;
7571 /* Remove leading spaces. */
7575 /* On an empty string, free memory and set name to NULL. */
7583 /* Remove trailing spaces. */
7584 p
= n
+ strlen(n
) - 1;
7588 /* Insert the identifier into the symbol table. */
7593 /* Now check that identifier is valid under C rules. */
7596 gfc_error ("Invalid C identifier in NAME= specifier at %C");
7601 if (!(ISALNUM (*p
) || *p
== '_' || *p
== '$'))
7603 gfc_error ("Invalid C identifier in NAME= specifier at %C");
7611 /* Match a BIND(C) specifier, with the optional 'name=' specifier if
7612 given, and set the binding label in either the given symbol (if not
7613 NULL), or in the current_ts. The symbol may be NULL because we may
7614 encounter the BIND(C) before the declaration itself. Return
7615 MATCH_NO if what we're looking at isn't a BIND(C) specifier,
7616 MATCH_ERROR if it is a BIND(C) clause but an error was encountered,
7617 or MATCH_YES if the specifier was correct and the binding label and
7618 bind(c) fields were set correctly for the given symbol or the
7619 current_ts. If allow_binding_name is false, no binding name may be
7623 gfc_match_bind_c (gfc_symbol
*sym
, bool allow_binding_name
)
7625 char *binding_label
= NULL
;
7628 /* Initialize the flag that specifies whether we encountered a NAME=
7629 specifier or not. */
7630 has_name_equals
= 0;
7632 /* This much we have to be able to match, in this order, if
7633 there is a bind(c) label. */
7634 if (gfc_match (" bind ( c ") != MATCH_YES
)
7637 /* Now see if there is a binding label, or if we've reached the
7638 end of the bind(c) attribute without one. */
7639 if (gfc_match_char (',') == MATCH_YES
)
7641 if (gfc_match (" name = ") != MATCH_YES
)
7643 gfc_error ("Syntax error in NAME= specifier for binding label "
7645 /* should give an error message here */
7649 has_name_equals
= 1;
7651 if (gfc_match_init_expr (&e
) != MATCH_YES
)
7657 if (!gfc_simplify_expr(e
, 0))
7659 gfc_error ("NAME= specifier at %C should be a constant expression");
7664 if (e
->expr_type
!= EXPR_CONSTANT
|| e
->ts
.type
!= BT_CHARACTER
7665 || e
->ts
.kind
!= gfc_default_character_kind
|| e
->rank
!= 0)
7667 gfc_error ("NAME= specifier at %C should be a scalar of "
7668 "default character kind");
7673 // Get a C string from the Fortran string constant
7674 binding_label
= gfc_widechar_to_char (e
->value
.character
.string
,
7675 e
->value
.character
.length
);
7678 // Check that it is valid (old gfc_match_name_C)
7679 if (check_bind_name_identifier (&binding_label
) != MATCH_YES
)
7683 /* Get the required right paren. */
7684 if (gfc_match_char (')') != MATCH_YES
)
7686 gfc_error ("Missing closing paren for binding label at %C");
7690 if (has_name_equals
&& !allow_binding_name
)
7692 gfc_error ("No binding name is allowed in BIND(C) at %C");
7696 if (has_name_equals
&& sym
!= NULL
&& sym
->attr
.dummy
)
7698 gfc_error ("For dummy procedure %s, no binding name is "
7699 "allowed in BIND(C) at %C", sym
->name
);
7704 /* Save the binding label to the symbol. If sym is null, we're
7705 probably matching the typespec attributes of a declaration and
7706 haven't gotten the name yet, and therefore, no symbol yet. */
7710 sym
->binding_label
= binding_label
;
7712 curr_binding_label
= binding_label
;
7714 else if (allow_binding_name
)
7716 /* No binding label, but if symbol isn't null, we
7717 can set the label for it here.
7718 If name="" or allow_binding_name is false, no C binding name is
7720 if (sym
!= NULL
&& sym
->name
!= NULL
&& has_name_equals
== 0)
7721 sym
->binding_label
= IDENTIFIER_POINTER (get_identifier (sym
->name
));
7724 if (has_name_equals
&& gfc_current_state () == COMP_INTERFACE
7725 && current_interface
.type
== INTERFACE_ABSTRACT
)
7727 gfc_error ("NAME not allowed on BIND(C) for ABSTRACT INTERFACE at %C");
7735 /* Return nonzero if we're currently compiling a contained procedure. */
7738 contained_procedure (void)
7740 gfc_state_data
*s
= gfc_state_stack
;
7742 if ((s
->state
== COMP_SUBROUTINE
|| s
->state
== COMP_FUNCTION
)
7743 && s
->previous
!= NULL
&& s
->previous
->state
== COMP_CONTAINS
)
7749 /* Set the kind of each enumerator. The kind is selected such that it is
7750 interoperable with the corresponding C enumeration type, making
7751 sure that -fshort-enums is honored. */
7756 enumerator_history
*current_history
= NULL
;
7760 if (max_enum
== NULL
|| enum_history
== NULL
)
7763 if (!flag_short_enums
)
7769 kind
= gfc_integer_kinds
[i
++].kind
;
7771 while (kind
< gfc_c_int_kind
7772 && gfc_check_integer_range (max_enum
->initializer
->value
.integer
,
7775 current_history
= enum_history
;
7776 while (current_history
!= NULL
)
7778 current_history
->sym
->ts
.kind
= kind
;
7779 current_history
= current_history
->next
;
7784 /* Match any of the various end-block statements. Returns the type of
7785 END to the caller. The END INTERFACE, END IF, END DO, END SELECT
7786 and END BLOCK statements cannot be replaced by a single END statement. */
7789 gfc_match_end (gfc_statement
*st
)
7791 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7792 gfc_compile_state state
;
7794 const char *block_name
;
7798 gfc_namespace
*parent_ns
, *ns
, *prev_ns
;
7799 gfc_namespace
**nsp
;
7800 bool abreviated_modproc_decl
= false;
7801 bool got_matching_end
= false;
7803 old_loc
= gfc_current_locus
;
7804 if (gfc_match ("end") != MATCH_YES
)
7807 state
= gfc_current_state ();
7808 block_name
= gfc_current_block () == NULL
7809 ? NULL
: gfc_current_block ()->name
;
7813 case COMP_ASSOCIATE
:
7815 if (!strncmp (block_name
, "block@", strlen("block@")))
7820 case COMP_DERIVED_CONTAINS
:
7821 state
= gfc_state_stack
->previous
->state
;
7822 block_name
= gfc_state_stack
->previous
->sym
== NULL
7823 ? NULL
: gfc_state_stack
->previous
->sym
->name
;
7824 abreviated_modproc_decl
= gfc_state_stack
->previous
->sym
7825 && gfc_state_stack
->previous
->sym
->abr_modproc_decl
;
7832 if (!abreviated_modproc_decl
)
7833 abreviated_modproc_decl
= gfc_current_block ()
7834 && gfc_current_block ()->abr_modproc_decl
;
7840 *st
= ST_END_PROGRAM
;
7841 target
= " program";
7845 case COMP_SUBROUTINE
:
7846 *st
= ST_END_SUBROUTINE
;
7847 if (!abreviated_modproc_decl
)
7848 target
= " subroutine";
7850 target
= " procedure";
7851 eos_ok
= !contained_procedure ();
7855 *st
= ST_END_FUNCTION
;
7856 if (!abreviated_modproc_decl
)
7857 target
= " function";
7859 target
= " procedure";
7860 eos_ok
= !contained_procedure ();
7863 case COMP_BLOCK_DATA
:
7864 *st
= ST_END_BLOCK_DATA
;
7865 target
= " block data";
7870 *st
= ST_END_MODULE
;
7875 case COMP_SUBMODULE
:
7876 *st
= ST_END_SUBMODULE
;
7877 target
= " submodule";
7881 case COMP_INTERFACE
:
7882 *st
= ST_END_INTERFACE
;
7883 target
= " interface";
7899 case COMP_STRUCTURE
:
7900 *st
= ST_END_STRUCTURE
;
7901 target
= " structure";
7906 case COMP_DERIVED_CONTAINS
:
7912 case COMP_ASSOCIATE
:
7913 *st
= ST_END_ASSOCIATE
;
7914 target
= " associate";
7931 case COMP_DO_CONCURRENT
:
7938 *st
= ST_END_CRITICAL
;
7939 target
= " critical";
7944 case COMP_SELECT_TYPE
:
7945 *st
= ST_END_SELECT
;
7951 *st
= ST_END_FORALL
;
7966 last_initializer
= NULL
;
7968 gfc_free_enum_history ();
7972 gfc_error ("Unexpected END statement at %C");
7976 old_loc
= gfc_current_locus
;
7977 if (gfc_match_eos () == MATCH_YES
)
7979 if (!eos_ok
&& (*st
== ST_END_SUBROUTINE
|| *st
== ST_END_FUNCTION
))
7981 if (!gfc_notify_std (GFC_STD_F2008
, "END statement "
7982 "instead of %s statement at %L",
7983 abreviated_modproc_decl
? "END PROCEDURE"
7984 : gfc_ascii_statement(*st
), &old_loc
))
7989 /* We would have required END [something]. */
7990 gfc_error ("%s statement expected at %L",
7991 gfc_ascii_statement (*st
), &old_loc
);
7998 /* Verify that we've got the sort of end-block that we're expecting. */
7999 if (gfc_match (target
) != MATCH_YES
)
8001 gfc_error ("Expecting %s statement at %L", abreviated_modproc_decl
8002 ? "END PROCEDURE" : gfc_ascii_statement(*st
), &old_loc
);
8006 got_matching_end
= true;
8008 old_loc
= gfc_current_locus
;
8009 /* If we're at the end, make sure a block name wasn't required. */
8010 if (gfc_match_eos () == MATCH_YES
)
8013 if (*st
!= ST_ENDDO
&& *st
!= ST_ENDIF
&& *st
!= ST_END_SELECT
8014 && *st
!= ST_END_FORALL
&& *st
!= ST_END_WHERE
&& *st
!= ST_END_BLOCK
8015 && *st
!= ST_END_ASSOCIATE
&& *st
!= ST_END_CRITICAL
)
8021 gfc_error ("Expected block name of %qs in %s statement at %L",
8022 block_name
, gfc_ascii_statement (*st
), &old_loc
);
8027 /* END INTERFACE has a special handler for its several possible endings. */
8028 if (*st
== ST_END_INTERFACE
)
8029 return gfc_match_end_interface ();
8031 /* We haven't hit the end of statement, so what is left must be an
8033 m
= gfc_match_space ();
8035 m
= gfc_match_name (name
);
8038 gfc_error ("Expected terminating name at %C");
8042 if (block_name
== NULL
)
8045 /* We have to pick out the declared submodule name from the composite
8046 required by F2008:11.2.3 para 2, which ends in the declared name. */
8047 if (state
== COMP_SUBMODULE
)
8048 block_name
= strchr (block_name
, '.') + 1;
8050 if (strcmp (name
, block_name
) != 0 && strcmp (block_name
, "ppr@") != 0)
8052 gfc_error ("Expected label %qs for %s statement at %C", block_name
,
8053 gfc_ascii_statement (*st
));
8056 /* Procedure pointer as function result. */
8057 else if (strcmp (block_name
, "ppr@") == 0
8058 && strcmp (name
, gfc_current_block ()->ns
->proc_name
->name
) != 0)
8060 gfc_error ("Expected label %qs for %s statement at %C",
8061 gfc_current_block ()->ns
->proc_name
->name
,
8062 gfc_ascii_statement (*st
));
8066 if (gfc_match_eos () == MATCH_YES
)
8070 gfc_syntax_error (*st
);
8073 gfc_current_locus
= old_loc
;
8075 /* If we are missing an END BLOCK, we created a half-ready namespace.
8076 Remove it from the parent namespace's sibling list. */
8078 while (state
== COMP_BLOCK
&& !got_matching_end
)
8080 parent_ns
= gfc_current_ns
->parent
;
8082 nsp
= &(gfc_state_stack
->previous
->tail
->ext
.block
.ns
);
8088 if (ns
== gfc_current_ns
)
8090 if (prev_ns
== NULL
)
8093 prev_ns
->sibling
= ns
->sibling
;
8099 gfc_free_namespace (gfc_current_ns
);
8100 gfc_current_ns
= parent_ns
;
8101 gfc_state_stack
= gfc_state_stack
->previous
;
8102 state
= gfc_current_state ();
8110 /***************** Attribute declaration statements ****************/
8112 /* Set the attribute of a single variable. */
8117 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8120 /* Workaround -Wmaybe-uninitialized false positive during
8121 profiledbootstrap by initializing them. */
8122 gfc_symbol
*sym
= NULL
;
8128 m
= gfc_match_name (name
);
8132 if (find_special (name
, &sym
, false))
8135 if (!check_function_name (name
))
8141 var_locus
= gfc_current_locus
;
8143 /* Deal with possible array specification for certain attributes. */
8144 if (current_attr
.dimension
8145 || current_attr
.codimension
8146 || current_attr
.allocatable
8147 || current_attr
.pointer
8148 || current_attr
.target
)
8150 m
= gfc_match_array_spec (&as
, !current_attr
.codimension
,
8151 !current_attr
.dimension
8152 && !current_attr
.pointer
8153 && !current_attr
.target
);
8154 if (m
== MATCH_ERROR
)
8157 if (current_attr
.dimension
&& m
== MATCH_NO
)
8159 gfc_error ("Missing array specification at %L in DIMENSION "
8160 "statement", &var_locus
);
8165 if (current_attr
.dimension
&& sym
->value
)
8167 gfc_error ("Dimensions specified for %s at %L after its "
8168 "initialization", sym
->name
, &var_locus
);
8173 if (current_attr
.codimension
&& m
== MATCH_NO
)
8175 gfc_error ("Missing array specification at %L in CODIMENSION "
8176 "statement", &var_locus
);
8181 if ((current_attr
.allocatable
|| current_attr
.pointer
)
8182 && (m
== MATCH_YES
) && (as
->type
!= AS_DEFERRED
))
8184 gfc_error ("Array specification must be deferred at %L", &var_locus
);
8190 /* Update symbol table. DIMENSION attribute is set in
8191 gfc_set_array_spec(). For CLASS variables, this must be applied
8192 to the first component, or '_data' field. */
8193 if (sym
->ts
.type
== BT_CLASS
&& sym
->ts
.u
.derived
->attr
.is_class
)
8195 if (!gfc_copy_attr (&CLASS_DATA(sym
)->attr
, ¤t_attr
, &var_locus
))
8203 if (current_attr
.dimension
== 0 && current_attr
.codimension
== 0
8204 && !gfc_copy_attr (&sym
->attr
, ¤t_attr
, &var_locus
))
8211 if (sym
->ts
.type
== BT_CLASS
8212 && !gfc_build_class_symbol (&sym
->ts
, &sym
->attr
, &sym
->as
))
8218 if (!gfc_set_array_spec (sym
, as
, &var_locus
))
8224 if (sym
->attr
.cray_pointee
&& sym
->as
!= NULL
)
8226 /* Fix the array spec. */
8227 m
= gfc_mod_pointee_as (sym
->as
);
8228 if (m
== MATCH_ERROR
)
8232 if (!gfc_add_attribute (&sym
->attr
, &var_locus
))
8238 if ((current_attr
.external
|| current_attr
.intrinsic
)
8239 && sym
->attr
.flavor
!= FL_PROCEDURE
8240 && !gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, NULL
))
8246 add_hidden_procptr_result (sym
);
8251 gfc_free_array_spec (as
);
8256 /* Generic attribute declaration subroutine. Used for attributes that
8257 just have a list of names. */
8264 /* Gobble the optional double colon, by simply ignoring the result
8274 if (gfc_match_eos () == MATCH_YES
)
8280 if (gfc_match_char (',') != MATCH_YES
)
8282 gfc_error ("Unexpected character in variable list at %C");
8292 /* This routine matches Cray Pointer declarations of the form:
8293 pointer ( <pointer>, <pointee> )
8295 pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...
8296 The pointer, if already declared, should be an integer. Otherwise, we
8297 set it as BT_INTEGER with kind gfc_index_integer_kind. The pointee may
8298 be either a scalar, or an array declaration. No space is allocated for
8299 the pointee. For the statement
8300 pointer (ipt, ar(10))
8301 any subsequent uses of ar will be translated (in C-notation) as
8302 ar(i) => ((<type> *) ipt)(i)
8303 After gimplification, pointee variable will disappear in the code. */
8306 cray_pointer_decl (void)
8309 gfc_array_spec
*as
= NULL
;
8310 gfc_symbol
*cptr
; /* Pointer symbol. */
8311 gfc_symbol
*cpte
; /* Pointee symbol. */
8317 if (gfc_match_char ('(') != MATCH_YES
)
8319 gfc_error ("Expected %<(%> at %C");
8323 /* Match pointer. */
8324 var_locus
= gfc_current_locus
;
8325 gfc_clear_attr (¤t_attr
);
8326 gfc_add_cray_pointer (¤t_attr
, &var_locus
);
8327 current_ts
.type
= BT_INTEGER
;
8328 current_ts
.kind
= gfc_index_integer_kind
;
8330 m
= gfc_match_symbol (&cptr
, 0);
8333 gfc_error ("Expected variable name at %C");
8337 if (!gfc_add_cray_pointer (&cptr
->attr
, &var_locus
))
8340 gfc_set_sym_referenced (cptr
);
8342 if (cptr
->ts
.type
== BT_UNKNOWN
) /* Override the type, if necessary. */
8344 cptr
->ts
.type
= BT_INTEGER
;
8345 cptr
->ts
.kind
= gfc_index_integer_kind
;
8347 else if (cptr
->ts
.type
!= BT_INTEGER
)
8349 gfc_error ("Cray pointer at %C must be an integer");
8352 else if (cptr
->ts
.kind
< gfc_index_integer_kind
)
8353 gfc_warning (0, "Cray pointer at %C has %d bytes of precision;"
8354 " memory addresses require %d bytes",
8355 cptr
->ts
.kind
, gfc_index_integer_kind
);
8357 if (gfc_match_char (',') != MATCH_YES
)
8359 gfc_error ("Expected \",\" at %C");
8363 /* Match Pointee. */
8364 var_locus
= gfc_current_locus
;
8365 gfc_clear_attr (¤t_attr
);
8366 gfc_add_cray_pointee (¤t_attr
, &var_locus
);
8367 current_ts
.type
= BT_UNKNOWN
;
8368 current_ts
.kind
= 0;
8370 m
= gfc_match_symbol (&cpte
, 0);
8373 gfc_error ("Expected variable name at %C");
8377 /* Check for an optional array spec. */
8378 m
= gfc_match_array_spec (&as
, true, false);
8379 if (m
== MATCH_ERROR
)
8381 gfc_free_array_spec (as
);
8384 else if (m
== MATCH_NO
)
8386 gfc_free_array_spec (as
);
8390 if (!gfc_add_cray_pointee (&cpte
->attr
, &var_locus
))
8393 gfc_set_sym_referenced (cpte
);
8395 if (cpte
->as
== NULL
)
8397 if (!gfc_set_array_spec (cpte
, as
, &var_locus
))
8398 gfc_internal_error ("Couldn't set Cray pointee array spec.");
8400 else if (as
!= NULL
)
8402 gfc_error ("Duplicate array spec for Cray pointee at %C");
8403 gfc_free_array_spec (as
);
8409 if (cpte
->as
!= NULL
)
8411 /* Fix array spec. */
8412 m
= gfc_mod_pointee_as (cpte
->as
);
8413 if (m
== MATCH_ERROR
)
8417 /* Point the Pointee at the Pointer. */
8418 cpte
->cp_pointer
= cptr
;
8420 if (gfc_match_char (')') != MATCH_YES
)
8422 gfc_error ("Expected \")\" at %C");
8425 m
= gfc_match_char (',');
8427 done
= true; /* Stop searching for more declarations. */
8431 if (m
== MATCH_ERROR
/* Failed when trying to find ',' above. */
8432 || gfc_match_eos () != MATCH_YES
)
8434 gfc_error ("Expected %<,%> or end of statement at %C");
8442 gfc_match_external (void)
8445 gfc_clear_attr (¤t_attr
);
8446 current_attr
.external
= 1;
8448 return attr_decl ();
8453 gfc_match_intent (void)
8457 /* This is not allowed within a BLOCK construct! */
8458 if (gfc_current_state () == COMP_BLOCK
)
8460 gfc_error ("INTENT is not allowed inside of BLOCK at %C");
8464 intent
= match_intent_spec ();
8465 if (intent
== INTENT_UNKNOWN
)
8468 gfc_clear_attr (¤t_attr
);
8469 current_attr
.intent
= intent
;
8471 return attr_decl ();
8476 gfc_match_intrinsic (void)
8479 gfc_clear_attr (¤t_attr
);
8480 current_attr
.intrinsic
= 1;
8482 return attr_decl ();
8487 gfc_match_optional (void)
8489 /* This is not allowed within a BLOCK construct! */
8490 if (gfc_current_state () == COMP_BLOCK
)
8492 gfc_error ("OPTIONAL is not allowed inside of BLOCK at %C");
8496 gfc_clear_attr (¤t_attr
);
8497 current_attr
.optional
= 1;
8499 return attr_decl ();
8504 gfc_match_pointer (void)
8506 gfc_gobble_whitespace ();
8507 if (gfc_peek_ascii_char () == '(')
8509 if (!flag_cray_pointer
)
8511 gfc_error ("Cray pointer declaration at %C requires -fcray-pointer "
8515 return cray_pointer_decl ();
8519 gfc_clear_attr (¤t_attr
);
8520 current_attr
.pointer
= 1;
8522 return attr_decl ();
8528 gfc_match_allocatable (void)
8530 gfc_clear_attr (¤t_attr
);
8531 current_attr
.allocatable
= 1;
8533 return attr_decl ();
8538 gfc_match_codimension (void)
8540 gfc_clear_attr (¤t_attr
);
8541 current_attr
.codimension
= 1;
8543 return attr_decl ();
8548 gfc_match_contiguous (void)
8550 if (!gfc_notify_std (GFC_STD_F2008
, "CONTIGUOUS statement at %C"))
8553 gfc_clear_attr (¤t_attr
);
8554 current_attr
.contiguous
= 1;
8556 return attr_decl ();
8561 gfc_match_dimension (void)
8563 gfc_clear_attr (¤t_attr
);
8564 current_attr
.dimension
= 1;
8566 return attr_decl ();
8571 gfc_match_target (void)
8573 gfc_clear_attr (¤t_attr
);
8574 current_attr
.target
= 1;
8576 return attr_decl ();
8580 /* Match the list of entities being specified in a PUBLIC or PRIVATE
8584 access_attr_decl (gfc_statement st
)
8586 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8587 interface_type type
;
8589 gfc_symbol
*sym
, *dt_sym
;
8590 gfc_intrinsic_op op
;
8593 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
8598 m
= gfc_match_generic_spec (&type
, name
, &op
);
8601 if (m
== MATCH_ERROR
)
8606 case INTERFACE_NAMELESS
:
8607 case INTERFACE_ABSTRACT
:
8610 case INTERFACE_GENERIC
:
8611 case INTERFACE_DTIO
:
8613 if (gfc_get_symbol (name
, NULL
, &sym
))
8616 if (type
== INTERFACE_DTIO
8617 && gfc_current_ns
->proc_name
8618 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
8619 && sym
->attr
.flavor
== FL_UNKNOWN
)
8620 sym
->attr
.flavor
= FL_PROCEDURE
;
8622 if (!gfc_add_access (&sym
->attr
,
8624 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
,
8628 if (sym
->attr
.generic
&& (dt_sym
= gfc_find_dt_in_generic (sym
))
8629 && !gfc_add_access (&dt_sym
->attr
,
8631 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
,
8637 case INTERFACE_INTRINSIC_OP
:
8638 if (gfc_current_ns
->operator_access
[op
] == ACCESS_UNKNOWN
)
8640 gfc_intrinsic_op other_op
;
8642 gfc_current_ns
->operator_access
[op
] =
8643 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
8645 /* Handle the case if there is another op with the same
8646 function, for INTRINSIC_EQ vs. INTRINSIC_EQ_OS and so on. */
8647 other_op
= gfc_equivalent_op (op
);
8649 if (other_op
!= INTRINSIC_NONE
)
8650 gfc_current_ns
->operator_access
[other_op
] =
8651 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
8656 gfc_error ("Access specification of the %s operator at %C has "
8657 "already been specified", gfc_op2string (op
));
8663 case INTERFACE_USER_OP
:
8664 uop
= gfc_get_uop (name
);
8666 if (uop
->access
== ACCESS_UNKNOWN
)
8668 uop
->access
= (st
== ST_PUBLIC
)
8669 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
8673 gfc_error ("Access specification of the .%s. operator at %C "
8674 "has already been specified", sym
->name
);
8681 if (gfc_match_char (',') == MATCH_NO
)
8685 if (gfc_match_eos () != MATCH_YES
)
8690 gfc_syntax_error (st
);
8698 gfc_match_protected (void)
8703 if (!gfc_current_ns
->proc_name
8704 || gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
8706 gfc_error ("PROTECTED at %C only allowed in specification "
8707 "part of a module");
8712 if (!gfc_notify_std (GFC_STD_F2003
, "PROTECTED statement at %C"))
8715 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
8720 if (gfc_match_eos () == MATCH_YES
)
8725 m
= gfc_match_symbol (&sym
, 0);
8729 if (!gfc_add_protected (&sym
->attr
, sym
->name
, &gfc_current_locus
))
8741 if (gfc_match_eos () == MATCH_YES
)
8743 if (gfc_match_char (',') != MATCH_YES
)
8750 gfc_error ("Syntax error in PROTECTED statement at %C");
8755 /* The PRIVATE statement is a bit weird in that it can be an attribute
8756 declaration, but also works as a standalone statement inside of a
8757 type declaration or a module. */
8760 gfc_match_private (gfc_statement
*st
)
8763 if (gfc_match ("private") != MATCH_YES
)
8766 if (gfc_current_state () != COMP_MODULE
8767 && !(gfc_current_state () == COMP_DERIVED
8768 && gfc_state_stack
->previous
8769 && gfc_state_stack
->previous
->state
== COMP_MODULE
)
8770 && !(gfc_current_state () == COMP_DERIVED_CONTAINS
8771 && gfc_state_stack
->previous
&& gfc_state_stack
->previous
->previous
8772 && gfc_state_stack
->previous
->previous
->state
== COMP_MODULE
))
8774 gfc_error ("PRIVATE statement at %C is only allowed in the "
8775 "specification part of a module");
8779 if (gfc_current_state () == COMP_DERIVED
)
8781 if (gfc_match_eos () == MATCH_YES
)
8787 gfc_syntax_error (ST_PRIVATE
);
8791 if (gfc_match_eos () == MATCH_YES
)
8798 return access_attr_decl (ST_PRIVATE
);
8803 gfc_match_public (gfc_statement
*st
)
8806 if (gfc_match ("public") != MATCH_YES
)
8809 if (gfc_current_state () != COMP_MODULE
)
8811 gfc_error ("PUBLIC statement at %C is only allowed in the "
8812 "specification part of a module");
8816 if (gfc_match_eos () == MATCH_YES
)
8823 return access_attr_decl (ST_PUBLIC
);
8827 /* Workhorse for gfc_match_parameter. */
8837 m
= gfc_match_symbol (&sym
, 0);
8839 gfc_error ("Expected variable name at %C in PARAMETER statement");
8844 if (gfc_match_char ('=') == MATCH_NO
)
8846 gfc_error ("Expected = sign in PARAMETER statement at %C");
8850 m
= gfc_match_init_expr (&init
);
8852 gfc_error ("Expected expression at %C in PARAMETER statement");
8856 if (sym
->ts
.type
== BT_UNKNOWN
8857 && !gfc_set_default_type (sym
, 1, NULL
))
8863 if (!gfc_check_assign_symbol (sym
, NULL
, init
)
8864 || !gfc_add_flavor (&sym
->attr
, FL_PARAMETER
, sym
->name
, NULL
))
8872 gfc_error ("Initializing already initialized variable at %C");
8877 t
= add_init_expr_to_sym (sym
->name
, &init
, &gfc_current_locus
);
8878 return (t
) ? MATCH_YES
: MATCH_ERROR
;
8881 gfc_free_expr (init
);
8886 /* Match a parameter statement, with the weird syntax that these have. */
8889 gfc_match_parameter (void)
8891 const char *term
= " )%t";
8894 if (gfc_match_char ('(') == MATCH_NO
)
8896 /* With legacy PARAMETER statements, don't expect a terminating ')'. */
8897 if (!gfc_notify_std (GFC_STD_LEGACY
, "PARAMETER without '()' at %C"))
8908 if (gfc_match (term
) == MATCH_YES
)
8911 if (gfc_match_char (',') != MATCH_YES
)
8913 gfc_error ("Unexpected characters in PARAMETER statement at %C");
8924 gfc_match_automatic (void)
8928 bool seen_symbol
= false;
8930 if (!flag_dec_static
)
8932 gfc_error ("%s at %C is a DEC extension, enable with "
8943 m
= gfc_match_symbol (&sym
, 0);
8953 if (!gfc_add_automatic (&sym
->attr
, sym
->name
, &gfc_current_locus
))
8959 if (gfc_match_eos () == MATCH_YES
)
8961 if (gfc_match_char (',') != MATCH_YES
)
8967 gfc_error ("Expected entity-list in AUTOMATIC statement at %C");
8974 gfc_error ("Syntax error in AUTOMATIC statement at %C");
8980 gfc_match_static (void)
8984 bool seen_symbol
= false;
8986 if (!flag_dec_static
)
8988 gfc_error ("%s at %C is a DEC extension, enable with "
8998 m
= gfc_match_symbol (&sym
, 0);
9008 if (!gfc_add_save (&sym
->attr
, SAVE_EXPLICIT
, sym
->name
,
9009 &gfc_current_locus
))
9015 if (gfc_match_eos () == MATCH_YES
)
9017 if (gfc_match_char (',') != MATCH_YES
)
9023 gfc_error ("Expected entity-list in STATIC statement at %C");
9030 gfc_error ("Syntax error in STATIC statement at %C");
9035 /* Save statements have a special syntax. */
9038 gfc_match_save (void)
9040 char n
[GFC_MAX_SYMBOL_LEN
+1];
9045 if (gfc_match_eos () == MATCH_YES
)
9047 if (gfc_current_ns
->seen_save
)
9049 if (!gfc_notify_std (GFC_STD_LEGACY
, "Blanket SAVE statement at %C "
9050 "follows previous SAVE statement"))
9054 gfc_current_ns
->save_all
= gfc_current_ns
->seen_save
= 1;
9058 if (gfc_current_ns
->save_all
)
9060 if (!gfc_notify_std (GFC_STD_LEGACY
, "SAVE statement at %C follows "
9061 "blanket SAVE statement"))
9069 m
= gfc_match_symbol (&sym
, 0);
9073 if (!gfc_add_save (&sym
->attr
, SAVE_EXPLICIT
, sym
->name
,
9074 &gfc_current_locus
))
9085 m
= gfc_match (" / %n /", &n
);
9086 if (m
== MATCH_ERROR
)
9091 c
= gfc_get_common (n
, 0);
9094 gfc_current_ns
->seen_save
= 1;
9097 if (gfc_match_eos () == MATCH_YES
)
9099 if (gfc_match_char (',') != MATCH_YES
)
9106 gfc_error ("Syntax error in SAVE statement at %C");
9112 gfc_match_value (void)
9117 /* This is not allowed within a BLOCK construct! */
9118 if (gfc_current_state () == COMP_BLOCK
)
9120 gfc_error ("VALUE is not allowed inside of BLOCK at %C");
9124 if (!gfc_notify_std (GFC_STD_F2003
, "VALUE statement at %C"))
9127 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
9132 if (gfc_match_eos () == MATCH_YES
)
9137 m
= gfc_match_symbol (&sym
, 0);
9141 if (!gfc_add_value (&sym
->attr
, sym
->name
, &gfc_current_locus
))
9153 if (gfc_match_eos () == MATCH_YES
)
9155 if (gfc_match_char (',') != MATCH_YES
)
9162 gfc_error ("Syntax error in VALUE statement at %C");
9168 gfc_match_volatile (void)
9174 if (!gfc_notify_std (GFC_STD_F2003
, "VOLATILE statement at %C"))
9177 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
9182 if (gfc_match_eos () == MATCH_YES
)
9187 /* VOLATILE is special because it can be added to host-associated
9188 symbols locally. Except for coarrays. */
9189 m
= gfc_match_symbol (&sym
, 1);
9193 name
= XCNEWVAR (char, strlen (sym
->name
) + 1);
9194 strcpy (name
, sym
->name
);
9195 if (!check_function_name (name
))
9197 /* F2008, C560+C561. VOLATILE for host-/use-associated variable or
9198 for variable in a BLOCK which is defined outside of the BLOCK. */
9199 if (sym
->ns
!= gfc_current_ns
&& sym
->attr
.codimension
)
9201 gfc_error ("Specifying VOLATILE for coarray variable %qs at "
9202 "%C, which is use-/host-associated", sym
->name
);
9205 if (!gfc_add_volatile (&sym
->attr
, sym
->name
, &gfc_current_locus
))
9217 if (gfc_match_eos () == MATCH_YES
)
9219 if (gfc_match_char (',') != MATCH_YES
)
9226 gfc_error ("Syntax error in VOLATILE statement at %C");
9232 gfc_match_asynchronous (void)
9238 if (!gfc_notify_std (GFC_STD_F2003
, "ASYNCHRONOUS statement at %C"))
9241 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
9246 if (gfc_match_eos () == MATCH_YES
)
9251 /* ASYNCHRONOUS is special because it can be added to host-associated
9253 m
= gfc_match_symbol (&sym
, 1);
9257 name
= XCNEWVAR (char, strlen (sym
->name
) + 1);
9258 strcpy (name
, sym
->name
);
9259 if (!check_function_name (name
))
9261 if (!gfc_add_asynchronous (&sym
->attr
, sym
->name
, &gfc_current_locus
))
9273 if (gfc_match_eos () == MATCH_YES
)
9275 if (gfc_match_char (',') != MATCH_YES
)
9282 gfc_error ("Syntax error in ASYNCHRONOUS statement at %C");
9287 /* Match a module procedure statement in a submodule. */
9290 gfc_match_submod_proc (void)
9292 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9293 gfc_symbol
*sym
, *fsym
;
9295 gfc_formal_arglist
*formal
, *head
, *tail
;
9297 if (gfc_current_state () != COMP_CONTAINS
9298 || !(gfc_state_stack
->previous
9299 && (gfc_state_stack
->previous
->state
== COMP_SUBMODULE
9300 || gfc_state_stack
->previous
->state
== COMP_MODULE
)))
9303 m
= gfc_match (" module% procedure% %n", name
);
9307 if (!gfc_notify_std (GFC_STD_F2008
, "MODULE PROCEDURE declaration "
9311 if (get_proc_name (name
, &sym
, false))
9314 /* Make sure that the result field is appropriately filled, even though
9315 the result symbol will be replaced later on. */
9316 if (sym
->tlink
&& sym
->tlink
->attr
.function
)
9318 if (sym
->tlink
->result
9319 && sym
->tlink
->result
!= sym
->tlink
)
9320 sym
->result
= sym
->tlink
->result
;
9325 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
9326 the symbol existed before. */
9327 sym
->declared_at
= gfc_current_locus
;
9329 if (!sym
->attr
.module_procedure
)
9332 /* Signal match_end to expect "end procedure". */
9333 sym
->abr_modproc_decl
= 1;
9335 /* Change from IFSRC_IFBODY coming from the interface declaration. */
9336 sym
->attr
.if_source
= IFSRC_DECL
;
9338 gfc_new_block
= sym
;
9340 /* Make a new formal arglist with the symbols in the procedure
9343 for (formal
= sym
->formal
; formal
&& formal
->sym
; formal
= formal
->next
)
9345 if (formal
== sym
->formal
)
9346 head
= tail
= gfc_get_formal_arglist ();
9349 tail
->next
= gfc_get_formal_arglist ();
9353 if (gfc_copy_dummy_sym (&fsym
, formal
->sym
, 0))
9357 gfc_set_sym_referenced (fsym
);
9360 /* The dummy symbols get cleaned up, when the formal_namespace of the
9361 interface declaration is cleared. This allows us to add the
9362 explicit interface as is done for other type of procedure. */
9363 if (!gfc_add_explicit_interface (sym
, IFSRC_DECL
, head
,
9364 &gfc_current_locus
))
9367 if (gfc_match_eos () != MATCH_YES
)
9369 gfc_syntax_error (ST_MODULE_PROC
);
9376 gfc_free_formal_arglist (head
);
9381 /* Match a module procedure statement. Note that we have to modify
9382 symbols in the parent's namespace because the current one was there
9383 to receive symbols that are in an interface's formal argument list. */
9386 gfc_match_modproc (void)
9388 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9392 gfc_namespace
*module_ns
;
9393 gfc_interface
*old_interface_head
, *interface
;
9395 if (gfc_state_stack
->state
!= COMP_INTERFACE
9396 || gfc_state_stack
->previous
== NULL
9397 || current_interface
.type
== INTERFACE_NAMELESS
9398 || current_interface
.type
== INTERFACE_ABSTRACT
)
9400 gfc_error ("MODULE PROCEDURE at %C must be in a generic module "
9405 module_ns
= gfc_current_ns
->parent
;
9406 for (; module_ns
; module_ns
= module_ns
->parent
)
9407 if (module_ns
->proc_name
->attr
.flavor
== FL_MODULE
9408 || module_ns
->proc_name
->attr
.flavor
== FL_PROGRAM
9409 || (module_ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
9410 && !module_ns
->proc_name
->attr
.contained
))
9413 if (module_ns
== NULL
)
9416 /* Store the current state of the interface. We will need it if we
9417 end up with a syntax error and need to recover. */
9418 old_interface_head
= gfc_current_interface_head ();
9420 /* Check if the F2008 optional double colon appears. */
9421 gfc_gobble_whitespace ();
9422 old_locus
= gfc_current_locus
;
9423 if (gfc_match ("::") == MATCH_YES
)
9425 if (!gfc_notify_std (GFC_STD_F2008
, "double colon in "
9426 "MODULE PROCEDURE statement at %L", &old_locus
))
9430 gfc_current_locus
= old_locus
;
9435 old_locus
= gfc_current_locus
;
9437 m
= gfc_match_name (name
);
9443 /* Check for syntax error before starting to add symbols to the
9444 current namespace. */
9445 if (gfc_match_eos () == MATCH_YES
)
9448 if (!last
&& gfc_match_char (',') != MATCH_YES
)
9451 /* Now we're sure the syntax is valid, we process this item
9453 if (gfc_get_symbol (name
, module_ns
, &sym
))
9456 if (sym
->attr
.intrinsic
)
9458 gfc_error ("Intrinsic procedure at %L cannot be a MODULE "
9459 "PROCEDURE", &old_locus
);
9463 if (sym
->attr
.proc
!= PROC_MODULE
9464 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
9467 if (!gfc_add_interface (sym
))
9470 sym
->attr
.mod_proc
= 1;
9471 sym
->declared_at
= old_locus
;
9480 /* Restore the previous state of the interface. */
9481 interface
= gfc_current_interface_head ();
9482 gfc_set_current_interface_head (old_interface_head
);
9484 /* Free the new interfaces. */
9485 while (interface
!= old_interface_head
)
9487 gfc_interface
*i
= interface
->next
;
9492 /* And issue a syntax error. */
9493 gfc_syntax_error (ST_MODULE_PROC
);
9498 /* Check a derived type that is being extended. */
9501 check_extended_derived_type (char *name
)
9503 gfc_symbol
*extended
;
9505 if (gfc_find_symbol (name
, gfc_current_ns
, 1, &extended
))
9507 gfc_error ("Ambiguous symbol in TYPE definition at %C");
9511 extended
= gfc_find_dt_in_generic (extended
);
9516 gfc_error ("Symbol %qs at %C has not been previously defined", name
);
9520 if (extended
->attr
.flavor
!= FL_DERIVED
)
9522 gfc_error ("%qs in EXTENDS expression at %C is not a "
9523 "derived type", name
);
9527 if (extended
->attr
.is_bind_c
)
9529 gfc_error ("%qs cannot be extended at %C because it "
9530 "is BIND(C)", extended
->name
);
9534 if (extended
->attr
.sequence
)
9536 gfc_error ("%qs cannot be extended at %C because it "
9537 "is a SEQUENCE type", extended
->name
);
9545 /* Match the optional attribute specifiers for a type declaration.
9546 Return MATCH_ERROR if an error is encountered in one of the handled
9547 attributes (public, private, bind(c)), MATCH_NO if what's found is
9548 not a handled attribute, and MATCH_YES otherwise. TODO: More error
9549 checking on attribute conflicts needs to be done. */
9552 gfc_get_type_attr_spec (symbol_attribute
*attr
, char *name
)
9554 /* See if the derived type is marked as private. */
9555 if (gfc_match (" , private") == MATCH_YES
)
9557 if (gfc_current_state () != COMP_MODULE
)
9559 gfc_error ("Derived type at %C can only be PRIVATE in the "
9560 "specification part of a module");
9564 if (!gfc_add_access (attr
, ACCESS_PRIVATE
, NULL
, NULL
))
9567 else if (gfc_match (" , public") == MATCH_YES
)
9569 if (gfc_current_state () != COMP_MODULE
)
9571 gfc_error ("Derived type at %C can only be PUBLIC in the "
9572 "specification part of a module");
9576 if (!gfc_add_access (attr
, ACCESS_PUBLIC
, NULL
, NULL
))
9579 else if (gfc_match (" , bind ( c )") == MATCH_YES
)
9581 /* If the type is defined to be bind(c) it then needs to make
9582 sure that all fields are interoperable. This will
9583 need to be a semantic check on the finished derived type.
9584 See 15.2.3 (lines 9-12) of F2003 draft. */
9585 if (!gfc_add_is_bind_c (attr
, NULL
, &gfc_current_locus
, 0))
9588 /* TODO: attr conflicts need to be checked, probably in symbol.c. */
9590 else if (gfc_match (" , abstract") == MATCH_YES
)
9592 if (!gfc_notify_std (GFC_STD_F2003
, "ABSTRACT type at %C"))
9595 if (!gfc_add_abstract (attr
, &gfc_current_locus
))
9598 else if (name
&& gfc_match (" , extends ( %n )", name
) == MATCH_YES
)
9600 if (!gfc_add_extension (attr
, &gfc_current_locus
))
9606 /* If we get here, something matched. */
9611 /* Common function for type declaration blocks similar to derived types, such
9612 as STRUCTURES and MAPs. Unlike derived types, a structure type
9613 does NOT have a generic symbol matching the name given by the user.
9614 STRUCTUREs can share names with variables and PARAMETERs so we must allow
9615 for the creation of an independent symbol.
9616 Other parameters are a message to prefix errors with, the name of the new
9617 type to be created, and the flavor to add to the resulting symbol. */
9620 get_struct_decl (const char *name
, sym_flavor fl
, locus
*decl
,
9621 gfc_symbol
**result
)
9626 gcc_assert (name
[0] == (char) TOUPPER (name
[0]));
9631 where
= gfc_current_locus
;
9633 if (gfc_get_symbol (name
, NULL
, &sym
))
9638 gfc_internal_error ("Failed to create structure type '%s' at %C", name
);
9642 if (sym
->components
!= NULL
|| sym
->attr
.zero_comp
)
9644 gfc_error ("Type definition of %qs at %C was already defined at %L",
9645 sym
->name
, &sym
->declared_at
);
9649 sym
->declared_at
= where
;
9651 if (sym
->attr
.flavor
!= fl
9652 && !gfc_add_flavor (&sym
->attr
, fl
, sym
->name
, NULL
))
9655 if (!sym
->hash_value
)
9656 /* Set the hash for the compound name for this type. */
9657 sym
->hash_value
= gfc_hash_value (sym
);
9659 /* Normally the type is expected to have been completely parsed by the time
9660 a field declaration with this type is seen. For unions, maps, and nested
9661 structure declarations, we need to indicate that it is okay that we
9662 haven't seen any components yet. This will be updated after the structure
9664 sym
->attr
.zero_comp
= 0;
9666 /* Structures always act like derived-types with the SEQUENCE attribute */
9667 gfc_add_sequence (&sym
->attr
, sym
->name
, NULL
);
9669 if (result
) *result
= sym
;
9675 /* Match the opening of a MAP block. Like a struct within a union in C;
9676 behaves identical to STRUCTURE blocks. */
9679 gfc_match_map (void)
9681 /* Counter used to give unique internal names to map structures. */
9682 static unsigned int gfc_map_id
= 0;
9683 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9687 old_loc
= gfc_current_locus
;
9689 if (gfc_match_eos () != MATCH_YES
)
9691 gfc_error ("Junk after MAP statement at %C");
9692 gfc_current_locus
= old_loc
;
9696 /* Map blocks are anonymous so we make up unique names for the symbol table
9697 which are invalid Fortran identifiers. */
9698 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "MM$%u", gfc_map_id
++);
9700 if (!get_struct_decl (name
, FL_STRUCT
, &old_loc
, &sym
))
9703 gfc_new_block
= sym
;
9709 /* Match the opening of a UNION block. */
9712 gfc_match_union (void)
9714 /* Counter used to give unique internal names to union types. */
9715 static unsigned int gfc_union_id
= 0;
9716 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9720 old_loc
= gfc_current_locus
;
9722 if (gfc_match_eos () != MATCH_YES
)
9724 gfc_error ("Junk after UNION statement at %C");
9725 gfc_current_locus
= old_loc
;
9729 /* Unions are anonymous so we make up unique names for the symbol table
9730 which are invalid Fortran identifiers. */
9731 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "UU$%u", gfc_union_id
++);
9733 if (!get_struct_decl (name
, FL_UNION
, &old_loc
, &sym
))
9736 gfc_new_block
= sym
;
9742 /* Match the beginning of a STRUCTURE declaration. This is similar to
9743 matching the beginning of a derived type declaration with a few
9744 twists. The resulting type symbol has no access control or other
9745 interesting attributes. */
9748 gfc_match_structure_decl (void)
9750 /* Counter used to give unique internal names to anonymous structures. */
9751 static unsigned int gfc_structure_id
= 0;
9752 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9757 if (!flag_dec_structure
)
9759 gfc_error ("%s at %C is a DEC extension, enable with "
9760 "%<-fdec-structure%>",
9767 m
= gfc_match (" /%n/", name
);
9770 /* Non-nested structure declarations require a structure name. */
9771 if (!gfc_comp_struct (gfc_current_state ()))
9773 gfc_error ("Structure name expected in non-nested structure "
9774 "declaration at %C");
9777 /* This is an anonymous structure; make up a unique name for it
9778 (upper-case letters never make it to symbol names from the source).
9779 The important thing is initializing the type variable
9780 and setting gfc_new_symbol, which is immediately used by
9781 parse_structure () and variable_decl () to add components of
9783 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "SS$%u", gfc_structure_id
++);
9786 where
= gfc_current_locus
;
9787 /* No field list allowed after non-nested structure declaration. */
9788 if (!gfc_comp_struct (gfc_current_state ())
9789 && gfc_match_eos () != MATCH_YES
)
9791 gfc_error ("Junk after non-nested STRUCTURE statement at %C");
9795 /* Make sure the name is not the name of an intrinsic type. */
9796 if (gfc_is_intrinsic_typename (name
))
9798 gfc_error ("Structure name %qs at %C cannot be the same as an"
9799 " intrinsic type", name
);
9803 /* Store the actual type symbol for the structure with an upper-case first
9804 letter (an invalid Fortran identifier). */
9806 if (!get_struct_decl (gfc_dt_upper_string (name
), FL_STRUCT
, &where
, &sym
))
9809 gfc_new_block
= sym
;
9814 /* This function does some work to determine which matcher should be used to
9815 * match a statement beginning with "TYPE". This is used to disambiguate TYPE
9816 * as an alias for PRINT from derived type declarations, TYPE IS statements,
9817 * and [parameterized] derived type declarations. */
9820 gfc_match_type (gfc_statement
*st
)
9822 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9826 /* Requires -fdec. */
9830 m
= gfc_match ("type");
9833 /* If we already have an error in the buffer, it is probably from failing to
9834 * match a derived type data declaration. Let it happen. */
9835 else if (gfc_error_flag_test ())
9838 old_loc
= gfc_current_locus
;
9841 /* If we see an attribute list before anything else it's definitely a derived
9842 * type declaration. */
9843 if (gfc_match (" ,") == MATCH_YES
|| gfc_match (" ::") == MATCH_YES
)
9846 /* By now "TYPE" has already been matched. If we do not see a name, this may
9847 * be something like "TYPE *" or "TYPE <fmt>". */
9848 m
= gfc_match_name (name
);
9851 /* Let print match if it can, otherwise throw an error from
9852 * gfc_match_derived_decl. */
9853 gfc_current_locus
= old_loc
;
9854 if (gfc_match_print () == MATCH_YES
)
9862 /* Check for EOS. */
9863 if (gfc_match_eos () == MATCH_YES
)
9865 /* By now we have "TYPE <name> <EOS>". Check first if the name is an
9866 * intrinsic typename - if so let gfc_match_derived_decl dump an error.
9867 * Otherwise if gfc_match_derived_decl fails it's probably an existing
9868 * symbol which can be printed. */
9869 gfc_current_locus
= old_loc
;
9870 m
= gfc_match_derived_decl ();
9871 if (gfc_is_intrinsic_typename (name
) || m
== MATCH_YES
)
9873 *st
= ST_DERIVED_DECL
;
9879 /* Here we have "TYPE <name>". Check for <TYPE IS (> or a PDT declaration
9880 like <type name(parameter)>. */
9881 gfc_gobble_whitespace ();
9882 bool paren
= gfc_peek_ascii_char () == '(';
9885 if (strcmp ("is", name
) == 0)
9892 /* Treat TYPE... like PRINT... */
9893 gfc_current_locus
= old_loc
;
9895 return gfc_match_print ();
9898 gfc_current_locus
= old_loc
;
9899 *st
= ST_DERIVED_DECL
;
9900 return gfc_match_derived_decl ();
9903 gfc_current_locus
= old_loc
;
9905 return gfc_match_type_is ();
9909 /* Match the beginning of a derived type declaration. If a type name
9910 was the result of a function, then it is possible to have a symbol
9911 already to be known as a derived type yet have no components. */
9914 gfc_match_derived_decl (void)
9916 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9917 char parent
[GFC_MAX_SYMBOL_LEN
+ 1];
9918 symbol_attribute attr
;
9919 gfc_symbol
*sym
, *gensym
;
9920 gfc_symbol
*extended
;
9922 match is_type_attr_spec
= MATCH_NO
;
9923 bool seen_attr
= false;
9924 gfc_interface
*intr
= NULL
, *head
;
9925 bool parameterized_type
= false;
9926 bool seen_colons
= false;
9928 if (gfc_comp_struct (gfc_current_state ()))
9933 gfc_clear_attr (&attr
);
9938 is_type_attr_spec
= gfc_get_type_attr_spec (&attr
, parent
);
9939 if (is_type_attr_spec
== MATCH_ERROR
)
9941 if (is_type_attr_spec
== MATCH_YES
)
9943 } while (is_type_attr_spec
== MATCH_YES
);
9945 /* Deal with derived type extensions. The extension attribute has
9946 been added to 'attr' but now the parent type must be found and
9949 extended
= check_extended_derived_type (parent
);
9951 if (parent
[0] && !extended
)
9954 m
= gfc_match (" ::");
9961 gfc_error ("Expected :: in TYPE definition at %C");
9965 m
= gfc_match (" %n ", name
);
9969 /* Make sure that we don't identify TYPE IS (...) as a parameterized
9970 derived type named 'is'.
9971 TODO Expand the check, when 'name' = "is" by matching " (tname) "
9972 and checking if this is a(n intrinsic) typename. his picks up
9973 misplaced TYPE IS statements such as in select_type_1.f03. */
9974 if (gfc_peek_ascii_char () == '(')
9976 if (gfc_current_state () == COMP_SELECT_TYPE
9977 || (!seen_colons
&& !strcmp (name
, "is")))
9979 parameterized_type
= true;
9982 m
= gfc_match_eos ();
9983 if (m
!= MATCH_YES
&& !parameterized_type
)
9986 /* Make sure the name is not the name of an intrinsic type. */
9987 if (gfc_is_intrinsic_typename (name
))
9989 gfc_error ("Type name %qs at %C cannot be the same as an intrinsic "
9994 if (gfc_get_symbol (name
, NULL
, &gensym
))
9997 if (!gensym
->attr
.generic
&& gensym
->ts
.type
!= BT_UNKNOWN
)
9999 if (gensym
->ts
.u
.derived
)
10000 gfc_error ("Derived type name %qs at %C already has a basic type "
10001 "of %s", gensym
->name
, gfc_typename (&gensym
->ts
));
10003 gfc_error ("Derived type name %qs at %C already has a basic type",
10005 return MATCH_ERROR
;
10008 if (!gensym
->attr
.generic
10009 && !gfc_add_generic (&gensym
->attr
, gensym
->name
, NULL
))
10010 return MATCH_ERROR
;
10012 if (!gensym
->attr
.function
10013 && !gfc_add_function (&gensym
->attr
, gensym
->name
, NULL
))
10014 return MATCH_ERROR
;
10016 sym
= gfc_find_dt_in_generic (gensym
);
10018 if (sym
&& (sym
->components
!= NULL
|| sym
->attr
.zero_comp
))
10020 gfc_error ("Derived type definition of %qs at %C has already been "
10021 "defined", sym
->name
);
10022 return MATCH_ERROR
;
10027 /* Use upper case to save the actual derived-type symbol. */
10028 gfc_get_symbol (gfc_dt_upper_string (gensym
->name
), NULL
, &sym
);
10029 sym
->name
= gfc_get_string ("%s", gensym
->name
);
10030 head
= gensym
->generic
;
10031 intr
= gfc_get_interface ();
10033 intr
->where
= gfc_current_locus
;
10034 intr
->sym
->declared_at
= gfc_current_locus
;
10036 gensym
->generic
= intr
;
10037 gensym
->attr
.if_source
= IFSRC_DECL
;
10040 /* The symbol may already have the derived attribute without the
10041 components. The ways this can happen is via a function
10042 definition, an INTRINSIC statement or a subtype in another
10043 derived type that is a pointer. The first part of the AND clause
10044 is true if the symbol is not the return value of a function. */
10045 if (sym
->attr
.flavor
!= FL_DERIVED
10046 && !gfc_add_flavor (&sym
->attr
, FL_DERIVED
, sym
->name
, NULL
))
10047 return MATCH_ERROR
;
10049 if (attr
.access
!= ACCESS_UNKNOWN
10050 && !gfc_add_access (&sym
->attr
, attr
.access
, sym
->name
, NULL
))
10051 return MATCH_ERROR
;
10052 else if (sym
->attr
.access
== ACCESS_UNKNOWN
10053 && gensym
->attr
.access
!= ACCESS_UNKNOWN
10054 && !gfc_add_access (&sym
->attr
, gensym
->attr
.access
,
10056 return MATCH_ERROR
;
10058 if (sym
->attr
.access
!= ACCESS_UNKNOWN
10059 && gensym
->attr
.access
== ACCESS_UNKNOWN
)
10060 gensym
->attr
.access
= sym
->attr
.access
;
10062 /* See if the derived type was labeled as bind(c). */
10063 if (attr
.is_bind_c
!= 0)
10064 sym
->attr
.is_bind_c
= attr
.is_bind_c
;
10066 /* Construct the f2k_derived namespace if it is not yet there. */
10067 if (!sym
->f2k_derived
)
10068 sym
->f2k_derived
= gfc_get_namespace (NULL
, 0);
10070 if (parameterized_type
)
10072 /* Ignore error or mismatches by going to the end of the statement
10073 in order to avoid the component declarations causing problems. */
10074 m
= gfc_match_formal_arglist (sym
, 0, 0, true);
10075 if (m
!= MATCH_YES
)
10076 gfc_error_recovery ();
10077 m
= gfc_match_eos ();
10078 if (m
!= MATCH_YES
)
10080 gfc_error_recovery ();
10081 gfc_error_now ("Garbage after PARAMETERIZED TYPE declaration at %C");
10083 sym
->attr
.pdt_template
= 1;
10086 if (extended
&& !sym
->components
)
10089 gfc_formal_arglist
*f
, *g
, *h
;
10091 /* Add the extended derived type as the first component. */
10092 gfc_add_component (sym
, parent
, &p
);
10094 gfc_set_sym_referenced (extended
);
10096 p
->ts
.type
= BT_DERIVED
;
10097 p
->ts
.u
.derived
= extended
;
10098 p
->initializer
= gfc_default_initializer (&p
->ts
);
10100 /* Set extension level. */
10101 if (extended
->attr
.extension
== 255)
10103 /* Since the extension field is 8 bit wide, we can only have
10104 up to 255 extension levels. */
10105 gfc_error ("Maximum extension level reached with type %qs at %L",
10106 extended
->name
, &extended
->declared_at
);
10107 return MATCH_ERROR
;
10109 sym
->attr
.extension
= extended
->attr
.extension
+ 1;
10111 /* Provide the links between the extended type and its extension. */
10112 if (!extended
->f2k_derived
)
10113 extended
->f2k_derived
= gfc_get_namespace (NULL
, 0);
10115 /* Copy the extended type-param-name-list from the extended type,
10116 append those of the extension and add the whole lot to the
10118 if (extended
->attr
.pdt_template
)
10121 sym
->attr
.pdt_template
= 1;
10122 for (f
= extended
->formal
; f
; f
= f
->next
)
10124 if (f
== extended
->formal
)
10126 g
= gfc_get_formal_arglist ();
10131 g
->next
= gfc_get_formal_arglist ();
10136 g
->next
= sym
->formal
;
10141 if (!sym
->hash_value
)
10142 /* Set the hash for the compound name for this type. */
10143 sym
->hash_value
= gfc_hash_value (sym
);
10145 /* Take over the ABSTRACT attribute. */
10146 sym
->attr
.abstract
= attr
.abstract
;
10148 gfc_new_block
= sym
;
10154 /* Cray Pointees can be declared as:
10155 pointer (ipt, a (n,m,...,*)) */
10158 gfc_mod_pointee_as (gfc_array_spec
*as
)
10160 as
->cray_pointee
= true; /* This will be useful to know later. */
10161 if (as
->type
== AS_ASSUMED_SIZE
)
10162 as
->cp_was_assumed
= true;
10163 else if (as
->type
== AS_ASSUMED_SHAPE
)
10165 gfc_error ("Cray Pointee at %C cannot be assumed shape array");
10166 return MATCH_ERROR
;
10172 /* Match the enum definition statement, here we are trying to match
10173 the first line of enum definition statement.
10174 Returns MATCH_YES if match is found. */
10177 gfc_match_enum (void)
10181 m
= gfc_match_eos ();
10182 if (m
!= MATCH_YES
)
10185 if (!gfc_notify_std (GFC_STD_F2003
, "ENUM and ENUMERATOR at %C"))
10186 return MATCH_ERROR
;
10192 /* Returns an initializer whose value is one higher than the value of the
10193 LAST_INITIALIZER argument. If the argument is NULL, the
10194 initializers value will be set to zero. The initializer's kind
10195 will be set to gfc_c_int_kind.
10197 If -fshort-enums is given, the appropriate kind will be selected
10198 later after all enumerators have been parsed. A warning is issued
10199 here if an initializer exceeds gfc_c_int_kind. */
10202 enum_initializer (gfc_expr
*last_initializer
, locus where
)
10205 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_c_int_kind
, &where
);
10207 mpz_init (result
->value
.integer
);
10209 if (last_initializer
!= NULL
)
10211 mpz_add_ui (result
->value
.integer
, last_initializer
->value
.integer
, 1);
10212 result
->where
= last_initializer
->where
;
10214 if (gfc_check_integer_range (result
->value
.integer
,
10215 gfc_c_int_kind
) != ARITH_OK
)
10217 gfc_error ("Enumerator exceeds the C integer type at %C");
10223 /* Control comes here, if it's the very first enumerator and no
10224 initializer has been given. It will be initialized to zero. */
10225 mpz_set_si (result
->value
.integer
, 0);
10232 /* Match a variable name with an optional initializer. When this
10233 subroutine is called, a variable is expected to be parsed next.
10234 Depending on what is happening at the moment, updates either the
10235 symbol table or the current interface. */
10238 enumerator_decl (void)
10240 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10241 gfc_expr
*initializer
;
10242 gfc_array_spec
*as
= NULL
;
10249 initializer
= NULL
;
10250 old_locus
= gfc_current_locus
;
10252 /* When we get here, we've just matched a list of attributes and
10253 maybe a type and a double colon. The next thing we expect to see
10254 is the name of the symbol. */
10255 m
= gfc_match_name (name
);
10256 if (m
!= MATCH_YES
)
10259 var_locus
= gfc_current_locus
;
10261 /* OK, we've successfully matched the declaration. Now put the
10262 symbol in the current namespace. If we fail to create the symbol,
10264 if (!build_sym (name
, NULL
, false, &as
, &var_locus
))
10270 /* The double colon must be present in order to have initializers.
10271 Otherwise the statement is ambiguous with an assignment statement. */
10274 if (gfc_match_char ('=') == MATCH_YES
)
10276 m
= gfc_match_init_expr (&initializer
);
10279 gfc_error ("Expected an initialization expression at %C");
10283 if (m
!= MATCH_YES
)
10288 /* If we do not have an initializer, the initialization value of the
10289 previous enumerator (stored in last_initializer) is incremented
10290 by 1 and is used to initialize the current enumerator. */
10291 if (initializer
== NULL
)
10292 initializer
= enum_initializer (last_initializer
, old_locus
);
10294 if (initializer
== NULL
|| initializer
->ts
.type
!= BT_INTEGER
)
10296 gfc_error ("ENUMERATOR %L not initialized with integer expression",
10302 /* Store this current initializer, for the next enumerator variable
10303 to be parsed. add_init_expr_to_sym() zeros initializer, so we
10304 use last_initializer below. */
10305 last_initializer
= initializer
;
10306 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
10308 /* Maintain enumerator history. */
10309 gfc_find_symbol (name
, NULL
, 0, &sym
);
10310 create_enum_history (sym
, last_initializer
);
10312 return (t
) ? MATCH_YES
: MATCH_ERROR
;
10315 /* Free stuff up and return. */
10316 gfc_free_expr (initializer
);
10322 /* Match the enumerator definition statement. */
10325 gfc_match_enumerator_def (void)
10330 gfc_clear_ts (¤t_ts
);
10332 m
= gfc_match (" enumerator");
10333 if (m
!= MATCH_YES
)
10336 m
= gfc_match (" :: ");
10337 if (m
== MATCH_ERROR
)
10340 colon_seen
= (m
== MATCH_YES
);
10342 if (gfc_current_state () != COMP_ENUM
)
10344 gfc_error ("ENUM definition statement expected before %C");
10345 gfc_free_enum_history ();
10346 return MATCH_ERROR
;
10349 (¤t_ts
)->type
= BT_INTEGER
;
10350 (¤t_ts
)->kind
= gfc_c_int_kind
;
10352 gfc_clear_attr (¤t_attr
);
10353 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, NULL
);
10362 m
= enumerator_decl ();
10363 if (m
== MATCH_ERROR
)
10365 gfc_free_enum_history ();
10371 if (gfc_match_eos () == MATCH_YES
)
10373 if (gfc_match_char (',') != MATCH_YES
)
10377 if (gfc_current_state () == COMP_ENUM
)
10379 gfc_free_enum_history ();
10380 gfc_error ("Syntax error in ENUMERATOR definition at %C");
10385 gfc_free_array_spec (current_as
);
10392 /* Match binding attributes. */
10395 match_binding_attributes (gfc_typebound_proc
* ba
, bool generic
, bool ppc
)
10397 bool found_passing
= false;
10398 bool seen_ptr
= false;
10399 match m
= MATCH_YES
;
10401 /* Initialize to defaults. Do so even before the MATCH_NO check so that in
10402 this case the defaults are in there. */
10403 ba
->access
= ACCESS_UNKNOWN
;
10404 ba
->pass_arg
= NULL
;
10405 ba
->pass_arg_num
= 0;
10407 ba
->non_overridable
= 0;
10411 /* If we find a comma, we believe there are binding attributes. */
10412 m
= gfc_match_char (',');
10418 /* Access specifier. */
10420 m
= gfc_match (" public");
10421 if (m
== MATCH_ERROR
)
10423 if (m
== MATCH_YES
)
10425 if (ba
->access
!= ACCESS_UNKNOWN
)
10427 gfc_error ("Duplicate access-specifier at %C");
10431 ba
->access
= ACCESS_PUBLIC
;
10435 m
= gfc_match (" private");
10436 if (m
== MATCH_ERROR
)
10438 if (m
== MATCH_YES
)
10440 if (ba
->access
!= ACCESS_UNKNOWN
)
10442 gfc_error ("Duplicate access-specifier at %C");
10446 ba
->access
= ACCESS_PRIVATE
;
10450 /* If inside GENERIC, the following is not allowed. */
10455 m
= gfc_match (" nopass");
10456 if (m
== MATCH_ERROR
)
10458 if (m
== MATCH_YES
)
10462 gfc_error ("Binding attributes already specify passing,"
10463 " illegal NOPASS at %C");
10467 found_passing
= true;
10472 /* PASS possibly including argument. */
10473 m
= gfc_match (" pass");
10474 if (m
== MATCH_ERROR
)
10476 if (m
== MATCH_YES
)
10478 char arg
[GFC_MAX_SYMBOL_LEN
+ 1];
10482 gfc_error ("Binding attributes already specify passing,"
10483 " illegal PASS at %C");
10487 m
= gfc_match (" ( %n )", arg
);
10488 if (m
== MATCH_ERROR
)
10490 if (m
== MATCH_YES
)
10491 ba
->pass_arg
= gfc_get_string ("%s", arg
);
10492 gcc_assert ((m
== MATCH_YES
) == (ba
->pass_arg
!= NULL
));
10494 found_passing
= true;
10501 /* POINTER flag. */
10502 m
= gfc_match (" pointer");
10503 if (m
== MATCH_ERROR
)
10505 if (m
== MATCH_YES
)
10509 gfc_error ("Duplicate POINTER attribute at %C");
10519 /* NON_OVERRIDABLE flag. */
10520 m
= gfc_match (" non_overridable");
10521 if (m
== MATCH_ERROR
)
10523 if (m
== MATCH_YES
)
10525 if (ba
->non_overridable
)
10527 gfc_error ("Duplicate NON_OVERRIDABLE at %C");
10531 ba
->non_overridable
= 1;
10535 /* DEFERRED flag. */
10536 m
= gfc_match (" deferred");
10537 if (m
== MATCH_ERROR
)
10539 if (m
== MATCH_YES
)
10543 gfc_error ("Duplicate DEFERRED at %C");
10554 /* Nothing matching found. */
10556 gfc_error ("Expected access-specifier at %C");
10558 gfc_error ("Expected binding attribute at %C");
10561 while (gfc_match_char (',') == MATCH_YES
);
10563 /* NON_OVERRIDABLE and DEFERRED exclude themselves. */
10564 if (ba
->non_overridable
&& ba
->deferred
)
10566 gfc_error ("NON_OVERRIDABLE and DEFERRED can't both appear at %C");
10573 if (ba
->access
== ACCESS_UNKNOWN
)
10574 ba
->access
= 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
;