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
->where
= gfc_current_locus
;
539 /* Match initial value list. This also eats the terminal '/'. */
540 m
= top_val_list (newdata
);
549 gfc_error ("Initialization at %C is not allowed in a PURE procedure");
553 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
555 /* Mark the variable as having appeared in a data statement. */
556 if (!gfc_add_data (&sym
->attr
, sym
->name
, &sym
->declared_at
))
562 /* Chain in namespace list of DATA initializers. */
563 newdata
->next
= gfc_current_ns
->data
;
564 gfc_current_ns
->data
= newdata
;
570 /* Match the stuff following a DATA statement. If ERROR_FLAG is set,
571 we are matching a DATA statement and are therefore issuing an error
572 if we encounter something unexpected, if not, we're trying to match
573 an old-style initialization expression of the form INTEGER I /2/. */
576 gfc_match_data (void)
581 /* Before parsing the rest of a DATA statement, check F2008:c1206. */
582 if ((gfc_current_state () == COMP_FUNCTION
583 || gfc_current_state () == COMP_SUBROUTINE
)
584 && gfc_state_stack
->previous
->state
== COMP_INTERFACE
)
586 gfc_error ("DATA statement at %C cannot appear within an INTERFACE");
590 set_in_match_data (true);
594 new_data
= gfc_get_data ();
595 new_data
->where
= gfc_current_locus
;
597 m
= top_var_list (new_data
);
601 if (new_data
->var
->iter
.var
602 && new_data
->var
->iter
.var
->ts
.type
== BT_INTEGER
603 && new_data
->var
->iter
.var
->symtree
->n
.sym
->attr
.implied_index
== 1
604 && new_data
->var
->list
605 && new_data
->var
->list
->expr
606 && new_data
->var
->list
->expr
->ts
.type
== BT_CHARACTER
607 && new_data
->var
->list
->expr
->ref
608 && new_data
->var
->list
->expr
->ref
->type
== REF_SUBSTRING
)
610 gfc_error ("Invalid substring in data-implied-do at %L in DATA "
611 "statement", &new_data
->var
->list
->expr
->where
);
615 m
= top_val_list (new_data
);
619 new_data
->next
= gfc_current_ns
->data
;
620 gfc_current_ns
->data
= new_data
;
622 if (gfc_match_eos () == MATCH_YES
)
625 gfc_match_char (','); /* Optional comma */
628 set_in_match_data (false);
632 gfc_error ("DATA statement at %C is not allowed in a PURE procedure");
635 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
640 set_in_match_data (false);
641 gfc_free_data (new_data
);
646 /************************ Declaration statements *********************/
649 /* Like gfc_match_init_expr, but matches a 'clist' (old-style initialization
650 list). The difference here is the expression is a list of constants
651 and is surrounded by '/'.
652 The typespec ts must match the typespec of the variable which the
653 clist is initializing.
654 The arrayspec tells whether this should match a list of constants
655 corresponding to array elements or a scalar (as == NULL). */
658 match_clist_expr (gfc_expr
**result
, gfc_typespec
*ts
, gfc_array_spec
*as
)
660 gfc_constructor_base array_head
= NULL
;
661 gfc_expr
*expr
= NULL
;
664 mpz_t repeat
, cons_size
, as_size
;
670 mpz_init_set_ui (repeat
, 0);
671 scalar
= !as
|| !as
->rank
;
673 /* We have already matched '/' - now look for a constant list, as with
674 top_val_list from decl.c, but append the result to an array. */
675 if (gfc_match ("/") == MATCH_YES
)
677 gfc_error ("Empty old style initializer list at %C");
681 where
= gfc_current_locus
;
684 m
= match_data_constant (&expr
);
686 expr
= NULL
; /* match_data_constant may set expr to garbage */
689 if (m
== MATCH_ERROR
)
692 /* Found r in repeat spec r*c; look for the constant to repeat. */
693 if ( gfc_match_char ('*') == MATCH_YES
)
697 gfc_error ("Repeat spec invalid in scalar initializer at %C");
700 if (expr
->ts
.type
!= BT_INTEGER
)
702 gfc_error ("Repeat spec must be an integer at %C");
705 mpz_set (repeat
, expr
->value
.integer
);
706 gfc_free_expr (expr
);
709 m
= match_data_constant (&expr
);
711 gfc_error ("Expected data constant after repeat spec at %C");
715 /* No repeat spec, we matched the data constant itself. */
717 mpz_set_ui (repeat
, 1);
721 /* Add the constant initializer as many times as repeated. */
722 for (; mpz_cmp_ui (repeat
, 0) > 0; mpz_sub_ui (repeat
, repeat
, 1))
724 /* Make sure types of elements match */
725 if(ts
&& !gfc_compare_types (&expr
->ts
, ts
)
726 && !gfc_convert_type (expr
, ts
, 1))
729 gfc_constructor_append_expr (&array_head
,
730 gfc_copy_expr (expr
), &gfc_current_locus
);
733 gfc_free_expr (expr
);
737 /* For scalar initializers quit after one element. */
740 if(gfc_match_char ('/') != MATCH_YES
)
742 gfc_error ("End of scalar initializer expected at %C");
748 if (gfc_match_char ('/') == MATCH_YES
)
750 if (gfc_match_char (',') == MATCH_NO
)
754 /* Set up expr as an array constructor. */
757 expr
= gfc_get_array_expr (ts
->type
, ts
->kind
, &where
);
759 expr
->value
.constructor
= array_head
;
761 expr
->rank
= as
->rank
;
762 expr
->shape
= gfc_get_shape (expr
->rank
);
764 /* Validate sizes. We built expr ourselves, so cons_size will be
765 constant (we fail above for non-constant expressions).
766 We still need to verify that the array-spec has constant size. */
768 gcc_assert (gfc_array_size (expr
, &cons_size
));
769 if (!spec_size (as
, &as_size
))
771 gfc_error ("Expected constant array-spec in initializer list at %L",
772 as
->type
== AS_EXPLICIT
? &as
->upper
[0]->where
: &where
);
777 /* Make sure the specs are of the same size. */
778 cmp
= mpz_cmp (cons_size
, as_size
);
780 gfc_error ("Not enough elements in array initializer at %C");
782 gfc_error ("Too many elements in array initializer at %C");
785 mpz_clear (cons_size
);
790 /* Make sure scalar types match. */
791 else if (!gfc_compare_types (&expr
->ts
, ts
)
792 && !gfc_convert_type (expr
, ts
, 1))
796 expr
->ts
.u
.cl
->length_from_typespec
= 1;
803 gfc_error ("Syntax error in old style initializer list at %C");
807 expr
->value
.constructor
= NULL
;
808 gfc_free_expr (expr
);
809 gfc_constructor_free (array_head
);
815 /* Auxiliary function to merge DIMENSION and CODIMENSION array specs. */
818 merge_array_spec (gfc_array_spec
*from
, gfc_array_spec
*to
, bool copy
)
822 if ((from
->type
== AS_ASSUMED_RANK
&& to
->corank
)
823 || (to
->type
== AS_ASSUMED_RANK
&& from
->corank
))
825 gfc_error ("The assumed-rank array at %C shall not have a codimension");
829 if (to
->rank
== 0 && from
->rank
> 0)
831 to
->rank
= from
->rank
;
832 to
->type
= from
->type
;
833 to
->cray_pointee
= from
->cray_pointee
;
834 to
->cp_was_assumed
= from
->cp_was_assumed
;
836 for (i
= 0; i
< to
->corank
; i
++)
838 /* Do not exceed the limits on lower[] and upper[]. gfortran
839 cleans up elsewhere. */
841 if (j
>= GFC_MAX_DIMENSIONS
)
844 to
->lower
[j
] = to
->lower
[i
];
845 to
->upper
[j
] = to
->upper
[i
];
847 for (i
= 0; i
< from
->rank
; i
++)
851 to
->lower
[i
] = gfc_copy_expr (from
->lower
[i
]);
852 to
->upper
[i
] = gfc_copy_expr (from
->upper
[i
]);
856 to
->lower
[i
] = from
->lower
[i
];
857 to
->upper
[i
] = from
->upper
[i
];
861 else if (to
->corank
== 0 && from
->corank
> 0)
863 to
->corank
= from
->corank
;
864 to
->cotype
= from
->cotype
;
866 for (i
= 0; i
< from
->corank
; i
++)
868 /* Do not exceed the limits on lower[] and upper[]. gfortran
869 cleans up elsewhere. */
871 if (j
>= GFC_MAX_DIMENSIONS
)
876 to
->lower
[j
] = gfc_copy_expr (from
->lower
[i
]);
877 to
->upper
[j
] = gfc_copy_expr (from
->upper
[i
]);
881 to
->lower
[j
] = from
->lower
[i
];
882 to
->upper
[j
] = from
->upper
[i
];
887 if (to
->rank
+ to
->corank
> GFC_MAX_DIMENSIONS
)
889 gfc_error ("Sum of array rank %d and corank %d at %C exceeds maximum "
890 "allowed dimensions of %d",
891 to
->rank
, to
->corank
, GFC_MAX_DIMENSIONS
);
892 to
->corank
= GFC_MAX_DIMENSIONS
- to
->rank
;
899 /* Match an intent specification. Since this can only happen after an
900 INTENT word, a legal intent-spec must follow. */
903 match_intent_spec (void)
906 if (gfc_match (" ( in out )") == MATCH_YES
)
908 if (gfc_match (" ( in )") == MATCH_YES
)
910 if (gfc_match (" ( out )") == MATCH_YES
)
913 gfc_error ("Bad INTENT specification at %C");
914 return INTENT_UNKNOWN
;
918 /* Matches a character length specification, which is either a
919 specification expression, '*', or ':'. */
922 char_len_param_value (gfc_expr
**expr
, bool *deferred
)
929 if (gfc_match_char ('*') == MATCH_YES
)
932 if (gfc_match_char (':') == MATCH_YES
)
934 if (!gfc_notify_std (GFC_STD_F2003
, "deferred type parameter at %C"))
942 m
= gfc_match_expr (expr
);
944 if (m
== MATCH_NO
|| m
== MATCH_ERROR
)
947 if (!gfc_expr_check_typed (*expr
, gfc_current_ns
, false))
950 if ((*expr
)->expr_type
== EXPR_FUNCTION
)
952 if ((*expr
)->ts
.type
== BT_INTEGER
953 || ((*expr
)->ts
.type
== BT_UNKNOWN
954 && strcmp((*expr
)->symtree
->name
, "null") != 0))
959 else if ((*expr
)->expr_type
== EXPR_CONSTANT
)
961 /* F2008, 4.4.3.1: The length is a type parameter; its kind is
962 processor dependent and its value is greater than or equal to zero.
963 F2008, 4.4.3.2: If the character length parameter value evaluates
964 to a negative value, the length of character entities declared
967 if ((*expr
)->ts
.type
== BT_INTEGER
)
969 if (mpz_cmp_si ((*expr
)->value
.integer
, 0) < 0)
970 mpz_set_si ((*expr
)->value
.integer
, 0);
975 else if ((*expr
)->expr_type
== EXPR_ARRAY
)
977 else if ((*expr
)->expr_type
== EXPR_VARIABLE
)
982 e
= gfc_copy_expr (*expr
);
984 /* This catches the invalid code "[character(m(2:3)) :: 'x', 'y']",
985 which causes an ICE if gfc_reduce_init_expr() is called. */
986 if (e
->ref
&& e
->ref
->type
== REF_ARRAY
987 && e
->ref
->u
.ar
.type
== AR_UNKNOWN
988 && e
->ref
->u
.ar
.dimen_type
[0] == DIMEN_RANGE
)
991 t
= gfc_reduce_init_expr (e
);
993 if (!t
&& e
->ts
.type
== BT_UNKNOWN
994 && e
->symtree
->n
.sym
->attr
.untyped
== 1
995 && (flag_implicit_none
996 || e
->symtree
->n
.sym
->ns
->seen_implicit_none
== 1
997 || e
->symtree
->n
.sym
->ns
->parent
->seen_implicit_none
== 1))
1003 if ((e
->ref
&& e
->ref
->type
== REF_ARRAY
1004 && e
->ref
->u
.ar
.type
!= AR_ELEMENT
)
1005 || (!e
->ref
&& e
->expr_type
== EXPR_ARRAY
))
1017 gfc_error ("Scalar INTEGER expression expected at %L", &(*expr
)->where
);
1022 /* A character length is a '*' followed by a literal integer or a
1023 char_len_param_value in parenthesis. */
1026 match_char_length (gfc_expr
**expr
, bool *deferred
, bool obsolescent_check
)
1032 m
= gfc_match_char ('*');
1036 m
= gfc_match_small_literal_int (&length
, NULL
);
1037 if (m
== MATCH_ERROR
)
1042 if (obsolescent_check
1043 && !gfc_notify_std (GFC_STD_F95_OBS
, "Old-style character length at %C"))
1045 *expr
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
, length
);
1049 if (gfc_match_char ('(') == MATCH_NO
)
1052 m
= char_len_param_value (expr
, deferred
);
1053 if (m
!= MATCH_YES
&& gfc_matching_function
)
1055 gfc_undo_symbols ();
1059 if (m
== MATCH_ERROR
)
1064 if (gfc_match_char (')') == MATCH_NO
)
1066 gfc_free_expr (*expr
);
1074 gfc_error ("Syntax error in character length specification at %C");
1079 /* Special subroutine for finding a symbol. Check if the name is found
1080 in the current name space. If not, and we're compiling a function or
1081 subroutine and the parent compilation unit is an interface, then check
1082 to see if the name we've been given is the name of the interface
1083 (located in another namespace). */
1086 find_special (const char *name
, gfc_symbol
**result
, bool allow_subroutine
)
1092 i
= gfc_get_sym_tree (name
, NULL
, &st
, allow_subroutine
);
1095 *result
= st
? st
->n
.sym
: NULL
;
1099 if (gfc_current_state () != COMP_SUBROUTINE
1100 && gfc_current_state () != COMP_FUNCTION
)
1103 s
= gfc_state_stack
->previous
;
1107 if (s
->state
!= COMP_INTERFACE
)
1110 goto end
; /* Nameless interface. */
1112 if (strcmp (name
, s
->sym
->name
) == 0)
1123 /* Special subroutine for getting a symbol node associated with a
1124 procedure name, used in SUBROUTINE and FUNCTION statements. The
1125 symbol is created in the parent using with symtree node in the
1126 child unit pointing to the symbol. If the current namespace has no
1127 parent, then the symbol is just created in the current unit. */
1130 get_proc_name (const char *name
, gfc_symbol
**result
, bool module_fcn_entry
)
1136 /* Module functions have to be left in their own namespace because
1137 they have potentially (almost certainly!) already been referenced.
1138 In this sense, they are rather like external functions. This is
1139 fixed up in resolve.c(resolve_entries), where the symbol name-
1140 space is set to point to the master function, so that the fake
1141 result mechanism can work. */
1142 if (module_fcn_entry
)
1144 /* Present if entry is declared to be a module procedure. */
1145 rc
= gfc_find_symbol (name
, gfc_current_ns
->parent
, 0, result
);
1147 if (*result
== NULL
)
1148 rc
= gfc_get_symbol (name
, NULL
, result
);
1149 else if (!gfc_get_symbol (name
, NULL
, &sym
) && sym
1150 && (*result
)->ts
.type
== BT_UNKNOWN
1151 && sym
->attr
.flavor
== FL_UNKNOWN
)
1152 /* Pick up the typespec for the entry, if declared in the function
1153 body. Note that this symbol is FL_UNKNOWN because it will
1154 only have appeared in a type declaration. The local symtree
1155 is set to point to the module symbol and a unique symtree
1156 to the local version. This latter ensures a correct clearing
1159 /* If the ENTRY proceeds its specification, we need to ensure
1160 that this does not raise a "has no IMPLICIT type" error. */
1161 if (sym
->ts
.type
== BT_UNKNOWN
)
1162 sym
->attr
.untyped
= 1;
1164 (*result
)->ts
= sym
->ts
;
1166 /* Put the symbol in the procedure namespace so that, should
1167 the ENTRY precede its specification, the specification
1169 (*result
)->ns
= gfc_current_ns
;
1171 gfc_find_sym_tree (name
, gfc_current_ns
, 0, &st
);
1172 st
->n
.sym
= *result
;
1173 st
= gfc_get_unique_symtree (gfc_current_ns
);
1179 rc
= gfc_get_symbol (name
, gfc_current_ns
->parent
, result
);
1185 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
1188 if (sym
->attr
.module_procedure
&& sym
->attr
.if_source
== IFSRC_IFBODY
)
1190 /* Create a partially populated interface symbol to carry the
1191 characteristics of the procedure and the result. */
1192 sym
->tlink
= gfc_new_symbol (name
, sym
->ns
);
1193 gfc_add_type (sym
->tlink
, &(sym
->ts
), &gfc_current_locus
);
1194 gfc_copy_attr (&sym
->tlink
->attr
, &sym
->attr
, NULL
);
1195 if (sym
->attr
.dimension
)
1196 sym
->tlink
->as
= gfc_copy_array_spec (sym
->as
);
1198 /* Ideally, at this point, a copy would be made of the formal
1199 arguments and their namespace. However, this does not appear
1200 to be necessary, albeit at the expense of not being able to
1201 use gfc_compare_interfaces directly. */
1203 if (sym
->result
&& sym
->result
!= sym
)
1205 sym
->tlink
->result
= sym
->result
;
1208 else if (sym
->result
)
1210 sym
->tlink
->result
= sym
->tlink
;
1213 else if (sym
&& !sym
->gfc_new
1214 && gfc_current_state () != COMP_INTERFACE
)
1216 /* Trap another encompassed procedure with the same name. All
1217 these conditions are necessary to avoid picking up an entry
1218 whose name clashes with that of the encompassing procedure;
1219 this is handled using gsymbols to register unique, globally
1220 accessible names. */
1221 if (sym
->attr
.flavor
!= 0
1222 && sym
->attr
.proc
!= 0
1223 && (sym
->attr
.subroutine
|| sym
->attr
.function
|| sym
->attr
.entry
)
1224 && sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
1225 gfc_error_now ("Procedure %qs at %C is already defined at %L",
1226 name
, &sym
->declared_at
);
1228 if (sym
->attr
.flavor
!= 0
1229 && sym
->attr
.entry
&& sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
1230 gfc_error_now ("Procedure %qs at %C is already defined at %L",
1231 name
, &sym
->declared_at
);
1233 if (sym
->attr
.external
&& sym
->attr
.procedure
1234 && gfc_current_state () == COMP_CONTAINS
)
1235 gfc_error_now ("Contained procedure %qs at %C clashes with "
1236 "procedure defined at %L",
1237 name
, &sym
->declared_at
);
1239 /* Trap a procedure with a name the same as interface in the
1240 encompassing scope. */
1241 if (sym
->attr
.generic
!= 0
1242 && (sym
->attr
.subroutine
|| sym
->attr
.function
)
1243 && !sym
->attr
.mod_proc
)
1244 gfc_error_now ("Name %qs at %C is already defined"
1245 " as a generic interface at %L",
1246 name
, &sym
->declared_at
);
1248 /* Trap declarations of attributes in encompassing scope. The
1249 signature for this is that ts.kind is set. Legitimate
1250 references only set ts.type. */
1251 if (sym
->ts
.kind
!= 0
1252 && !sym
->attr
.implicit_type
1253 && sym
->attr
.proc
== 0
1254 && gfc_current_ns
->parent
!= NULL
1255 && sym
->attr
.access
== 0
1256 && !module_fcn_entry
)
1257 gfc_error_now ("Procedure %qs at %C has an explicit interface "
1258 "from a previous declaration", name
);
1261 /* C1246 (R1225) MODULE shall appear only in the function-stmt or
1262 subroutine-stmt of a module subprogram or of a nonabstract interface
1263 body that is declared in the scoping unit of a module or submodule. */
1264 if (sym
->attr
.external
1265 && (sym
->attr
.subroutine
|| sym
->attr
.function
)
1266 && sym
->attr
.if_source
== IFSRC_IFBODY
1267 && !current_attr
.module_procedure
1268 && sym
->attr
.proc
== PROC_MODULE
1269 && gfc_state_stack
->state
== COMP_CONTAINS
)
1270 gfc_error_now ("Procedure %qs defined in interface body at %L "
1271 "clashes with internal procedure defined at %C",
1272 name
, &sym
->declared_at
);
1274 if (sym
&& !sym
->gfc_new
1275 && sym
->attr
.flavor
!= FL_UNKNOWN
1276 && sym
->attr
.referenced
== 0 && sym
->attr
.subroutine
== 1
1277 && gfc_state_stack
->state
== COMP_CONTAINS
1278 && gfc_state_stack
->previous
->state
== COMP_SUBROUTINE
)
1279 gfc_error_now ("Procedure %qs at %C is already defined at %L",
1280 name
, &sym
->declared_at
);
1282 if (gfc_current_ns
->parent
== NULL
|| *result
== NULL
)
1285 /* Module function entries will already have a symtree in
1286 the current namespace but will need one at module level. */
1287 if (module_fcn_entry
)
1289 /* Present if entry is declared to be a module procedure. */
1290 rc
= gfc_find_sym_tree (name
, gfc_current_ns
->parent
, 0, &st
);
1292 st
= gfc_new_symtree (&gfc_current_ns
->parent
->sym_root
, name
);
1295 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, name
);
1300 /* See if the procedure should be a module procedure. */
1302 if (((sym
->ns
->proc_name
!= NULL
1303 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
1304 && sym
->attr
.proc
!= PROC_MODULE
)
1305 || (module_fcn_entry
&& sym
->attr
.proc
!= PROC_MODULE
))
1306 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
1313 /* Verify that the given symbol representing a parameter is C
1314 interoperable, by checking to see if it was marked as such after
1315 its declaration. If the given symbol is not interoperable, a
1316 warning is reported, thus removing the need to return the status to
1317 the calling function. The standard does not require the user use
1318 one of the iso_c_binding named constants to declare an
1319 interoperable parameter, but we can't be sure if the param is C
1320 interop or not if the user doesn't. For example, integer(4) may be
1321 legal Fortran, but doesn't have meaning in C. It may interop with
1322 a number of the C types, which causes a problem because the
1323 compiler can't know which one. This code is almost certainly not
1324 portable, and the user will get what they deserve if the C type
1325 across platforms isn't always interoperable with integer(4). If
1326 the user had used something like integer(c_int) or integer(c_long),
1327 the compiler could have automatically handled the varying sizes
1328 across platforms. */
1331 gfc_verify_c_interop_param (gfc_symbol
*sym
)
1333 int is_c_interop
= 0;
1336 /* We check implicitly typed variables in symbol.c:gfc_set_default_type().
1337 Don't repeat the checks here. */
1338 if (sym
->attr
.implicit_type
)
1341 /* For subroutines or functions that are passed to a BIND(C) procedure,
1342 they're interoperable if they're BIND(C) and their params are all
1344 if (sym
->attr
.flavor
== FL_PROCEDURE
)
1346 if (sym
->attr
.is_bind_c
== 0)
1348 gfc_error_now ("Procedure %qs at %L must have the BIND(C) "
1349 "attribute to be C interoperable", sym
->name
,
1350 &(sym
->declared_at
));
1355 if (sym
->attr
.is_c_interop
== 1)
1356 /* We've already checked this procedure; don't check it again. */
1359 return verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
1364 /* See if we've stored a reference to a procedure that owns sym. */
1365 if (sym
->ns
!= NULL
&& sym
->ns
->proc_name
!= NULL
)
1367 if (sym
->ns
->proc_name
->attr
.is_bind_c
== 1)
1369 is_c_interop
= (gfc_verify_c_interop(&(sym
->ts
)) ? 1 : 0);
1371 if (is_c_interop
!= 1)
1373 /* Make personalized messages to give better feedback. */
1374 if (sym
->ts
.type
== BT_DERIVED
)
1375 gfc_error ("Variable %qs at %L is a dummy argument to the "
1376 "BIND(C) procedure %qs but is not C interoperable "
1377 "because derived type %qs is not C interoperable",
1378 sym
->name
, &(sym
->declared_at
),
1379 sym
->ns
->proc_name
->name
,
1380 sym
->ts
.u
.derived
->name
);
1381 else if (sym
->ts
.type
== BT_CLASS
)
1382 gfc_error ("Variable %qs at %L is a dummy argument to the "
1383 "BIND(C) procedure %qs but is not C interoperable "
1384 "because it is polymorphic",
1385 sym
->name
, &(sym
->declared_at
),
1386 sym
->ns
->proc_name
->name
);
1387 else if (warn_c_binding_type
)
1388 gfc_warning (OPT_Wc_binding_type
,
1389 "Variable %qs at %L is a dummy argument of the "
1390 "BIND(C) procedure %qs but may not be C "
1392 sym
->name
, &(sym
->declared_at
),
1393 sym
->ns
->proc_name
->name
);
1396 /* Character strings are only C interoperable if they have a
1398 if (sym
->ts
.type
== BT_CHARACTER
)
1400 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
1401 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
1402 || mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
1404 gfc_error ("Character argument %qs at %L "
1405 "must be length 1 because "
1406 "procedure %qs is BIND(C)",
1407 sym
->name
, &sym
->declared_at
,
1408 sym
->ns
->proc_name
->name
);
1413 /* We have to make sure that any param to a bind(c) routine does
1414 not have the allocatable, pointer, or optional attributes,
1415 according to J3/04-007, section 5.1. */
1416 if (sym
->attr
.allocatable
== 1
1417 && !gfc_notify_std (GFC_STD_F2018
, "Variable %qs at %L with "
1418 "ALLOCATABLE attribute in procedure %qs "
1419 "with BIND(C)", sym
->name
,
1420 &(sym
->declared_at
),
1421 sym
->ns
->proc_name
->name
))
1424 if (sym
->attr
.pointer
== 1
1425 && !gfc_notify_std (GFC_STD_F2018
, "Variable %qs at %L with "
1426 "POINTER attribute in procedure %qs "
1427 "with BIND(C)", sym
->name
,
1428 &(sym
->declared_at
),
1429 sym
->ns
->proc_name
->name
))
1432 if ((sym
->attr
.allocatable
|| sym
->attr
.pointer
) && !sym
->as
)
1434 gfc_error ("Scalar variable %qs at %L with POINTER or "
1435 "ALLOCATABLE in procedure %qs with BIND(C) is not yet"
1436 " supported", sym
->name
, &(sym
->declared_at
),
1437 sym
->ns
->proc_name
->name
);
1441 if (sym
->attr
.optional
== 1 && sym
->attr
.value
)
1443 gfc_error ("Variable %qs at %L cannot have both the OPTIONAL "
1444 "and the VALUE attribute because procedure %qs "
1445 "is BIND(C)", sym
->name
, &(sym
->declared_at
),
1446 sym
->ns
->proc_name
->name
);
1449 else if (sym
->attr
.optional
== 1
1450 && !gfc_notify_std (GFC_STD_F2018
, "Variable %qs "
1451 "at %L with OPTIONAL attribute in "
1452 "procedure %qs which is BIND(C)",
1453 sym
->name
, &(sym
->declared_at
),
1454 sym
->ns
->proc_name
->name
))
1457 /* Make sure that if it has the dimension attribute, that it is
1458 either assumed size or explicit shape. Deferred shape is already
1459 covered by the pointer/allocatable attribute. */
1460 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SHAPE
1461 && !gfc_notify_std (GFC_STD_F2018
, "Assumed-shape array %qs "
1462 "at %L as dummy argument to the BIND(C) "
1463 "procedure %qs at %L", sym
->name
,
1464 &(sym
->declared_at
),
1465 sym
->ns
->proc_name
->name
,
1466 &(sym
->ns
->proc_name
->declared_at
)))
1476 /* Function called by variable_decl() that adds a name to the symbol table. */
1479 build_sym (const char *name
, gfc_charlen
*cl
, bool cl_deferred
,
1480 gfc_array_spec
**as
, locus
*var_locus
)
1482 symbol_attribute attr
;
1487 /* Symbols in a submodule are host associated from the parent module or
1488 submodules. Therefore, they can be overridden by declarations in the
1489 submodule scope. Deal with this by attaching the existing symbol to
1490 a new symtree and recycling the old symtree with a new symbol... */
1491 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
1492 if (st
!= NULL
&& gfc_state_stack
->state
== COMP_SUBMODULE
1493 && st
->n
.sym
!= NULL
1494 && st
->n
.sym
->attr
.host_assoc
&& st
->n
.sym
->attr
.used_in_submodule
)
1496 gfc_symtree
*s
= gfc_get_unique_symtree (gfc_current_ns
);
1497 s
->n
.sym
= st
->n
.sym
;
1498 sym
= gfc_new_symbol (name
, gfc_current_ns
);
1503 gfc_set_sym_referenced (sym
);
1505 /* ...Otherwise generate a new symtree and new symbol. */
1506 else if (gfc_get_symbol (name
, NULL
, &sym
))
1509 /* Check if the name has already been defined as a type. The
1510 first letter of the symtree will be in upper case then. Of
1511 course, this is only necessary if the upper case letter is
1512 actually different. */
1514 upper
= TOUPPER(name
[0]);
1515 if (upper
!= name
[0])
1517 char u_name
[GFC_MAX_SYMBOL_LEN
+ 1];
1520 gcc_assert (strlen(name
) <= GFC_MAX_SYMBOL_LEN
);
1521 strcpy (u_name
, name
);
1524 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, u_name
);
1526 /* STRUCTURE types can alias symbol names */
1527 if (st
!= 0 && st
->n
.sym
->attr
.flavor
!= FL_STRUCT
)
1529 gfc_error ("Symbol %qs at %C also declared as a type at %L", name
,
1530 &st
->n
.sym
->declared_at
);
1535 /* Start updating the symbol table. Add basic type attribute if present. */
1536 if (current_ts
.type
!= BT_UNKNOWN
1537 && (sym
->attr
.implicit_type
== 0
1538 || !gfc_compare_types (&sym
->ts
, ¤t_ts
))
1539 && !gfc_add_type (sym
, ¤t_ts
, var_locus
))
1542 if (sym
->ts
.type
== BT_CHARACTER
)
1545 sym
->ts
.deferred
= cl_deferred
;
1548 /* Add dimension attribute if present. */
1549 if (!gfc_set_array_spec (sym
, *as
, var_locus
))
1553 /* Add attribute to symbol. The copy is so that we can reset the
1554 dimension attribute. */
1555 attr
= current_attr
;
1557 attr
.codimension
= 0;
1559 if (!gfc_copy_attr (&sym
->attr
, &attr
, var_locus
))
1562 /* Finish any work that may need to be done for the binding label,
1563 if it's a bind(c). The bind(c) attr is found before the symbol
1564 is made, and before the symbol name (for data decls), so the
1565 current_ts is holding the binding label, or nothing if the
1566 name= attr wasn't given. Therefore, test here if we're dealing
1567 with a bind(c) and make sure the binding label is set correctly. */
1568 if (sym
->attr
.is_bind_c
== 1)
1570 if (!sym
->binding_label
)
1572 /* Set the binding label and verify that if a NAME= was specified
1573 then only one identifier was in the entity-decl-list. */
1574 if (!set_binding_label (&sym
->binding_label
, sym
->name
,
1575 num_idents_on_line
))
1580 /* See if we know we're in a common block, and if it's a bind(c)
1581 common then we need to make sure we're an interoperable type. */
1582 if (sym
->attr
.in_common
== 1)
1584 /* Test the common block object. */
1585 if (sym
->common_block
!= NULL
&& sym
->common_block
->is_bind_c
== 1
1586 && sym
->ts
.is_c_interop
!= 1)
1588 gfc_error_now ("Variable %qs in common block %qs at %C "
1589 "must be declared with a C interoperable "
1590 "kind since common block %qs is BIND(C)",
1591 sym
->name
, sym
->common_block
->name
,
1592 sym
->common_block
->name
);
1597 sym
->attr
.implied_index
= 0;
1599 /* Use the parameter expressions for a parameterized derived type. */
1600 if ((sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
1601 && sym
->ts
.u
.derived
->attr
.pdt_type
&& type_param_spec_list
)
1602 sym
->param_list
= gfc_copy_actual_arglist (type_param_spec_list
);
1604 if (sym
->ts
.type
== BT_CLASS
)
1605 return gfc_build_class_symbol (&sym
->ts
, &sym
->attr
, &sym
->as
);
1611 /* Set character constant to the given length. The constant will be padded or
1612 truncated. If we're inside an array constructor without a typespec, we
1613 additionally check that all elements have the same length; check_len -1
1614 means no checking. */
1617 gfc_set_constant_character_len (gfc_charlen_t len
, gfc_expr
*expr
,
1618 gfc_charlen_t check_len
)
1623 if (expr
->ts
.type
!= BT_CHARACTER
)
1626 if (expr
->expr_type
!= EXPR_CONSTANT
)
1628 gfc_error_now ("CHARACTER length must be a constant at %L", &expr
->where
);
1632 slen
= expr
->value
.character
.length
;
1635 s
= gfc_get_wide_string (len
+ 1);
1636 memcpy (s
, expr
->value
.character
.string
,
1637 MIN (len
, slen
) * sizeof (gfc_char_t
));
1639 gfc_wide_memset (&s
[slen
], ' ', len
- slen
);
1641 if (warn_character_truncation
&& slen
> len
)
1642 gfc_warning_now (OPT_Wcharacter_truncation
,
1643 "CHARACTER expression at %L is being truncated "
1644 "(%ld/%ld)", &expr
->where
,
1645 (long) slen
, (long) len
);
1647 /* Apply the standard by 'hand' otherwise it gets cleared for
1649 if (check_len
!= -1 && slen
!= check_len
1650 && !(gfc_option
.allow_std
& GFC_STD_GNU
))
1651 gfc_error_now ("The CHARACTER elements of the array constructor "
1652 "at %L must have the same length (%ld/%ld)",
1653 &expr
->where
, (long) slen
,
1657 free (expr
->value
.character
.string
);
1658 expr
->value
.character
.string
= s
;
1659 expr
->value
.character
.length
= len
;
1664 /* Function to create and update the enumerator history
1665 using the information passed as arguments.
1666 Pointer "max_enum" is also updated, to point to
1667 enum history node containing largest initializer.
1669 SYM points to the symbol node of enumerator.
1670 INIT points to its enumerator value. */
1673 create_enum_history (gfc_symbol
*sym
, gfc_expr
*init
)
1675 enumerator_history
*new_enum_history
;
1676 gcc_assert (sym
!= NULL
&& init
!= NULL
);
1678 new_enum_history
= XCNEW (enumerator_history
);
1680 new_enum_history
->sym
= sym
;
1681 new_enum_history
->initializer
= init
;
1682 new_enum_history
->next
= NULL
;
1684 if (enum_history
== NULL
)
1686 enum_history
= new_enum_history
;
1687 max_enum
= enum_history
;
1691 new_enum_history
->next
= enum_history
;
1692 enum_history
= new_enum_history
;
1694 if (mpz_cmp (max_enum
->initializer
->value
.integer
,
1695 new_enum_history
->initializer
->value
.integer
) < 0)
1696 max_enum
= new_enum_history
;
1701 /* Function to free enum kind history. */
1704 gfc_free_enum_history (void)
1706 enumerator_history
*current
= enum_history
;
1707 enumerator_history
*next
;
1709 while (current
!= NULL
)
1711 next
= current
->next
;
1716 enum_history
= NULL
;
1720 /* Function called by variable_decl() that adds an initialization
1721 expression to a symbol. */
1724 add_init_expr_to_sym (const char *name
, gfc_expr
**initp
, locus
*var_locus
)
1726 symbol_attribute attr
;
1731 if (find_special (name
, &sym
, false))
1736 /* If this symbol is confirming an implicit parameter type,
1737 then an initialization expression is not allowed. */
1738 if (attr
.flavor
== FL_PARAMETER
1739 && sym
->value
!= NULL
1742 gfc_error ("Initializer not allowed for PARAMETER %qs at %C",
1749 /* An initializer is required for PARAMETER declarations. */
1750 if (attr
.flavor
== FL_PARAMETER
)
1752 gfc_error ("PARAMETER at %L is missing an initializer", var_locus
);
1758 /* If a variable appears in a DATA block, it cannot have an
1762 gfc_error ("Variable %qs at %C with an initializer already "
1763 "appears in a DATA statement", sym
->name
);
1767 /* Check if the assignment can happen. This has to be put off
1768 until later for derived type variables and procedure pointers. */
1769 if (!gfc_bt_struct (sym
->ts
.type
) && !gfc_bt_struct (init
->ts
.type
)
1770 && sym
->ts
.type
!= BT_CLASS
&& init
->ts
.type
!= BT_CLASS
1771 && !sym
->attr
.proc_pointer
1772 && !gfc_check_assign_symbol (sym
, NULL
, init
))
1775 if (sym
->ts
.type
== BT_CHARACTER
&& sym
->ts
.u
.cl
1776 && init
->ts
.type
== BT_CHARACTER
)
1778 /* Update symbol character length according initializer. */
1779 if (!gfc_check_assign_symbol (sym
, NULL
, init
))
1782 if (sym
->ts
.u
.cl
->length
== NULL
)
1785 /* If there are multiple CHARACTER variables declared on the
1786 same line, we don't want them to share the same length. */
1787 sym
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1789 if (sym
->attr
.flavor
== FL_PARAMETER
)
1791 if (init
->expr_type
== EXPR_CONSTANT
)
1793 clen
= init
->value
.character
.length
;
1794 sym
->ts
.u
.cl
->length
1795 = gfc_get_int_expr (gfc_charlen_int_kind
,
1798 else if (init
->expr_type
== EXPR_ARRAY
)
1800 if (init
->ts
.u
.cl
&& init
->ts
.u
.cl
->length
)
1802 const gfc_expr
*length
= init
->ts
.u
.cl
->length
;
1803 if (length
->expr_type
!= EXPR_CONSTANT
)
1805 gfc_error ("Cannot initialize parameter array "
1807 "with variable length elements",
1811 clen
= mpz_get_si (length
->value
.integer
);
1813 else if (init
->value
.constructor
)
1816 c
= gfc_constructor_first (init
->value
.constructor
);
1817 clen
= c
->expr
->value
.character
.length
;
1821 sym
->ts
.u
.cl
->length
1822 = gfc_get_int_expr (gfc_charlen_int_kind
,
1825 else if (init
->ts
.u
.cl
&& init
->ts
.u
.cl
->length
)
1826 sym
->ts
.u
.cl
->length
=
1827 gfc_copy_expr (sym
->value
->ts
.u
.cl
->length
);
1830 /* Update initializer character length according symbol. */
1831 else if (sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1833 if (!gfc_specification_expr (sym
->ts
.u
.cl
->length
))
1836 int k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
,
1838 /* resolve_charlen will complain later on if the length
1839 is too large. Just skeep the initialization in that case. */
1840 if (mpz_cmp (sym
->ts
.u
.cl
->length
->value
.integer
,
1841 gfc_integer_kinds
[k
].huge
) <= 0)
1844 = gfc_mpz_get_hwi (sym
->ts
.u
.cl
->length
->value
.integer
);
1846 if (init
->expr_type
== EXPR_CONSTANT
)
1847 gfc_set_constant_character_len (len
, init
, -1);
1848 else if (init
->expr_type
== EXPR_ARRAY
)
1852 /* Build a new charlen to prevent simplification from
1853 deleting the length before it is resolved. */
1854 init
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1855 init
->ts
.u
.cl
->length
1856 = gfc_copy_expr (sym
->ts
.u
.cl
->length
);
1858 for (c
= gfc_constructor_first (init
->value
.constructor
);
1859 c
; c
= gfc_constructor_next (c
))
1860 gfc_set_constant_character_len (len
, c
->expr
, -1);
1866 /* If sym is implied-shape, set its upper bounds from init. */
1867 if (sym
->attr
.flavor
== FL_PARAMETER
&& sym
->attr
.dimension
1868 && sym
->as
->type
== AS_IMPLIED_SHAPE
)
1872 if (init
->rank
== 0)
1874 gfc_error ("Can't initialize implied-shape array at %L"
1875 " with scalar", &sym
->declared_at
);
1879 /* Shape should be present, we get an initialization expression. */
1880 gcc_assert (init
->shape
);
1882 for (dim
= 0; dim
< sym
->as
->rank
; ++dim
)
1885 gfc_expr
*e
, *lower
;
1887 lower
= sym
->as
->lower
[dim
];
1889 /* If the lower bound is an array element from another
1890 parameterized array, then it is marked with EXPR_VARIABLE and
1891 is an initialization expression. Try to reduce it. */
1892 if (lower
->expr_type
== EXPR_VARIABLE
)
1893 gfc_reduce_init_expr (lower
);
1895 if (lower
->expr_type
== EXPR_CONSTANT
)
1897 /* All dimensions must be without upper bound. */
1898 gcc_assert (!sym
->as
->upper
[dim
]);
1901 e
= gfc_get_constant_expr (BT_INTEGER
, k
, &sym
->declared_at
);
1902 mpz_add (e
->value
.integer
, lower
->value
.integer
,
1904 mpz_sub_ui (e
->value
.integer
, e
->value
.integer
, 1);
1905 sym
->as
->upper
[dim
] = e
;
1909 gfc_error ("Non-constant lower bound in implied-shape"
1910 " declaration at %L", &lower
->where
);
1915 sym
->as
->type
= AS_EXPLICIT
;
1918 /* Need to check if the expression we initialized this
1919 to was one of the iso_c_binding named constants. If so,
1920 and we're a parameter (constant), let it be iso_c.
1922 integer(c_int), parameter :: my_int = c_int
1923 integer(my_int) :: my_int_2
1924 If we mark my_int as iso_c (since we can see it's value
1925 is equal to one of the named constants), then my_int_2
1926 will be considered C interoperable. */
1927 if (sym
->ts
.type
!= BT_CHARACTER
&& !gfc_bt_struct (sym
->ts
.type
))
1929 sym
->ts
.is_iso_c
|= init
->ts
.is_iso_c
;
1930 sym
->ts
.is_c_interop
|= init
->ts
.is_c_interop
;
1931 /* attr bits needed for module files. */
1932 sym
->attr
.is_iso_c
|= init
->ts
.is_iso_c
;
1933 sym
->attr
.is_c_interop
|= init
->ts
.is_c_interop
;
1934 if (init
->ts
.is_iso_c
)
1935 sym
->ts
.f90_type
= init
->ts
.f90_type
;
1938 /* Add initializer. Make sure we keep the ranks sane. */
1939 if (sym
->attr
.dimension
&& init
->rank
== 0)
1944 if (sym
->attr
.flavor
== FL_PARAMETER
1945 && init
->expr_type
== EXPR_CONSTANT
1946 && spec_size (sym
->as
, &size
)
1947 && mpz_cmp_si (size
, 0) > 0)
1949 array
= gfc_get_array_expr (init
->ts
.type
, init
->ts
.kind
,
1951 for (n
= 0; n
< (int)mpz_get_si (size
); n
++)
1952 gfc_constructor_append_expr (&array
->value
.constructor
,
1955 : gfc_copy_expr (init
),
1958 array
->shape
= gfc_get_shape (sym
->as
->rank
);
1959 for (n
= 0; n
< sym
->as
->rank
; n
++)
1960 spec_dimen_size (sym
->as
, n
, &array
->shape
[n
]);
1965 init
->rank
= sym
->as
->rank
;
1969 if (sym
->attr
.save
== SAVE_NONE
)
1970 sym
->attr
.save
= SAVE_IMPLICIT
;
1978 /* Function called by variable_decl() that adds a name to a structure
1982 build_struct (const char *name
, gfc_charlen
*cl
, gfc_expr
**init
,
1983 gfc_array_spec
**as
)
1988 /* F03:C438/C439. If the current symbol is of the same derived type that we're
1989 constructing, it must have the pointer attribute. */
1990 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
1991 && current_ts
.u
.derived
== gfc_current_block ()
1992 && current_attr
.pointer
== 0)
1994 if (current_attr
.allocatable
1995 && !gfc_notify_std(GFC_STD_F2008
, "Component at %C "
1996 "must have the POINTER attribute"))
2000 else if (current_attr
.allocatable
== 0)
2002 gfc_error ("Component at %C must have the POINTER attribute");
2008 if (current_ts
.type
== BT_CLASS
2009 && !(current_attr
.pointer
|| current_attr
.allocatable
))
2011 gfc_error ("Component %qs with CLASS at %C must be allocatable "
2012 "or pointer", name
);
2016 if (gfc_current_block ()->attr
.pointer
&& (*as
)->rank
!= 0)
2018 if ((*as
)->type
!= AS_DEFERRED
&& (*as
)->type
!= AS_EXPLICIT
)
2020 gfc_error ("Array component of structure at %C must have explicit "
2021 "or deferred shape");
2026 /* If we are in a nested union/map definition, gfc_add_component will not
2027 properly find repeated components because:
2028 (i) gfc_add_component does a flat search, where components of unions
2029 and maps are implicity chained so nested components may conflict.
2030 (ii) Unions and maps are not linked as components of their parent
2031 structures until after they are parsed.
2032 For (i) we use gfc_find_component which searches recursively, and for (ii)
2033 we search each block directly from the parse stack until we find the top
2036 s
= gfc_state_stack
;
2037 if (s
->state
== COMP_UNION
|| s
->state
== COMP_MAP
)
2039 while (s
->state
== COMP_UNION
|| gfc_comp_struct (s
->state
))
2041 c
= gfc_find_component (s
->sym
, name
, true, true, NULL
);
2044 gfc_error_now ("Component %qs at %C already declared at %L",
2048 /* Break after we've searched the entire chain. */
2049 if (s
->state
== COMP_DERIVED
|| s
->state
== COMP_STRUCTURE
)
2055 if (!gfc_add_component (gfc_current_block(), name
, &c
))
2059 if (c
->ts
.type
== BT_CHARACTER
)
2062 if (c
->ts
.type
!= BT_CLASS
&& c
->ts
.type
!= BT_DERIVED
2063 && (c
->ts
.kind
== 0 || c
->ts
.type
== BT_CHARACTER
)
2064 && saved_kind_expr
!= NULL
)
2065 c
->kind_expr
= gfc_copy_expr (saved_kind_expr
);
2067 c
->attr
= current_attr
;
2069 c
->initializer
= *init
;
2076 c
->attr
.codimension
= 1;
2078 c
->attr
.dimension
= 1;
2082 gfc_apply_init (&c
->ts
, &c
->attr
, c
->initializer
);
2084 /* Check array components. */
2085 if (!c
->attr
.dimension
)
2088 if (c
->attr
.pointer
)
2090 if (c
->as
->type
!= AS_DEFERRED
)
2092 gfc_error ("Pointer array component of structure at %C must have a "
2097 else if (c
->attr
.allocatable
)
2099 if (c
->as
->type
!= AS_DEFERRED
)
2101 gfc_error ("Allocatable component of structure at %C must have a "
2108 if (c
->as
->type
!= AS_EXPLICIT
)
2110 gfc_error ("Array component of structure at %C must have an "
2117 if (c
->ts
.type
== BT_CLASS
)
2118 return gfc_build_class_symbol (&c
->ts
, &c
->attr
, &c
->as
);
2120 if (c
->attr
.pdt_kind
|| c
->attr
.pdt_len
)
2123 gfc_find_symbol (c
->name
, gfc_current_block ()->f2k_derived
,
2127 gfc_error ("Type parameter %qs at %C has no corresponding entry "
2128 "in the type parameter name list at %L",
2129 c
->name
, &gfc_current_block ()->declared_at
);
2133 sym
->attr
.pdt_kind
= c
->attr
.pdt_kind
;
2134 sym
->attr
.pdt_len
= c
->attr
.pdt_len
;
2136 sym
->value
= gfc_copy_expr (c
->initializer
);
2137 sym
->attr
.flavor
= FL_VARIABLE
;
2140 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
2141 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_template
2142 && decl_type_param_list
)
2143 c
->param_list
= gfc_copy_actual_arglist (decl_type_param_list
);
2149 /* Match a 'NULL()', and possibly take care of some side effects. */
2152 gfc_match_null (gfc_expr
**result
)
2155 match m
, m2
= MATCH_NO
;
2157 if ((m
= gfc_match (" null ( )")) == MATCH_ERROR
)
2163 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2165 if ((m2
= gfc_match (" null (")) != MATCH_YES
)
2168 old_loc
= gfc_current_locus
;
2169 if ((m2
= gfc_match (" %n ) ", name
)) == MATCH_ERROR
)
2172 && ((m2
= gfc_match (" mold = %n )", name
)) == MATCH_ERROR
))
2176 gfc_current_locus
= old_loc
;
2181 /* The NULL symbol now has to be/become an intrinsic function. */
2182 if (gfc_get_symbol ("null", NULL
, &sym
))
2184 gfc_error ("NULL() initialization at %C is ambiguous");
2188 gfc_intrinsic_symbol (sym
);
2190 if (sym
->attr
.proc
!= PROC_INTRINSIC
2191 && !(sym
->attr
.use_assoc
&& sym
->attr
.intrinsic
)
2192 && (!gfc_add_procedure(&sym
->attr
, PROC_INTRINSIC
, sym
->name
, NULL
)
2193 || !gfc_add_function (&sym
->attr
, sym
->name
, NULL
)))
2196 *result
= gfc_get_null_expr (&gfc_current_locus
);
2198 /* Invalid per F2008, C512. */
2199 if (m2
== MATCH_YES
)
2201 gfc_error ("NULL() initialization at %C may not have MOLD");
2209 /* Match the initialization expr for a data pointer or procedure pointer. */
2212 match_pointer_init (gfc_expr
**init
, int procptr
)
2216 if (gfc_pure (NULL
) && !gfc_comp_struct (gfc_state_stack
->state
))
2218 gfc_error ("Initialization of pointer at %C is not allowed in "
2219 "a PURE procedure");
2222 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
2224 /* Match NULL() initialization. */
2225 m
= gfc_match_null (init
);
2229 /* Match non-NULL initialization. */
2230 gfc_matching_ptr_assignment
= !procptr
;
2231 gfc_matching_procptr_assignment
= procptr
;
2232 m
= gfc_match_rvalue (init
);
2233 gfc_matching_ptr_assignment
= 0;
2234 gfc_matching_procptr_assignment
= 0;
2235 if (m
== MATCH_ERROR
)
2237 else if (m
== MATCH_NO
)
2239 gfc_error ("Error in pointer initialization at %C");
2243 if (!procptr
&& !gfc_resolve_expr (*init
))
2246 if (!gfc_notify_std (GFC_STD_F2008
, "non-NULL pointer "
2247 "initialization at %C"))
2255 check_function_name (char *name
)
2257 /* In functions that have a RESULT variable defined, the function name always
2258 refers to function calls. Therefore, the name is not allowed to appear in
2259 specification statements. When checking this, be careful about
2260 'hidden' procedure pointer results ('ppr@'). */
2262 if (gfc_current_state () == COMP_FUNCTION
)
2264 gfc_symbol
*block
= gfc_current_block ();
2265 if (block
&& block
->result
&& block
->result
!= block
2266 && strcmp (block
->result
->name
, "ppr@") != 0
2267 && strcmp (block
->name
, name
) == 0)
2269 gfc_error ("RESULT variable %qs at %L prohibits FUNCTION name %qs at %C "
2270 "from appearing in a specification statement",
2271 block
->result
->name
, &block
->result
->declared_at
, name
);
2280 /* Match a variable name with an optional initializer. When this
2281 subroutine is called, a variable is expected to be parsed next.
2282 Depending on what is happening at the moment, updates either the
2283 symbol table or the current interface. */
2286 variable_decl (int elem
)
2288 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2289 static unsigned int fill_id
= 0;
2290 gfc_expr
*initializer
, *char_len
;
2292 gfc_array_spec
*cp_as
; /* Extra copy for Cray Pointees. */
2304 /* When we get here, we've just matched a list of attributes and
2305 maybe a type and a double colon. The next thing we expect to see
2306 is the name of the symbol. */
2308 /* If we are parsing a structure with legacy support, we allow the symbol
2309 name to be '%FILL' which gives it an anonymous (inaccessible) name. */
2311 gfc_gobble_whitespace ();
2312 if (gfc_peek_ascii_char () == '%')
2314 gfc_next_ascii_char ();
2315 m
= gfc_match ("fill");
2320 m
= gfc_match_name (name
);
2328 if (gfc_current_state () != COMP_STRUCTURE
)
2330 if (flag_dec_structure
)
2331 gfc_error ("%qs not allowed outside STRUCTURE at %C", "%FILL");
2333 gfc_error ("%qs at %C is a DEC extension, enable with "
2334 "%<-fdec-structure%>", "%FILL");
2340 gfc_error ("%qs entity cannot have attributes at %C", "%FILL");
2344 /* %FILL components are given invalid fortran names. */
2345 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "%%FILL%u", fill_id
++);
2349 var_locus
= gfc_current_locus
;
2351 /* Now we could see the optional array spec. or character length. */
2352 m
= gfc_match_array_spec (&as
, true, true);
2353 if (m
== MATCH_ERROR
)
2357 as
= gfc_copy_array_spec (current_as
);
2359 && !merge_array_spec (current_as
, as
, true))
2365 if (flag_cray_pointer
)
2366 cp_as
= gfc_copy_array_spec (as
);
2368 /* At this point, we know for sure if the symbol is PARAMETER and can thus
2369 determine (and check) whether it can be implied-shape. If it
2370 was parsed as assumed-size, change it because PARAMETERs can not
2373 An explicit-shape-array cannot appear under several conditions.
2374 That check is done here as well. */
2377 if (as
->type
== AS_IMPLIED_SHAPE
&& current_attr
.flavor
!= FL_PARAMETER
)
2380 gfc_error ("Non-PARAMETER symbol %qs at %L can't be implied-shape",
2385 if (as
->type
== AS_ASSUMED_SIZE
&& as
->rank
== 1
2386 && current_attr
.flavor
== FL_PARAMETER
)
2387 as
->type
= AS_IMPLIED_SHAPE
;
2389 if (as
->type
== AS_IMPLIED_SHAPE
2390 && !gfc_notify_std (GFC_STD_F2008
, "Implied-shape array at %L",
2397 /* F2018:C830 (R816) An explicit-shape-spec whose bounds are not
2398 constant expressions shall appear only in a subprogram, derived
2399 type definition, BLOCK construct, or interface body. */
2400 if (as
->type
== AS_EXPLICIT
2401 && gfc_current_state () != COMP_BLOCK
2402 && gfc_current_state () != COMP_DERIVED
2403 && gfc_current_state () != COMP_FUNCTION
2404 && gfc_current_state () != COMP_INTERFACE
2405 && gfc_current_state () != COMP_SUBROUTINE
)
2408 bool not_constant
= false;
2410 for (int i
= 0; i
< as
->rank
; i
++)
2412 e
= gfc_copy_expr (as
->lower
[i
]);
2413 gfc_resolve_expr (e
);
2414 gfc_simplify_expr (e
, 0);
2415 if (e
&& (e
->expr_type
!= EXPR_CONSTANT
))
2417 not_constant
= true;
2422 e
= gfc_copy_expr (as
->upper
[i
]);
2423 gfc_resolve_expr (e
);
2424 gfc_simplify_expr (e
, 0);
2425 if (e
&& (e
->expr_type
!= EXPR_CONSTANT
))
2427 not_constant
= true;
2435 gfc_error ("Explicit shaped array with nonconstant bounds at %C");
2440 if (as
->type
== AS_EXPLICIT
)
2442 for (int i
= 0; i
< as
->rank
; i
++)
2446 if (e
->expr_type
!= EXPR_CONSTANT
)
2448 n
= gfc_copy_expr (e
);
2449 gfc_simplify_expr (n
, 1);
2450 if (n
->expr_type
== EXPR_CONSTANT
)
2451 gfc_replace_expr (e
, n
);
2456 if (e
->expr_type
!= EXPR_CONSTANT
)
2458 n
= gfc_copy_expr (e
);
2459 gfc_simplify_expr (n
, 1);
2460 if (n
->expr_type
== EXPR_CONSTANT
)
2461 gfc_replace_expr (e
, n
);
2471 cl_deferred
= false;
2473 if (current_ts
.type
== BT_CHARACTER
)
2475 switch (match_char_length (&char_len
, &cl_deferred
, false))
2478 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2480 cl
->length
= char_len
;
2483 /* Non-constant lengths need to be copied after the first
2484 element. Also copy assumed lengths. */
2487 && (current_ts
.u
.cl
->length
== NULL
2488 || current_ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
2490 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2491 cl
->length
= gfc_copy_expr (current_ts
.u
.cl
->length
);
2494 cl
= current_ts
.u
.cl
;
2496 cl_deferred
= current_ts
.deferred
;
2505 /* The dummy arguments and result of the abreviated form of MODULE
2506 PROCEDUREs, used in SUBMODULES should not be redefined. */
2507 if (gfc_current_ns
->proc_name
2508 && gfc_current_ns
->proc_name
->abr_modproc_decl
)
2510 gfc_find_symbol (name
, gfc_current_ns
, 1, &sym
);
2511 if (sym
!= NULL
&& (sym
->attr
.dummy
|| sym
->attr
.result
))
2514 gfc_error ("%qs at %C is a redefinition of the declaration "
2515 "in the corresponding interface for MODULE "
2516 "PROCEDURE %qs", sym
->name
,
2517 gfc_current_ns
->proc_name
->name
);
2522 /* %FILL components may not have initializers. */
2523 if (strncmp (name
, "%FILL", 5) == 0 && gfc_match_eos () != MATCH_YES
)
2525 gfc_error ("%qs entity cannot have an initializer at %C", "%FILL");
2530 /* If this symbol has already shown up in a Cray Pointer declaration,
2531 and this is not a component declaration,
2532 then we want to set the type & bail out. */
2533 if (flag_cray_pointer
&& !gfc_comp_struct (gfc_current_state ()))
2535 gfc_find_symbol (name
, gfc_current_ns
, 1, &sym
);
2536 if (sym
!= NULL
&& sym
->attr
.cray_pointee
)
2539 if (!gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
2545 /* Check to see if we have an array specification. */
2548 if (sym
->as
!= NULL
)
2550 gfc_error ("Duplicate array spec for Cray pointee at %C");
2551 gfc_free_array_spec (cp_as
);
2557 if (!gfc_set_array_spec (sym
, cp_as
, &var_locus
))
2558 gfc_internal_error ("Couldn't set pointee array spec.");
2560 /* Fix the array spec. */
2561 m
= gfc_mod_pointee_as (sym
->as
);
2562 if (m
== MATCH_ERROR
)
2570 gfc_free_array_spec (cp_as
);
2574 /* Procedure pointer as function result. */
2575 if (gfc_current_state () == COMP_FUNCTION
2576 && strcmp ("ppr@", gfc_current_block ()->name
) == 0
2577 && strcmp (name
, gfc_current_block ()->ns
->proc_name
->name
) == 0)
2578 strcpy (name
, "ppr@");
2580 if (gfc_current_state () == COMP_FUNCTION
2581 && strcmp (name
, gfc_current_block ()->name
) == 0
2582 && gfc_current_block ()->result
2583 && strcmp ("ppr@", gfc_current_block ()->result
->name
) == 0)
2584 strcpy (name
, "ppr@");
2586 /* OK, we've successfully matched the declaration. Now put the
2587 symbol in the current namespace, because it might be used in the
2588 optional initialization expression for this symbol, e.g. this is
2591 integer, parameter :: i = huge(i)
2593 This is only true for parameters or variables of a basic type.
2594 For components of derived types, it is not true, so we don't
2595 create a symbol for those yet. If we fail to create the symbol,
2597 if (!gfc_comp_struct (gfc_current_state ())
2598 && !build_sym (name
, cl
, cl_deferred
, &as
, &var_locus
))
2604 if (!check_function_name (name
))
2610 /* We allow old-style initializations of the form
2611 integer i /2/, j(4) /3*3, 1/
2612 (if no colon has been seen). These are different from data
2613 statements in that initializers are only allowed to apply to the
2614 variable immediately preceding, i.e.
2616 is not allowed. Therefore we have to do some work manually, that
2617 could otherwise be left to the matchers for DATA statements. */
2619 if (!colon_seen
&& gfc_match (" /") == MATCH_YES
)
2621 if (!gfc_notify_std (GFC_STD_GNU
, "Old-style "
2622 "initialization at %C"))
2625 /* Allow old style initializations for components of STRUCTUREs and MAPs
2626 but not components of derived types. */
2627 else if (gfc_current_state () == COMP_DERIVED
)
2629 gfc_error ("Invalid old style initialization for derived type "
2635 /* For structure components, read the initializer as a special
2636 expression and let the rest of this function apply the initializer
2638 else if (gfc_comp_struct (gfc_current_state ()))
2640 m
= match_clist_expr (&initializer
, ¤t_ts
, as
);
2642 gfc_error ("Syntax error in old style initialization of %s at %C",
2648 /* Otherwise we treat the old style initialization just like a
2649 DATA declaration for the current variable. */
2651 return match_old_style_init (name
);
2654 /* The double colon must be present in order to have initializers.
2655 Otherwise the statement is ambiguous with an assignment statement. */
2658 if (gfc_match (" =>") == MATCH_YES
)
2660 if (!current_attr
.pointer
)
2662 gfc_error ("Initialization at %C isn't for a pointer variable");
2667 m
= match_pointer_init (&initializer
, 0);
2671 else if (gfc_match_char ('=') == MATCH_YES
)
2673 if (current_attr
.pointer
)
2675 gfc_error ("Pointer initialization at %C requires %<=>%>, "
2681 m
= gfc_match_init_expr (&initializer
);
2684 gfc_error ("Expected an initialization expression at %C");
2688 if (current_attr
.flavor
!= FL_PARAMETER
&& gfc_pure (NULL
)
2689 && !gfc_comp_struct (gfc_state_stack
->state
))
2691 gfc_error ("Initialization of variable at %C is not allowed in "
2692 "a PURE procedure");
2696 if (current_attr
.flavor
!= FL_PARAMETER
2697 && !gfc_comp_struct (gfc_state_stack
->state
))
2698 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
2705 if (initializer
!= NULL
&& current_attr
.allocatable
2706 && gfc_comp_struct (gfc_current_state ()))
2708 gfc_error ("Initialization of allocatable component at %C is not "
2714 if (gfc_current_state () == COMP_DERIVED
2715 && gfc_current_block ()->attr
.pdt_template
)
2718 gfc_find_symbol (name
, gfc_current_block ()->f2k_derived
,
2720 if (!param
&& (current_attr
.pdt_kind
|| current_attr
.pdt_len
))
2722 gfc_error ("The component with KIND or LEN attribute at %C does not "
2723 "not appear in the type parameter list at %L",
2724 &gfc_current_block ()->declared_at
);
2728 else if (param
&& !(current_attr
.pdt_kind
|| current_attr
.pdt_len
))
2730 gfc_error ("The component at %C that appears in the type parameter "
2731 "list at %L has neither the KIND nor LEN attribute",
2732 &gfc_current_block ()->declared_at
);
2736 else if (as
&& (current_attr
.pdt_kind
|| current_attr
.pdt_len
))
2738 gfc_error ("The component at %C which is a type parameter must be "
2743 else if (param
&& initializer
)
2744 param
->value
= gfc_copy_expr (initializer
);
2747 /* Add the initializer. Note that it is fine if initializer is
2748 NULL here, because we sometimes also need to check if a
2749 declaration *must* have an initialization expression. */
2750 if (!gfc_comp_struct (gfc_current_state ()))
2751 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
2754 if (current_ts
.type
== BT_DERIVED
2755 && !current_attr
.pointer
&& !initializer
)
2756 initializer
= gfc_default_initializer (¤t_ts
);
2757 t
= build_struct (name
, cl
, &initializer
, &as
);
2759 /* If we match a nested structure definition we expect to see the
2760 * body even if the variable declarations blow up, so we need to keep
2761 * the structure declaration around. */
2762 if (gfc_new_block
&& gfc_new_block
->attr
.flavor
== FL_STRUCT
)
2763 gfc_commit_symbol (gfc_new_block
);
2766 m
= (t
) ? MATCH_YES
: MATCH_ERROR
;
2769 /* Free stuff up and return. */
2770 gfc_free_expr (initializer
);
2771 gfc_free_array_spec (as
);
2777 /* Match an extended-f77 "TYPESPEC*bytesize"-style kind specification.
2778 This assumes that the byte size is equal to the kind number for
2779 non-COMPLEX types, and equal to twice the kind number for COMPLEX. */
2782 gfc_match_old_kind_spec (gfc_typespec
*ts
)
2787 if (gfc_match_char ('*') != MATCH_YES
)
2790 m
= gfc_match_small_literal_int (&ts
->kind
, NULL
);
2794 original_kind
= ts
->kind
;
2796 /* Massage the kind numbers for complex types. */
2797 if (ts
->type
== BT_COMPLEX
)
2801 gfc_error ("Old-style type declaration %s*%d not supported at %C",
2802 gfc_basic_typename (ts
->type
), original_kind
);
2809 if (ts
->type
== BT_INTEGER
&& ts
->kind
== 4 && flag_integer4_kind
== 8)
2812 if (ts
->type
== BT_REAL
|| ts
->type
== BT_COMPLEX
)
2816 if (flag_real4_kind
== 8)
2818 if (flag_real4_kind
== 10)
2820 if (flag_real4_kind
== 16)
2826 if (flag_real8_kind
== 4)
2828 if (flag_real8_kind
== 10)
2830 if (flag_real8_kind
== 16)
2835 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
2837 gfc_error ("Old-style type declaration %s*%d not supported at %C",
2838 gfc_basic_typename (ts
->type
), original_kind
);
2842 if (!gfc_notify_std (GFC_STD_GNU
,
2843 "Nonstandard type declaration %s*%d at %C",
2844 gfc_basic_typename(ts
->type
), original_kind
))
2851 /* Match a kind specification. Since kinds are generally optional, we
2852 usually return MATCH_NO if something goes wrong. If a "kind="
2853 string is found, then we know we have an error. */
2856 gfc_match_kind_spec (gfc_typespec
*ts
, bool kind_expr_only
)
2866 saved_kind_expr
= NULL
;
2868 where
= loc
= gfc_current_locus
;
2873 if (gfc_match_char ('(') == MATCH_NO
)
2876 /* Also gobbles optional text. */
2877 if (gfc_match (" kind = ") == MATCH_YES
)
2880 loc
= gfc_current_locus
;
2884 n
= gfc_match_init_expr (&e
);
2886 if (gfc_derived_parameter_expr (e
))
2889 saved_kind_expr
= gfc_copy_expr (e
);
2890 goto close_brackets
;
2895 if (gfc_matching_function
)
2897 /* The function kind expression might include use associated or
2898 imported parameters and try again after the specification
2900 if (gfc_match_char (')') != MATCH_YES
)
2902 gfc_error ("Missing right parenthesis at %C");
2908 gfc_undo_symbols ();
2913 /* ....or else, the match is real. */
2915 gfc_error ("Expected initialization expression at %C");
2923 gfc_error ("Expected scalar initialization expression at %C");
2928 if (gfc_extract_int (e
, &ts
->kind
, 1))
2934 /* Before throwing away the expression, let's see if we had a
2935 C interoperable kind (and store the fact). */
2936 if (e
->ts
.is_c_interop
== 1)
2938 /* Mark this as C interoperable if being declared with one
2939 of the named constants from iso_c_binding. */
2940 ts
->is_c_interop
= e
->ts
.is_iso_c
;
2941 ts
->f90_type
= e
->ts
.f90_type
;
2943 ts
->interop_kind
= e
->symtree
->n
.sym
;
2949 /* Ignore errors to this point, if we've gotten here. This means
2950 we ignore the m=MATCH_ERROR from above. */
2951 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
2953 gfc_error ("Kind %d not supported for type %s at %C", ts
->kind
,
2954 gfc_basic_typename (ts
->type
));
2955 gfc_current_locus
= where
;
2959 /* Warn if, e.g., c_int is used for a REAL variable, but not
2960 if, e.g., c_double is used for COMPLEX as the standard
2961 explicitly says that the kind type parameter for complex and real
2962 variable is the same, i.e. c_float == c_float_complex. */
2963 if (ts
->f90_type
!= BT_UNKNOWN
&& ts
->f90_type
!= ts
->type
2964 && !((ts
->f90_type
== BT_REAL
&& ts
->type
== BT_COMPLEX
)
2965 || (ts
->f90_type
== BT_COMPLEX
&& ts
->type
== BT_REAL
)))
2966 gfc_warning_now (0, "C kind type parameter is for type %s but type at %L "
2967 "is %s", gfc_basic_typename (ts
->f90_type
), &where
,
2968 gfc_basic_typename (ts
->type
));
2972 gfc_gobble_whitespace ();
2973 if ((c
= gfc_next_ascii_char ()) != ')'
2974 && (ts
->type
!= BT_CHARACTER
|| c
!= ','))
2976 if (ts
->type
== BT_CHARACTER
)
2977 gfc_error ("Missing right parenthesis or comma at %C");
2979 gfc_error ("Missing right parenthesis at %C");
2983 /* All tests passed. */
2986 if(m
== MATCH_ERROR
)
2987 gfc_current_locus
= where
;
2989 if (ts
->type
== BT_INTEGER
&& ts
->kind
== 4 && flag_integer4_kind
== 8)
2992 if (ts
->type
== BT_REAL
|| ts
->type
== BT_COMPLEX
)
2996 if (flag_real4_kind
== 8)
2998 if (flag_real4_kind
== 10)
3000 if (flag_real4_kind
== 16)
3006 if (flag_real8_kind
== 4)
3008 if (flag_real8_kind
== 10)
3010 if (flag_real8_kind
== 16)
3015 /* Return what we know from the test(s). */
3020 gfc_current_locus
= where
;
3026 match_char_kind (int * kind
, int * is_iso_c
)
3035 where
= gfc_current_locus
;
3037 n
= gfc_match_init_expr (&e
);
3039 if (n
!= MATCH_YES
&& gfc_matching_function
)
3041 /* The expression might include use-associated or imported
3042 parameters and try again after the specification
3045 gfc_undo_symbols ();
3050 gfc_error ("Expected initialization expression at %C");
3056 gfc_error ("Expected scalar initialization expression at %C");
3061 if (gfc_derived_parameter_expr (e
))
3063 saved_kind_expr
= e
;
3068 fail
= gfc_extract_int (e
, kind
, 1);
3069 *is_iso_c
= e
->ts
.is_iso_c
;
3078 /* Ignore errors to this point, if we've gotten here. This means
3079 we ignore the m=MATCH_ERROR from above. */
3080 if (gfc_validate_kind (BT_CHARACTER
, *kind
, true) < 0)
3082 gfc_error ("Kind %d is not supported for CHARACTER at %C", *kind
);
3086 /* All tests passed. */
3089 if (m
== MATCH_ERROR
)
3090 gfc_current_locus
= where
;
3092 /* Return what we know from the test(s). */
3097 gfc_current_locus
= where
;
3102 /* Match the various kind/length specifications in a CHARACTER
3103 declaration. We don't return MATCH_NO. */
3106 gfc_match_char_spec (gfc_typespec
*ts
)
3108 int kind
, seen_length
, is_iso_c
;
3120 /* Try the old-style specification first. */
3121 old_char_selector
= 0;
3123 m
= match_char_length (&len
, &deferred
, true);
3127 old_char_selector
= 1;
3132 m
= gfc_match_char ('(');
3135 m
= MATCH_YES
; /* Character without length is a single char. */
3139 /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ). */
3140 if (gfc_match (" kind =") == MATCH_YES
)
3142 m
= match_char_kind (&kind
, &is_iso_c
);
3144 if (m
== MATCH_ERROR
)
3149 if (gfc_match (" , len =") == MATCH_NO
)
3152 m
= char_len_param_value (&len
, &deferred
);
3155 if (m
== MATCH_ERROR
)
3162 /* Try to match "LEN = <len-param>" or "LEN = <len-param>, KIND = <int>". */
3163 if (gfc_match (" len =") == MATCH_YES
)
3165 m
= char_len_param_value (&len
, &deferred
);
3168 if (m
== MATCH_ERROR
)
3172 if (gfc_match_char (')') == MATCH_YES
)
3175 if (gfc_match (" , kind =") != MATCH_YES
)
3178 if (match_char_kind (&kind
, &is_iso_c
) == MATCH_ERROR
)
3184 /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ). */
3185 m
= char_len_param_value (&len
, &deferred
);
3188 if (m
== MATCH_ERROR
)
3192 m
= gfc_match_char (')');
3196 if (gfc_match_char (',') != MATCH_YES
)
3199 gfc_match (" kind ="); /* Gobble optional text. */
3201 m
= match_char_kind (&kind
, &is_iso_c
);
3202 if (m
== MATCH_ERROR
)
3208 /* Require a right-paren at this point. */
3209 m
= gfc_match_char (')');
3214 gfc_error ("Syntax error in CHARACTER declaration at %C");
3216 gfc_free_expr (len
);
3220 /* Deal with character functions after USE and IMPORT statements. */
3221 if (gfc_matching_function
)
3223 gfc_free_expr (len
);
3224 gfc_undo_symbols ();
3230 gfc_free_expr (len
);
3234 /* Do some final massaging of the length values. */
3235 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
3237 if (seen_length
== 0)
3238 cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
, 1);
3241 /* If gfortran ends up here, then len may be reducible to a constant.
3242 Try to do that here. If it does not reduce, simply assign len to
3243 charlen. A complication occurs with user-defined generic functions,
3244 which are not resolved. Use a private namespace to deal with
3245 generic functions. */
3247 if (len
&& len
->expr_type
!= EXPR_CONSTANT
)
3249 gfc_namespace
*old_ns
;
3252 old_ns
= gfc_current_ns
;
3253 gfc_current_ns
= gfc_get_namespace (NULL
, 0);
3255 e
= gfc_copy_expr (len
);
3256 gfc_reduce_init_expr (e
);
3257 if (e
->expr_type
== EXPR_CONSTANT
)
3259 gfc_replace_expr (len
, e
);
3260 if (mpz_cmp_si (len
->value
.integer
, 0) < 0)
3261 mpz_set_ui (len
->value
.integer
, 0);
3266 gfc_free_namespace (gfc_current_ns
);
3267 gfc_current_ns
= old_ns
;
3274 ts
->kind
= kind
== 0 ? gfc_default_character_kind
: kind
;
3275 ts
->deferred
= deferred
;
3277 /* We have to know if it was a C interoperable kind so we can
3278 do accurate type checking of bind(c) procs, etc. */
3280 /* Mark this as C interoperable if being declared with one
3281 of the named constants from iso_c_binding. */
3282 ts
->is_c_interop
= is_iso_c
;
3283 else if (len
!= NULL
)
3284 /* Here, we might have parsed something such as: character(c_char)
3285 In this case, the parsing code above grabs the c_char when
3286 looking for the length (line 1690, roughly). it's the last
3287 testcase for parsing the kind params of a character variable.
3288 However, it's not actually the length. this seems like it
3290 To see if the user used a C interop kind, test the expr
3291 of the so called length, and see if it's C interoperable. */
3292 ts
->is_c_interop
= len
->ts
.is_iso_c
;
3298 /* Matches a RECORD declaration. */
3301 match_record_decl (char *name
)
3304 old_loc
= gfc_current_locus
;
3307 m
= gfc_match (" record /");
3310 if (!flag_dec_structure
)
3312 gfc_current_locus
= old_loc
;
3313 gfc_error ("RECORD at %C is an extension, enable it with "
3317 m
= gfc_match (" %n/", name
);
3322 gfc_current_locus
= old_loc
;
3323 if (flag_dec_structure
3324 && (gfc_match (" record% ") == MATCH_YES
3325 || gfc_match (" record%t") == MATCH_YES
))
3326 gfc_error ("Structure name expected after RECORD at %C");
3334 /* This function uses the gfc_actual_arglist 'type_param_spec_list' as a source
3335 of expressions to substitute into the possibly parameterized expression
3336 'e'. Using a list is inefficient but should not be too bad since the
3337 number of type parameters is not likely to be large. */
3339 insert_parameter_exprs (gfc_expr
* e
, gfc_symbol
* sym ATTRIBUTE_UNUSED
,
3342 gfc_actual_arglist
*param
;
3345 if (e
->expr_type
!= EXPR_VARIABLE
)
3348 gcc_assert (e
->symtree
);
3349 if (e
->symtree
->n
.sym
->attr
.pdt_kind
3350 || (*f
!= 0 && e
->symtree
->n
.sym
->attr
.pdt_len
))
3352 for (param
= type_param_spec_list
; param
; param
= param
->next
)
3353 if (strcmp (e
->symtree
->n
.sym
->name
, param
->name
) == 0)
3358 copy
= gfc_copy_expr (param
->expr
);
3369 gfc_insert_kind_parameter_exprs (gfc_expr
*e
)
3371 return gfc_traverse_expr (e
, NULL
, &insert_parameter_exprs
, 0);
3376 gfc_insert_parameter_exprs (gfc_expr
*e
, gfc_actual_arglist
*param_list
)
3378 gfc_actual_arglist
*old_param_spec_list
= type_param_spec_list
;
3379 type_param_spec_list
= param_list
;
3380 return gfc_traverse_expr (e
, NULL
, &insert_parameter_exprs
, 1);
3381 type_param_spec_list
= NULL
;
3382 type_param_spec_list
= old_param_spec_list
;
3385 /* Determines the instance of a parameterized derived type to be used by
3386 matching determining the values of the kind parameters and using them
3387 in the name of the instance. If the instance exists, it is used, otherwise
3388 a new derived type is created. */
3390 gfc_get_pdt_instance (gfc_actual_arglist
*param_list
, gfc_symbol
**sym
,
3391 gfc_actual_arglist
**ext_param_list
)
3393 /* The PDT template symbol. */
3394 gfc_symbol
*pdt
= *sym
;
3395 /* The symbol for the parameter in the template f2k_namespace. */
3397 /* The hoped for instance of the PDT. */
3398 gfc_symbol
*instance
;
3399 /* The list of parameters appearing in the PDT declaration. */
3400 gfc_formal_arglist
*type_param_name_list
;
3401 /* Used to store the parameter specification list during recursive calls. */
3402 gfc_actual_arglist
*old_param_spec_list
;
3403 /* Pointers to the parameter specification being used. */
3404 gfc_actual_arglist
*actual_param
;
3405 gfc_actual_arglist
*tail
= NULL
;
3406 /* Used to build up the name of the PDT instance. The prefix uses 4
3407 characters and each KIND parameter 2 more. Allow 8 of the latter. */
3408 char name
[GFC_MAX_SYMBOL_LEN
+ 21];
3410 bool name_seen
= (param_list
== NULL
);
3411 bool assumed_seen
= false;
3412 bool deferred_seen
= false;
3413 bool spec_error
= false;
3415 gfc_expr
*kind_expr
;
3416 gfc_component
*c1
, *c2
;
3419 type_param_spec_list
= NULL
;
3421 type_param_name_list
= pdt
->formal
;
3422 actual_param
= param_list
;
3423 sprintf (name
, "Pdt%s", pdt
->name
);
3425 /* Run through the parameter name list and pick up the actual
3426 parameter values or use the default values in the PDT declaration. */
3427 for (; type_param_name_list
;
3428 type_param_name_list
= type_param_name_list
->next
)
3430 if (actual_param
&& actual_param
->spec_type
!= SPEC_EXPLICIT
)
3432 if (actual_param
->spec_type
== SPEC_ASSUMED
)
3433 spec_error
= deferred_seen
;
3435 spec_error
= assumed_seen
;
3439 gfc_error ("The type parameter spec list at %C cannot contain "
3440 "both ASSUMED and DEFERRED parameters");
3445 if (actual_param
&& actual_param
->name
)
3447 param
= type_param_name_list
->sym
;
3449 if (!param
|| !param
->name
)
3452 c1
= gfc_find_component (pdt
, param
->name
, false, true, NULL
);
3453 /* An error should already have been thrown in resolve.c
3454 (resolve_fl_derived0). */
3455 if (!pdt
->attr
.use_assoc
&& !c1
)
3461 if (!actual_param
&& !(c1
&& c1
->initializer
))
3463 gfc_error ("The type parameter spec list at %C does not contain "
3464 "enough parameter expressions");
3467 else if (!actual_param
&& c1
&& c1
->initializer
)
3468 kind_expr
= gfc_copy_expr (c1
->initializer
);
3469 else if (actual_param
&& actual_param
->spec_type
== SPEC_EXPLICIT
)
3470 kind_expr
= gfc_copy_expr (actual_param
->expr
);
3474 actual_param
= param_list
;
3475 for (;actual_param
; actual_param
= actual_param
->next
)
3476 if (actual_param
->name
3477 && strcmp (actual_param
->name
, param
->name
) == 0)
3479 if (actual_param
&& actual_param
->spec_type
== SPEC_EXPLICIT
)
3480 kind_expr
= gfc_copy_expr (actual_param
->expr
);
3483 if (c1
->initializer
)
3484 kind_expr
= gfc_copy_expr (c1
->initializer
);
3485 else if (!(actual_param
&& param
->attr
.pdt_len
))
3487 gfc_error ("The derived parameter %qs at %C does not "
3488 "have a default value", param
->name
);
3494 /* Store the current parameter expressions in a temporary actual
3495 arglist 'list' so that they can be substituted in the corresponding
3496 expressions in the PDT instance. */
3497 if (type_param_spec_list
== NULL
)
3499 type_param_spec_list
= gfc_get_actual_arglist ();
3500 tail
= type_param_spec_list
;
3504 tail
->next
= gfc_get_actual_arglist ();
3507 tail
->name
= param
->name
;
3511 /* Try simplification even for LEN expressions. */
3512 gfc_resolve_expr (kind_expr
);
3513 gfc_simplify_expr (kind_expr
, 1);
3514 /* Variable expressions seem to default to BT_PROCEDURE.
3515 TODO find out why this is and fix it. */
3516 if (kind_expr
->ts
.type
!= BT_INTEGER
3517 && kind_expr
->ts
.type
!= BT_PROCEDURE
)
3519 gfc_error ("The parameter expression at %C must be of "
3520 "INTEGER type and not %s type",
3521 gfc_basic_typename (kind_expr
->ts
.type
));
3525 tail
->expr
= gfc_copy_expr (kind_expr
);
3529 tail
->spec_type
= actual_param
->spec_type
;
3531 if (!param
->attr
.pdt_kind
)
3533 if (!name_seen
&& actual_param
)
3534 actual_param
= actual_param
->next
;
3537 gfc_free_expr (kind_expr
);
3544 && (actual_param
->spec_type
== SPEC_ASSUMED
3545 || actual_param
->spec_type
== SPEC_DEFERRED
))
3547 gfc_error ("The KIND parameter %qs at %C cannot either be "
3548 "ASSUMED or DEFERRED", param
->name
);
3552 if (!kind_expr
|| !gfc_is_constant_expr (kind_expr
))
3554 gfc_error ("The value for the KIND parameter %qs at %C does not "
3555 "reduce to a constant expression", param
->name
);
3559 gfc_extract_int (kind_expr
, &kind_value
);
3560 sprintf (name
+ strlen (name
), "_%d", kind_value
);
3562 if (!name_seen
&& actual_param
)
3563 actual_param
= actual_param
->next
;
3564 gfc_free_expr (kind_expr
);
3567 if (!name_seen
&& actual_param
)
3569 gfc_error ("The type parameter spec list at %C contains too many "
3570 "parameter expressions");
3574 /* Now we search for the PDT instance 'name'. If it doesn't exist, we
3575 build it, using 'pdt' as a template. */
3576 if (gfc_get_symbol (name
, pdt
->ns
, &instance
))
3578 gfc_error ("Parameterized derived type at %C is ambiguous");
3584 if (instance
->attr
.flavor
== FL_DERIVED
3585 && instance
->attr
.pdt_type
)
3589 *ext_param_list
= type_param_spec_list
;
3591 gfc_commit_symbols ();
3595 /* Start building the new instance of the parameterized type. */
3596 gfc_copy_attr (&instance
->attr
, &pdt
->attr
, &pdt
->declared_at
);
3597 instance
->attr
.pdt_template
= 0;
3598 instance
->attr
.pdt_type
= 1;
3599 instance
->declared_at
= gfc_current_locus
;
3601 /* Add the components, replacing the parameters in all expressions
3602 with the expressions for their values in 'type_param_spec_list'. */
3603 c1
= pdt
->components
;
3604 tail
= type_param_spec_list
;
3605 for (; c1
; c1
= c1
->next
)
3607 gfc_add_component (instance
, c1
->name
, &c2
);
3610 c2
->attr
= c1
->attr
;
3612 /* The order of declaration of the type_specs might not be the
3613 same as that of the components. */
3614 if (c1
->attr
.pdt_kind
|| c1
->attr
.pdt_len
)
3616 for (tail
= type_param_spec_list
; tail
; tail
= tail
->next
)
3617 if (strcmp (c1
->name
, tail
->name
) == 0)
3621 /* Deal with type extension by recursively calling this function
3622 to obtain the instance of the extended type. */
3623 if (gfc_current_state () != COMP_DERIVED
3624 && c1
== pdt
->components
3625 && (c1
->ts
.type
== BT_DERIVED
|| c1
->ts
.type
== BT_CLASS
)
3626 && c1
->ts
.u
.derived
&& c1
->ts
.u
.derived
->attr
.pdt_template
3627 && gfc_get_derived_super_type (*sym
) == c2
->ts
.u
.derived
)
3629 gfc_formal_arglist
*f
;
3631 old_param_spec_list
= type_param_spec_list
;
3633 /* Obtain a spec list appropriate to the extended type..*/
3634 actual_param
= gfc_copy_actual_arglist (type_param_spec_list
);
3635 type_param_spec_list
= actual_param
;
3636 for (f
= c1
->ts
.u
.derived
->formal
; f
&& f
->next
; f
= f
->next
)
3637 actual_param
= actual_param
->next
;
3640 gfc_free_actual_arglist (actual_param
->next
);
3641 actual_param
->next
= NULL
;
3644 /* Now obtain the PDT instance for the extended type. */
3645 c2
->param_list
= type_param_spec_list
;
3646 m
= gfc_get_pdt_instance (type_param_spec_list
, &c2
->ts
.u
.derived
,
3648 type_param_spec_list
= old_param_spec_list
;
3650 c2
->ts
.u
.derived
->refs
++;
3651 gfc_set_sym_referenced (c2
->ts
.u
.derived
);
3653 /* Set extension level. */
3654 if (c2
->ts
.u
.derived
->attr
.extension
== 255)
3656 /* Since the extension field is 8 bit wide, we can only have
3657 up to 255 extension levels. */
3658 gfc_error ("Maximum extension level reached with type %qs at %L",
3659 c2
->ts
.u
.derived
->name
,
3660 &c2
->ts
.u
.derived
->declared_at
);
3663 instance
->attr
.extension
= c2
->ts
.u
.derived
->attr
.extension
+ 1;
3668 /* Set the component kind using the parameterized expression. */
3669 if ((c1
->ts
.kind
== 0 || c1
->ts
.type
== BT_CHARACTER
)
3670 && c1
->kind_expr
!= NULL
)
3672 gfc_expr
*e
= gfc_copy_expr (c1
->kind_expr
);
3673 gfc_insert_kind_parameter_exprs (e
);
3674 gfc_simplify_expr (e
, 1);
3675 gfc_extract_int (e
, &c2
->ts
.kind
);
3677 if (gfc_validate_kind (c2
->ts
.type
, c2
->ts
.kind
, true) < 0)
3679 gfc_error ("Kind %d not supported for type %s at %C",
3680 c2
->ts
.kind
, gfc_basic_typename (c2
->ts
.type
));
3685 /* Similarly, set the string length if parameterized. */
3686 if (c1
->ts
.type
== BT_CHARACTER
3687 && c1
->ts
.u
.cl
->length
3688 && gfc_derived_parameter_expr (c1
->ts
.u
.cl
->length
))
3691 e
= gfc_copy_expr (c1
->ts
.u
.cl
->length
);
3692 gfc_insert_kind_parameter_exprs (e
);
3693 gfc_simplify_expr (e
, 1);
3694 c2
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
3695 c2
->ts
.u
.cl
->length
= e
;
3696 c2
->attr
.pdt_string
= 1;
3699 /* Set up either the KIND/LEN initializer, if constant,
3700 or the parameterized expression. Use the template
3701 initializer if one is not already set in this instance. */
3702 if (c2
->attr
.pdt_kind
|| c2
->attr
.pdt_len
)
3704 if (tail
&& tail
->expr
&& gfc_is_constant_expr (tail
->expr
))
3705 c2
->initializer
= gfc_copy_expr (tail
->expr
);
3706 else if (tail
&& tail
->expr
)
3708 c2
->param_list
= gfc_get_actual_arglist ();
3709 c2
->param_list
->name
= tail
->name
;
3710 c2
->param_list
->expr
= gfc_copy_expr (tail
->expr
);
3711 c2
->param_list
->next
= NULL
;
3714 if (!c2
->initializer
&& c1
->initializer
)
3715 c2
->initializer
= gfc_copy_expr (c1
->initializer
);
3718 /* Copy the array spec. */
3719 c2
->as
= gfc_copy_array_spec (c1
->as
);
3720 if (c1
->ts
.type
== BT_CLASS
)
3721 CLASS_DATA (c2
)->as
= gfc_copy_array_spec (CLASS_DATA (c1
)->as
);
3723 /* Determine if an array spec is parameterized. If so, substitute
3724 in the parameter expressions for the bounds and set the pdt_array
3725 attribute. Notice that this attribute must be unconditionally set
3726 if this is an array of parameterized character length. */
3727 if (c1
->as
&& c1
->as
->type
== AS_EXPLICIT
)
3729 bool pdt_array
= false;
3731 /* Are the bounds of the array parameterized? */
3732 for (i
= 0; i
< c1
->as
->rank
; i
++)
3734 if (gfc_derived_parameter_expr (c1
->as
->lower
[i
]))
3736 if (gfc_derived_parameter_expr (c1
->as
->upper
[i
]))
3740 /* If they are, free the expressions for the bounds and
3741 replace them with the template expressions with substitute
3743 for (i
= 0; pdt_array
&& i
< c1
->as
->rank
; i
++)
3746 e
= gfc_copy_expr (c1
->as
->lower
[i
]);
3747 gfc_insert_kind_parameter_exprs (e
);
3748 gfc_simplify_expr (e
, 1);
3749 gfc_free_expr (c2
->as
->lower
[i
]);
3750 c2
->as
->lower
[i
] = e
;
3751 e
= gfc_copy_expr (c1
->as
->upper
[i
]);
3752 gfc_insert_kind_parameter_exprs (e
);
3753 gfc_simplify_expr (e
, 1);
3754 gfc_free_expr (c2
->as
->upper
[i
]);
3755 c2
->as
->upper
[i
] = e
;
3757 c2
->attr
.pdt_array
= pdt_array
? 1 : c2
->attr
.pdt_string
;
3758 if (c1
->initializer
)
3760 c2
->initializer
= gfc_copy_expr (c1
->initializer
);
3761 gfc_insert_kind_parameter_exprs (c2
->initializer
);
3762 gfc_simplify_expr (c2
->initializer
, 1);
3766 /* Recurse into this function for PDT components. */
3767 if ((c1
->ts
.type
== BT_DERIVED
|| c1
->ts
.type
== BT_CLASS
)
3768 && c1
->ts
.u
.derived
&& c1
->ts
.u
.derived
->attr
.pdt_template
)
3770 gfc_actual_arglist
*params
;
3771 /* The component in the template has a list of specification
3772 expressions derived from its declaration. */
3773 params
= gfc_copy_actual_arglist (c1
->param_list
);
3774 actual_param
= params
;
3775 /* Substitute the template parameters with the expressions
3776 from the specification list. */
3777 for (;actual_param
; actual_param
= actual_param
->next
)
3778 gfc_insert_parameter_exprs (actual_param
->expr
,
3779 type_param_spec_list
);
3781 /* Now obtain the PDT instance for the component. */
3782 old_param_spec_list
= type_param_spec_list
;
3783 m
= gfc_get_pdt_instance (params
, &c2
->ts
.u
.derived
, NULL
);
3784 type_param_spec_list
= old_param_spec_list
;
3786 c2
->param_list
= params
;
3787 if (!(c2
->attr
.pointer
|| c2
->attr
.allocatable
))
3788 c2
->initializer
= gfc_default_initializer (&c2
->ts
);
3790 if (c2
->attr
.allocatable
)
3791 instance
->attr
.alloc_comp
= 1;
3795 gfc_commit_symbol (instance
);
3797 *ext_param_list
= type_param_spec_list
;
3802 gfc_free_actual_arglist (type_param_spec_list
);
3807 /* Matches a declaration-type-spec (F03:R502). If successful, sets the ts
3808 structure to the matched specification. This is necessary for FUNCTION and
3809 IMPLICIT statements.
3811 If implicit_flag is nonzero, then we don't check for the optional
3812 kind specification. Not doing so is needed for matching an IMPLICIT
3813 statement correctly. */
3816 gfc_match_decl_type_spec (gfc_typespec
*ts
, int implicit_flag
)
3818 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3819 gfc_symbol
*sym
, *dt_sym
;
3822 bool seen_deferred_kind
, matched_type
;
3823 const char *dt_name
;
3825 decl_type_param_list
= NULL
;
3827 /* A belt and braces check that the typespec is correctly being treated
3828 as a deferred characteristic association. */
3829 seen_deferred_kind
= (gfc_current_state () == COMP_FUNCTION
)
3830 && (gfc_current_block ()->result
->ts
.kind
== -1)
3831 && (ts
->kind
== -1);
3833 if (seen_deferred_kind
)
3836 /* Clear the current binding label, in case one is given. */
3837 curr_binding_label
= NULL
;
3839 if (gfc_match (" byte") == MATCH_YES
)
3841 if (!gfc_notify_std (GFC_STD_GNU
, "BYTE type at %C"))
3844 if (gfc_validate_kind (BT_INTEGER
, 1, true) < 0)
3846 gfc_error ("BYTE type used at %C "
3847 "is not available on the target machine");
3851 ts
->type
= BT_INTEGER
;
3857 m
= gfc_match (" type (");
3858 matched_type
= (m
== MATCH_YES
);
3861 gfc_gobble_whitespace ();
3862 if (gfc_peek_ascii_char () == '*')
3864 if ((m
= gfc_match ("*)")) != MATCH_YES
)
3866 if (gfc_comp_struct (gfc_current_state ()))
3868 gfc_error ("Assumed type at %C is not allowed for components");
3871 if (!gfc_notify_std (GFC_STD_F2018
, "Assumed type at %C"))
3873 ts
->type
= BT_ASSUMED
;
3877 m
= gfc_match ("%n", name
);
3878 matched_type
= (m
== MATCH_YES
);
3881 if ((matched_type
&& strcmp ("integer", name
) == 0)
3882 || (!matched_type
&& gfc_match (" integer") == MATCH_YES
))
3884 ts
->type
= BT_INTEGER
;
3885 ts
->kind
= gfc_default_integer_kind
;
3889 if ((matched_type
&& strcmp ("character", name
) == 0)
3890 || (!matched_type
&& gfc_match (" character") == MATCH_YES
))
3893 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
3894 "intrinsic-type-spec at %C"))
3897 ts
->type
= BT_CHARACTER
;
3898 if (implicit_flag
== 0)
3899 m
= gfc_match_char_spec (ts
);
3903 if (matched_type
&& m
== MATCH_YES
&& gfc_match_char (')') != MATCH_YES
)
3909 if ((matched_type
&& strcmp ("real", name
) == 0)
3910 || (!matched_type
&& gfc_match (" real") == MATCH_YES
))
3913 ts
->kind
= gfc_default_real_kind
;
3918 && (strcmp ("doubleprecision", name
) == 0
3919 || (strcmp ("double", name
) == 0
3920 && gfc_match (" precision") == MATCH_YES
)))
3921 || (!matched_type
&& gfc_match (" double precision") == MATCH_YES
))
3924 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
3925 "intrinsic-type-spec at %C"))
3927 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
3931 ts
->kind
= gfc_default_double_kind
;
3935 if ((matched_type
&& strcmp ("complex", name
) == 0)
3936 || (!matched_type
&& gfc_match (" complex") == MATCH_YES
))
3938 ts
->type
= BT_COMPLEX
;
3939 ts
->kind
= gfc_default_complex_kind
;
3944 && (strcmp ("doublecomplex", name
) == 0
3945 || (strcmp ("double", name
) == 0
3946 && gfc_match (" complex") == MATCH_YES
)))
3947 || (!matched_type
&& gfc_match (" double complex") == MATCH_YES
))
3949 if (!gfc_notify_std (GFC_STD_GNU
, "DOUBLE COMPLEX at %C"))
3953 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
3954 "intrinsic-type-spec at %C"))
3957 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
3960 ts
->type
= BT_COMPLEX
;
3961 ts
->kind
= gfc_default_double_kind
;
3965 if ((matched_type
&& strcmp ("logical", name
) == 0)
3966 || (!matched_type
&& gfc_match (" logical") == MATCH_YES
))
3968 ts
->type
= BT_LOGICAL
;
3969 ts
->kind
= gfc_default_logical_kind
;
3975 m
= gfc_match_actual_arglist (1, &decl_type_param_list
, true);
3976 if (m
== MATCH_ERROR
)
3979 m
= gfc_match_char (')');
3983 m
= match_record_decl (name
);
3985 if (matched_type
|| m
== MATCH_YES
)
3987 ts
->type
= BT_DERIVED
;
3988 /* We accept record/s/ or type(s) where s is a structure, but we
3989 * don't need all the extra derived-type stuff for structures. */
3990 if (gfc_find_symbol (gfc_dt_upper_string (name
), NULL
, 1, &sym
))
3992 gfc_error ("Type name %qs at %C is ambiguous", name
);
3996 if (sym
&& sym
->attr
.flavor
== FL_DERIVED
3997 && sym
->attr
.pdt_template
3998 && gfc_current_state () != COMP_DERIVED
)
4000 m
= gfc_get_pdt_instance (decl_type_param_list
, &sym
, NULL
);
4003 gcc_assert (!sym
->attr
.pdt_template
&& sym
->attr
.pdt_type
);
4004 ts
->u
.derived
= sym
;
4005 strcpy (name
, gfc_dt_lower_string (sym
->name
));
4008 if (sym
&& sym
->attr
.flavor
== FL_STRUCT
)
4010 ts
->u
.derived
= sym
;
4013 /* Actually a derived type. */
4018 /* Match nested STRUCTURE declarations; only valid within another
4019 structure declaration. */
4020 if (flag_dec_structure
4021 && (gfc_current_state () == COMP_STRUCTURE
4022 || gfc_current_state () == COMP_MAP
))
4024 m
= gfc_match (" structure");
4027 m
= gfc_match_structure_decl ();
4030 /* gfc_new_block is updated by match_structure_decl. */
4031 ts
->type
= BT_DERIVED
;
4032 ts
->u
.derived
= gfc_new_block
;
4036 if (m
== MATCH_ERROR
)
4040 /* Match CLASS declarations. */
4041 m
= gfc_match (" class ( * )");
4042 if (m
== MATCH_ERROR
)
4044 else if (m
== MATCH_YES
)
4048 ts
->type
= BT_CLASS
;
4049 gfc_find_symbol ("STAR", gfc_current_ns
, 1, &upe
);
4052 upe
= gfc_new_symbol ("STAR", gfc_current_ns
);
4053 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "STAR");
4055 gfc_set_sym_referenced (upe
);
4057 upe
->ts
.type
= BT_VOID
;
4058 upe
->attr
.unlimited_polymorphic
= 1;
4059 /* This is essential to force the construction of
4060 unlimited polymorphic component class containers. */
4061 upe
->attr
.zero_comp
= 1;
4062 if (!gfc_add_flavor (&upe
->attr
, FL_DERIVED
, NULL
,
4063 &gfc_current_locus
))
4068 st
= gfc_get_tbp_symtree (&gfc_current_ns
->sym_root
, "STAR");
4072 ts
->u
.derived
= upe
;
4076 m
= gfc_match (" class (");
4079 m
= gfc_match ("%n", name
);
4085 ts
->type
= BT_CLASS
;
4087 if (!gfc_notify_std (GFC_STD_F2003
, "CLASS statement at %C"))
4090 m
= gfc_match_actual_arglist (1, &decl_type_param_list
, true);
4091 if (m
== MATCH_ERROR
)
4094 m
= gfc_match_char (')');
4099 /* Defer association of the derived type until the end of the
4100 specification block. However, if the derived type can be
4101 found, add it to the typespec. */
4102 if (gfc_matching_function
)
4104 ts
->u
.derived
= NULL
;
4105 if (gfc_current_state () != COMP_INTERFACE
4106 && !gfc_find_symbol (name
, NULL
, 1, &sym
) && sym
)
4108 sym
= gfc_find_dt_in_generic (sym
);
4109 ts
->u
.derived
= sym
;
4114 /* Search for the name but allow the components to be defined later. If
4115 type = -1, this typespec has been seen in a function declaration but
4116 the type could not be accessed at that point. The actual derived type is
4117 stored in a symtree with the first letter of the name capitalized; the
4118 symtree with the all lower-case name contains the associated
4119 generic function. */
4120 dt_name
= gfc_dt_upper_string (name
);
4125 gfc_get_ha_symbol (name
, &sym
);
4126 if (sym
->generic
&& gfc_find_symbol (dt_name
, NULL
, 0, &dt_sym
))
4128 gfc_error ("Type name %qs at %C is ambiguous", name
);
4131 if (sym
->generic
&& !dt_sym
)
4132 dt_sym
= gfc_find_dt_in_generic (sym
);
4134 /* Host associated PDTs can get confused with their constructors
4135 because they ar instantiated in the template's namespace. */
4138 if (gfc_find_symbol (dt_name
, NULL
, 1, &dt_sym
))
4140 gfc_error ("Type name %qs at %C is ambiguous", name
);
4143 if (dt_sym
&& !dt_sym
->attr
.pdt_type
)
4147 else if (ts
->kind
== -1)
4149 int iface
= gfc_state_stack
->previous
->state
!= COMP_INTERFACE
4150 || gfc_current_ns
->has_import_set
;
4151 gfc_find_symbol (name
, NULL
, iface
, &sym
);
4152 if (sym
&& sym
->generic
&& gfc_find_symbol (dt_name
, NULL
, 1, &dt_sym
))
4154 gfc_error ("Type name %qs at %C is ambiguous", name
);
4157 if (sym
&& sym
->generic
&& !dt_sym
)
4158 dt_sym
= gfc_find_dt_in_generic (sym
);
4165 if ((sym
->attr
.flavor
!= FL_UNKNOWN
&& sym
->attr
.flavor
!= FL_STRUCT
4166 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.generic
))
4167 || sym
->attr
.subroutine
)
4169 gfc_error ("Type name %qs at %C conflicts with previously declared "
4170 "entity at %L, which has the same name", name
,
4175 if (sym
&& sym
->attr
.flavor
== FL_DERIVED
4176 && sym
->attr
.pdt_template
4177 && gfc_current_state () != COMP_DERIVED
)
4179 m
= gfc_get_pdt_instance (decl_type_param_list
, &sym
, NULL
);
4182 gcc_assert (!sym
->attr
.pdt_template
&& sym
->attr
.pdt_type
);
4183 ts
->u
.derived
= sym
;
4184 strcpy (name
, gfc_dt_lower_string (sym
->name
));
4187 gfc_save_symbol_data (sym
);
4188 gfc_set_sym_referenced (sym
);
4189 if (!sym
->attr
.generic
4190 && !gfc_add_generic (&sym
->attr
, sym
->name
, NULL
))
4193 if (!sym
->attr
.function
4194 && !gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
4197 if (dt_sym
&& dt_sym
->attr
.flavor
== FL_DERIVED
4198 && dt_sym
->attr
.pdt_template
4199 && gfc_current_state () != COMP_DERIVED
)
4201 m
= gfc_get_pdt_instance (decl_type_param_list
, &dt_sym
, NULL
);
4204 gcc_assert (!dt_sym
->attr
.pdt_template
&& dt_sym
->attr
.pdt_type
);
4209 gfc_interface
*intr
, *head
;
4211 /* Use upper case to save the actual derived-type symbol. */
4212 gfc_get_symbol (dt_name
, NULL
, &dt_sym
);
4213 dt_sym
->name
= gfc_get_string ("%s", sym
->name
);
4214 head
= sym
->generic
;
4215 intr
= gfc_get_interface ();
4217 intr
->where
= gfc_current_locus
;
4219 sym
->generic
= intr
;
4220 sym
->attr
.if_source
= IFSRC_DECL
;
4223 gfc_save_symbol_data (dt_sym
);
4225 gfc_set_sym_referenced (dt_sym
);
4227 if (dt_sym
->attr
.flavor
!= FL_DERIVED
&& dt_sym
->attr
.flavor
!= FL_STRUCT
4228 && !gfc_add_flavor (&dt_sym
->attr
, FL_DERIVED
, sym
->name
, NULL
))
4231 ts
->u
.derived
= dt_sym
;
4237 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
4238 "intrinsic-type-spec at %C"))
4241 /* For all types except double, derived and character, look for an
4242 optional kind specifier. MATCH_NO is actually OK at this point. */
4243 if (implicit_flag
== 1)
4245 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
4251 if (gfc_current_form
== FORM_FREE
)
4253 c
= gfc_peek_ascii_char ();
4254 if (!gfc_is_whitespace (c
) && c
!= '*' && c
!= '('
4255 && c
!= ':' && c
!= ',')
4257 if (matched_type
&& c
== ')')
4259 gfc_next_ascii_char ();
4266 m
= gfc_match_kind_spec (ts
, false);
4267 if (m
== MATCH_NO
&& ts
->type
!= BT_CHARACTER
)
4269 m
= gfc_match_old_kind_spec (ts
);
4270 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) == -1)
4274 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
4277 /* Defer association of the KIND expression of function results
4278 until after USE and IMPORT statements. */
4279 if ((gfc_current_state () == COMP_NONE
&& gfc_error_flag_test ())
4280 || gfc_matching_function
)
4284 m
= MATCH_YES
; /* No kind specifier found. */
4290 /* Match an IMPLICIT NONE statement. Actually, this statement is
4291 already matched in parse.c, or we would not end up here in the
4292 first place. So the only thing we need to check, is if there is
4293 trailing garbage. If not, the match is successful. */
4296 gfc_match_implicit_none (void)
4300 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4302 bool external
= false;
4303 locus cur_loc
= gfc_current_locus
;
4305 if (gfc_current_ns
->seen_implicit_none
4306 || gfc_current_ns
->has_implicit_none_export
)
4308 gfc_error ("Duplicate IMPLICIT NONE statement at %C");
4312 gfc_gobble_whitespace ();
4313 c
= gfc_peek_ascii_char ();
4316 (void) gfc_next_ascii_char ();
4317 if (!gfc_notify_std (GFC_STD_F2018
, "IMPORT NONE with spec list at %C"))
4320 gfc_gobble_whitespace ();
4321 if (gfc_peek_ascii_char () == ')')
4323 (void) gfc_next_ascii_char ();
4329 m
= gfc_match (" %n", name
);
4333 if (strcmp (name
, "type") == 0)
4335 else if (strcmp (name
, "external") == 0)
4340 gfc_gobble_whitespace ();
4341 c
= gfc_next_ascii_char ();
4352 if (gfc_match_eos () != MATCH_YES
)
4355 gfc_set_implicit_none (type
, external
, &cur_loc
);
4361 /* Match the letter range(s) of an IMPLICIT statement. */
4364 match_implicit_range (void)
4370 cur_loc
= gfc_current_locus
;
4372 gfc_gobble_whitespace ();
4373 c
= gfc_next_ascii_char ();
4376 gfc_error ("Missing character range in IMPLICIT at %C");
4383 gfc_gobble_whitespace ();
4384 c1
= gfc_next_ascii_char ();
4388 gfc_gobble_whitespace ();
4389 c
= gfc_next_ascii_char ();
4394 inner
= 0; /* Fall through. */
4401 gfc_gobble_whitespace ();
4402 c2
= gfc_next_ascii_char ();
4406 gfc_gobble_whitespace ();
4407 c
= gfc_next_ascii_char ();
4409 if ((c
!= ',') && (c
!= ')'))
4422 gfc_error ("Letters must be in alphabetic order in "
4423 "IMPLICIT statement at %C");
4427 /* See if we can add the newly matched range to the pending
4428 implicits from this IMPLICIT statement. We do not check for
4429 conflicts with whatever earlier IMPLICIT statements may have
4430 set. This is done when we've successfully finished matching
4432 if (!gfc_add_new_implicit_range (c1
, c2
))
4439 gfc_syntax_error (ST_IMPLICIT
);
4441 gfc_current_locus
= cur_loc
;
4446 /* Match an IMPLICIT statement, storing the types for
4447 gfc_set_implicit() if the statement is accepted by the parser.
4448 There is a strange looking, but legal syntactic construction
4449 possible. It looks like:
4451 IMPLICIT INTEGER (a-b) (c-d)
4453 This is legal if "a-b" is a constant expression that happens to
4454 equal one of the legal kinds for integers. The real problem
4455 happens with an implicit specification that looks like:
4457 IMPLICIT INTEGER (a-b)
4459 In this case, a typespec matcher that is "greedy" (as most of the
4460 matchers are) gobbles the character range as a kindspec, leaving
4461 nothing left. We therefore have to go a bit more slowly in the
4462 matching process by inhibiting the kindspec checking during
4463 typespec matching and checking for a kind later. */
4466 gfc_match_implicit (void)
4473 if (gfc_current_ns
->seen_implicit_none
)
4475 gfc_error ("IMPLICIT statement at %C following an IMPLICIT NONE (type) "
4482 /* We don't allow empty implicit statements. */
4483 if (gfc_match_eos () == MATCH_YES
)
4485 gfc_error ("Empty IMPLICIT statement at %C");
4491 /* First cleanup. */
4492 gfc_clear_new_implicit ();
4494 /* A basic type is mandatory here. */
4495 m
= gfc_match_decl_type_spec (&ts
, 1);
4496 if (m
== MATCH_ERROR
)
4501 cur_loc
= gfc_current_locus
;
4502 m
= match_implicit_range ();
4506 /* We may have <TYPE> (<RANGE>). */
4507 gfc_gobble_whitespace ();
4508 c
= gfc_peek_ascii_char ();
4509 if (c
== ',' || c
== '\n' || c
== ';' || c
== '!')
4511 /* Check for CHARACTER with no length parameter. */
4512 if (ts
.type
== BT_CHARACTER
&& !ts
.u
.cl
)
4514 ts
.kind
= gfc_default_character_kind
;
4515 ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4516 ts
.u
.cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
,
4520 /* Record the Successful match. */
4521 if (!gfc_merge_new_implicit (&ts
))
4524 c
= gfc_next_ascii_char ();
4525 else if (gfc_match_eos () == MATCH_ERROR
)
4530 gfc_current_locus
= cur_loc
;
4533 /* Discard the (incorrectly) matched range. */
4534 gfc_clear_new_implicit ();
4536 /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
4537 if (ts
.type
== BT_CHARACTER
)
4538 m
= gfc_match_char_spec (&ts
);
4541 m
= gfc_match_kind_spec (&ts
, false);
4544 m
= gfc_match_old_kind_spec (&ts
);
4545 if (m
== MATCH_ERROR
)
4551 if (m
== MATCH_ERROR
)
4554 m
= match_implicit_range ();
4555 if (m
== MATCH_ERROR
)
4560 gfc_gobble_whitespace ();
4561 c
= gfc_next_ascii_char ();
4562 if (c
!= ',' && gfc_match_eos () != MATCH_YES
)
4565 if (!gfc_merge_new_implicit (&ts
))
4573 gfc_syntax_error (ST_IMPLICIT
);
4581 gfc_match_import (void)
4583 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4588 if (gfc_current_ns
->proc_name
== NULL
4589 || gfc_current_ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
4591 gfc_error ("IMPORT statement at %C only permitted in "
4592 "an INTERFACE body");
4596 if (gfc_current_ns
->proc_name
->attr
.module_procedure
)
4598 gfc_error ("F2008: C1210 IMPORT statement at %C is not permitted "
4599 "in a module procedure interface body");
4603 if (!gfc_notify_std (GFC_STD_F2003
, "IMPORT statement at %C"))
4606 if (gfc_match_eos () == MATCH_YES
)
4608 /* All host variables should be imported. */
4609 gfc_current_ns
->has_import_set
= 1;
4613 if (gfc_match (" ::") == MATCH_YES
)
4615 if (gfc_match_eos () == MATCH_YES
)
4617 gfc_error ("Expecting list of named entities at %C");
4625 m
= gfc_match (" %n", name
);
4629 if (gfc_current_ns
->parent
!= NULL
4630 && gfc_find_symbol (name
, gfc_current_ns
->parent
, 1, &sym
))
4632 gfc_error ("Type name %qs at %C is ambiguous", name
);
4635 else if (!sym
&& gfc_current_ns
->proc_name
->ns
->parent
!= NULL
4636 && gfc_find_symbol (name
,
4637 gfc_current_ns
->proc_name
->ns
->parent
,
4640 gfc_error ("Type name %qs at %C is ambiguous", name
);
4646 gfc_error ("Cannot IMPORT %qs from host scoping unit "
4647 "at %C - does not exist.", name
);
4651 if (gfc_find_symtree (gfc_current_ns
->sym_root
, name
))
4653 gfc_warning (0, "%qs is already IMPORTed from host scoping unit "
4658 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, name
);
4661 sym
->attr
.imported
= 1;
4663 if (sym
->attr
.generic
&& (sym
= gfc_find_dt_in_generic (sym
)))
4665 /* The actual derived type is stored in a symtree with the first
4666 letter of the name capitalized; the symtree with the all
4667 lower-case name contains the associated generic function. */
4668 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
,
4669 gfc_dt_upper_string (name
));
4672 sym
->attr
.imported
= 1;
4685 if (gfc_match_eos () == MATCH_YES
)
4687 if (gfc_match_char (',') != MATCH_YES
)
4694 gfc_error ("Syntax error in IMPORT statement at %C");
4699 /* A minimal implementation of gfc_match without whitespace, escape
4700 characters or variable arguments. Returns true if the next
4701 characters match the TARGET template exactly. */
4704 match_string_p (const char *target
)
4708 for (p
= target
; *p
; p
++)
4709 if ((char) gfc_next_ascii_char () != *p
)
4714 /* Matches an attribute specification including array specs. If
4715 successful, leaves the variables current_attr and current_as
4716 holding the specification. Also sets the colon_seen variable for
4717 later use by matchers associated with initializations.
4719 This subroutine is a little tricky in the sense that we don't know
4720 if we really have an attr-spec until we hit the double colon.
4721 Until that time, we can only return MATCH_NO. This forces us to
4722 check for duplicate specification at this level. */
4725 match_attr_spec (void)
4727 /* Modifiers that can exist in a type statement. */
4729 { GFC_DECL_BEGIN
= 0,
4730 DECL_ALLOCATABLE
= GFC_DECL_BEGIN
, DECL_DIMENSION
, DECL_EXTERNAL
,
4731 DECL_IN
, DECL_OUT
, DECL_INOUT
, DECL_INTRINSIC
, DECL_OPTIONAL
,
4732 DECL_PARAMETER
, DECL_POINTER
, DECL_PROTECTED
, DECL_PRIVATE
,
4733 DECL_STATIC
, DECL_AUTOMATIC
,
4734 DECL_PUBLIC
, DECL_SAVE
, DECL_TARGET
, DECL_VALUE
, DECL_VOLATILE
,
4735 DECL_IS_BIND_C
, DECL_CODIMENSION
, DECL_ASYNCHRONOUS
, DECL_CONTIGUOUS
,
4736 DECL_LEN
, DECL_KIND
, DECL_NONE
, GFC_DECL_END
/* Sentinel */
4739 /* GFC_DECL_END is the sentinel, index starts at 0. */
4740 #define NUM_DECL GFC_DECL_END
4742 locus start
, seen_at
[NUM_DECL
];
4749 gfc_clear_attr (¤t_attr
);
4750 start
= gfc_current_locus
;
4756 /* See if we get all of the keywords up to the final double colon. */
4757 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
4765 gfc_gobble_whitespace ();
4767 ch
= gfc_next_ascii_char ();
4770 /* This is the successful exit condition for the loop. */
4771 if (gfc_next_ascii_char () == ':')
4776 gfc_gobble_whitespace ();
4777 switch (gfc_peek_ascii_char ())
4780 gfc_next_ascii_char ();
4781 switch (gfc_next_ascii_char ())
4784 if (match_string_p ("locatable"))
4786 /* Matched "allocatable". */
4787 d
= DECL_ALLOCATABLE
;
4792 if (match_string_p ("ynchronous"))
4794 /* Matched "asynchronous". */
4795 d
= DECL_ASYNCHRONOUS
;
4800 if (match_string_p ("tomatic"))
4802 /* Matched "automatic". */
4810 /* Try and match the bind(c). */
4811 m
= gfc_match_bind_c (NULL
, true);
4814 else if (m
== MATCH_ERROR
)
4819 gfc_next_ascii_char ();
4820 if ('o' != gfc_next_ascii_char ())
4822 switch (gfc_next_ascii_char ())
4825 if (match_string_p ("imension"))
4827 d
= DECL_CODIMENSION
;
4832 if (match_string_p ("tiguous"))
4834 d
= DECL_CONTIGUOUS
;
4841 if (match_string_p ("dimension"))
4846 if (match_string_p ("external"))
4851 if (match_string_p ("int"))
4853 ch
= gfc_next_ascii_char ();
4856 if (match_string_p ("nt"))
4858 /* Matched "intent". */
4859 /* TODO: Call match_intent_spec from here. */
4860 if (gfc_match (" ( in out )") == MATCH_YES
)
4862 else if (gfc_match (" ( in )") == MATCH_YES
)
4864 else if (gfc_match (" ( out )") == MATCH_YES
)
4870 if (match_string_p ("insic"))
4872 /* Matched "intrinsic". */
4880 if (match_string_p ("kind"))
4885 if (match_string_p ("len"))
4890 if (match_string_p ("optional"))
4895 gfc_next_ascii_char ();
4896 switch (gfc_next_ascii_char ())
4899 if (match_string_p ("rameter"))
4901 /* Matched "parameter". */
4907 if (match_string_p ("inter"))
4909 /* Matched "pointer". */
4915 ch
= gfc_next_ascii_char ();
4918 if (match_string_p ("vate"))
4920 /* Matched "private". */
4926 if (match_string_p ("tected"))
4928 /* Matched "protected". */
4935 if (match_string_p ("blic"))
4937 /* Matched "public". */
4945 gfc_next_ascii_char ();
4946 switch (gfc_next_ascii_char ())
4949 if (match_string_p ("ve"))
4951 /* Matched "save". */
4957 if (match_string_p ("atic"))
4959 /* Matched "static". */
4967 if (match_string_p ("target"))
4972 gfc_next_ascii_char ();
4973 ch
= gfc_next_ascii_char ();
4976 if (match_string_p ("lue"))
4978 /* Matched "value". */
4984 if (match_string_p ("latile"))
4986 /* Matched "volatile". */
4994 /* No double colon and no recognizable decl_type, so assume that
4995 we've been looking at something else the whole time. */
5002 /* Check to make sure any parens are paired up correctly. */
5003 if (gfc_match_parens () == MATCH_ERROR
)
5010 seen_at
[d
] = gfc_current_locus
;
5012 if (d
== DECL_DIMENSION
|| d
== DECL_CODIMENSION
)
5014 gfc_array_spec
*as
= NULL
;
5016 m
= gfc_match_array_spec (&as
, d
== DECL_DIMENSION
,
5017 d
== DECL_CODIMENSION
);
5019 if (current_as
== NULL
)
5021 else if (m
== MATCH_YES
)
5023 if (!merge_array_spec (as
, current_as
, false))
5030 if (d
== DECL_CODIMENSION
)
5031 gfc_error ("Missing codimension specification at %C");
5033 gfc_error ("Missing dimension specification at %C");
5037 if (m
== MATCH_ERROR
)
5042 /* Since we've seen a double colon, we have to be looking at an
5043 attr-spec. This means that we can now issue errors. */
5044 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
5049 case DECL_ALLOCATABLE
:
5050 attr
= "ALLOCATABLE";
5052 case DECL_ASYNCHRONOUS
:
5053 attr
= "ASYNCHRONOUS";
5055 case DECL_CODIMENSION
:
5056 attr
= "CODIMENSION";
5058 case DECL_CONTIGUOUS
:
5059 attr
= "CONTIGUOUS";
5061 case DECL_DIMENSION
:
5068 attr
= "INTENT (IN)";
5071 attr
= "INTENT (OUT)";
5074 attr
= "INTENT (IN OUT)";
5076 case DECL_INTRINSIC
:
5088 case DECL_PARAMETER
:
5094 case DECL_PROTECTED
:
5109 case DECL_AUTOMATIC
:
5115 case DECL_IS_BIND_C
:
5125 attr
= NULL
; /* This shouldn't happen. */
5128 gfc_error ("Duplicate %s attribute at %L", attr
, &seen_at
[d
]);
5133 /* Now that we've dealt with duplicate attributes, add the attributes
5134 to the current attribute. */
5135 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
5142 if ((d
== DECL_STATIC
|| d
== DECL_AUTOMATIC
)
5143 && !flag_dec_static
)
5145 gfc_error ("%s at %L is a DEC extension, enable with "
5147 d
== DECL_STATIC
? "STATIC" : "AUTOMATIC", &seen_at
[d
]);
5151 /* Allow SAVE with STATIC, but don't complain. */
5152 if (d
== DECL_STATIC
&& seen
[DECL_SAVE
])
5155 if (gfc_current_state () == COMP_DERIVED
5156 && d
!= DECL_DIMENSION
&& d
!= DECL_CODIMENSION
5157 && d
!= DECL_POINTER
&& d
!= DECL_PRIVATE
5158 && d
!= DECL_PUBLIC
&& d
!= DECL_CONTIGUOUS
&& d
!= DECL_NONE
)
5160 if (d
== DECL_ALLOCATABLE
)
5162 if (!gfc_notify_std (GFC_STD_F2003
, "ALLOCATABLE "
5163 "attribute at %C in a TYPE definition"))
5169 else if (d
== DECL_KIND
)
5171 if (!gfc_notify_std (GFC_STD_F2003
, "KIND "
5172 "attribute at %C in a TYPE definition"))
5177 if (current_ts
.type
!= BT_INTEGER
)
5179 gfc_error ("Component with KIND attribute at %C must be "
5184 if (current_ts
.kind
!= gfc_default_integer_kind
)
5186 gfc_error ("Component with KIND attribute at %C must be "
5187 "default integer kind (%d)",
5188 gfc_default_integer_kind
);
5193 else if (d
== DECL_LEN
)
5195 if (!gfc_notify_std (GFC_STD_F2003
, "LEN "
5196 "attribute at %C in a TYPE definition"))
5201 if (current_ts
.type
!= BT_INTEGER
)
5203 gfc_error ("Component with LEN attribute at %C must be "
5208 if (current_ts
.kind
!= gfc_default_integer_kind
)
5210 gfc_error ("Component with LEN attribute at %C must be "
5211 "default integer kind (%d)",
5212 gfc_default_integer_kind
);
5219 gfc_error ("Attribute at %L is not allowed in a TYPE definition",
5226 if ((d
== DECL_PRIVATE
|| d
== DECL_PUBLIC
)
5227 && gfc_current_state () != COMP_MODULE
)
5229 if (d
== DECL_PRIVATE
)
5233 if (gfc_current_state () == COMP_DERIVED
5234 && gfc_state_stack
->previous
5235 && gfc_state_stack
->previous
->state
== COMP_MODULE
)
5237 if (!gfc_notify_std (GFC_STD_F2003
, "Attribute %s "
5238 "at %L in a TYPE definition", attr
,
5247 gfc_error ("%s attribute at %L is not allowed outside of the "
5248 "specification part of a module", attr
, &seen_at
[d
]);
5254 if (gfc_current_state () != COMP_DERIVED
5255 && (d
== DECL_KIND
|| d
== DECL_LEN
))
5257 gfc_error ("Attribute at %L is not allowed outside a TYPE "
5258 "definition", &seen_at
[d
]);
5265 case DECL_ALLOCATABLE
:
5266 t
= gfc_add_allocatable (¤t_attr
, &seen_at
[d
]);
5269 case DECL_ASYNCHRONOUS
:
5270 if (!gfc_notify_std (GFC_STD_F2003
, "ASYNCHRONOUS attribute at %C"))
5273 t
= gfc_add_asynchronous (¤t_attr
, NULL
, &seen_at
[d
]);
5276 case DECL_CODIMENSION
:
5277 t
= gfc_add_codimension (¤t_attr
, NULL
, &seen_at
[d
]);
5280 case DECL_CONTIGUOUS
:
5281 if (!gfc_notify_std (GFC_STD_F2008
, "CONTIGUOUS attribute at %C"))
5284 t
= gfc_add_contiguous (¤t_attr
, NULL
, &seen_at
[d
]);
5287 case DECL_DIMENSION
:
5288 t
= gfc_add_dimension (¤t_attr
, NULL
, &seen_at
[d
]);
5292 t
= gfc_add_external (¤t_attr
, &seen_at
[d
]);
5296 t
= gfc_add_intent (¤t_attr
, INTENT_IN
, &seen_at
[d
]);
5300 t
= gfc_add_intent (¤t_attr
, INTENT_OUT
, &seen_at
[d
]);
5304 t
= gfc_add_intent (¤t_attr
, INTENT_INOUT
, &seen_at
[d
]);
5307 case DECL_INTRINSIC
:
5308 t
= gfc_add_intrinsic (¤t_attr
, &seen_at
[d
]);
5312 t
= gfc_add_optional (¤t_attr
, &seen_at
[d
]);
5316 t
= gfc_add_kind (¤t_attr
, &seen_at
[d
]);
5320 t
= gfc_add_len (¤t_attr
, &seen_at
[d
]);
5323 case DECL_PARAMETER
:
5324 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, &seen_at
[d
]);
5328 t
= gfc_add_pointer (¤t_attr
, &seen_at
[d
]);
5331 case DECL_PROTECTED
:
5332 if (gfc_current_state () != COMP_MODULE
5333 || (gfc_current_ns
->proc_name
5334 && gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
))
5336 gfc_error ("PROTECTED at %C only allowed in specification "
5337 "part of a module");
5342 if (!gfc_notify_std (GFC_STD_F2003
, "PROTECTED attribute at %C"))
5345 t
= gfc_add_protected (¤t_attr
, NULL
, &seen_at
[d
]);
5349 t
= gfc_add_access (¤t_attr
, ACCESS_PRIVATE
, NULL
,
5354 t
= gfc_add_access (¤t_attr
, ACCESS_PUBLIC
, NULL
,
5360 t
= gfc_add_save (¤t_attr
, SAVE_EXPLICIT
, NULL
, &seen_at
[d
]);
5363 case DECL_AUTOMATIC
:
5364 t
= gfc_add_automatic (¤t_attr
, NULL
, &seen_at
[d
]);
5368 t
= gfc_add_target (¤t_attr
, &seen_at
[d
]);
5371 case DECL_IS_BIND_C
:
5372 t
= gfc_add_is_bind_c(¤t_attr
, NULL
, &seen_at
[d
], 0);
5376 if (!gfc_notify_std (GFC_STD_F2003
, "VALUE attribute at %C"))
5379 t
= gfc_add_value (¤t_attr
, NULL
, &seen_at
[d
]);
5383 if (!gfc_notify_std (GFC_STD_F2003
, "VOLATILE attribute at %C"))
5386 t
= gfc_add_volatile (¤t_attr
, NULL
, &seen_at
[d
]);
5390 gfc_internal_error ("match_attr_spec(): Bad attribute");
5400 /* Since Fortran 2008 module variables implicitly have the SAVE attribute. */
5401 if ((gfc_current_state () == COMP_MODULE
5402 || gfc_current_state () == COMP_SUBMODULE
)
5403 && !current_attr
.save
5404 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
5405 current_attr
.save
= SAVE_IMPLICIT
;
5411 gfc_current_locus
= start
;
5412 gfc_free_array_spec (current_as
);
5419 /* Set the binding label, dest_label, either with the binding label
5420 stored in the given gfc_typespec, ts, or if none was provided, it
5421 will be the symbol name in all lower case, as required by the draft
5422 (J3/04-007, section 15.4.1). If a binding label was given and
5423 there is more than one argument (num_idents), it is an error. */
5426 set_binding_label (const char **dest_label
, const char *sym_name
,
5429 if (num_idents
> 1 && has_name_equals
)
5431 gfc_error ("Multiple identifiers provided with "
5432 "single NAME= specifier at %C");
5436 if (curr_binding_label
)
5437 /* Binding label given; store in temp holder till have sym. */
5438 *dest_label
= curr_binding_label
;
5441 /* No binding label given, and the NAME= specifier did not exist,
5442 which means there was no NAME="". */
5443 if (sym_name
!= NULL
&& has_name_equals
== 0)
5444 *dest_label
= IDENTIFIER_POINTER (get_identifier (sym_name
));
5451 /* Set the status of the given common block as being BIND(C) or not,
5452 depending on the given parameter, is_bind_c. */
5455 set_com_block_bind_c (gfc_common_head
*com_block
, int is_bind_c
)
5457 com_block
->is_bind_c
= is_bind_c
;
5462 /* Verify that the given gfc_typespec is for a C interoperable type. */
5465 gfc_verify_c_interop (gfc_typespec
*ts
)
5467 if (ts
->type
== BT_DERIVED
&& ts
->u
.derived
!= NULL
)
5468 return (ts
->u
.derived
->ts
.is_c_interop
|| ts
->u
.derived
->attr
.is_bind_c
)
5470 else if (ts
->type
== BT_CLASS
)
5472 else if (ts
->is_c_interop
!= 1 && ts
->type
!= BT_ASSUMED
)
5479 /* Verify that the variables of a given common block, which has been
5480 defined with the attribute specifier bind(c), to be of a C
5481 interoperable type. Errors will be reported here, if
5485 verify_com_block_vars_c_interop (gfc_common_head
*com_block
)
5487 gfc_symbol
*curr_sym
= NULL
;
5490 curr_sym
= com_block
->head
;
5492 /* Make sure we have at least one symbol. */
5493 if (curr_sym
== NULL
)
5496 /* Here we know we have a symbol, so we'll execute this loop
5500 /* The second to last param, 1, says this is in a common block. */
5501 retval
= verify_bind_c_sym (curr_sym
, &(curr_sym
->ts
), 1, com_block
);
5502 curr_sym
= curr_sym
->common_next
;
5503 } while (curr_sym
!= NULL
);
5509 /* Verify that a given BIND(C) symbol is C interoperable. If it is not,
5510 an appropriate error message is reported. */
5513 verify_bind_c_sym (gfc_symbol
*tmp_sym
, gfc_typespec
*ts
,
5514 int is_in_common
, gfc_common_head
*com_block
)
5516 bool bind_c_function
= false;
5519 if (tmp_sym
->attr
.function
&& tmp_sym
->attr
.is_bind_c
)
5520 bind_c_function
= true;
5522 if (tmp_sym
->attr
.function
&& tmp_sym
->result
!= NULL
)
5524 tmp_sym
= tmp_sym
->result
;
5525 /* Make sure it wasn't an implicitly typed result. */
5526 if (tmp_sym
->attr
.implicit_type
&& warn_c_binding_type
)
5528 gfc_warning (OPT_Wc_binding_type
,
5529 "Implicitly declared BIND(C) function %qs at "
5530 "%L may not be C interoperable", tmp_sym
->name
,
5531 &tmp_sym
->declared_at
);
5532 tmp_sym
->ts
.f90_type
= tmp_sym
->ts
.type
;
5533 /* Mark it as C interoperable to prevent duplicate warnings. */
5534 tmp_sym
->ts
.is_c_interop
= 1;
5535 tmp_sym
->attr
.is_c_interop
= 1;
5539 /* Here, we know we have the bind(c) attribute, so if we have
5540 enough type info, then verify that it's a C interop kind.
5541 The info could be in the symbol already, or possibly still in
5542 the given ts (current_ts), so look in both. */
5543 if (tmp_sym
->ts
.type
!= BT_UNKNOWN
|| ts
->type
!= BT_UNKNOWN
)
5545 if (!gfc_verify_c_interop (&(tmp_sym
->ts
)))
5547 /* See if we're dealing with a sym in a common block or not. */
5548 if (is_in_common
== 1 && warn_c_binding_type
)
5550 gfc_warning (OPT_Wc_binding_type
,
5551 "Variable %qs in common block %qs at %L "
5552 "may not be a C interoperable "
5553 "kind though common block %qs is BIND(C)",
5554 tmp_sym
->name
, com_block
->name
,
5555 &(tmp_sym
->declared_at
), com_block
->name
);
5559 if (tmp_sym
->ts
.type
== BT_DERIVED
|| ts
->type
== BT_DERIVED
)
5560 gfc_error ("Type declaration %qs at %L is not C "
5561 "interoperable but it is BIND(C)",
5562 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5563 else if (warn_c_binding_type
)
5564 gfc_warning (OPT_Wc_binding_type
, "Variable %qs at %L "
5565 "may not be a C interoperable "
5566 "kind but it is BIND(C)",
5567 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5571 /* Variables declared w/in a common block can't be bind(c)
5572 since there's no way for C to see these variables, so there's
5573 semantically no reason for the attribute. */
5574 if (is_in_common
== 1 && tmp_sym
->attr
.is_bind_c
== 1)
5576 gfc_error ("Variable %qs in common block %qs at "
5577 "%L cannot be declared with BIND(C) "
5578 "since it is not a global",
5579 tmp_sym
->name
, com_block
->name
,
5580 &(tmp_sym
->declared_at
));
5584 /* Scalar variables that are bind(c) can not have the pointer
5585 or allocatable attributes. */
5586 if (tmp_sym
->attr
.is_bind_c
== 1)
5588 if (tmp_sym
->attr
.pointer
== 1)
5590 gfc_error ("Variable %qs at %L cannot have both the "
5591 "POINTER and BIND(C) attributes",
5592 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5596 if (tmp_sym
->attr
.allocatable
== 1)
5598 gfc_error ("Variable %qs at %L cannot have both the "
5599 "ALLOCATABLE and BIND(C) attributes",
5600 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5606 /* If it is a BIND(C) function, make sure the return value is a
5607 scalar value. The previous tests in this function made sure
5608 the type is interoperable. */
5609 if (bind_c_function
&& tmp_sym
->as
!= NULL
)
5610 gfc_error ("Return type of BIND(C) function %qs at %L cannot "
5611 "be an array", tmp_sym
->name
, &(tmp_sym
->declared_at
));
5613 /* BIND(C) functions can not return a character string. */
5614 if (bind_c_function
&& tmp_sym
->ts
.type
== BT_CHARACTER
)
5615 if (tmp_sym
->ts
.u
.cl
== NULL
|| tmp_sym
->ts
.u
.cl
->length
== NULL
5616 || tmp_sym
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
5617 || mpz_cmp_si (tmp_sym
->ts
.u
.cl
->length
->value
.integer
, 1) != 0)
5618 gfc_error ("Return type of BIND(C) function %qs at %L cannot "
5619 "be a character string", tmp_sym
->name
,
5620 &(tmp_sym
->declared_at
));
5623 /* See if the symbol has been marked as private. If it has, make sure
5624 there is no binding label and warn the user if there is one. */
5625 if (tmp_sym
->attr
.access
== ACCESS_PRIVATE
5626 && tmp_sym
->binding_label
)
5627 /* Use gfc_warning_now because we won't say that the symbol fails
5628 just because of this. */
5629 gfc_warning_now (0, "Symbol %qs at %L is marked PRIVATE but has been "
5630 "given the binding label %qs", tmp_sym
->name
,
5631 &(tmp_sym
->declared_at
), tmp_sym
->binding_label
);
5637 /* Set the appropriate fields for a symbol that's been declared as
5638 BIND(C) (the is_bind_c flag and the binding label), and verify that
5639 the type is C interoperable. Errors are reported by the functions
5640 used to set/test these fields. */
5643 set_verify_bind_c_sym (gfc_symbol
*tmp_sym
, int num_idents
)
5647 /* TODO: Do we need to make sure the vars aren't marked private? */
5649 /* Set the is_bind_c bit in symbol_attribute. */
5650 gfc_add_is_bind_c (&(tmp_sym
->attr
), tmp_sym
->name
, &gfc_current_locus
, 0);
5652 if (!set_binding_label (&tmp_sym
->binding_label
, tmp_sym
->name
, num_idents
))
5659 /* Set the fields marking the given common block as BIND(C), including
5660 a binding label, and report any errors encountered. */
5663 set_verify_bind_c_com_block (gfc_common_head
*com_block
, int num_idents
)
5667 /* destLabel, common name, typespec (which may have binding label). */
5668 if (!set_binding_label (&com_block
->binding_label
, com_block
->name
,
5672 /* Set the given common block (com_block) to being bind(c) (1). */
5673 set_com_block_bind_c (com_block
, 1);
5679 /* Retrieve the list of one or more identifiers that the given bind(c)
5680 attribute applies to. */
5683 get_bind_c_idents (void)
5685 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5687 gfc_symbol
*tmp_sym
= NULL
;
5689 gfc_common_head
*com_block
= NULL
;
5691 if (gfc_match_name (name
) == MATCH_YES
)
5693 found_id
= MATCH_YES
;
5694 gfc_get_ha_symbol (name
, &tmp_sym
);
5696 else if (match_common_name (name
) == MATCH_YES
)
5698 found_id
= MATCH_YES
;
5699 com_block
= gfc_get_common (name
, 0);
5703 gfc_error ("Need either entity or common block name for "
5704 "attribute specification statement at %C");
5708 /* Save the current identifier and look for more. */
5711 /* Increment the number of identifiers found for this spec stmt. */
5714 /* Make sure we have a sym or com block, and verify that it can
5715 be bind(c). Set the appropriate field(s) and look for more
5717 if (tmp_sym
!= NULL
|| com_block
!= NULL
)
5719 if (tmp_sym
!= NULL
)
5721 if (!set_verify_bind_c_sym (tmp_sym
, num_idents
))
5726 if (!set_verify_bind_c_com_block (com_block
, num_idents
))
5730 /* Look to see if we have another identifier. */
5732 if (gfc_match_eos () == MATCH_YES
)
5733 found_id
= MATCH_NO
;
5734 else if (gfc_match_char (',') != MATCH_YES
)
5735 found_id
= MATCH_NO
;
5736 else if (gfc_match_name (name
) == MATCH_YES
)
5738 found_id
= MATCH_YES
;
5739 gfc_get_ha_symbol (name
, &tmp_sym
);
5741 else if (match_common_name (name
) == MATCH_YES
)
5743 found_id
= MATCH_YES
;
5744 com_block
= gfc_get_common (name
, 0);
5748 gfc_error ("Missing entity or common block name for "
5749 "attribute specification statement at %C");
5755 gfc_internal_error ("Missing symbol");
5757 } while (found_id
== MATCH_YES
);
5759 /* if we get here we were successful */
5764 /* Try and match a BIND(C) attribute specification statement. */
5767 gfc_match_bind_c_stmt (void)
5769 match found_match
= MATCH_NO
;
5774 /* This may not be necessary. */
5776 /* Clear the temporary binding label holder. */
5777 curr_binding_label
= NULL
;
5779 /* Look for the bind(c). */
5780 found_match
= gfc_match_bind_c (NULL
, true);
5782 if (found_match
== MATCH_YES
)
5784 if (!gfc_notify_std (GFC_STD_F2003
, "BIND(C) statement at %C"))
5787 /* Look for the :: now, but it is not required. */
5790 /* Get the identifier(s) that needs to be updated. This may need to
5791 change to hand the flag(s) for the attr specified so all identifiers
5792 found can have all appropriate parts updated (assuming that the same
5793 spec stmt can have multiple attrs, such as both bind(c) and
5795 if (!get_bind_c_idents ())
5796 /* Error message should have printed already. */
5804 /* Match a data declaration statement. */
5807 gfc_match_data_decl (void)
5813 type_param_spec_list
= NULL
;
5814 decl_type_param_list
= NULL
;
5816 num_idents_on_line
= 0;
5818 m
= gfc_match_decl_type_spec (¤t_ts
, 0);
5822 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
5823 && !gfc_comp_struct (gfc_current_state ()))
5825 sym
= gfc_use_derived (current_ts
.u
.derived
);
5833 current_ts
.u
.derived
= sym
;
5836 m
= match_attr_spec ();
5837 if (m
== MATCH_ERROR
)
5843 if (current_ts
.type
== BT_CLASS
5844 && current_ts
.u
.derived
->attr
.unlimited_polymorphic
)
5847 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
5848 && current_ts
.u
.derived
->components
== NULL
5849 && !current_ts
.u
.derived
->attr
.zero_comp
)
5852 if (current_attr
.pointer
&& gfc_comp_struct (gfc_current_state ()))
5855 if (current_attr
.allocatable
&& gfc_current_state () == COMP_DERIVED
5856 && current_ts
.u
.derived
== gfc_current_block ())
5859 gfc_find_symbol (current_ts
.u
.derived
->name
,
5860 current_ts
.u
.derived
->ns
, 1, &sym
);
5862 /* Any symbol that we find had better be a type definition
5863 which has its components defined, or be a structure definition
5864 actively being parsed. */
5865 if (sym
!= NULL
&& gfc_fl_struct (sym
->attr
.flavor
)
5866 && (current_ts
.u
.derived
->components
!= NULL
5867 || current_ts
.u
.derived
->attr
.zero_comp
5868 || current_ts
.u
.derived
== gfc_new_block
))
5871 gfc_error ("Derived type at %C has not been previously defined "
5872 "and so cannot appear in a derived type definition");
5878 /* If we have an old-style character declaration, and no new-style
5879 attribute specifications, then there a comma is optional between
5880 the type specification and the variable list. */
5881 if (m
== MATCH_NO
&& current_ts
.type
== BT_CHARACTER
&& old_char_selector
)
5882 gfc_match_char (',');
5884 /* Give the types/attributes to symbols that follow. Give the element
5885 a number so that repeat character length expressions can be copied. */
5889 num_idents_on_line
++;
5890 m
= variable_decl (elem
++);
5891 if (m
== MATCH_ERROR
)
5896 if (gfc_match_eos () == MATCH_YES
)
5898 if (gfc_match_char (',') != MATCH_YES
)
5902 if (!gfc_error_flag_test ())
5904 /* An anonymous structure declaration is unambiguous; if we matched one
5905 according to gfc_match_structure_decl, we need to return MATCH_YES
5906 here to avoid confusing the remaining matchers, even if there was an
5907 error during variable_decl. We must flush any such errors. Note this
5908 causes the parser to gracefully continue parsing the remaining input
5909 as a structure body, which likely follows. */
5910 if (current_ts
.type
== BT_DERIVED
&& current_ts
.u
.derived
5911 && gfc_fl_struct (current_ts
.u
.derived
->attr
.flavor
))
5913 gfc_error_now ("Syntax error in anonymous structure declaration"
5915 /* Skip the bad variable_decl and line up for the start of the
5917 gfc_error_recovery ();
5922 gfc_error ("Syntax error in data declaration at %C");
5927 gfc_free_data_all (gfc_current_ns
);
5930 if (saved_kind_expr
)
5931 gfc_free_expr (saved_kind_expr
);
5932 if (type_param_spec_list
)
5933 gfc_free_actual_arglist (type_param_spec_list
);
5934 if (decl_type_param_list
)
5935 gfc_free_actual_arglist (decl_type_param_list
);
5936 saved_kind_expr
= NULL
;
5937 gfc_free_array_spec (current_as
);
5943 /* Match a prefix associated with a function or subroutine
5944 declaration. If the typespec pointer is nonnull, then a typespec
5945 can be matched. Note that if nothing matches, MATCH_YES is
5946 returned (the null string was matched). */
5949 gfc_match_prefix (gfc_typespec
*ts
)
5955 gfc_clear_attr (¤t_attr
);
5957 seen_impure
= false;
5959 gcc_assert (!gfc_matching_prefix
);
5960 gfc_matching_prefix
= true;
5964 found_prefix
= false;
5966 /* MODULE is a prefix like PURE, ELEMENTAL, etc., having a
5967 corresponding attribute seems natural and distinguishes these
5968 procedures from procedure types of PROC_MODULE, which these are
5970 if (gfc_match ("module% ") == MATCH_YES
)
5972 if (!gfc_notify_std (GFC_STD_F2008
, "MODULE prefix at %C"))
5975 current_attr
.module_procedure
= 1;
5976 found_prefix
= true;
5979 if (!seen_type
&& ts
!= NULL
5980 && gfc_match_decl_type_spec (ts
, 0) == MATCH_YES
5981 && gfc_match_space () == MATCH_YES
)
5985 found_prefix
= true;
5988 if (gfc_match ("elemental% ") == MATCH_YES
)
5990 if (!gfc_add_elemental (¤t_attr
, NULL
))
5993 found_prefix
= true;
5996 if (gfc_match ("pure% ") == MATCH_YES
)
5998 if (!gfc_add_pure (¤t_attr
, NULL
))
6001 found_prefix
= true;
6004 if (gfc_match ("recursive% ") == MATCH_YES
)
6006 if (!gfc_add_recursive (¤t_attr
, NULL
))
6009 found_prefix
= true;
6012 /* IMPURE is a somewhat special case, as it needs not set an actual
6013 attribute but rather only prevents ELEMENTAL routines from being
6014 automatically PURE. */
6015 if (gfc_match ("impure% ") == MATCH_YES
)
6017 if (!gfc_notify_std (GFC_STD_F2008
, "IMPURE procedure at %C"))
6021 found_prefix
= true;
6024 while (found_prefix
);
6026 /* IMPURE and PURE must not both appear, of course. */
6027 if (seen_impure
&& current_attr
.pure
)
6029 gfc_error ("PURE and IMPURE must not appear both at %C");
6033 /* If IMPURE it not seen but the procedure is ELEMENTAL, mark it as PURE. */
6034 if (!seen_impure
&& current_attr
.elemental
&& !current_attr
.pure
)
6036 if (!gfc_add_pure (¤t_attr
, NULL
))
6040 /* At this point, the next item is not a prefix. */
6041 gcc_assert (gfc_matching_prefix
);
6043 gfc_matching_prefix
= false;
6047 gcc_assert (gfc_matching_prefix
);
6048 gfc_matching_prefix
= false;
6053 /* Copy attributes matched by gfc_match_prefix() to attributes on a symbol. */
6056 copy_prefix (symbol_attribute
*dest
, locus
*where
)
6058 if (dest
->module_procedure
)
6060 if (current_attr
.elemental
)
6061 dest
->elemental
= 1;
6063 if (current_attr
.pure
)
6066 if (current_attr
.recursive
)
6067 dest
->recursive
= 1;
6069 /* Module procedures are unusual in that the 'dest' is copied from
6070 the interface declaration. However, this is an oportunity to
6071 check that the submodule declaration is compliant with the
6073 if (dest
->elemental
&& !current_attr
.elemental
)
6075 gfc_error ("ELEMENTAL prefix in MODULE PROCEDURE interface is "
6076 "missing at %L", where
);
6080 if (dest
->pure
&& !current_attr
.pure
)
6082 gfc_error ("PURE prefix in MODULE PROCEDURE interface is "
6083 "missing at %L", where
);
6087 if (dest
->recursive
&& !current_attr
.recursive
)
6089 gfc_error ("RECURSIVE prefix in MODULE PROCEDURE interface is "
6090 "missing at %L", where
);
6097 if (current_attr
.elemental
&& !gfc_add_elemental (dest
, where
))
6100 if (current_attr
.pure
&& !gfc_add_pure (dest
, where
))
6103 if (current_attr
.recursive
&& !gfc_add_recursive (dest
, where
))
6110 /* Match a formal argument list or, if typeparam is true, a
6111 type_param_name_list. */
6114 gfc_match_formal_arglist (gfc_symbol
*progname
, int st_flag
,
6115 int null_flag
, bool typeparam
)
6117 gfc_formal_arglist
*head
, *tail
, *p
, *q
;
6118 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6121 gfc_formal_arglist
*formal
= NULL
;
6125 /* Keep the interface formal argument list and null it so that the
6126 matching for the new declaration can be done. The numbers and
6127 names of the arguments are checked here. The interface formal
6128 arguments are retained in formal_arglist and the characteristics
6129 are compared in resolve.c(resolve_fl_procedure). See the remark
6130 in get_proc_name about the eventual need to copy the formal_arglist
6131 and populate the formal namespace of the interface symbol. */
6132 if (progname
->attr
.module_procedure
6133 && progname
->attr
.host_assoc
)
6135 formal
= progname
->formal
;
6136 progname
->formal
= NULL
;
6139 if (gfc_match_char ('(') != MATCH_YES
)
6146 if (gfc_match_char (')') == MATCH_YES
)
6151 if (gfc_match_char ('*') == MATCH_YES
)
6154 if (!typeparam
&& !gfc_notify_std (GFC_STD_F95_OBS
,
6155 "Alternate-return argument at %C"))
6161 gfc_error_now ("A parameter name is required at %C");
6165 m
= gfc_match_name (name
);
6169 gfc_error_now ("A parameter name is required at %C");
6173 if (!typeparam
&& gfc_get_symbol (name
, NULL
, &sym
))
6176 && gfc_get_symbol (name
, progname
->f2k_derived
, &sym
))
6180 p
= gfc_get_formal_arglist ();
6192 /* We don't add the VARIABLE flavor because the name could be a
6193 dummy procedure. We don't apply these attributes to formal
6194 arguments of statement functions. */
6195 if (sym
!= NULL
&& !st_flag
6196 && (!gfc_add_dummy(&sym
->attr
, sym
->name
, NULL
)
6197 || !gfc_missing_attr (&sym
->attr
, NULL
)))
6203 /* The name of a program unit can be in a different namespace,
6204 so check for it explicitly. After the statement is accepted,
6205 the name is checked for especially in gfc_get_symbol(). */
6206 if (gfc_new_block
!= NULL
&& sym
!= NULL
&& !typeparam
6207 && strcmp (sym
->name
, gfc_new_block
->name
) == 0)
6209 gfc_error ("Name %qs at %C is the name of the procedure",
6215 if (gfc_match_char (')') == MATCH_YES
)
6218 m
= gfc_match_char (',');
6222 gfc_error_now ("Expected parameter list in type declaration "
6225 gfc_error ("Unexpected junk in formal argument list at %C");
6231 /* Check for duplicate symbols in the formal argument list. */
6234 for (p
= head
; p
->next
; p
= p
->next
)
6239 for (q
= p
->next
; q
; q
= q
->next
)
6240 if (p
->sym
== q
->sym
)
6243 gfc_error_now ("Duplicate name %qs in parameter "
6244 "list at %C", p
->sym
->name
);
6246 gfc_error ("Duplicate symbol %qs in formal argument "
6247 "list at %C", p
->sym
->name
);
6255 if (!gfc_add_explicit_interface (progname
, IFSRC_DECL
, head
, NULL
))
6261 /* gfc_error_now used in following and return with MATCH_YES because
6262 doing otherwise results in a cascade of extraneous errors and in
6263 some cases an ICE in symbol.c(gfc_release_symbol). */
6264 if (progname
->attr
.module_procedure
&& progname
->attr
.host_assoc
)
6266 bool arg_count_mismatch
= false;
6268 if (!formal
&& head
)
6269 arg_count_mismatch
= true;
6271 /* Abbreviated module procedure declaration is not meant to have any
6272 formal arguments! */
6273 if (!progname
->abr_modproc_decl
&& formal
&& !head
)
6274 arg_count_mismatch
= true;
6276 for (p
= formal
, q
= head
; p
&& q
; p
= p
->next
, q
= q
->next
)
6278 if ((p
->next
!= NULL
&& q
->next
== NULL
)
6279 || (p
->next
== NULL
&& q
->next
!= NULL
))
6280 arg_count_mismatch
= true;
6281 else if ((p
->sym
== NULL
&& q
->sym
== NULL
)
6282 || strcmp (p
->sym
->name
, q
->sym
->name
) == 0)
6285 gfc_error_now ("Mismatch in MODULE PROCEDURE formal "
6286 "argument names (%s/%s) at %C",
6287 p
->sym
->name
, q
->sym
->name
);
6290 if (arg_count_mismatch
)
6291 gfc_error_now ("Mismatch in number of MODULE PROCEDURE "
6292 "formal arguments at %C");
6298 gfc_free_formal_arglist (head
);
6303 /* Match a RESULT specification following a function declaration or
6304 ENTRY statement. Also matches the end-of-statement. */
6307 match_result (gfc_symbol
*function
, gfc_symbol
**result
)
6309 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6313 if (gfc_match (" result (") != MATCH_YES
)
6316 m
= gfc_match_name (name
);
6320 /* Get the right paren, and that's it because there could be the
6321 bind(c) attribute after the result clause. */
6322 if (gfc_match_char (')') != MATCH_YES
)
6324 /* TODO: should report the missing right paren here. */
6328 if (strcmp (function
->name
, name
) == 0)
6330 gfc_error ("RESULT variable at %C must be different than function name");
6334 if (gfc_get_symbol (name
, NULL
, &r
))
6337 if (!gfc_add_result (&r
->attr
, r
->name
, NULL
))
6346 /* Match a function suffix, which could be a combination of a result
6347 clause and BIND(C), either one, or neither. The draft does not
6348 require them to come in a specific order. */
6351 gfc_match_suffix (gfc_symbol
*sym
, gfc_symbol
**result
)
6353 match is_bind_c
; /* Found bind(c). */
6354 match is_result
; /* Found result clause. */
6355 match found_match
; /* Status of whether we've found a good match. */
6356 char peek_char
; /* Character we're going to peek at. */
6357 bool allow_binding_name
;
6359 /* Initialize to having found nothing. */
6360 found_match
= MATCH_NO
;
6361 is_bind_c
= MATCH_NO
;
6362 is_result
= MATCH_NO
;
6364 /* Get the next char to narrow between result and bind(c). */
6365 gfc_gobble_whitespace ();
6366 peek_char
= gfc_peek_ascii_char ();
6368 /* C binding names are not allowed for internal procedures. */
6369 if (gfc_current_state () == COMP_CONTAINS
6370 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
6371 allow_binding_name
= false;
6373 allow_binding_name
= true;
6378 /* Look for result clause. */
6379 is_result
= match_result (sym
, result
);
6380 if (is_result
== MATCH_YES
)
6382 /* Now see if there is a bind(c) after it. */
6383 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
6384 /* We've found the result clause and possibly bind(c). */
6385 found_match
= MATCH_YES
;
6388 /* This should only be MATCH_ERROR. */
6389 found_match
= is_result
;
6392 /* Look for bind(c) first. */
6393 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
6394 if (is_bind_c
== MATCH_YES
)
6396 /* Now see if a result clause followed it. */
6397 is_result
= match_result (sym
, result
);
6398 found_match
= MATCH_YES
;
6402 /* Should only be a MATCH_ERROR if we get here after seeing 'b'. */
6403 found_match
= MATCH_ERROR
;
6407 gfc_error ("Unexpected junk after function declaration at %C");
6408 found_match
= MATCH_ERROR
;
6412 if (is_bind_c
== MATCH_YES
)
6414 /* Fortran 2008 draft allows BIND(C) for internal procedures. */
6415 if (gfc_current_state () == COMP_CONTAINS
6416 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
6417 && !gfc_notify_std (GFC_STD_F2008
, "BIND(C) attribute "
6418 "at %L may not be specified for an internal "
6419 "procedure", &gfc_current_locus
))
6422 if (!gfc_add_is_bind_c (&(sym
->attr
), sym
->name
, &gfc_current_locus
, 1))
6430 /* Procedure pointer return value without RESULT statement:
6431 Add "hidden" result variable named "ppr@". */
6434 add_hidden_procptr_result (gfc_symbol
*sym
)
6438 if (gfc_notification_std (GFC_STD_F2003
) == ERROR
)
6441 /* First usage case: PROCEDURE and EXTERNAL statements. */
6442 case1
= gfc_current_state () == COMP_FUNCTION
&& gfc_current_block ()
6443 && strcmp (gfc_current_block ()->name
, sym
->name
) == 0
6444 && sym
->attr
.external
;
6445 /* Second usage case: INTERFACE statements. */
6446 case2
= gfc_current_state () == COMP_INTERFACE
&& gfc_state_stack
->previous
6447 && gfc_state_stack
->previous
->state
== COMP_FUNCTION
6448 && strcmp (gfc_state_stack
->previous
->sym
->name
, sym
->name
) == 0;
6454 gfc_get_sym_tree ("ppr@", gfc_current_ns
, &stree
, false);
6458 gfc_get_sym_tree ("ppr@", gfc_current_ns
->parent
, &stree
, false);
6459 st2
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "ppr@");
6460 st2
->n
.sym
= stree
->n
.sym
;
6461 stree
->n
.sym
->refs
++;
6463 sym
->result
= stree
->n
.sym
;
6465 sym
->result
->attr
.proc_pointer
= sym
->attr
.proc_pointer
;
6466 sym
->result
->attr
.pointer
= sym
->attr
.pointer
;
6467 sym
->result
->attr
.external
= sym
->attr
.external
;
6468 sym
->result
->attr
.referenced
= sym
->attr
.referenced
;
6469 sym
->result
->ts
= sym
->ts
;
6470 sym
->attr
.proc_pointer
= 0;
6471 sym
->attr
.pointer
= 0;
6472 sym
->attr
.external
= 0;
6473 if (sym
->result
->attr
.external
&& sym
->result
->attr
.pointer
)
6475 sym
->result
->attr
.pointer
= 0;
6476 sym
->result
->attr
.proc_pointer
= 1;
6479 return gfc_add_result (&sym
->result
->attr
, sym
->result
->name
, NULL
);
6481 /* POINTER after PROCEDURE/EXTERNAL/INTERFACE statement. */
6482 else if (sym
->attr
.function
&& !sym
->attr
.external
&& sym
->attr
.pointer
6483 && sym
->result
&& sym
->result
!= sym
&& sym
->result
->attr
.external
6484 && sym
== gfc_current_ns
->proc_name
6485 && sym
== sym
->result
->ns
->proc_name
6486 && strcmp ("ppr@", sym
->result
->name
) == 0)
6488 sym
->result
->attr
.proc_pointer
= 1;
6489 sym
->attr
.pointer
= 0;
6497 /* Match the interface for a PROCEDURE declaration,
6498 including brackets (R1212). */
6501 match_procedure_interface (gfc_symbol
**proc_if
)
6505 locus old_loc
, entry_loc
;
6506 gfc_namespace
*old_ns
= gfc_current_ns
;
6507 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6509 old_loc
= entry_loc
= gfc_current_locus
;
6510 gfc_clear_ts (¤t_ts
);
6512 if (gfc_match (" (") != MATCH_YES
)
6514 gfc_current_locus
= entry_loc
;
6518 /* Get the type spec. for the procedure interface. */
6519 old_loc
= gfc_current_locus
;
6520 m
= gfc_match_decl_type_spec (¤t_ts
, 0);
6521 gfc_gobble_whitespace ();
6522 if (m
== MATCH_YES
|| (m
== MATCH_NO
&& gfc_peek_ascii_char () == ')'))
6525 if (m
== MATCH_ERROR
)
6528 /* Procedure interface is itself a procedure. */
6529 gfc_current_locus
= old_loc
;
6530 m
= gfc_match_name (name
);
6532 /* First look to see if it is already accessible in the current
6533 namespace because it is use associated or contained. */
6535 if (gfc_find_sym_tree (name
, NULL
, 0, &st
))
6538 /* If it is still not found, then try the parent namespace, if it
6539 exists and create the symbol there if it is still not found. */
6540 if (gfc_current_ns
->parent
)
6541 gfc_current_ns
= gfc_current_ns
->parent
;
6542 if (st
== NULL
&& gfc_get_ha_sym_tree (name
, &st
))
6545 gfc_current_ns
= old_ns
;
6546 *proc_if
= st
->n
.sym
;
6551 /* Resolve interface if possible. That way, attr.procedure is only set
6552 if it is declared by a later procedure-declaration-stmt, which is
6553 invalid per F08:C1216 (cf. resolve_procedure_interface). */
6554 while ((*proc_if
)->ts
.interface
6555 && *proc_if
!= (*proc_if
)->ts
.interface
)
6556 *proc_if
= (*proc_if
)->ts
.interface
;
6558 if ((*proc_if
)->attr
.flavor
== FL_UNKNOWN
6559 && (*proc_if
)->ts
.type
== BT_UNKNOWN
6560 && !gfc_add_flavor (&(*proc_if
)->attr
, FL_PROCEDURE
,
6561 (*proc_if
)->name
, NULL
))
6566 if (gfc_match (" )") != MATCH_YES
)
6568 gfc_current_locus
= entry_loc
;
6576 /* Match a PROCEDURE declaration (R1211). */
6579 match_procedure_decl (void)
6582 gfc_symbol
*sym
, *proc_if
= NULL
;
6584 gfc_expr
*initializer
= NULL
;
6586 /* Parse interface (with brackets). */
6587 m
= match_procedure_interface (&proc_if
);
6591 /* Parse attributes (with colons). */
6592 m
= match_attr_spec();
6593 if (m
== MATCH_ERROR
)
6596 if (proc_if
&& proc_if
->attr
.is_bind_c
&& !current_attr
.is_bind_c
)
6598 current_attr
.is_bind_c
= 1;
6599 has_name_equals
= 0;
6600 curr_binding_label
= NULL
;
6603 /* Get procedure symbols. */
6606 m
= gfc_match_symbol (&sym
, 0);
6609 else if (m
== MATCH_ERROR
)
6612 /* Add current_attr to the symbol attributes. */
6613 if (!gfc_copy_attr (&sym
->attr
, ¤t_attr
, NULL
))
6616 if (sym
->attr
.is_bind_c
)
6618 /* Check for C1218. */
6619 if (!proc_if
|| !proc_if
->attr
.is_bind_c
)
6621 gfc_error ("BIND(C) attribute at %C requires "
6622 "an interface with BIND(C)");
6625 /* Check for C1217. */
6626 if (has_name_equals
&& sym
->attr
.pointer
)
6628 gfc_error ("BIND(C) procedure with NAME may not have "
6629 "POINTER attribute at %C");
6632 if (has_name_equals
&& sym
->attr
.dummy
)
6634 gfc_error ("Dummy procedure at %C may not have "
6635 "BIND(C) attribute with NAME");
6638 /* Set binding label for BIND(C). */
6639 if (!set_binding_label (&sym
->binding_label
, sym
->name
, num
))
6643 if (!gfc_add_external (&sym
->attr
, NULL
))
6646 if (add_hidden_procptr_result (sym
))
6649 if (!gfc_add_proc (&sym
->attr
, sym
->name
, NULL
))
6652 /* Set interface. */
6653 if (proc_if
!= NULL
)
6655 if (sym
->ts
.type
!= BT_UNKNOWN
)
6657 gfc_error ("Procedure %qs at %L already has basic type of %s",
6658 sym
->name
, &gfc_current_locus
,
6659 gfc_basic_typename (sym
->ts
.type
));
6662 sym
->ts
.interface
= proc_if
;
6663 sym
->attr
.untyped
= 1;
6664 sym
->attr
.if_source
= IFSRC_IFBODY
;
6666 else if (current_ts
.type
!= BT_UNKNOWN
)
6668 if (!gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
6670 sym
->ts
.interface
= gfc_new_symbol ("", gfc_current_ns
);
6671 sym
->ts
.interface
->ts
= current_ts
;
6672 sym
->ts
.interface
->attr
.flavor
= FL_PROCEDURE
;
6673 sym
->ts
.interface
->attr
.function
= 1;
6674 sym
->attr
.function
= 1;
6675 sym
->attr
.if_source
= IFSRC_UNKNOWN
;
6678 if (gfc_match (" =>") == MATCH_YES
)
6680 if (!current_attr
.pointer
)
6682 gfc_error ("Initialization at %C isn't for a pointer variable");
6687 m
= match_pointer_init (&initializer
, 1);
6691 if (!add_init_expr_to_sym (sym
->name
, &initializer
, &gfc_current_locus
))
6696 if (gfc_match_eos () == MATCH_YES
)
6698 if (gfc_match_char (',') != MATCH_YES
)
6703 gfc_error ("Syntax error in PROCEDURE statement at %C");
6707 /* Free stuff up and return. */
6708 gfc_free_expr (initializer
);
6714 match_binding_attributes (gfc_typebound_proc
* ba
, bool generic
, bool ppc
);
6717 /* Match a procedure pointer component declaration (R445). */
6720 match_ppc_decl (void)
6723 gfc_symbol
*proc_if
= NULL
;
6727 gfc_expr
*initializer
= NULL
;
6728 gfc_typebound_proc
* tb
;
6729 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6731 /* Parse interface (with brackets). */
6732 m
= match_procedure_interface (&proc_if
);
6736 /* Parse attributes. */
6737 tb
= XCNEW (gfc_typebound_proc
);
6738 tb
->where
= gfc_current_locus
;
6739 m
= match_binding_attributes (tb
, false, true);
6740 if (m
== MATCH_ERROR
)
6743 gfc_clear_attr (¤t_attr
);
6744 current_attr
.procedure
= 1;
6745 current_attr
.proc_pointer
= 1;
6746 current_attr
.access
= tb
->access
;
6747 current_attr
.flavor
= FL_PROCEDURE
;
6749 /* Match the colons (required). */
6750 if (gfc_match (" ::") != MATCH_YES
)
6752 gfc_error ("Expected %<::%> after binding-attributes at %C");
6756 /* Check for C450. */
6757 if (!tb
->nopass
&& proc_if
== NULL
)
6759 gfc_error("NOPASS or explicit interface required at %C");
6763 if (!gfc_notify_std (GFC_STD_F2003
, "Procedure pointer component at %C"))
6766 /* Match PPC names. */
6770 m
= gfc_match_name (name
);
6773 else if (m
== MATCH_ERROR
)
6776 if (!gfc_add_component (gfc_current_block(), name
, &c
))
6779 /* Add current_attr to the symbol attributes. */
6780 if (!gfc_copy_attr (&c
->attr
, ¤t_attr
, NULL
))
6783 if (!gfc_add_external (&c
->attr
, NULL
))
6786 if (!gfc_add_proc (&c
->attr
, name
, NULL
))
6793 c
->tb
= XCNEW (gfc_typebound_proc
);
6794 c
->tb
->where
= gfc_current_locus
;
6798 /* Set interface. */
6799 if (proc_if
!= NULL
)
6801 c
->ts
.interface
= proc_if
;
6802 c
->attr
.untyped
= 1;
6803 c
->attr
.if_source
= IFSRC_IFBODY
;
6805 else if (ts
.type
!= BT_UNKNOWN
)
6808 c
->ts
.interface
= gfc_new_symbol ("", gfc_current_ns
);
6809 c
->ts
.interface
->result
= c
->ts
.interface
;
6810 c
->ts
.interface
->ts
= ts
;
6811 c
->ts
.interface
->attr
.flavor
= FL_PROCEDURE
;
6812 c
->ts
.interface
->attr
.function
= 1;
6813 c
->attr
.function
= 1;
6814 c
->attr
.if_source
= IFSRC_UNKNOWN
;
6817 if (gfc_match (" =>") == MATCH_YES
)
6819 m
= match_pointer_init (&initializer
, 1);
6822 gfc_free_expr (initializer
);
6825 c
->initializer
= initializer
;
6828 if (gfc_match_eos () == MATCH_YES
)
6830 if (gfc_match_char (',') != MATCH_YES
)
6835 gfc_error ("Syntax error in procedure pointer component at %C");
6840 /* Match a PROCEDURE declaration inside an interface (R1206). */
6843 match_procedure_in_interface (void)
6847 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6850 if (current_interface
.type
== INTERFACE_NAMELESS
6851 || current_interface
.type
== INTERFACE_ABSTRACT
)
6853 gfc_error ("PROCEDURE at %C must be in a generic interface");
6857 /* Check if the F2008 optional double colon appears. */
6858 gfc_gobble_whitespace ();
6859 old_locus
= gfc_current_locus
;
6860 if (gfc_match ("::") == MATCH_YES
)
6862 if (!gfc_notify_std (GFC_STD_F2008
, "double colon in "
6863 "MODULE PROCEDURE statement at %L", &old_locus
))
6867 gfc_current_locus
= old_locus
;
6871 m
= gfc_match_name (name
);
6874 else if (m
== MATCH_ERROR
)
6876 if (gfc_get_symbol (name
, gfc_current_ns
->parent
, &sym
))
6879 if (!gfc_add_interface (sym
))
6882 if (gfc_match_eos () == MATCH_YES
)
6884 if (gfc_match_char (',') != MATCH_YES
)
6891 gfc_error ("Syntax error in PROCEDURE statement at %C");
6896 /* General matcher for PROCEDURE declarations. */
6898 static match
match_procedure_in_type (void);
6901 gfc_match_procedure (void)
6905 switch (gfc_current_state ())
6910 case COMP_SUBMODULE
:
6911 case COMP_SUBROUTINE
:
6914 m
= match_procedure_decl ();
6916 case COMP_INTERFACE
:
6917 m
= match_procedure_in_interface ();
6920 m
= match_ppc_decl ();
6922 case COMP_DERIVED_CONTAINS
:
6923 m
= match_procedure_in_type ();
6932 if (!gfc_notify_std (GFC_STD_F2003
, "PROCEDURE statement at %C"))
6939 /* Warn if a matched procedure has the same name as an intrinsic; this is
6940 simply a wrapper around gfc_warn_intrinsic_shadow that interprets the current
6941 parser-state-stack to find out whether we're in a module. */
6944 do_warn_intrinsic_shadow (const gfc_symbol
* sym
, bool func
)
6948 in_module
= (gfc_state_stack
->previous
6949 && (gfc_state_stack
->previous
->state
== COMP_MODULE
6950 || gfc_state_stack
->previous
->state
== COMP_SUBMODULE
));
6952 gfc_warn_intrinsic_shadow (sym
, in_module
, func
);
6956 /* Match a function declaration. */
6959 gfc_match_function_decl (void)
6961 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6962 gfc_symbol
*sym
, *result
;
6966 match found_match
; /* Status returned by match func. */
6968 if (gfc_current_state () != COMP_NONE
6969 && gfc_current_state () != COMP_INTERFACE
6970 && gfc_current_state () != COMP_CONTAINS
)
6973 gfc_clear_ts (¤t_ts
);
6975 old_loc
= gfc_current_locus
;
6977 m
= gfc_match_prefix (¤t_ts
);
6980 gfc_current_locus
= old_loc
;
6984 if (gfc_match ("function% %n", name
) != MATCH_YES
)
6986 gfc_current_locus
= old_loc
;
6990 if (get_proc_name (name
, &sym
, false))
6993 if (add_hidden_procptr_result (sym
))
6996 if (current_attr
.module_procedure
)
6997 sym
->attr
.module_procedure
= 1;
6999 gfc_new_block
= sym
;
7001 m
= gfc_match_formal_arglist (sym
, 0, 0);
7004 gfc_error ("Expected formal argument list in function "
7005 "definition at %C");
7009 else if (m
== MATCH_ERROR
)
7014 /* According to the draft, the bind(c) and result clause can
7015 come in either order after the formal_arg_list (i.e., either
7016 can be first, both can exist together or by themselves or neither
7017 one). Therefore, the match_result can't match the end of the
7018 string, and check for the bind(c) or result clause in either order. */
7019 found_match
= gfc_match_eos ();
7021 /* Make sure that it isn't already declared as BIND(C). If it is, it
7022 must have been marked BIND(C) with a BIND(C) attribute and that is
7023 not allowed for procedures. */
7024 if (sym
->attr
.is_bind_c
== 1)
7026 sym
->attr
.is_bind_c
= 0;
7027 if (sym
->old_symbol
!= NULL
)
7028 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7029 "variables or common blocks",
7030 &(sym
->old_symbol
->declared_at
));
7032 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7033 "variables or common blocks", &gfc_current_locus
);
7036 if (found_match
!= MATCH_YES
)
7038 /* If we haven't found the end-of-statement, look for a suffix. */
7039 suffix_match
= gfc_match_suffix (sym
, &result
);
7040 if (suffix_match
== MATCH_YES
)
7041 /* Need to get the eos now. */
7042 found_match
= gfc_match_eos ();
7044 found_match
= suffix_match
;
7047 if(found_match
!= MATCH_YES
)
7051 /* Make changes to the symbol. */
7054 if (!gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
7057 if (!gfc_missing_attr (&sym
->attr
, NULL
))
7060 if (!copy_prefix (&sym
->attr
, &sym
->declared_at
))
7062 if(!sym
->attr
.module_procedure
)
7068 /* Delay matching the function characteristics until after the
7069 specification block by signalling kind=-1. */
7070 sym
->declared_at
= old_loc
;
7071 if (current_ts
.type
!= BT_UNKNOWN
)
7072 current_ts
.kind
= -1;
7074 current_ts
.kind
= 0;
7078 if (current_ts
.type
!= BT_UNKNOWN
7079 && !gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
7085 if (current_ts
.type
!= BT_UNKNOWN
7086 && !gfc_add_type (result
, ¤t_ts
, &gfc_current_locus
))
7088 sym
->result
= result
;
7091 /* Warn if this procedure has the same name as an intrinsic. */
7092 do_warn_intrinsic_shadow (sym
, true);
7098 gfc_current_locus
= old_loc
;
7103 /* This is mostly a copy of parse.c(add_global_procedure) but modified to
7104 pass the name of the entry, rather than the gfc_current_block name, and
7105 to return false upon finding an existing global entry. */
7108 add_global_entry (const char *name
, const char *binding_label
, bool sub
,
7112 enum gfc_symbol_type type
;
7114 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
7116 /* Only in Fortran 2003: For procedures with a binding label also the Fortran
7117 name is a global identifier. */
7118 if (!binding_label
|| gfc_notification_std (GFC_STD_F2008
))
7120 s
= gfc_get_gsymbol (name
);
7122 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= type
))
7124 gfc_global_used (s
, where
);
7133 s
->ns
= gfc_current_ns
;
7137 /* Don't add the symbol multiple times. */
7139 && (!gfc_notification_std (GFC_STD_F2008
)
7140 || strcmp (name
, binding_label
) != 0))
7142 s
= gfc_get_gsymbol (binding_label
);
7144 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= type
))
7146 gfc_global_used (s
, where
);
7153 s
->binding_label
= binding_label
;
7156 s
->ns
= gfc_current_ns
;
7164 /* Match an ENTRY statement. */
7167 gfc_match_entry (void)
7172 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7173 gfc_compile_state state
;
7177 bool module_procedure
;
7181 m
= gfc_match_name (name
);
7185 if (!gfc_notify_std (GFC_STD_F2008_OBS
, "ENTRY statement at %C"))
7188 state
= gfc_current_state ();
7189 if (state
!= COMP_SUBROUTINE
&& state
!= COMP_FUNCTION
)
7194 gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
7197 gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
7199 case COMP_SUBMODULE
:
7200 gfc_error ("ENTRY statement at %C cannot appear within a SUBMODULE");
7202 case COMP_BLOCK_DATA
:
7203 gfc_error ("ENTRY statement at %C cannot appear within "
7206 case COMP_INTERFACE
:
7207 gfc_error ("ENTRY statement at %C cannot appear within "
7210 case COMP_STRUCTURE
:
7211 gfc_error ("ENTRY statement at %C cannot appear within "
7212 "a STRUCTURE block");
7215 gfc_error ("ENTRY statement at %C cannot appear within "
7216 "a DERIVED TYPE block");
7219 gfc_error ("ENTRY statement at %C cannot appear within "
7220 "an IF-THEN block");
7223 case COMP_DO_CONCURRENT
:
7224 gfc_error ("ENTRY statement at %C cannot appear within "
7228 gfc_error ("ENTRY statement at %C cannot appear within "
7232 gfc_error ("ENTRY statement at %C cannot appear within "
7236 gfc_error ("ENTRY statement at %C cannot appear within "
7240 gfc_error ("ENTRY statement at %C cannot appear within "
7241 "a contained subprogram");
7244 gfc_error ("Unexpected ENTRY statement at %C");
7249 if ((state
== COMP_SUBROUTINE
|| state
== COMP_FUNCTION
)
7250 && gfc_state_stack
->previous
->state
== COMP_INTERFACE
)
7252 gfc_error ("ENTRY statement at %C cannot appear within an INTERFACE");
7256 module_procedure
= gfc_current_ns
->parent
!= NULL
7257 && gfc_current_ns
->parent
->proc_name
7258 && gfc_current_ns
->parent
->proc_name
->attr
.flavor
7261 if (gfc_current_ns
->parent
!= NULL
7262 && gfc_current_ns
->parent
->proc_name
7263 && !module_procedure
)
7265 gfc_error("ENTRY statement at %C cannot appear in a "
7266 "contained procedure");
7270 /* Module function entries need special care in get_proc_name
7271 because previous references within the function will have
7272 created symbols attached to the current namespace. */
7273 if (get_proc_name (name
, &entry
,
7274 gfc_current_ns
->parent
!= NULL
7275 && module_procedure
))
7278 proc
= gfc_current_block ();
7280 /* Make sure that it isn't already declared as BIND(C). If it is, it
7281 must have been marked BIND(C) with a BIND(C) attribute and that is
7282 not allowed for procedures. */
7283 if (entry
->attr
.is_bind_c
== 1)
7285 entry
->attr
.is_bind_c
= 0;
7286 if (entry
->old_symbol
!= NULL
)
7287 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7288 "variables or common blocks",
7289 &(entry
->old_symbol
->declared_at
));
7291 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7292 "variables or common blocks", &gfc_current_locus
);
7295 /* Check what next non-whitespace character is so we can tell if there
7296 is the required parens if we have a BIND(C). */
7297 old_loc
= gfc_current_locus
;
7298 gfc_gobble_whitespace ();
7299 peek_char
= gfc_peek_ascii_char ();
7301 if (state
== COMP_SUBROUTINE
)
7303 m
= gfc_match_formal_arglist (entry
, 0, 1);
7307 /* Call gfc_match_bind_c with allow_binding_name = true as ENTRY can
7308 never be an internal procedure. */
7309 is_bind_c
= gfc_match_bind_c (entry
, true);
7310 if (is_bind_c
== MATCH_ERROR
)
7312 if (is_bind_c
== MATCH_YES
)
7314 if (peek_char
!= '(')
7316 gfc_error ("Missing required parentheses before BIND(C) at %C");
7319 if (!gfc_add_is_bind_c (&(entry
->attr
), entry
->name
,
7320 &(entry
->declared_at
), 1))
7324 if (!gfc_current_ns
->parent
7325 && !add_global_entry (name
, entry
->binding_label
, true,
7329 /* An entry in a subroutine. */
7330 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
7331 || !gfc_add_subroutine (&entry
->attr
, entry
->name
, NULL
))
7336 /* An entry in a function.
7337 We need to take special care because writing
7342 ENTRY f() RESULT (r)
7344 ENTRY f RESULT (r). */
7345 if (gfc_match_eos () == MATCH_YES
)
7347 gfc_current_locus
= old_loc
;
7348 /* Match the empty argument list, and add the interface to
7350 m
= gfc_match_formal_arglist (entry
, 0, 1);
7353 m
= gfc_match_formal_arglist (entry
, 0, 0);
7360 if (gfc_match_eos () == MATCH_YES
)
7362 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
7363 || !gfc_add_function (&entry
->attr
, entry
->name
, NULL
))
7366 entry
->result
= entry
;
7370 m
= gfc_match_suffix (entry
, &result
);
7372 gfc_syntax_error (ST_ENTRY
);
7378 if (!gfc_add_result (&result
->attr
, result
->name
, NULL
)
7379 || !gfc_add_entry (&entry
->attr
, result
->name
, NULL
)
7380 || !gfc_add_function (&entry
->attr
, result
->name
, NULL
))
7382 entry
->result
= result
;
7386 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
7387 || !gfc_add_function (&entry
->attr
, entry
->name
, NULL
))
7389 entry
->result
= entry
;
7393 if (!gfc_current_ns
->parent
7394 && !add_global_entry (name
, entry
->binding_label
, false,
7399 if (gfc_match_eos () != MATCH_YES
)
7401 gfc_syntax_error (ST_ENTRY
);
7405 entry
->attr
.recursive
= proc
->attr
.recursive
;
7406 entry
->attr
.elemental
= proc
->attr
.elemental
;
7407 entry
->attr
.pure
= proc
->attr
.pure
;
7409 el
= gfc_get_entry_list ();
7411 el
->next
= gfc_current_ns
->entries
;
7412 gfc_current_ns
->entries
= el
;
7414 el
->id
= el
->next
->id
+ 1;
7418 new_st
.op
= EXEC_ENTRY
;
7419 new_st
.ext
.entry
= el
;
7425 /* Match a subroutine statement, including optional prefixes. */
7428 gfc_match_subroutine (void)
7430 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7435 bool allow_binding_name
;
7437 if (gfc_current_state () != COMP_NONE
7438 && gfc_current_state () != COMP_INTERFACE
7439 && gfc_current_state () != COMP_CONTAINS
)
7442 m
= gfc_match_prefix (NULL
);
7446 m
= gfc_match ("subroutine% %n", name
);
7450 if (get_proc_name (name
, &sym
, false))
7453 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
7454 the symbol existed before. */
7455 sym
->declared_at
= gfc_current_locus
;
7457 if (current_attr
.module_procedure
)
7458 sym
->attr
.module_procedure
= 1;
7460 if (add_hidden_procptr_result (sym
))
7463 gfc_new_block
= sym
;
7465 /* Check what next non-whitespace character is so we can tell if there
7466 is the required parens if we have a BIND(C). */
7467 gfc_gobble_whitespace ();
7468 peek_char
= gfc_peek_ascii_char ();
7470 if (!gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
))
7473 if (gfc_match_formal_arglist (sym
, 0, 1) != MATCH_YES
)
7476 /* Make sure that it isn't already declared as BIND(C). If it is, it
7477 must have been marked BIND(C) with a BIND(C) attribute and that is
7478 not allowed for procedures. */
7479 if (sym
->attr
.is_bind_c
== 1)
7481 sym
->attr
.is_bind_c
= 0;
7482 if (sym
->old_symbol
!= NULL
)
7483 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7484 "variables or common blocks",
7485 &(sym
->old_symbol
->declared_at
));
7487 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7488 "variables or common blocks", &gfc_current_locus
);
7491 /* C binding names are not allowed for internal procedures. */
7492 if (gfc_current_state () == COMP_CONTAINS
7493 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
7494 allow_binding_name
= false;
7496 allow_binding_name
= true;
7498 /* Here, we are just checking if it has the bind(c) attribute, and if
7499 so, then we need to make sure it's all correct. If it doesn't,
7500 we still need to continue matching the rest of the subroutine line. */
7501 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
7502 if (is_bind_c
== MATCH_ERROR
)
7504 /* There was an attempt at the bind(c), but it was wrong. An
7505 error message should have been printed w/in the gfc_match_bind_c
7506 so here we'll just return the MATCH_ERROR. */
7510 if (is_bind_c
== MATCH_YES
)
7512 /* The following is allowed in the Fortran 2008 draft. */
7513 if (gfc_current_state () == COMP_CONTAINS
7514 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
7515 && !gfc_notify_std (GFC_STD_F2008
, "BIND(C) attribute "
7516 "at %L may not be specified for an internal "
7517 "procedure", &gfc_current_locus
))
7520 if (peek_char
!= '(')
7522 gfc_error ("Missing required parentheses before BIND(C) at %C");
7525 if (!gfc_add_is_bind_c (&(sym
->attr
), sym
->name
,
7526 &(sym
->declared_at
), 1))
7530 if (gfc_match_eos () != MATCH_YES
)
7532 gfc_syntax_error (ST_SUBROUTINE
);
7536 if (!copy_prefix (&sym
->attr
, &sym
->declared_at
))
7538 if(!sym
->attr
.module_procedure
)
7544 /* Warn if it has the same name as an intrinsic. */
7545 do_warn_intrinsic_shadow (sym
, false);
7551 /* Check that the NAME identifier in a BIND attribute or statement
7552 is conform to C identifier rules. */
7555 check_bind_name_identifier (char **name
)
7557 char *n
= *name
, *p
;
7559 /* Remove leading spaces. */
7563 /* On an empty string, free memory and set name to NULL. */
7571 /* Remove trailing spaces. */
7572 p
= n
+ strlen(n
) - 1;
7576 /* Insert the identifier into the symbol table. */
7581 /* Now check that identifier is valid under C rules. */
7584 gfc_error ("Invalid C identifier in NAME= specifier at %C");
7589 if (!(ISALNUM (*p
) || *p
== '_' || *p
== '$'))
7591 gfc_error ("Invalid C identifier in NAME= specifier at %C");
7599 /* Match a BIND(C) specifier, with the optional 'name=' specifier if
7600 given, and set the binding label in either the given symbol (if not
7601 NULL), or in the current_ts. The symbol may be NULL because we may
7602 encounter the BIND(C) before the declaration itself. Return
7603 MATCH_NO if what we're looking at isn't a BIND(C) specifier,
7604 MATCH_ERROR if it is a BIND(C) clause but an error was encountered,
7605 or MATCH_YES if the specifier was correct and the binding label and
7606 bind(c) fields were set correctly for the given symbol or the
7607 current_ts. If allow_binding_name is false, no binding name may be
7611 gfc_match_bind_c (gfc_symbol
*sym
, bool allow_binding_name
)
7613 char *binding_label
= NULL
;
7616 /* Initialize the flag that specifies whether we encountered a NAME=
7617 specifier or not. */
7618 has_name_equals
= 0;
7620 /* This much we have to be able to match, in this order, if
7621 there is a bind(c) label. */
7622 if (gfc_match (" bind ( c ") != MATCH_YES
)
7625 /* Now see if there is a binding label, or if we've reached the
7626 end of the bind(c) attribute without one. */
7627 if (gfc_match_char (',') == MATCH_YES
)
7629 if (gfc_match (" name = ") != MATCH_YES
)
7631 gfc_error ("Syntax error in NAME= specifier for binding label "
7633 /* should give an error message here */
7637 has_name_equals
= 1;
7639 if (gfc_match_init_expr (&e
) != MATCH_YES
)
7645 if (!gfc_simplify_expr(e
, 0))
7647 gfc_error ("NAME= specifier at %C should be a constant expression");
7652 if (e
->expr_type
!= EXPR_CONSTANT
|| e
->ts
.type
!= BT_CHARACTER
7653 || e
->ts
.kind
!= gfc_default_character_kind
|| e
->rank
!= 0)
7655 gfc_error ("NAME= specifier at %C should be a scalar of "
7656 "default character kind");
7661 // Get a C string from the Fortran string constant
7662 binding_label
= gfc_widechar_to_char (e
->value
.character
.string
,
7663 e
->value
.character
.length
);
7666 // Check that it is valid (old gfc_match_name_C)
7667 if (check_bind_name_identifier (&binding_label
) != MATCH_YES
)
7671 /* Get the required right paren. */
7672 if (gfc_match_char (')') != MATCH_YES
)
7674 gfc_error ("Missing closing paren for binding label at %C");
7678 if (has_name_equals
&& !allow_binding_name
)
7680 gfc_error ("No binding name is allowed in BIND(C) at %C");
7684 if (has_name_equals
&& sym
!= NULL
&& sym
->attr
.dummy
)
7686 gfc_error ("For dummy procedure %s, no binding name is "
7687 "allowed in BIND(C) at %C", sym
->name
);
7692 /* Save the binding label to the symbol. If sym is null, we're
7693 probably matching the typespec attributes of a declaration and
7694 haven't gotten the name yet, and therefore, no symbol yet. */
7698 sym
->binding_label
= binding_label
;
7700 curr_binding_label
= binding_label
;
7702 else if (allow_binding_name
)
7704 /* No binding label, but if symbol isn't null, we
7705 can set the label for it here.
7706 If name="" or allow_binding_name is false, no C binding name is
7708 if (sym
!= NULL
&& sym
->name
!= NULL
&& has_name_equals
== 0)
7709 sym
->binding_label
= IDENTIFIER_POINTER (get_identifier (sym
->name
));
7712 if (has_name_equals
&& gfc_current_state () == COMP_INTERFACE
7713 && current_interface
.type
== INTERFACE_ABSTRACT
)
7715 gfc_error ("NAME not allowed on BIND(C) for ABSTRACT INTERFACE at %C");
7723 /* Return nonzero if we're currently compiling a contained procedure. */
7726 contained_procedure (void)
7728 gfc_state_data
*s
= gfc_state_stack
;
7730 if ((s
->state
== COMP_SUBROUTINE
|| s
->state
== COMP_FUNCTION
)
7731 && s
->previous
!= NULL
&& s
->previous
->state
== COMP_CONTAINS
)
7737 /* Set the kind of each enumerator. The kind is selected such that it is
7738 interoperable with the corresponding C enumeration type, making
7739 sure that -fshort-enums is honored. */
7744 enumerator_history
*current_history
= NULL
;
7748 if (max_enum
== NULL
|| enum_history
== NULL
)
7751 if (!flag_short_enums
)
7757 kind
= gfc_integer_kinds
[i
++].kind
;
7759 while (kind
< gfc_c_int_kind
7760 && gfc_check_integer_range (max_enum
->initializer
->value
.integer
,
7763 current_history
= enum_history
;
7764 while (current_history
!= NULL
)
7766 current_history
->sym
->ts
.kind
= kind
;
7767 current_history
= current_history
->next
;
7772 /* Match any of the various end-block statements. Returns the type of
7773 END to the caller. The END INTERFACE, END IF, END DO, END SELECT
7774 and END BLOCK statements cannot be replaced by a single END statement. */
7777 gfc_match_end (gfc_statement
*st
)
7779 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7780 gfc_compile_state state
;
7782 const char *block_name
;
7786 gfc_namespace
*parent_ns
, *ns
, *prev_ns
;
7787 gfc_namespace
**nsp
;
7788 bool abreviated_modproc_decl
= false;
7789 bool got_matching_end
= false;
7791 old_loc
= gfc_current_locus
;
7792 if (gfc_match ("end") != MATCH_YES
)
7795 state
= gfc_current_state ();
7796 block_name
= gfc_current_block () == NULL
7797 ? NULL
: gfc_current_block ()->name
;
7801 case COMP_ASSOCIATE
:
7803 if (!strncmp (block_name
, "block@", strlen("block@")))
7808 case COMP_DERIVED_CONTAINS
:
7809 state
= gfc_state_stack
->previous
->state
;
7810 block_name
= gfc_state_stack
->previous
->sym
== NULL
7811 ? NULL
: gfc_state_stack
->previous
->sym
->name
;
7812 abreviated_modproc_decl
= gfc_state_stack
->previous
->sym
7813 && gfc_state_stack
->previous
->sym
->abr_modproc_decl
;
7820 if (!abreviated_modproc_decl
)
7821 abreviated_modproc_decl
= gfc_current_block ()
7822 && gfc_current_block ()->abr_modproc_decl
;
7828 *st
= ST_END_PROGRAM
;
7829 target
= " program";
7833 case COMP_SUBROUTINE
:
7834 *st
= ST_END_SUBROUTINE
;
7835 if (!abreviated_modproc_decl
)
7836 target
= " subroutine";
7838 target
= " procedure";
7839 eos_ok
= !contained_procedure ();
7843 *st
= ST_END_FUNCTION
;
7844 if (!abreviated_modproc_decl
)
7845 target
= " function";
7847 target
= " procedure";
7848 eos_ok
= !contained_procedure ();
7851 case COMP_BLOCK_DATA
:
7852 *st
= ST_END_BLOCK_DATA
;
7853 target
= " block data";
7858 *st
= ST_END_MODULE
;
7863 case COMP_SUBMODULE
:
7864 *st
= ST_END_SUBMODULE
;
7865 target
= " submodule";
7869 case COMP_INTERFACE
:
7870 *st
= ST_END_INTERFACE
;
7871 target
= " interface";
7887 case COMP_STRUCTURE
:
7888 *st
= ST_END_STRUCTURE
;
7889 target
= " structure";
7894 case COMP_DERIVED_CONTAINS
:
7900 case COMP_ASSOCIATE
:
7901 *st
= ST_END_ASSOCIATE
;
7902 target
= " associate";
7919 case COMP_DO_CONCURRENT
:
7926 *st
= ST_END_CRITICAL
;
7927 target
= " critical";
7932 case COMP_SELECT_TYPE
:
7933 *st
= ST_END_SELECT
;
7939 *st
= ST_END_FORALL
;
7954 last_initializer
= NULL
;
7956 gfc_free_enum_history ();
7960 gfc_error ("Unexpected END statement at %C");
7964 old_loc
= gfc_current_locus
;
7965 if (gfc_match_eos () == MATCH_YES
)
7967 if (!eos_ok
&& (*st
== ST_END_SUBROUTINE
|| *st
== ST_END_FUNCTION
))
7969 if (!gfc_notify_std (GFC_STD_F2008
, "END statement "
7970 "instead of %s statement at %L",
7971 abreviated_modproc_decl
? "END PROCEDURE"
7972 : gfc_ascii_statement(*st
), &old_loc
))
7977 /* We would have required END [something]. */
7978 gfc_error ("%s statement expected at %L",
7979 gfc_ascii_statement (*st
), &old_loc
);
7986 /* Verify that we've got the sort of end-block that we're expecting. */
7987 if (gfc_match (target
) != MATCH_YES
)
7989 gfc_error ("Expecting %s statement at %L", abreviated_modproc_decl
7990 ? "END PROCEDURE" : gfc_ascii_statement(*st
), &old_loc
);
7994 got_matching_end
= true;
7996 old_loc
= gfc_current_locus
;
7997 /* If we're at the end, make sure a block name wasn't required. */
7998 if (gfc_match_eos () == MATCH_YES
)
8001 if (*st
!= ST_ENDDO
&& *st
!= ST_ENDIF
&& *st
!= ST_END_SELECT
8002 && *st
!= ST_END_FORALL
&& *st
!= ST_END_WHERE
&& *st
!= ST_END_BLOCK
8003 && *st
!= ST_END_ASSOCIATE
&& *st
!= ST_END_CRITICAL
)
8009 gfc_error ("Expected block name of %qs in %s statement at %L",
8010 block_name
, gfc_ascii_statement (*st
), &old_loc
);
8015 /* END INTERFACE has a special handler for its several possible endings. */
8016 if (*st
== ST_END_INTERFACE
)
8017 return gfc_match_end_interface ();
8019 /* We haven't hit the end of statement, so what is left must be an
8021 m
= gfc_match_space ();
8023 m
= gfc_match_name (name
);
8026 gfc_error ("Expected terminating name at %C");
8030 if (block_name
== NULL
)
8033 /* We have to pick out the declared submodule name from the composite
8034 required by F2008:11.2.3 para 2, which ends in the declared name. */
8035 if (state
== COMP_SUBMODULE
)
8036 block_name
= strchr (block_name
, '.') + 1;
8038 if (strcmp (name
, block_name
) != 0 && strcmp (block_name
, "ppr@") != 0)
8040 gfc_error ("Expected label %qs for %s statement at %C", block_name
,
8041 gfc_ascii_statement (*st
));
8044 /* Procedure pointer as function result. */
8045 else if (strcmp (block_name
, "ppr@") == 0
8046 && strcmp (name
, gfc_current_block ()->ns
->proc_name
->name
) != 0)
8048 gfc_error ("Expected label %qs for %s statement at %C",
8049 gfc_current_block ()->ns
->proc_name
->name
,
8050 gfc_ascii_statement (*st
));
8054 if (gfc_match_eos () == MATCH_YES
)
8058 gfc_syntax_error (*st
);
8061 gfc_current_locus
= old_loc
;
8063 /* If we are missing an END BLOCK, we created a half-ready namespace.
8064 Remove it from the parent namespace's sibling list. */
8066 while (state
== COMP_BLOCK
&& !got_matching_end
)
8068 parent_ns
= gfc_current_ns
->parent
;
8070 nsp
= &(gfc_state_stack
->previous
->tail
->ext
.block
.ns
);
8076 if (ns
== gfc_current_ns
)
8078 if (prev_ns
== NULL
)
8081 prev_ns
->sibling
= ns
->sibling
;
8087 gfc_free_namespace (gfc_current_ns
);
8088 gfc_current_ns
= parent_ns
;
8089 gfc_state_stack
= gfc_state_stack
->previous
;
8090 state
= gfc_current_state ();
8098 /***************** Attribute declaration statements ****************/
8100 /* Set the attribute of a single variable. */
8105 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8108 /* Workaround -Wmaybe-uninitialized false positive during
8109 profiledbootstrap by initializing them. */
8110 gfc_symbol
*sym
= NULL
;
8116 m
= gfc_match_name (name
);
8120 if (find_special (name
, &sym
, false))
8123 if (!check_function_name (name
))
8129 var_locus
= gfc_current_locus
;
8131 /* Deal with possible array specification for certain attributes. */
8132 if (current_attr
.dimension
8133 || current_attr
.codimension
8134 || current_attr
.allocatable
8135 || current_attr
.pointer
8136 || current_attr
.target
)
8138 m
= gfc_match_array_spec (&as
, !current_attr
.codimension
,
8139 !current_attr
.dimension
8140 && !current_attr
.pointer
8141 && !current_attr
.target
);
8142 if (m
== MATCH_ERROR
)
8145 if (current_attr
.dimension
&& m
== MATCH_NO
)
8147 gfc_error ("Missing array specification at %L in DIMENSION "
8148 "statement", &var_locus
);
8153 if (current_attr
.dimension
&& sym
->value
)
8155 gfc_error ("Dimensions specified for %s at %L after its "
8156 "initialization", sym
->name
, &var_locus
);
8161 if (current_attr
.codimension
&& m
== MATCH_NO
)
8163 gfc_error ("Missing array specification at %L in CODIMENSION "
8164 "statement", &var_locus
);
8169 if ((current_attr
.allocatable
|| current_attr
.pointer
)
8170 && (m
== MATCH_YES
) && (as
->type
!= AS_DEFERRED
))
8172 gfc_error ("Array specification must be deferred at %L", &var_locus
);
8178 /* Update symbol table. DIMENSION attribute is set in
8179 gfc_set_array_spec(). For CLASS variables, this must be applied
8180 to the first component, or '_data' field. */
8181 if (sym
->ts
.type
== BT_CLASS
&& sym
->ts
.u
.derived
->attr
.is_class
)
8183 if (!gfc_copy_attr (&CLASS_DATA(sym
)->attr
, ¤t_attr
, &var_locus
))
8191 if (current_attr
.dimension
== 0 && current_attr
.codimension
== 0
8192 && !gfc_copy_attr (&sym
->attr
, ¤t_attr
, &var_locus
))
8199 if (sym
->ts
.type
== BT_CLASS
8200 && !gfc_build_class_symbol (&sym
->ts
, &sym
->attr
, &sym
->as
))
8206 if (!gfc_set_array_spec (sym
, as
, &var_locus
))
8212 if (sym
->attr
.cray_pointee
&& sym
->as
!= NULL
)
8214 /* Fix the array spec. */
8215 m
= gfc_mod_pointee_as (sym
->as
);
8216 if (m
== MATCH_ERROR
)
8220 if (!gfc_add_attribute (&sym
->attr
, &var_locus
))
8226 if ((current_attr
.external
|| current_attr
.intrinsic
)
8227 && sym
->attr
.flavor
!= FL_PROCEDURE
8228 && !gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, NULL
))
8234 add_hidden_procptr_result (sym
);
8239 gfc_free_array_spec (as
);
8244 /* Generic attribute declaration subroutine. Used for attributes that
8245 just have a list of names. */
8252 /* Gobble the optional double colon, by simply ignoring the result
8262 if (gfc_match_eos () == MATCH_YES
)
8268 if (gfc_match_char (',') != MATCH_YES
)
8270 gfc_error ("Unexpected character in variable list at %C");
8280 /* This routine matches Cray Pointer declarations of the form:
8281 pointer ( <pointer>, <pointee> )
8283 pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...
8284 The pointer, if already declared, should be an integer. Otherwise, we
8285 set it as BT_INTEGER with kind gfc_index_integer_kind. The pointee may
8286 be either a scalar, or an array declaration. No space is allocated for
8287 the pointee. For the statement
8288 pointer (ipt, ar(10))
8289 any subsequent uses of ar will be translated (in C-notation) as
8290 ar(i) => ((<type> *) ipt)(i)
8291 After gimplification, pointee variable will disappear in the code. */
8294 cray_pointer_decl (void)
8297 gfc_array_spec
*as
= NULL
;
8298 gfc_symbol
*cptr
; /* Pointer symbol. */
8299 gfc_symbol
*cpte
; /* Pointee symbol. */
8305 if (gfc_match_char ('(') != MATCH_YES
)
8307 gfc_error ("Expected %<(%> at %C");
8311 /* Match pointer. */
8312 var_locus
= gfc_current_locus
;
8313 gfc_clear_attr (¤t_attr
);
8314 gfc_add_cray_pointer (¤t_attr
, &var_locus
);
8315 current_ts
.type
= BT_INTEGER
;
8316 current_ts
.kind
= gfc_index_integer_kind
;
8318 m
= gfc_match_symbol (&cptr
, 0);
8321 gfc_error ("Expected variable name at %C");
8325 if (!gfc_add_cray_pointer (&cptr
->attr
, &var_locus
))
8328 gfc_set_sym_referenced (cptr
);
8330 if (cptr
->ts
.type
== BT_UNKNOWN
) /* Override the type, if necessary. */
8332 cptr
->ts
.type
= BT_INTEGER
;
8333 cptr
->ts
.kind
= gfc_index_integer_kind
;
8335 else if (cptr
->ts
.type
!= BT_INTEGER
)
8337 gfc_error ("Cray pointer at %C must be an integer");
8340 else if (cptr
->ts
.kind
< gfc_index_integer_kind
)
8341 gfc_warning (0, "Cray pointer at %C has %d bytes of precision;"
8342 " memory addresses require %d bytes",
8343 cptr
->ts
.kind
, gfc_index_integer_kind
);
8345 if (gfc_match_char (',') != MATCH_YES
)
8347 gfc_error ("Expected \",\" at %C");
8351 /* Match Pointee. */
8352 var_locus
= gfc_current_locus
;
8353 gfc_clear_attr (¤t_attr
);
8354 gfc_add_cray_pointee (¤t_attr
, &var_locus
);
8355 current_ts
.type
= BT_UNKNOWN
;
8356 current_ts
.kind
= 0;
8358 m
= gfc_match_symbol (&cpte
, 0);
8361 gfc_error ("Expected variable name at %C");
8365 /* Check for an optional array spec. */
8366 m
= gfc_match_array_spec (&as
, true, false);
8367 if (m
== MATCH_ERROR
)
8369 gfc_free_array_spec (as
);
8372 else if (m
== MATCH_NO
)
8374 gfc_free_array_spec (as
);
8378 if (!gfc_add_cray_pointee (&cpte
->attr
, &var_locus
))
8381 gfc_set_sym_referenced (cpte
);
8383 if (cpte
->as
== NULL
)
8385 if (!gfc_set_array_spec (cpte
, as
, &var_locus
))
8386 gfc_internal_error ("Couldn't set Cray pointee array spec.");
8388 else if (as
!= NULL
)
8390 gfc_error ("Duplicate array spec for Cray pointee at %C");
8391 gfc_free_array_spec (as
);
8397 if (cpte
->as
!= NULL
)
8399 /* Fix array spec. */
8400 m
= gfc_mod_pointee_as (cpte
->as
);
8401 if (m
== MATCH_ERROR
)
8405 /* Point the Pointee at the Pointer. */
8406 cpte
->cp_pointer
= cptr
;
8408 if (gfc_match_char (')') != MATCH_YES
)
8410 gfc_error ("Expected \")\" at %C");
8413 m
= gfc_match_char (',');
8415 done
= true; /* Stop searching for more declarations. */
8419 if (m
== MATCH_ERROR
/* Failed when trying to find ',' above. */
8420 || gfc_match_eos () != MATCH_YES
)
8422 gfc_error ("Expected %<,%> or end of statement at %C");
8430 gfc_match_external (void)
8433 gfc_clear_attr (¤t_attr
);
8434 current_attr
.external
= 1;
8436 return attr_decl ();
8441 gfc_match_intent (void)
8445 /* This is not allowed within a BLOCK construct! */
8446 if (gfc_current_state () == COMP_BLOCK
)
8448 gfc_error ("INTENT is not allowed inside of BLOCK at %C");
8452 intent
= match_intent_spec ();
8453 if (intent
== INTENT_UNKNOWN
)
8456 gfc_clear_attr (¤t_attr
);
8457 current_attr
.intent
= intent
;
8459 return attr_decl ();
8464 gfc_match_intrinsic (void)
8467 gfc_clear_attr (¤t_attr
);
8468 current_attr
.intrinsic
= 1;
8470 return attr_decl ();
8475 gfc_match_optional (void)
8477 /* This is not allowed within a BLOCK construct! */
8478 if (gfc_current_state () == COMP_BLOCK
)
8480 gfc_error ("OPTIONAL is not allowed inside of BLOCK at %C");
8484 gfc_clear_attr (¤t_attr
);
8485 current_attr
.optional
= 1;
8487 return attr_decl ();
8492 gfc_match_pointer (void)
8494 gfc_gobble_whitespace ();
8495 if (gfc_peek_ascii_char () == '(')
8497 if (!flag_cray_pointer
)
8499 gfc_error ("Cray pointer declaration at %C requires -fcray-pointer "
8503 return cray_pointer_decl ();
8507 gfc_clear_attr (¤t_attr
);
8508 current_attr
.pointer
= 1;
8510 return attr_decl ();
8516 gfc_match_allocatable (void)
8518 gfc_clear_attr (¤t_attr
);
8519 current_attr
.allocatable
= 1;
8521 return attr_decl ();
8526 gfc_match_codimension (void)
8528 gfc_clear_attr (¤t_attr
);
8529 current_attr
.codimension
= 1;
8531 return attr_decl ();
8536 gfc_match_contiguous (void)
8538 if (!gfc_notify_std (GFC_STD_F2008
, "CONTIGUOUS statement at %C"))
8541 gfc_clear_attr (¤t_attr
);
8542 current_attr
.contiguous
= 1;
8544 return attr_decl ();
8549 gfc_match_dimension (void)
8551 gfc_clear_attr (¤t_attr
);
8552 current_attr
.dimension
= 1;
8554 return attr_decl ();
8559 gfc_match_target (void)
8561 gfc_clear_attr (¤t_attr
);
8562 current_attr
.target
= 1;
8564 return attr_decl ();
8568 /* Match the list of entities being specified in a PUBLIC or PRIVATE
8572 access_attr_decl (gfc_statement st
)
8574 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8575 interface_type type
;
8577 gfc_symbol
*sym
, *dt_sym
;
8578 gfc_intrinsic_op op
;
8581 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
8586 m
= gfc_match_generic_spec (&type
, name
, &op
);
8589 if (m
== MATCH_ERROR
)
8594 case INTERFACE_NAMELESS
:
8595 case INTERFACE_ABSTRACT
:
8598 case INTERFACE_GENERIC
:
8599 case INTERFACE_DTIO
:
8601 if (gfc_get_symbol (name
, NULL
, &sym
))
8604 if (type
== INTERFACE_DTIO
8605 && gfc_current_ns
->proc_name
8606 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
8607 && sym
->attr
.flavor
== FL_UNKNOWN
)
8608 sym
->attr
.flavor
= FL_PROCEDURE
;
8610 if (!gfc_add_access (&sym
->attr
,
8612 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
,
8616 if (sym
->attr
.generic
&& (dt_sym
= gfc_find_dt_in_generic (sym
))
8617 && !gfc_add_access (&dt_sym
->attr
,
8619 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
,
8625 case INTERFACE_INTRINSIC_OP
:
8626 if (gfc_current_ns
->operator_access
[op
] == ACCESS_UNKNOWN
)
8628 gfc_intrinsic_op other_op
;
8630 gfc_current_ns
->operator_access
[op
] =
8631 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
8633 /* Handle the case if there is another op with the same
8634 function, for INTRINSIC_EQ vs. INTRINSIC_EQ_OS and so on. */
8635 other_op
= gfc_equivalent_op (op
);
8637 if (other_op
!= INTRINSIC_NONE
)
8638 gfc_current_ns
->operator_access
[other_op
] =
8639 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
8644 gfc_error ("Access specification of the %s operator at %C has "
8645 "already been specified", gfc_op2string (op
));
8651 case INTERFACE_USER_OP
:
8652 uop
= gfc_get_uop (name
);
8654 if (uop
->access
== ACCESS_UNKNOWN
)
8656 uop
->access
= (st
== ST_PUBLIC
)
8657 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
8661 gfc_error ("Access specification of the .%s. operator at %C "
8662 "has already been specified", sym
->name
);
8669 if (gfc_match_char (',') == MATCH_NO
)
8673 if (gfc_match_eos () != MATCH_YES
)
8678 gfc_syntax_error (st
);
8686 gfc_match_protected (void)
8691 if (!gfc_current_ns
->proc_name
8692 || gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
8694 gfc_error ("PROTECTED at %C only allowed in specification "
8695 "part of a module");
8700 if (!gfc_notify_std (GFC_STD_F2003
, "PROTECTED statement at %C"))
8703 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
8708 if (gfc_match_eos () == MATCH_YES
)
8713 m
= gfc_match_symbol (&sym
, 0);
8717 if (!gfc_add_protected (&sym
->attr
, sym
->name
, &gfc_current_locus
))
8729 if (gfc_match_eos () == MATCH_YES
)
8731 if (gfc_match_char (',') != MATCH_YES
)
8738 gfc_error ("Syntax error in PROTECTED statement at %C");
8743 /* The PRIVATE statement is a bit weird in that it can be an attribute
8744 declaration, but also works as a standalone statement inside of a
8745 type declaration or a module. */
8748 gfc_match_private (gfc_statement
*st
)
8751 if (gfc_match ("private") != MATCH_YES
)
8754 if (gfc_current_state () != COMP_MODULE
8755 && !(gfc_current_state () == COMP_DERIVED
8756 && gfc_state_stack
->previous
8757 && gfc_state_stack
->previous
->state
== COMP_MODULE
)
8758 && !(gfc_current_state () == COMP_DERIVED_CONTAINS
8759 && gfc_state_stack
->previous
&& gfc_state_stack
->previous
->previous
8760 && gfc_state_stack
->previous
->previous
->state
== COMP_MODULE
))
8762 gfc_error ("PRIVATE statement at %C is only allowed in the "
8763 "specification part of a module");
8767 if (gfc_current_state () == COMP_DERIVED
)
8769 if (gfc_match_eos () == MATCH_YES
)
8775 gfc_syntax_error (ST_PRIVATE
);
8779 if (gfc_match_eos () == MATCH_YES
)
8786 return access_attr_decl (ST_PRIVATE
);
8791 gfc_match_public (gfc_statement
*st
)
8794 if (gfc_match ("public") != MATCH_YES
)
8797 if (gfc_current_state () != COMP_MODULE
)
8799 gfc_error ("PUBLIC statement at %C is only allowed in the "
8800 "specification part of a module");
8804 if (gfc_match_eos () == MATCH_YES
)
8811 return access_attr_decl (ST_PUBLIC
);
8815 /* Workhorse for gfc_match_parameter. */
8825 m
= gfc_match_symbol (&sym
, 0);
8827 gfc_error ("Expected variable name at %C in PARAMETER statement");
8832 if (gfc_match_char ('=') == MATCH_NO
)
8834 gfc_error ("Expected = sign in PARAMETER statement at %C");
8838 m
= gfc_match_init_expr (&init
);
8840 gfc_error ("Expected expression at %C in PARAMETER statement");
8844 if (sym
->ts
.type
== BT_UNKNOWN
8845 && !gfc_set_default_type (sym
, 1, NULL
))
8851 if (!gfc_check_assign_symbol (sym
, NULL
, init
)
8852 || !gfc_add_flavor (&sym
->attr
, FL_PARAMETER
, sym
->name
, NULL
))
8860 gfc_error ("Initializing already initialized variable at %C");
8865 t
= add_init_expr_to_sym (sym
->name
, &init
, &gfc_current_locus
);
8866 return (t
) ? MATCH_YES
: MATCH_ERROR
;
8869 gfc_free_expr (init
);
8874 /* Match a parameter statement, with the weird syntax that these have. */
8877 gfc_match_parameter (void)
8879 const char *term
= " )%t";
8882 if (gfc_match_char ('(') == MATCH_NO
)
8884 /* With legacy PARAMETER statements, don't expect a terminating ')'. */
8885 if (!gfc_notify_std (GFC_STD_LEGACY
, "PARAMETER without '()' at %C"))
8896 if (gfc_match (term
) == MATCH_YES
)
8899 if (gfc_match_char (',') != MATCH_YES
)
8901 gfc_error ("Unexpected characters in PARAMETER statement at %C");
8912 gfc_match_automatic (void)
8916 bool seen_symbol
= false;
8918 if (!flag_dec_static
)
8920 gfc_error ("%s at %C is a DEC extension, enable with "
8931 m
= gfc_match_symbol (&sym
, 0);
8941 if (!gfc_add_automatic (&sym
->attr
, sym
->name
, &gfc_current_locus
))
8947 if (gfc_match_eos () == MATCH_YES
)
8949 if (gfc_match_char (',') != MATCH_YES
)
8955 gfc_error ("Expected entity-list in AUTOMATIC statement at %C");
8962 gfc_error ("Syntax error in AUTOMATIC statement at %C");
8968 gfc_match_static (void)
8972 bool seen_symbol
= false;
8974 if (!flag_dec_static
)
8976 gfc_error ("%s at %C is a DEC extension, enable with "
8986 m
= gfc_match_symbol (&sym
, 0);
8996 if (!gfc_add_save (&sym
->attr
, SAVE_EXPLICIT
, sym
->name
,
8997 &gfc_current_locus
))
9003 if (gfc_match_eos () == MATCH_YES
)
9005 if (gfc_match_char (',') != MATCH_YES
)
9011 gfc_error ("Expected entity-list in STATIC statement at %C");
9018 gfc_error ("Syntax error in STATIC statement at %C");
9023 /* Save statements have a special syntax. */
9026 gfc_match_save (void)
9028 char n
[GFC_MAX_SYMBOL_LEN
+1];
9033 if (gfc_match_eos () == MATCH_YES
)
9035 if (gfc_current_ns
->seen_save
)
9037 if (!gfc_notify_std (GFC_STD_LEGACY
, "Blanket SAVE statement at %C "
9038 "follows previous SAVE statement"))
9042 gfc_current_ns
->save_all
= gfc_current_ns
->seen_save
= 1;
9046 if (gfc_current_ns
->save_all
)
9048 if (!gfc_notify_std (GFC_STD_LEGACY
, "SAVE statement at %C follows "
9049 "blanket SAVE statement"))
9057 m
= gfc_match_symbol (&sym
, 0);
9061 if (!gfc_add_save (&sym
->attr
, SAVE_EXPLICIT
, sym
->name
,
9062 &gfc_current_locus
))
9073 m
= gfc_match (" / %n /", &n
);
9074 if (m
== MATCH_ERROR
)
9079 c
= gfc_get_common (n
, 0);
9082 gfc_current_ns
->seen_save
= 1;
9085 if (gfc_match_eos () == MATCH_YES
)
9087 if (gfc_match_char (',') != MATCH_YES
)
9094 gfc_error ("Syntax error in SAVE statement at %C");
9100 gfc_match_value (void)
9105 /* This is not allowed within a BLOCK construct! */
9106 if (gfc_current_state () == COMP_BLOCK
)
9108 gfc_error ("VALUE is not allowed inside of BLOCK at %C");
9112 if (!gfc_notify_std (GFC_STD_F2003
, "VALUE statement at %C"))
9115 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
9120 if (gfc_match_eos () == MATCH_YES
)
9125 m
= gfc_match_symbol (&sym
, 0);
9129 if (!gfc_add_value (&sym
->attr
, sym
->name
, &gfc_current_locus
))
9141 if (gfc_match_eos () == MATCH_YES
)
9143 if (gfc_match_char (',') != MATCH_YES
)
9150 gfc_error ("Syntax error in VALUE statement at %C");
9156 gfc_match_volatile (void)
9162 if (!gfc_notify_std (GFC_STD_F2003
, "VOLATILE statement at %C"))
9165 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
9170 if (gfc_match_eos () == MATCH_YES
)
9175 /* VOLATILE is special because it can be added to host-associated
9176 symbols locally. Except for coarrays. */
9177 m
= gfc_match_symbol (&sym
, 1);
9181 name
= XCNEWVAR (char, strlen (sym
->name
) + 1);
9182 strcpy (name
, sym
->name
);
9183 if (!check_function_name (name
))
9185 /* F2008, C560+C561. VOLATILE for host-/use-associated variable or
9186 for variable in a BLOCK which is defined outside of the BLOCK. */
9187 if (sym
->ns
!= gfc_current_ns
&& sym
->attr
.codimension
)
9189 gfc_error ("Specifying VOLATILE for coarray variable %qs at "
9190 "%C, which is use-/host-associated", sym
->name
);
9193 if (!gfc_add_volatile (&sym
->attr
, sym
->name
, &gfc_current_locus
))
9205 if (gfc_match_eos () == MATCH_YES
)
9207 if (gfc_match_char (',') != MATCH_YES
)
9214 gfc_error ("Syntax error in VOLATILE statement at %C");
9220 gfc_match_asynchronous (void)
9226 if (!gfc_notify_std (GFC_STD_F2003
, "ASYNCHRONOUS statement at %C"))
9229 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
9234 if (gfc_match_eos () == MATCH_YES
)
9239 /* ASYNCHRONOUS is special because it can be added to host-associated
9241 m
= gfc_match_symbol (&sym
, 1);
9245 name
= XCNEWVAR (char, strlen (sym
->name
) + 1);
9246 strcpy (name
, sym
->name
);
9247 if (!check_function_name (name
))
9249 if (!gfc_add_asynchronous (&sym
->attr
, sym
->name
, &gfc_current_locus
))
9261 if (gfc_match_eos () == MATCH_YES
)
9263 if (gfc_match_char (',') != MATCH_YES
)
9270 gfc_error ("Syntax error in ASYNCHRONOUS statement at %C");
9275 /* Match a module procedure statement in a submodule. */
9278 gfc_match_submod_proc (void)
9280 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9281 gfc_symbol
*sym
, *fsym
;
9283 gfc_formal_arglist
*formal
, *head
, *tail
;
9285 if (gfc_current_state () != COMP_CONTAINS
9286 || !(gfc_state_stack
->previous
9287 && (gfc_state_stack
->previous
->state
== COMP_SUBMODULE
9288 || gfc_state_stack
->previous
->state
== COMP_MODULE
)))
9291 m
= gfc_match (" module% procedure% %n", name
);
9295 if (!gfc_notify_std (GFC_STD_F2008
, "MODULE PROCEDURE declaration "
9299 if (get_proc_name (name
, &sym
, false))
9302 /* Make sure that the result field is appropriately filled, even though
9303 the result symbol will be replaced later on. */
9304 if (sym
->tlink
&& sym
->tlink
->attr
.function
)
9306 if (sym
->tlink
->result
9307 && sym
->tlink
->result
!= sym
->tlink
)
9308 sym
->result
= sym
->tlink
->result
;
9313 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
9314 the symbol existed before. */
9315 sym
->declared_at
= gfc_current_locus
;
9317 if (!sym
->attr
.module_procedure
)
9320 /* Signal match_end to expect "end procedure". */
9321 sym
->abr_modproc_decl
= 1;
9323 /* Change from IFSRC_IFBODY coming from the interface declaration. */
9324 sym
->attr
.if_source
= IFSRC_DECL
;
9326 gfc_new_block
= sym
;
9328 /* Make a new formal arglist with the symbols in the procedure
9331 for (formal
= sym
->formal
; formal
&& formal
->sym
; formal
= formal
->next
)
9333 if (formal
== sym
->formal
)
9334 head
= tail
= gfc_get_formal_arglist ();
9337 tail
->next
= gfc_get_formal_arglist ();
9341 if (gfc_copy_dummy_sym (&fsym
, formal
->sym
, 0))
9345 gfc_set_sym_referenced (fsym
);
9348 /* The dummy symbols get cleaned up, when the formal_namespace of the
9349 interface declaration is cleared. This allows us to add the
9350 explicit interface as is done for other type of procedure. */
9351 if (!gfc_add_explicit_interface (sym
, IFSRC_DECL
, head
,
9352 &gfc_current_locus
))
9355 if (gfc_match_eos () != MATCH_YES
)
9357 gfc_syntax_error (ST_MODULE_PROC
);
9364 gfc_free_formal_arglist (head
);
9369 /* Match a module procedure statement. Note that we have to modify
9370 symbols in the parent's namespace because the current one was there
9371 to receive symbols that are in an interface's formal argument list. */
9374 gfc_match_modproc (void)
9376 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9380 gfc_namespace
*module_ns
;
9381 gfc_interface
*old_interface_head
, *interface
;
9383 if (gfc_state_stack
->state
!= COMP_INTERFACE
9384 || gfc_state_stack
->previous
== NULL
9385 || current_interface
.type
== INTERFACE_NAMELESS
9386 || current_interface
.type
== INTERFACE_ABSTRACT
)
9388 gfc_error ("MODULE PROCEDURE at %C must be in a generic module "
9393 module_ns
= gfc_current_ns
->parent
;
9394 for (; module_ns
; module_ns
= module_ns
->parent
)
9395 if (module_ns
->proc_name
->attr
.flavor
== FL_MODULE
9396 || module_ns
->proc_name
->attr
.flavor
== FL_PROGRAM
9397 || (module_ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
9398 && !module_ns
->proc_name
->attr
.contained
))
9401 if (module_ns
== NULL
)
9404 /* Store the current state of the interface. We will need it if we
9405 end up with a syntax error and need to recover. */
9406 old_interface_head
= gfc_current_interface_head ();
9408 /* Check if the F2008 optional double colon appears. */
9409 gfc_gobble_whitespace ();
9410 old_locus
= gfc_current_locus
;
9411 if (gfc_match ("::") == MATCH_YES
)
9413 if (!gfc_notify_std (GFC_STD_F2008
, "double colon in "
9414 "MODULE PROCEDURE statement at %L", &old_locus
))
9418 gfc_current_locus
= old_locus
;
9423 old_locus
= gfc_current_locus
;
9425 m
= gfc_match_name (name
);
9431 /* Check for syntax error before starting to add symbols to the
9432 current namespace. */
9433 if (gfc_match_eos () == MATCH_YES
)
9436 if (!last
&& gfc_match_char (',') != MATCH_YES
)
9439 /* Now we're sure the syntax is valid, we process this item
9441 if (gfc_get_symbol (name
, module_ns
, &sym
))
9444 if (sym
->attr
.intrinsic
)
9446 gfc_error ("Intrinsic procedure at %L cannot be a MODULE "
9447 "PROCEDURE", &old_locus
);
9451 if (sym
->attr
.proc
!= PROC_MODULE
9452 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
9455 if (!gfc_add_interface (sym
))
9458 sym
->attr
.mod_proc
= 1;
9459 sym
->declared_at
= old_locus
;
9468 /* Restore the previous state of the interface. */
9469 interface
= gfc_current_interface_head ();
9470 gfc_set_current_interface_head (old_interface_head
);
9472 /* Free the new interfaces. */
9473 while (interface
!= old_interface_head
)
9475 gfc_interface
*i
= interface
->next
;
9480 /* And issue a syntax error. */
9481 gfc_syntax_error (ST_MODULE_PROC
);
9486 /* Check a derived type that is being extended. */
9489 check_extended_derived_type (char *name
)
9491 gfc_symbol
*extended
;
9493 if (gfc_find_symbol (name
, gfc_current_ns
, 1, &extended
))
9495 gfc_error ("Ambiguous symbol in TYPE definition at %C");
9499 extended
= gfc_find_dt_in_generic (extended
);
9504 gfc_error ("Symbol %qs at %C has not been previously defined", name
);
9508 if (extended
->attr
.flavor
!= FL_DERIVED
)
9510 gfc_error ("%qs in EXTENDS expression at %C is not a "
9511 "derived type", name
);
9515 if (extended
->attr
.is_bind_c
)
9517 gfc_error ("%qs cannot be extended at %C because it "
9518 "is BIND(C)", extended
->name
);
9522 if (extended
->attr
.sequence
)
9524 gfc_error ("%qs cannot be extended at %C because it "
9525 "is a SEQUENCE type", extended
->name
);
9533 /* Match the optional attribute specifiers for a type declaration.
9534 Return MATCH_ERROR if an error is encountered in one of the handled
9535 attributes (public, private, bind(c)), MATCH_NO if what's found is
9536 not a handled attribute, and MATCH_YES otherwise. TODO: More error
9537 checking on attribute conflicts needs to be done. */
9540 gfc_get_type_attr_spec (symbol_attribute
*attr
, char *name
)
9542 /* See if the derived type is marked as private. */
9543 if (gfc_match (" , private") == MATCH_YES
)
9545 if (gfc_current_state () != COMP_MODULE
)
9547 gfc_error ("Derived type at %C can only be PRIVATE in the "
9548 "specification part of a module");
9552 if (!gfc_add_access (attr
, ACCESS_PRIVATE
, NULL
, NULL
))
9555 else if (gfc_match (" , public") == MATCH_YES
)
9557 if (gfc_current_state () != COMP_MODULE
)
9559 gfc_error ("Derived type at %C can only be PUBLIC in the "
9560 "specification part of a module");
9564 if (!gfc_add_access (attr
, ACCESS_PUBLIC
, NULL
, NULL
))
9567 else if (gfc_match (" , bind ( c )") == MATCH_YES
)
9569 /* If the type is defined to be bind(c) it then needs to make
9570 sure that all fields are interoperable. This will
9571 need to be a semantic check on the finished derived type.
9572 See 15.2.3 (lines 9-12) of F2003 draft. */
9573 if (!gfc_add_is_bind_c (attr
, NULL
, &gfc_current_locus
, 0))
9576 /* TODO: attr conflicts need to be checked, probably in symbol.c. */
9578 else if (gfc_match (" , abstract") == MATCH_YES
)
9580 if (!gfc_notify_std (GFC_STD_F2003
, "ABSTRACT type at %C"))
9583 if (!gfc_add_abstract (attr
, &gfc_current_locus
))
9586 else if (name
&& gfc_match (" , extends ( %n )", name
) == MATCH_YES
)
9588 if (!gfc_add_extension (attr
, &gfc_current_locus
))
9594 /* If we get here, something matched. */
9599 /* Common function for type declaration blocks similar to derived types, such
9600 as STRUCTURES and MAPs. Unlike derived types, a structure type
9601 does NOT have a generic symbol matching the name given by the user.
9602 STRUCTUREs can share names with variables and PARAMETERs so we must allow
9603 for the creation of an independent symbol.
9604 Other parameters are a message to prefix errors with, the name of the new
9605 type to be created, and the flavor to add to the resulting symbol. */
9608 get_struct_decl (const char *name
, sym_flavor fl
, locus
*decl
,
9609 gfc_symbol
**result
)
9614 gcc_assert (name
[0] == (char) TOUPPER (name
[0]));
9619 where
= gfc_current_locus
;
9621 if (gfc_get_symbol (name
, NULL
, &sym
))
9626 gfc_internal_error ("Failed to create structure type '%s' at %C", name
);
9630 if (sym
->components
!= NULL
|| sym
->attr
.zero_comp
)
9632 gfc_error ("Type definition of %qs at %C was already defined at %L",
9633 sym
->name
, &sym
->declared_at
);
9637 sym
->declared_at
= where
;
9639 if (sym
->attr
.flavor
!= fl
9640 && !gfc_add_flavor (&sym
->attr
, fl
, sym
->name
, NULL
))
9643 if (!sym
->hash_value
)
9644 /* Set the hash for the compound name for this type. */
9645 sym
->hash_value
= gfc_hash_value (sym
);
9647 /* Normally the type is expected to have been completely parsed by the time
9648 a field declaration with this type is seen. For unions, maps, and nested
9649 structure declarations, we need to indicate that it is okay that we
9650 haven't seen any components yet. This will be updated after the structure
9652 sym
->attr
.zero_comp
= 0;
9654 /* Structures always act like derived-types with the SEQUENCE attribute */
9655 gfc_add_sequence (&sym
->attr
, sym
->name
, NULL
);
9657 if (result
) *result
= sym
;
9663 /* Match the opening of a MAP block. Like a struct within a union in C;
9664 behaves identical to STRUCTURE blocks. */
9667 gfc_match_map (void)
9669 /* Counter used to give unique internal names to map structures. */
9670 static unsigned int gfc_map_id
= 0;
9671 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9675 old_loc
= gfc_current_locus
;
9677 if (gfc_match_eos () != MATCH_YES
)
9679 gfc_error ("Junk after MAP statement at %C");
9680 gfc_current_locus
= old_loc
;
9684 /* Map blocks are anonymous so we make up unique names for the symbol table
9685 which are invalid Fortran identifiers. */
9686 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "MM$%u", gfc_map_id
++);
9688 if (!get_struct_decl (name
, FL_STRUCT
, &old_loc
, &sym
))
9691 gfc_new_block
= sym
;
9697 /* Match the opening of a UNION block. */
9700 gfc_match_union (void)
9702 /* Counter used to give unique internal names to union types. */
9703 static unsigned int gfc_union_id
= 0;
9704 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9708 old_loc
= gfc_current_locus
;
9710 if (gfc_match_eos () != MATCH_YES
)
9712 gfc_error ("Junk after UNION statement at %C");
9713 gfc_current_locus
= old_loc
;
9717 /* Unions are anonymous so we make up unique names for the symbol table
9718 which are invalid Fortran identifiers. */
9719 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "UU$%u", gfc_union_id
++);
9721 if (!get_struct_decl (name
, FL_UNION
, &old_loc
, &sym
))
9724 gfc_new_block
= sym
;
9730 /* Match the beginning of a STRUCTURE declaration. This is similar to
9731 matching the beginning of a derived type declaration with a few
9732 twists. The resulting type symbol has no access control or other
9733 interesting attributes. */
9736 gfc_match_structure_decl (void)
9738 /* Counter used to give unique internal names to anonymous structures. */
9739 static unsigned int gfc_structure_id
= 0;
9740 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9745 if (!flag_dec_structure
)
9747 gfc_error ("%s at %C is a DEC extension, enable with "
9748 "%<-fdec-structure%>",
9755 m
= gfc_match (" /%n/", name
);
9758 /* Non-nested structure declarations require a structure name. */
9759 if (!gfc_comp_struct (gfc_current_state ()))
9761 gfc_error ("Structure name expected in non-nested structure "
9762 "declaration at %C");
9765 /* This is an anonymous structure; make up a unique name for it
9766 (upper-case letters never make it to symbol names from the source).
9767 The important thing is initializing the type variable
9768 and setting gfc_new_symbol, which is immediately used by
9769 parse_structure () and variable_decl () to add components of
9771 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "SS$%u", gfc_structure_id
++);
9774 where
= gfc_current_locus
;
9775 /* No field list allowed after non-nested structure declaration. */
9776 if (!gfc_comp_struct (gfc_current_state ())
9777 && gfc_match_eos () != MATCH_YES
)
9779 gfc_error ("Junk after non-nested STRUCTURE statement at %C");
9783 /* Make sure the name is not the name of an intrinsic type. */
9784 if (gfc_is_intrinsic_typename (name
))
9786 gfc_error ("Structure name %qs at %C cannot be the same as an"
9787 " intrinsic type", name
);
9791 /* Store the actual type symbol for the structure with an upper-case first
9792 letter (an invalid Fortran identifier). */
9794 if (!get_struct_decl (gfc_dt_upper_string (name
), FL_STRUCT
, &where
, &sym
))
9797 gfc_new_block
= sym
;
9802 /* This function does some work to determine which matcher should be used to
9803 * match a statement beginning with "TYPE". This is used to disambiguate TYPE
9804 * as an alias for PRINT from derived type declarations, TYPE IS statements,
9805 * and derived type data declarations. */
9808 gfc_match_type (gfc_statement
*st
)
9810 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9814 /* Requires -fdec. */
9818 m
= gfc_match ("type");
9821 /* If we already have an error in the buffer, it is probably from failing to
9822 * match a derived type data declaration. Let it happen. */
9823 else if (gfc_error_flag_test ())
9826 old_loc
= gfc_current_locus
;
9829 /* If we see an attribute list before anything else it's definitely a derived
9830 * type declaration. */
9831 if (gfc_match (" ,") == MATCH_YES
|| gfc_match (" ::") == MATCH_YES
)
9833 gfc_current_locus
= old_loc
;
9834 *st
= ST_DERIVED_DECL
;
9835 return gfc_match_derived_decl ();
9838 /* By now "TYPE" has already been matched. If we do not see a name, this may
9839 * be something like "TYPE *" or "TYPE <fmt>". */
9840 m
= gfc_match_name (name
);
9843 /* Let print match if it can, otherwise throw an error from
9844 * gfc_match_derived_decl. */
9845 gfc_current_locus
= old_loc
;
9846 if (gfc_match_print () == MATCH_YES
)
9851 gfc_current_locus
= old_loc
;
9852 *st
= ST_DERIVED_DECL
;
9853 return gfc_match_derived_decl ();
9856 /* A derived type declaration requires an EOS. Without it, assume print. */
9857 m
= gfc_match_eos ();
9860 /* Check manually for TYPE IS (... - this is invalid print syntax. */
9861 if (strncmp ("is", name
, 3) == 0
9862 && gfc_match (" (", name
) == MATCH_YES
)
9864 gfc_current_locus
= old_loc
;
9865 gcc_assert (gfc_match (" is") == MATCH_YES
);
9867 return gfc_match_type_is ();
9869 gfc_current_locus
= old_loc
;
9871 return gfc_match_print ();
9875 /* By now we have "TYPE <name> <EOS>". Check first if the name is an
9876 * intrinsic typename - if so let gfc_match_derived_decl dump an error.
9877 * Otherwise if gfc_match_derived_decl fails it's probably an existing
9878 * symbol which can be printed. */
9879 gfc_current_locus
= old_loc
;
9880 m
= gfc_match_derived_decl ();
9881 if (gfc_is_intrinsic_typename (name
) || m
== MATCH_YES
)
9883 *st
= ST_DERIVED_DECL
;
9886 gfc_current_locus
= old_loc
;
9888 return gfc_match_print ();
9895 /* Match the beginning of a derived type declaration. If a type name
9896 was the result of a function, then it is possible to have a symbol
9897 already to be known as a derived type yet have no components. */
9900 gfc_match_derived_decl (void)
9902 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9903 char parent
[GFC_MAX_SYMBOL_LEN
+ 1];
9904 symbol_attribute attr
;
9905 gfc_symbol
*sym
, *gensym
;
9906 gfc_symbol
*extended
;
9908 match is_type_attr_spec
= MATCH_NO
;
9909 bool seen_attr
= false;
9910 gfc_interface
*intr
= NULL
, *head
;
9911 bool parameterized_type
= false;
9912 bool seen_colons
= false;
9914 if (gfc_comp_struct (gfc_current_state ()))
9919 gfc_clear_attr (&attr
);
9924 is_type_attr_spec
= gfc_get_type_attr_spec (&attr
, parent
);
9925 if (is_type_attr_spec
== MATCH_ERROR
)
9927 if (is_type_attr_spec
== MATCH_YES
)
9929 } while (is_type_attr_spec
== MATCH_YES
);
9931 /* Deal with derived type extensions. The extension attribute has
9932 been added to 'attr' but now the parent type must be found and
9935 extended
= check_extended_derived_type (parent
);
9937 if (parent
[0] && !extended
)
9940 m
= gfc_match (" ::");
9947 gfc_error ("Expected :: in TYPE definition at %C");
9951 m
= gfc_match (" %n ", name
);
9955 /* Make sure that we don't identify TYPE IS (...) as a parameterized
9956 derived type named 'is'.
9957 TODO Expand the check, when 'name' = "is" by matching " (tname) "
9958 and checking if this is a(n intrinsic) typename. his picks up
9959 misplaced TYPE IS statements such as in select_type_1.f03. */
9960 if (gfc_peek_ascii_char () == '(')
9962 if (gfc_current_state () == COMP_SELECT_TYPE
9963 || (!seen_colons
&& !strcmp (name
, "is")))
9965 parameterized_type
= true;
9968 m
= gfc_match_eos ();
9969 if (m
!= MATCH_YES
&& !parameterized_type
)
9972 /* Make sure the name is not the name of an intrinsic type. */
9973 if (gfc_is_intrinsic_typename (name
))
9975 gfc_error ("Type name %qs at %C cannot be the same as an intrinsic "
9980 if (gfc_get_symbol (name
, NULL
, &gensym
))
9983 if (!gensym
->attr
.generic
&& gensym
->ts
.type
!= BT_UNKNOWN
)
9985 if (gensym
->ts
.u
.derived
)
9986 gfc_error ("Derived type name %qs at %C already has a basic type "
9987 "of %s", gensym
->name
, gfc_typename (&gensym
->ts
));
9989 gfc_error ("Derived type name %qs at %C already has a basic type",
9994 if (!gensym
->attr
.generic
9995 && !gfc_add_generic (&gensym
->attr
, gensym
->name
, NULL
))
9998 if (!gensym
->attr
.function
9999 && !gfc_add_function (&gensym
->attr
, gensym
->name
, NULL
))
10000 return MATCH_ERROR
;
10002 sym
= gfc_find_dt_in_generic (gensym
);
10004 if (sym
&& (sym
->components
!= NULL
|| sym
->attr
.zero_comp
))
10006 gfc_error ("Derived type definition of %qs at %C has already been "
10007 "defined", sym
->name
);
10008 return MATCH_ERROR
;
10013 /* Use upper case to save the actual derived-type symbol. */
10014 gfc_get_symbol (gfc_dt_upper_string (gensym
->name
), NULL
, &sym
);
10015 sym
->name
= gfc_get_string ("%s", gensym
->name
);
10016 head
= gensym
->generic
;
10017 intr
= gfc_get_interface ();
10019 intr
->where
= gfc_current_locus
;
10020 intr
->sym
->declared_at
= gfc_current_locus
;
10022 gensym
->generic
= intr
;
10023 gensym
->attr
.if_source
= IFSRC_DECL
;
10026 /* The symbol may already have the derived attribute without the
10027 components. The ways this can happen is via a function
10028 definition, an INTRINSIC statement or a subtype in another
10029 derived type that is a pointer. The first part of the AND clause
10030 is true if the symbol is not the return value of a function. */
10031 if (sym
->attr
.flavor
!= FL_DERIVED
10032 && !gfc_add_flavor (&sym
->attr
, FL_DERIVED
, sym
->name
, NULL
))
10033 return MATCH_ERROR
;
10035 if (attr
.access
!= ACCESS_UNKNOWN
10036 && !gfc_add_access (&sym
->attr
, attr
.access
, sym
->name
, NULL
))
10037 return MATCH_ERROR
;
10038 else if (sym
->attr
.access
== ACCESS_UNKNOWN
10039 && gensym
->attr
.access
!= ACCESS_UNKNOWN
10040 && !gfc_add_access (&sym
->attr
, gensym
->attr
.access
,
10042 return MATCH_ERROR
;
10044 if (sym
->attr
.access
!= ACCESS_UNKNOWN
10045 && gensym
->attr
.access
== ACCESS_UNKNOWN
)
10046 gensym
->attr
.access
= sym
->attr
.access
;
10048 /* See if the derived type was labeled as bind(c). */
10049 if (attr
.is_bind_c
!= 0)
10050 sym
->attr
.is_bind_c
= attr
.is_bind_c
;
10052 /* Construct the f2k_derived namespace if it is not yet there. */
10053 if (!sym
->f2k_derived
)
10054 sym
->f2k_derived
= gfc_get_namespace (NULL
, 0);
10056 if (parameterized_type
)
10058 /* Ignore error or mismatches by going to the end of the statement
10059 in order to avoid the component declarations causing problems. */
10060 m
= gfc_match_formal_arglist (sym
, 0, 0, true);
10061 if (m
!= MATCH_YES
)
10062 gfc_error_recovery ();
10063 m
= gfc_match_eos ();
10064 if (m
!= MATCH_YES
)
10066 gfc_error_recovery ();
10067 gfc_error_now ("Garbage after PARAMETERIZED TYPE declaration at %C");
10069 sym
->attr
.pdt_template
= 1;
10072 if (extended
&& !sym
->components
)
10075 gfc_formal_arglist
*f
, *g
, *h
;
10077 /* Add the extended derived type as the first component. */
10078 gfc_add_component (sym
, parent
, &p
);
10080 gfc_set_sym_referenced (extended
);
10082 p
->ts
.type
= BT_DERIVED
;
10083 p
->ts
.u
.derived
= extended
;
10084 p
->initializer
= gfc_default_initializer (&p
->ts
);
10086 /* Set extension level. */
10087 if (extended
->attr
.extension
== 255)
10089 /* Since the extension field is 8 bit wide, we can only have
10090 up to 255 extension levels. */
10091 gfc_error ("Maximum extension level reached with type %qs at %L",
10092 extended
->name
, &extended
->declared_at
);
10093 return MATCH_ERROR
;
10095 sym
->attr
.extension
= extended
->attr
.extension
+ 1;
10097 /* Provide the links between the extended type and its extension. */
10098 if (!extended
->f2k_derived
)
10099 extended
->f2k_derived
= gfc_get_namespace (NULL
, 0);
10101 /* Copy the extended type-param-name-list from the extended type,
10102 append those of the extension and add the whole lot to the
10104 if (extended
->attr
.pdt_template
)
10107 sym
->attr
.pdt_template
= 1;
10108 for (f
= extended
->formal
; f
; f
= f
->next
)
10110 if (f
== extended
->formal
)
10112 g
= gfc_get_formal_arglist ();
10117 g
->next
= gfc_get_formal_arglist ();
10122 g
->next
= sym
->formal
;
10127 if (!sym
->hash_value
)
10128 /* Set the hash for the compound name for this type. */
10129 sym
->hash_value
= gfc_hash_value (sym
);
10131 /* Take over the ABSTRACT attribute. */
10132 sym
->attr
.abstract
= attr
.abstract
;
10134 gfc_new_block
= sym
;
10140 /* Cray Pointees can be declared as:
10141 pointer (ipt, a (n,m,...,*)) */
10144 gfc_mod_pointee_as (gfc_array_spec
*as
)
10146 as
->cray_pointee
= true; /* This will be useful to know later. */
10147 if (as
->type
== AS_ASSUMED_SIZE
)
10148 as
->cp_was_assumed
= true;
10149 else if (as
->type
== AS_ASSUMED_SHAPE
)
10151 gfc_error ("Cray Pointee at %C cannot be assumed shape array");
10152 return MATCH_ERROR
;
10158 /* Match the enum definition statement, here we are trying to match
10159 the first line of enum definition statement.
10160 Returns MATCH_YES if match is found. */
10163 gfc_match_enum (void)
10167 m
= gfc_match_eos ();
10168 if (m
!= MATCH_YES
)
10171 if (!gfc_notify_std (GFC_STD_F2003
, "ENUM and ENUMERATOR at %C"))
10172 return MATCH_ERROR
;
10178 /* Returns an initializer whose value is one higher than the value of the
10179 LAST_INITIALIZER argument. If the argument is NULL, the
10180 initializers value will be set to zero. The initializer's kind
10181 will be set to gfc_c_int_kind.
10183 If -fshort-enums is given, the appropriate kind will be selected
10184 later after all enumerators have been parsed. A warning is issued
10185 here if an initializer exceeds gfc_c_int_kind. */
10188 enum_initializer (gfc_expr
*last_initializer
, locus where
)
10191 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_c_int_kind
, &where
);
10193 mpz_init (result
->value
.integer
);
10195 if (last_initializer
!= NULL
)
10197 mpz_add_ui (result
->value
.integer
, last_initializer
->value
.integer
, 1);
10198 result
->where
= last_initializer
->where
;
10200 if (gfc_check_integer_range (result
->value
.integer
,
10201 gfc_c_int_kind
) != ARITH_OK
)
10203 gfc_error ("Enumerator exceeds the C integer type at %C");
10209 /* Control comes here, if it's the very first enumerator and no
10210 initializer has been given. It will be initialized to zero. */
10211 mpz_set_si (result
->value
.integer
, 0);
10218 /* Match a variable name with an optional initializer. When this
10219 subroutine is called, a variable is expected to be parsed next.
10220 Depending on what is happening at the moment, updates either the
10221 symbol table or the current interface. */
10224 enumerator_decl (void)
10226 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10227 gfc_expr
*initializer
;
10228 gfc_array_spec
*as
= NULL
;
10235 initializer
= NULL
;
10236 old_locus
= gfc_current_locus
;
10238 /* When we get here, we've just matched a list of attributes and
10239 maybe a type and a double colon. The next thing we expect to see
10240 is the name of the symbol. */
10241 m
= gfc_match_name (name
);
10242 if (m
!= MATCH_YES
)
10245 var_locus
= gfc_current_locus
;
10247 /* OK, we've successfully matched the declaration. Now put the
10248 symbol in the current namespace. If we fail to create the symbol,
10250 if (!build_sym (name
, NULL
, false, &as
, &var_locus
))
10256 /* The double colon must be present in order to have initializers.
10257 Otherwise the statement is ambiguous with an assignment statement. */
10260 if (gfc_match_char ('=') == MATCH_YES
)
10262 m
= gfc_match_init_expr (&initializer
);
10265 gfc_error ("Expected an initialization expression at %C");
10269 if (m
!= MATCH_YES
)
10274 /* If we do not have an initializer, the initialization value of the
10275 previous enumerator (stored in last_initializer) is incremented
10276 by 1 and is used to initialize the current enumerator. */
10277 if (initializer
== NULL
)
10278 initializer
= enum_initializer (last_initializer
, old_locus
);
10280 if (initializer
== NULL
|| initializer
->ts
.type
!= BT_INTEGER
)
10282 gfc_error ("ENUMERATOR %L not initialized with integer expression",
10288 /* Store this current initializer, for the next enumerator variable
10289 to be parsed. add_init_expr_to_sym() zeros initializer, so we
10290 use last_initializer below. */
10291 last_initializer
= initializer
;
10292 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
10294 /* Maintain enumerator history. */
10295 gfc_find_symbol (name
, NULL
, 0, &sym
);
10296 create_enum_history (sym
, last_initializer
);
10298 return (t
) ? MATCH_YES
: MATCH_ERROR
;
10301 /* Free stuff up and return. */
10302 gfc_free_expr (initializer
);
10308 /* Match the enumerator definition statement. */
10311 gfc_match_enumerator_def (void)
10316 gfc_clear_ts (¤t_ts
);
10318 m
= gfc_match (" enumerator");
10319 if (m
!= MATCH_YES
)
10322 m
= gfc_match (" :: ");
10323 if (m
== MATCH_ERROR
)
10326 colon_seen
= (m
== MATCH_YES
);
10328 if (gfc_current_state () != COMP_ENUM
)
10330 gfc_error ("ENUM definition statement expected before %C");
10331 gfc_free_enum_history ();
10332 return MATCH_ERROR
;
10335 (¤t_ts
)->type
= BT_INTEGER
;
10336 (¤t_ts
)->kind
= gfc_c_int_kind
;
10338 gfc_clear_attr (¤t_attr
);
10339 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, NULL
);
10348 m
= enumerator_decl ();
10349 if (m
== MATCH_ERROR
)
10351 gfc_free_enum_history ();
10357 if (gfc_match_eos () == MATCH_YES
)
10359 if (gfc_match_char (',') != MATCH_YES
)
10363 if (gfc_current_state () == COMP_ENUM
)
10365 gfc_free_enum_history ();
10366 gfc_error ("Syntax error in ENUMERATOR definition at %C");
10371 gfc_free_array_spec (current_as
);
10378 /* Match binding attributes. */
10381 match_binding_attributes (gfc_typebound_proc
* ba
, bool generic
, bool ppc
)
10383 bool found_passing
= false;
10384 bool seen_ptr
= false;
10385 match m
= MATCH_YES
;
10387 /* Initialize to defaults. Do so even before the MATCH_NO check so that in
10388 this case the defaults are in there. */
10389 ba
->access
= ACCESS_UNKNOWN
;
10390 ba
->pass_arg
= NULL
;
10391 ba
->pass_arg_num
= 0;
10393 ba
->non_overridable
= 0;
10397 /* If we find a comma, we believe there are binding attributes. */
10398 m
= gfc_match_char (',');
10404 /* Access specifier. */
10406 m
= gfc_match (" public");
10407 if (m
== MATCH_ERROR
)
10409 if (m
== MATCH_YES
)
10411 if (ba
->access
!= ACCESS_UNKNOWN
)
10413 gfc_error ("Duplicate access-specifier at %C");
10417 ba
->access
= ACCESS_PUBLIC
;
10421 m
= gfc_match (" private");
10422 if (m
== MATCH_ERROR
)
10424 if (m
== MATCH_YES
)
10426 if (ba
->access
!= ACCESS_UNKNOWN
)
10428 gfc_error ("Duplicate access-specifier at %C");
10432 ba
->access
= ACCESS_PRIVATE
;
10436 /* If inside GENERIC, the following is not allowed. */
10441 m
= gfc_match (" nopass");
10442 if (m
== MATCH_ERROR
)
10444 if (m
== MATCH_YES
)
10448 gfc_error ("Binding attributes already specify passing,"
10449 " illegal NOPASS at %C");
10453 found_passing
= true;
10458 /* PASS possibly including argument. */
10459 m
= gfc_match (" pass");
10460 if (m
== MATCH_ERROR
)
10462 if (m
== MATCH_YES
)
10464 char arg
[GFC_MAX_SYMBOL_LEN
+ 1];
10468 gfc_error ("Binding attributes already specify passing,"
10469 " illegal PASS at %C");
10473 m
= gfc_match (" ( %n )", arg
);
10474 if (m
== MATCH_ERROR
)
10476 if (m
== MATCH_YES
)
10477 ba
->pass_arg
= gfc_get_string ("%s", arg
);
10478 gcc_assert ((m
== MATCH_YES
) == (ba
->pass_arg
!= NULL
));
10480 found_passing
= true;
10487 /* POINTER flag. */
10488 m
= gfc_match (" pointer");
10489 if (m
== MATCH_ERROR
)
10491 if (m
== MATCH_YES
)
10495 gfc_error ("Duplicate POINTER attribute at %C");
10505 /* NON_OVERRIDABLE flag. */
10506 m
= gfc_match (" non_overridable");
10507 if (m
== MATCH_ERROR
)
10509 if (m
== MATCH_YES
)
10511 if (ba
->non_overridable
)
10513 gfc_error ("Duplicate NON_OVERRIDABLE at %C");
10517 ba
->non_overridable
= 1;
10521 /* DEFERRED flag. */
10522 m
= gfc_match (" deferred");
10523 if (m
== MATCH_ERROR
)
10525 if (m
== MATCH_YES
)
10529 gfc_error ("Duplicate DEFERRED at %C");
10540 /* Nothing matching found. */
10542 gfc_error ("Expected access-specifier at %C");
10544 gfc_error ("Expected binding attribute at %C");
10547 while (gfc_match_char (',') == MATCH_YES
);
10549 /* NON_OVERRIDABLE and DEFERRED exclude themselves. */
10550 if (ba
->non_overridable
&& ba
->deferred
)
10552 gfc_error ("NON_OVERRIDABLE and DEFERRED can't both appear at %C");
10559 if (ba
->access
== ACCESS_UNKNOWN
)
10560 ba
->access
= gfc_typebound_default_access
;
10562 if (ppc
&& !seen_ptr
)
10564 gfc_error ("POINTER attribute is required for procedure pointer component"
10572 return MATCH_ERROR
;
10576 /* Match a PROCEDURE specific binding inside a derived type. */
10579 match_procedure_in_type (void)
10581 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10582 char target_buf
[GFC_MAX_SYMBOL_LEN
+ 1];
10583 char* target
= NULL
, *ifc
= NULL
;
10584 gfc_typebound_proc tb
;
10588 gfc_symtree
* stree
;
10593 /* Check current state. */
10594 gcc_assert (gfc_state_stack
->state
== COMP_DERIVED_CONTAINS
);
10595 block
= gfc_state_stack
->previous
->sym
;
10596 gcc_assert (block
);
10598 /* Try to match PROCEDURE(interface). */
10599 if (gfc_match (" (") == MATCH_YES
)
10601 m
= gfc_match_name (target_buf
);
10602 if (m
== MATCH_ERROR
)
10604 if (m
!= MATCH_YES
)
10606 gfc_error ("Interface-name expected after %<(%> at %C");
10607 return MATCH_ERROR
;
10610 if (gfc_match (" )") != MATCH_YES
)
10612 gfc_error ("%<)%> expected at %C");
10613 return MATCH_ERROR
;
10619 /* Construct the data structure. */
10620 memset (&tb
, 0, sizeof (tb
));
10621 tb
.where
= gfc_current_locus
;
10623 /* Match binding attributes. */
10624 m
= match_binding_attributes (&tb
, false, false);
10625 if (m
== MATCH_ERROR
)
10627 seen_attrs
= (m
== MATCH_YES
);
10629 /* Check that attribute DEFERRED is given if an interface is specified. */
10630 if (tb
.deferred
&& !ifc
)
10632 gfc_error ("Interface must be specified for DEFERRED binding at %C");
10633 return MATCH_ERROR
;
10635 if (ifc
&& !tb
.deferred
)
10637 gfc_error ("PROCEDURE(interface) at %C should be declared DEFERRED");
10638 return MATCH_ERROR
;
10641 /* Match the colons. */
10642 m
= gfc_match (" ::");
10643 if (m
== MATCH_ERROR
)
10645 seen_colons
= (m
== MATCH_YES
);
10646 if (seen_attrs
&& !seen_colons
)
10648 gfc_error ("Expected %<::%> after binding-attributes at %C");
10649 return MATCH_ERROR
;
10652 /* Match the binding names. */
10655 m
= gfc_match_name (name
);
10656 if (m
== MATCH_ERROR
)
10660 gfc_error ("Expected binding name at %C");
10661 return MATCH_ERROR
;
10664 if (num
>1 && !gfc_notify_std (GFC_STD_F2008
, "PROCEDURE list at %C"))
10665 return MATCH_ERROR
;
10667 /* Try to match the '=> target', if it's there. */
10669 m
= gfc_match (" =>");
10670 if (m
== MATCH_ERROR
)
10672 if (m
== MATCH_YES
)
10676 gfc_error ("%<=> target%> is invalid for DEFERRED binding at %C");
10677 return MATCH_ERROR
;
10682 gfc_error ("%<::%> needed in PROCEDURE binding with explicit target"
10684 return MATCH_ERROR
;
10687 m
= gfc_match_name (target_buf
);
10688 if (m
== MATCH_ERROR
)
10692 gfc_error ("Expected binding target after %<=>%> at %C");
10693 return MATCH_ERROR
;
10695 target
= target_buf
;
10698 /* If no target was found, it has the same name as the binding. */
10702 /* Get the namespace to insert the symbols into. */
10703 ns
= block
->f2k_derived
;
10706 /* If the binding is DEFERRED, check that the containing type is ABSTRACT. */
10707 if (tb
.deferred
&& !block
->attr
.abstract
)
10709 gfc_error ("Type %qs containing DEFERRED binding at %C "
10710 "is not ABSTRACT", block
->name
);
10711 return MATCH_ERROR
;
10714 /* See if we already have a binding with this name in the symtree which
10715 would be an error. If a GENERIC already targeted this binding, it may
10716 be already there but then typebound is still NULL. */
10717 stree
= gfc_find_symtree (ns
->tb_sym_root
, name
);
10718 if (stree
&& stree
->n
.tb
)
10720 gfc_error ("There is already a procedure with binding name %qs for "
10721 "the derived type %qs at %C", name
, block
->name
);
10722 return MATCH_ERROR
;
10725 /* Insert it and set attributes. */
10729 stree
= gfc_new_symtree (&ns
->tb_sym_root
, name
);
10730 gcc_assert (stree
);
10732 stree
->n
.tb
= gfc_get_typebound_proc (&tb
);
10734 if (gfc_get_sym_tree (target
, gfc_current_ns
, &stree
->n
.tb
->u
.specific
,
10736 return MATCH_ERROR
;
10737 gfc_set_sym_referenced (stree
->n
.tb
->u
.specific
->n
.sym
);
10738 gfc_add_flavor(&stree
->n
.tb
->u
.specific
->n
.sym
->attr
, FL_PROCEDURE
,
10739 target
, &stree
->n
.tb
->u
.specific
->n
.sym
->declared_at
);
10741 if (gfc_match_eos () == MATCH_YES
)
10743 if (gfc_match_char (',') != MATCH_YES
)
10748 gfc_error ("Syntax error in PROCEDURE statement at %C");
10749 return MATCH_ERROR
;
10753 /* Match a GENERIC procedure binding inside a derived type. */
10756 gfc_match_generic (void)
10758 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10759 char bind_name
[GFC_MAX_SYMBOL_LEN
+ 16]; /* Allow space for OPERATOR(...). */
10761 gfc_typebound_proc tbattr
; /* Used for match_binding_attributes. */
10762 gfc_typebound_proc
* tb
;
10764 interface_type op_type
;
10765 gfc_intrinsic_op op
;
10768 /* Check current state. */
10769 if (gfc_current_state () == COMP_DERIVED
)
10771 gfc_error ("GENERIC at %C must be inside a derived-type CONTAINS");
10772 return MATCH_ERROR
;
10774 if (gfc_current_state () != COMP_DERIVED_CONTAINS
)
10776 block
= gfc_state_stack
->previous
->sym
;
10777 ns
= block
->f2k_derived
;
10778 gcc_assert (block
&& ns
);
10780 memset (&tbattr
, 0, sizeof (tbattr
));
10781 tbattr
.where
= gfc_current_locus
;
10783 /* See if we get an access-specifier. */
10784 m
= match_binding_attributes (&tbattr
, true, false);
10785 if (m
== MATCH_ERROR
)
10788 /* Now the colons, those are required. */
10789 if (gfc_match (" ::") != MATCH_YES
)
10791 gfc_error ("Expected %<::%> at %C");
10795 /* Match the binding name; depending on type (operator / generic) format
10796 it for future error messages into bind_name. */
10798 m
= gfc_match_generic_spec (&op_type
, name
, &op
);
10799 if (m
== MATCH_ERROR
)
10800 return MATCH_ERROR
;
10803 gfc_error ("Expected generic name or operator descriptor at %C");
10809 case INTERFACE_GENERIC
:
10810 case INTERFACE_DTIO
:
10811 snprintf (bind_name
, sizeof (bind_name
), "%s", name
);
10814 case INTERFACE_USER_OP
:
10815 snprintf (bind_name
, sizeof (bind_name
), "OPERATOR(.%s.)", name
);
10818 case INTERFACE_INTRINSIC_OP
:
10819 snprintf (bind_name
, sizeof (bind_name
), "OPERATOR(%s)",
10820 gfc_op2string (op
));
10823 case INTERFACE_NAMELESS
:
10824 gfc_error ("Malformed GENERIC statement at %C");
10829 gcc_unreachable ();
10832 /* Match the required =>. */
10833 if (gfc_match (" =>") != MATCH_YES
)
10835 gfc_error ("Expected %<=>%> at %C");
10839 /* Try to find existing GENERIC binding with this name / for this operator;
10840 if there is something, check that it is another GENERIC and then extend
10841 it rather than building a new node. Otherwise, create it and put it
10842 at the right position. */
10846 case INTERFACE_DTIO
:
10847 case INTERFACE_USER_OP
:
10848 case INTERFACE_GENERIC
:
10850 const bool is_op
= (op_type
== INTERFACE_USER_OP
);
10853 st
= gfc_find_symtree (is_op
? ns
->tb_uop_root
: ns
->tb_sym_root
, name
);
10854 tb
= st
? st
->n
.tb
: NULL
;
10858 case INTERFACE_INTRINSIC_OP
:
10859 tb
= ns
->tb_op
[op
];
10863 gcc_unreachable ();
10868 if (!tb
->is_generic
)
10870 gcc_assert (op_type
== INTERFACE_GENERIC
);
10871 gfc_error ("There's already a non-generic procedure with binding name"
10872 " %qs for the derived type %qs at %C",
10873 bind_name
, block
->name
);
10877 if (tb
->access
!= tbattr
.access
)
10879 gfc_error ("Binding at %C must have the same access as already"
10880 " defined binding %qs", bind_name
);
10886 tb
= gfc_get_typebound_proc (NULL
);
10887 tb
->where
= gfc_current_locus
;
10888 tb
->access
= tbattr
.access
;
10889 tb
->is_generic
= 1;
10890 tb
->u
.generic
= NULL
;
10894 case INTERFACE_DTIO
:
10895 case INTERFACE_GENERIC
:
10896 case INTERFACE_USER_OP
:
10898 const bool is_op
= (op_type
== INTERFACE_USER_OP
);
10899 gfc_symtree
* st
= gfc_get_tbp_symtree (is_op
? &ns
->tb_uop_root
:
10900 &ns
->tb_sym_root
, name
);
10907 case INTERFACE_INTRINSIC_OP
:
10908 ns
->tb_op
[op
] = tb
;
10912 gcc_unreachable ();
10916 /* Now, match all following names as specific targets. */
10919 gfc_symtree
* target_st
;
10920 gfc_tbp_generic
* target
;
10922 m
= gfc_match_name (name
);
10923 if (m
== MATCH_ERROR
)
10927 gfc_error ("Expected specific binding name at %C");
10931 target_st
= gfc_get_tbp_symtree (&ns
->tb_sym_root
, name
);
10933 /* See if this is a duplicate specification. */
10934 for (target
= tb
->u
.generic
; target
; target
= target
->next
)
10935 if (target_st
== target
->specific_st
)
10937 gfc_error ("%qs already defined as specific binding for the"
10938 " generic %qs at %C", name
, bind_name
);
10942 target
= gfc_get_tbp_generic ();
10943 target
->specific_st
= target_st
;
10944 target
->specific
= NULL
;
10945 target
->next
= tb
->u
.generic
;
10946 target
->is_operator
= ((op_type
== INTERFACE_USER_OP
)
10947 || (op_type
== INTERFACE_INTRINSIC_OP
));
10948 tb
->u
.generic
= target
;
10950 while (gfc_match (" ,") == MATCH_YES
);
10952 /* Here should be the end. */
10953 if (gfc_match_eos () != MATCH_YES
)
10955 gfc_error ("Junk after GENERIC binding at %C");
10962 return MATCH_ERROR
;
10966 /* Match a FINAL declaration inside a derived type. */
10969 gfc_match_final_decl (void)
10971 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10974 gfc_namespace
* module_ns
;
10978 if (gfc_current_form
== FORM_FREE
)
10980 char c
= gfc_peek_ascii_char ();
10981 if (!gfc_is_whitespace (c
) && c
!= ':')
10985 if (gfc_state_stack
->state
!= COMP_DERIVED_CONTAINS
)
10987 if (gfc_current_form
== FORM_FIXED
)
10990 gfc_error ("FINAL declaration at %C must be inside a derived type "
10991 "CONTAINS section");
10992 return MATCH_ERROR
;
10995 block
= gfc_state_stack
->previous
->sym
;
10996 gcc_assert (block
);
10998 if (!gfc_state_stack
->previous
|| !gfc_state_stack
->previous
->previous
10999 || gfc_state_stack
->previous
->previous
->state
!= COMP_MODULE
)
11001 gfc_error ("Derived type declaration with FINAL at %C must be in the"
11002 " specification part of a MODULE");
11003 return MATCH_ERROR
;
11006 module_ns
= gfc_current_ns
;
11007 gcc_assert (module_ns
);
11008 gcc_assert (module_ns
->proc_name
->attr
.flavor
== FL_MODULE
);
11010 /* Match optional ::, don't care about MATCH_YES or MATCH_NO. */
11011 if (gfc_match (" ::") == MATCH_ERROR
)
11012 return MATCH_ERROR
;
11014 /* Match the sequence of procedure names. */
11021 if (first
&& gfc_match_eos () == MATCH_YES
)
11023 gfc_error ("Empty FINAL at %C");
11024 return MATCH_ERROR
;
11027 m
= gfc_match_name (name
);
11030 gfc_error ("Expected module procedure name at %C");
11031 return MATCH_ERROR
;
11033 else if (m
!= MATCH_YES
)
11034 return MATCH_ERROR
;
11036 if (gfc_match_eos () == MATCH_YES
)
11038 if (!last
&& gfc_match_char (',') != MATCH_YES
)
11040 gfc_error ("Expected %<,%> at %C");
11041 return MATCH_ERROR
;
11044 if (gfc_get_symbol (name
, module_ns
, &sym
))
11046 gfc_error ("Unknown procedure name %qs at %C", name
);
11047 return MATCH_ERROR
;
11050 /* Mark the symbol as module procedure. */
11051 if (sym
->attr
.proc
!= PROC_MODULE
11052 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
11053 return MATCH_ERROR
;
11055 /* Check if we already have this symbol in the list, this is an error. */
11056 for (f
= block
->f2k_derived
->finalizers
; f
; f
= f
->next
)
11057 if (f
->proc_sym
== sym
)
11059 gfc_error ("%qs at %C is already defined as FINAL procedure",
11061 return MATCH_ERROR
;
11064 /* Add this symbol to the list of finalizers. */
11065 gcc_assert (block
->f2k_derived
);
11067 f
= XCNEW (gfc_finalizer
);
11069 f
->proc_tree
= NULL
;
11070 f
->where
= gfc_current_locus
;
11071 f
->next
= block
->f2k_derived
->finalizers
;
11072 block
->f2k_derived
->finalizers
= f
;
11082 const ext_attr_t ext_attr_list
[] = {
11083 { "dllimport", EXT_ATTR_DLLIMPORT
, "dllimport" },
11084 { "dllexport", EXT_ATTR_DLLEXPORT
, "dllexport" },
11085 { "cdecl", EXT_ATTR_CDECL
, "cdecl" },
11086 { "stdcall", EXT_ATTR_STDCALL
, "stdcall" },
11087 { "fastcall", EXT_ATTR_FASTCALL
, "fastcall" },
11088 { "no_arg_check", EXT_ATTR_NO_ARG_CHECK
, NULL
},
11089 { NULL
, EXT_ATTR_LAST
, NULL
}
11092 /* Match a !GCC$ ATTRIBUTES statement of the form:
11093 !GCC$ ATTRIBUTES attribute-list :: var-name [, var-name] ...
11094 When we come here, we have already matched the !GCC$ ATTRIBUTES string.
11096 TODO: We should support all GCC attributes using the same syntax for
11097 the attribute list, i.e. the list in C
11098 __attributes(( attribute-list ))
11100 !GCC$ ATTRIBUTES attribute-list ::
11101 Cf. c-parser.c's c_parser_attributes; the data can then directly be
11104 As there is absolutely no risk of confusion, we should never return
11107 gfc_match_gcc_attributes (void)
11109 symbol_attribute attr
;
11110 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
11115 gfc_clear_attr (&attr
);
11120 if (gfc_match_name (name
) != MATCH_YES
)
11121 return MATCH_ERROR
;
11123 for (id
= 0; id
< EXT_ATTR_LAST
; id
++)
11124 if (strcmp (name
, ext_attr_list
[id
].name
) == 0)
11127 if (id
== EXT_ATTR_LAST
)
11129 gfc_error ("Unknown attribute in !GCC$ ATTRIBUTES statement at %C");
11130 return MATCH_ERROR
;
11133 if (!gfc_add_ext_attribute (&attr
, (ext_attr_id_t
)id
, &gfc_current_locus
))
11134 return MATCH_ERROR
;
11136 gfc_gobble_whitespace ();
11137 ch
= gfc_next_ascii_char ();
11140 /* This is the successful exit condition for the loop. */
11141 if (gfc_next_ascii_char () == ':')
11151 if (gfc_match_eos () == MATCH_YES
)
11156 m
= gfc_match_name (name
);
11157 if (m
!= MATCH_YES
)
11160 if (find_special (name
, &sym
, true))
11161 return MATCH_ERROR
;
11163 sym
->attr
.ext_attr
|= attr
.ext_attr
;
11165 if (gfc_match_eos () == MATCH_YES
)
11168 if (gfc_match_char (',') != MATCH_YES
)
11175 gfc_error ("Syntax error in !GCC$ ATTRIBUTES statement at %C");
11176 return MATCH_ERROR
;
11180 /* Match a !GCC$ UNROLL statement of the form:
11183 The parameter n is the number of times we are supposed to unroll.
11185 When we come here, we have already matched the !GCC$ UNROLL string. */
11187 gfc_match_gcc_unroll (void)
11191 if (gfc_match_small_int (&value
) == MATCH_YES
)
11193 if (value
< 0 || value
> USHRT_MAX
)
11195 gfc_error ("%<GCC unroll%> directive requires a"
11196 " non-negative integral constant"
11197 " less than or equal to %u at %C",
11200 return MATCH_ERROR
;
11202 if (gfc_match_eos () == MATCH_YES
)
11204 directive_unroll
= value
== 0 ? 1 : value
;
11209 gfc_error ("Syntax error in !GCC$ UNROLL directive at %C");
11210 return MATCH_ERROR
;