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 the len may be reducible to a
3242 constant. Try to do that here. If it does not reduce, simply
3243 assign len to the charlen. */
3244 if (len
&& len
->expr_type
!= EXPR_CONSTANT
)
3247 e
= gfc_copy_expr (len
);
3248 gfc_reduce_init_expr (e
);
3249 if (e
->expr_type
== EXPR_CONSTANT
)
3251 gfc_replace_expr (len
, e
);
3252 if (mpz_cmp_si (len
->value
.integer
, 0) < 0)
3253 mpz_set_ui (len
->value
.integer
, 0);
3264 ts
->kind
= kind
== 0 ? gfc_default_character_kind
: kind
;
3265 ts
->deferred
= deferred
;
3267 /* We have to know if it was a C interoperable kind so we can
3268 do accurate type checking of bind(c) procs, etc. */
3270 /* Mark this as C interoperable if being declared with one
3271 of the named constants from iso_c_binding. */
3272 ts
->is_c_interop
= is_iso_c
;
3273 else if (len
!= NULL
)
3274 /* Here, we might have parsed something such as: character(c_char)
3275 In this case, the parsing code above grabs the c_char when
3276 looking for the length (line 1690, roughly). it's the last
3277 testcase for parsing the kind params of a character variable.
3278 However, it's not actually the length. this seems like it
3280 To see if the user used a C interop kind, test the expr
3281 of the so called length, and see if it's C interoperable. */
3282 ts
->is_c_interop
= len
->ts
.is_iso_c
;
3288 /* Matches a RECORD declaration. */
3291 match_record_decl (char *name
)
3294 old_loc
= gfc_current_locus
;
3297 m
= gfc_match (" record /");
3300 if (!flag_dec_structure
)
3302 gfc_current_locus
= old_loc
;
3303 gfc_error ("RECORD at %C is an extension, enable it with "
3307 m
= gfc_match (" %n/", name
);
3312 gfc_current_locus
= old_loc
;
3313 if (flag_dec_structure
3314 && (gfc_match (" record% ") == MATCH_YES
3315 || gfc_match (" record%t") == MATCH_YES
))
3316 gfc_error ("Structure name expected after RECORD at %C");
3324 /* This function uses the gfc_actual_arglist 'type_param_spec_list' as a source
3325 of expressions to substitute into the possibly parameterized expression
3326 'e'. Using a list is inefficient but should not be too bad since the
3327 number of type parameters is not likely to be large. */
3329 insert_parameter_exprs (gfc_expr
* e
, gfc_symbol
* sym ATTRIBUTE_UNUSED
,
3332 gfc_actual_arglist
*param
;
3335 if (e
->expr_type
!= EXPR_VARIABLE
)
3338 gcc_assert (e
->symtree
);
3339 if (e
->symtree
->n
.sym
->attr
.pdt_kind
3340 || (*f
!= 0 && e
->symtree
->n
.sym
->attr
.pdt_len
))
3342 for (param
= type_param_spec_list
; param
; param
= param
->next
)
3343 if (strcmp (e
->symtree
->n
.sym
->name
, param
->name
) == 0)
3348 copy
= gfc_copy_expr (param
->expr
);
3359 gfc_insert_kind_parameter_exprs (gfc_expr
*e
)
3361 return gfc_traverse_expr (e
, NULL
, &insert_parameter_exprs
, 0);
3366 gfc_insert_parameter_exprs (gfc_expr
*e
, gfc_actual_arglist
*param_list
)
3368 gfc_actual_arglist
*old_param_spec_list
= type_param_spec_list
;
3369 type_param_spec_list
= param_list
;
3370 return gfc_traverse_expr (e
, NULL
, &insert_parameter_exprs
, 1);
3371 type_param_spec_list
= NULL
;
3372 type_param_spec_list
= old_param_spec_list
;
3375 /* Determines the instance of a parameterized derived type to be used by
3376 matching determining the values of the kind parameters and using them
3377 in the name of the instance. If the instance exists, it is used, otherwise
3378 a new derived type is created. */
3380 gfc_get_pdt_instance (gfc_actual_arglist
*param_list
, gfc_symbol
**sym
,
3381 gfc_actual_arglist
**ext_param_list
)
3383 /* The PDT template symbol. */
3384 gfc_symbol
*pdt
= *sym
;
3385 /* The symbol for the parameter in the template f2k_namespace. */
3387 /* The hoped for instance of the PDT. */
3388 gfc_symbol
*instance
;
3389 /* The list of parameters appearing in the PDT declaration. */
3390 gfc_formal_arglist
*type_param_name_list
;
3391 /* Used to store the parameter specification list during recursive calls. */
3392 gfc_actual_arglist
*old_param_spec_list
;
3393 /* Pointers to the parameter specification being used. */
3394 gfc_actual_arglist
*actual_param
;
3395 gfc_actual_arglist
*tail
= NULL
;
3396 /* Used to build up the name of the PDT instance. The prefix uses 4
3397 characters and each KIND parameter 2 more. Allow 8 of the latter. */
3398 char name
[GFC_MAX_SYMBOL_LEN
+ 21];
3400 bool name_seen
= (param_list
== NULL
);
3401 bool assumed_seen
= false;
3402 bool deferred_seen
= false;
3403 bool spec_error
= false;
3405 gfc_expr
*kind_expr
;
3406 gfc_component
*c1
, *c2
;
3409 type_param_spec_list
= NULL
;
3411 type_param_name_list
= pdt
->formal
;
3412 actual_param
= param_list
;
3413 sprintf (name
, "Pdt%s", pdt
->name
);
3415 /* Run through the parameter name list and pick up the actual
3416 parameter values or use the default values in the PDT declaration. */
3417 for (; type_param_name_list
;
3418 type_param_name_list
= type_param_name_list
->next
)
3420 if (actual_param
&& actual_param
->spec_type
!= SPEC_EXPLICIT
)
3422 if (actual_param
->spec_type
== SPEC_ASSUMED
)
3423 spec_error
= deferred_seen
;
3425 spec_error
= assumed_seen
;
3429 gfc_error ("The type parameter spec list at %C cannot contain "
3430 "both ASSUMED and DEFERRED parameters");
3435 if (actual_param
&& actual_param
->name
)
3437 param
= type_param_name_list
->sym
;
3439 if (!param
|| !param
->name
)
3442 c1
= gfc_find_component (pdt
, param
->name
, false, true, NULL
);
3443 /* An error should already have been thrown in resolve.c
3444 (resolve_fl_derived0). */
3445 if (!pdt
->attr
.use_assoc
&& !c1
)
3451 if (!actual_param
&& !(c1
&& c1
->initializer
))
3453 gfc_error ("The type parameter spec list at %C does not contain "
3454 "enough parameter expressions");
3457 else if (!actual_param
&& c1
&& c1
->initializer
)
3458 kind_expr
= gfc_copy_expr (c1
->initializer
);
3459 else if (actual_param
&& actual_param
->spec_type
== SPEC_EXPLICIT
)
3460 kind_expr
= gfc_copy_expr (actual_param
->expr
);
3464 actual_param
= param_list
;
3465 for (;actual_param
; actual_param
= actual_param
->next
)
3466 if (actual_param
->name
3467 && strcmp (actual_param
->name
, param
->name
) == 0)
3469 if (actual_param
&& actual_param
->spec_type
== SPEC_EXPLICIT
)
3470 kind_expr
= gfc_copy_expr (actual_param
->expr
);
3473 if (c1
->initializer
)
3474 kind_expr
= gfc_copy_expr (c1
->initializer
);
3475 else if (!(actual_param
&& param
->attr
.pdt_len
))
3477 gfc_error ("The derived parameter %qs at %C does not "
3478 "have a default value", param
->name
);
3484 /* Store the current parameter expressions in a temporary actual
3485 arglist 'list' so that they can be substituted in the corresponding
3486 expressions in the PDT instance. */
3487 if (type_param_spec_list
== NULL
)
3489 type_param_spec_list
= gfc_get_actual_arglist ();
3490 tail
= type_param_spec_list
;
3494 tail
->next
= gfc_get_actual_arglist ();
3497 tail
->name
= param
->name
;
3501 /* Try simplification even for LEN expressions. */
3502 gfc_resolve_expr (kind_expr
);
3503 gfc_simplify_expr (kind_expr
, 1);
3504 /* Variable expressions seem to default to BT_PROCEDURE.
3505 TODO find out why this is and fix it. */
3506 if (kind_expr
->ts
.type
!= BT_INTEGER
3507 && kind_expr
->ts
.type
!= BT_PROCEDURE
)
3509 gfc_error ("The parameter expression at %C must be of "
3510 "INTEGER type and not %s type",
3511 gfc_basic_typename (kind_expr
->ts
.type
));
3515 tail
->expr
= gfc_copy_expr (kind_expr
);
3519 tail
->spec_type
= actual_param
->spec_type
;
3521 if (!param
->attr
.pdt_kind
)
3523 if (!name_seen
&& actual_param
)
3524 actual_param
= actual_param
->next
;
3527 gfc_free_expr (kind_expr
);
3534 && (actual_param
->spec_type
== SPEC_ASSUMED
3535 || actual_param
->spec_type
== SPEC_DEFERRED
))
3537 gfc_error ("The KIND parameter %qs at %C cannot either be "
3538 "ASSUMED or DEFERRED", param
->name
);
3542 if (!kind_expr
|| !gfc_is_constant_expr (kind_expr
))
3544 gfc_error ("The value for the KIND parameter %qs at %C does not "
3545 "reduce to a constant expression", param
->name
);
3549 gfc_extract_int (kind_expr
, &kind_value
);
3550 sprintf (name
+ strlen (name
), "_%d", kind_value
);
3552 if (!name_seen
&& actual_param
)
3553 actual_param
= actual_param
->next
;
3554 gfc_free_expr (kind_expr
);
3557 if (!name_seen
&& actual_param
)
3559 gfc_error ("The type parameter spec list at %C contains too many "
3560 "parameter expressions");
3564 /* Now we search for the PDT instance 'name'. If it doesn't exist, we
3565 build it, using 'pdt' as a template. */
3566 if (gfc_get_symbol (name
, pdt
->ns
, &instance
))
3568 gfc_error ("Parameterized derived type at %C is ambiguous");
3574 if (instance
->attr
.flavor
== FL_DERIVED
3575 && instance
->attr
.pdt_type
)
3579 *ext_param_list
= type_param_spec_list
;
3581 gfc_commit_symbols ();
3585 /* Start building the new instance of the parameterized type. */
3586 gfc_copy_attr (&instance
->attr
, &pdt
->attr
, &pdt
->declared_at
);
3587 instance
->attr
.pdt_template
= 0;
3588 instance
->attr
.pdt_type
= 1;
3589 instance
->declared_at
= gfc_current_locus
;
3591 /* Add the components, replacing the parameters in all expressions
3592 with the expressions for their values in 'type_param_spec_list'. */
3593 c1
= pdt
->components
;
3594 tail
= type_param_spec_list
;
3595 for (; c1
; c1
= c1
->next
)
3597 gfc_add_component (instance
, c1
->name
, &c2
);
3600 c2
->attr
= c1
->attr
;
3602 /* The order of declaration of the type_specs might not be the
3603 same as that of the components. */
3604 if (c1
->attr
.pdt_kind
|| c1
->attr
.pdt_len
)
3606 for (tail
= type_param_spec_list
; tail
; tail
= tail
->next
)
3607 if (strcmp (c1
->name
, tail
->name
) == 0)
3611 /* Deal with type extension by recursively calling this function
3612 to obtain the instance of the extended type. */
3613 if (gfc_current_state () != COMP_DERIVED
3614 && c1
== pdt
->components
3615 && (c1
->ts
.type
== BT_DERIVED
|| c1
->ts
.type
== BT_CLASS
)
3616 && c1
->ts
.u
.derived
&& c1
->ts
.u
.derived
->attr
.pdt_template
3617 && gfc_get_derived_super_type (*sym
) == c2
->ts
.u
.derived
)
3619 gfc_formal_arglist
*f
;
3621 old_param_spec_list
= type_param_spec_list
;
3623 /* Obtain a spec list appropriate to the extended type..*/
3624 actual_param
= gfc_copy_actual_arglist (type_param_spec_list
);
3625 type_param_spec_list
= actual_param
;
3626 for (f
= c1
->ts
.u
.derived
->formal
; f
&& f
->next
; f
= f
->next
)
3627 actual_param
= actual_param
->next
;
3630 gfc_free_actual_arglist (actual_param
->next
);
3631 actual_param
->next
= NULL
;
3634 /* Now obtain the PDT instance for the extended type. */
3635 c2
->param_list
= type_param_spec_list
;
3636 m
= gfc_get_pdt_instance (type_param_spec_list
, &c2
->ts
.u
.derived
,
3638 type_param_spec_list
= old_param_spec_list
;
3640 c2
->ts
.u
.derived
->refs
++;
3641 gfc_set_sym_referenced (c2
->ts
.u
.derived
);
3643 /* Set extension level. */
3644 if (c2
->ts
.u
.derived
->attr
.extension
== 255)
3646 /* Since the extension field is 8 bit wide, we can only have
3647 up to 255 extension levels. */
3648 gfc_error ("Maximum extension level reached with type %qs at %L",
3649 c2
->ts
.u
.derived
->name
,
3650 &c2
->ts
.u
.derived
->declared_at
);
3653 instance
->attr
.extension
= c2
->ts
.u
.derived
->attr
.extension
+ 1;
3658 /* Set the component kind using the parameterized expression. */
3659 if ((c1
->ts
.kind
== 0 || c1
->ts
.type
== BT_CHARACTER
)
3660 && c1
->kind_expr
!= NULL
)
3662 gfc_expr
*e
= gfc_copy_expr (c1
->kind_expr
);
3663 gfc_insert_kind_parameter_exprs (e
);
3664 gfc_simplify_expr (e
, 1);
3665 gfc_extract_int (e
, &c2
->ts
.kind
);
3667 if (gfc_validate_kind (c2
->ts
.type
, c2
->ts
.kind
, true) < 0)
3669 gfc_error ("Kind %d not supported for type %s at %C",
3670 c2
->ts
.kind
, gfc_basic_typename (c2
->ts
.type
));
3675 /* Similarly, set the string length if parameterized. */
3676 if (c1
->ts
.type
== BT_CHARACTER
3677 && c1
->ts
.u
.cl
->length
3678 && gfc_derived_parameter_expr (c1
->ts
.u
.cl
->length
))
3681 e
= gfc_copy_expr (c1
->ts
.u
.cl
->length
);
3682 gfc_insert_kind_parameter_exprs (e
);
3683 gfc_simplify_expr (e
, 1);
3684 c2
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
3685 c2
->ts
.u
.cl
->length
= e
;
3686 c2
->attr
.pdt_string
= 1;
3689 /* Set up either the KIND/LEN initializer, if constant,
3690 or the parameterized expression. Use the template
3691 initializer if one is not already set in this instance. */
3692 if (c2
->attr
.pdt_kind
|| c2
->attr
.pdt_len
)
3694 if (tail
&& tail
->expr
&& gfc_is_constant_expr (tail
->expr
))
3695 c2
->initializer
= gfc_copy_expr (tail
->expr
);
3696 else if (tail
&& tail
->expr
)
3698 c2
->param_list
= gfc_get_actual_arglist ();
3699 c2
->param_list
->name
= tail
->name
;
3700 c2
->param_list
->expr
= gfc_copy_expr (tail
->expr
);
3701 c2
->param_list
->next
= NULL
;
3704 if (!c2
->initializer
&& c1
->initializer
)
3705 c2
->initializer
= gfc_copy_expr (c1
->initializer
);
3708 /* Copy the array spec. */
3709 c2
->as
= gfc_copy_array_spec (c1
->as
);
3710 if (c1
->ts
.type
== BT_CLASS
)
3711 CLASS_DATA (c2
)->as
= gfc_copy_array_spec (CLASS_DATA (c1
)->as
);
3713 /* Determine if an array spec is parameterized. If so, substitute
3714 in the parameter expressions for the bounds and set the pdt_array
3715 attribute. Notice that this attribute must be unconditionally set
3716 if this is an array of parameterized character length. */
3717 if (c1
->as
&& c1
->as
->type
== AS_EXPLICIT
)
3719 bool pdt_array
= false;
3721 /* Are the bounds of the array parameterized? */
3722 for (i
= 0; i
< c1
->as
->rank
; i
++)
3724 if (gfc_derived_parameter_expr (c1
->as
->lower
[i
]))
3726 if (gfc_derived_parameter_expr (c1
->as
->upper
[i
]))
3730 /* If they are, free the expressions for the bounds and
3731 replace them with the template expressions with substitute
3733 for (i
= 0; pdt_array
&& i
< c1
->as
->rank
; i
++)
3736 e
= gfc_copy_expr (c1
->as
->lower
[i
]);
3737 gfc_insert_kind_parameter_exprs (e
);
3738 gfc_simplify_expr (e
, 1);
3739 gfc_free_expr (c2
->as
->lower
[i
]);
3740 c2
->as
->lower
[i
] = e
;
3741 e
= gfc_copy_expr (c1
->as
->upper
[i
]);
3742 gfc_insert_kind_parameter_exprs (e
);
3743 gfc_simplify_expr (e
, 1);
3744 gfc_free_expr (c2
->as
->upper
[i
]);
3745 c2
->as
->upper
[i
] = e
;
3747 c2
->attr
.pdt_array
= pdt_array
? 1 : c2
->attr
.pdt_string
;
3748 if (c1
->initializer
)
3750 c2
->initializer
= gfc_copy_expr (c1
->initializer
);
3751 gfc_insert_kind_parameter_exprs (c2
->initializer
);
3752 gfc_simplify_expr (c2
->initializer
, 1);
3756 /* Recurse into this function for PDT components. */
3757 if ((c1
->ts
.type
== BT_DERIVED
|| c1
->ts
.type
== BT_CLASS
)
3758 && c1
->ts
.u
.derived
&& c1
->ts
.u
.derived
->attr
.pdt_template
)
3760 gfc_actual_arglist
*params
;
3761 /* The component in the template has a list of specification
3762 expressions derived from its declaration. */
3763 params
= gfc_copy_actual_arglist (c1
->param_list
);
3764 actual_param
= params
;
3765 /* Substitute the template parameters with the expressions
3766 from the specification list. */
3767 for (;actual_param
; actual_param
= actual_param
->next
)
3768 gfc_insert_parameter_exprs (actual_param
->expr
,
3769 type_param_spec_list
);
3771 /* Now obtain the PDT instance for the component. */
3772 old_param_spec_list
= type_param_spec_list
;
3773 m
= gfc_get_pdt_instance (params
, &c2
->ts
.u
.derived
, NULL
);
3774 type_param_spec_list
= old_param_spec_list
;
3776 c2
->param_list
= params
;
3777 if (!(c2
->attr
.pointer
|| c2
->attr
.allocatable
))
3778 c2
->initializer
= gfc_default_initializer (&c2
->ts
);
3780 if (c2
->attr
.allocatable
)
3781 instance
->attr
.alloc_comp
= 1;
3785 gfc_commit_symbol (instance
);
3787 *ext_param_list
= type_param_spec_list
;
3792 gfc_free_actual_arglist (type_param_spec_list
);
3797 /* Matches a declaration-type-spec (F03:R502). If successful, sets the ts
3798 structure to the matched specification. This is necessary for FUNCTION and
3799 IMPLICIT statements.
3801 If implicit_flag is nonzero, then we don't check for the optional
3802 kind specification. Not doing so is needed for matching an IMPLICIT
3803 statement correctly. */
3806 gfc_match_decl_type_spec (gfc_typespec
*ts
, int implicit_flag
)
3808 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3809 gfc_symbol
*sym
, *dt_sym
;
3812 bool seen_deferred_kind
, matched_type
;
3813 const char *dt_name
;
3815 decl_type_param_list
= NULL
;
3817 /* A belt and braces check that the typespec is correctly being treated
3818 as a deferred characteristic association. */
3819 seen_deferred_kind
= (gfc_current_state () == COMP_FUNCTION
)
3820 && (gfc_current_block ()->result
->ts
.kind
== -1)
3821 && (ts
->kind
== -1);
3823 if (seen_deferred_kind
)
3826 /* Clear the current binding label, in case one is given. */
3827 curr_binding_label
= NULL
;
3829 if (gfc_match (" byte") == MATCH_YES
)
3831 if (!gfc_notify_std (GFC_STD_GNU
, "BYTE type at %C"))
3834 if (gfc_validate_kind (BT_INTEGER
, 1, true) < 0)
3836 gfc_error ("BYTE type used at %C "
3837 "is not available on the target machine");
3841 ts
->type
= BT_INTEGER
;
3847 m
= gfc_match (" type (");
3848 matched_type
= (m
== MATCH_YES
);
3851 gfc_gobble_whitespace ();
3852 if (gfc_peek_ascii_char () == '*')
3854 if ((m
= gfc_match ("*)")) != MATCH_YES
)
3856 if (gfc_comp_struct (gfc_current_state ()))
3858 gfc_error ("Assumed type at %C is not allowed for components");
3861 if (!gfc_notify_std (GFC_STD_F2018
, "Assumed type at %C"))
3863 ts
->type
= BT_ASSUMED
;
3867 m
= gfc_match ("%n", name
);
3868 matched_type
= (m
== MATCH_YES
);
3871 if ((matched_type
&& strcmp ("integer", name
) == 0)
3872 || (!matched_type
&& gfc_match (" integer") == MATCH_YES
))
3874 ts
->type
= BT_INTEGER
;
3875 ts
->kind
= gfc_default_integer_kind
;
3879 if ((matched_type
&& strcmp ("character", name
) == 0)
3880 || (!matched_type
&& gfc_match (" character") == MATCH_YES
))
3883 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
3884 "intrinsic-type-spec at %C"))
3887 ts
->type
= BT_CHARACTER
;
3888 if (implicit_flag
== 0)
3889 m
= gfc_match_char_spec (ts
);
3893 if (matched_type
&& m
== MATCH_YES
&& gfc_match_char (')') != MATCH_YES
)
3899 if ((matched_type
&& strcmp ("real", name
) == 0)
3900 || (!matched_type
&& gfc_match (" real") == MATCH_YES
))
3903 ts
->kind
= gfc_default_real_kind
;
3908 && (strcmp ("doubleprecision", name
) == 0
3909 || (strcmp ("double", name
) == 0
3910 && gfc_match (" precision") == MATCH_YES
)))
3911 || (!matched_type
&& gfc_match (" double precision") == MATCH_YES
))
3914 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
3915 "intrinsic-type-spec at %C"))
3917 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
3921 ts
->kind
= gfc_default_double_kind
;
3925 if ((matched_type
&& strcmp ("complex", name
) == 0)
3926 || (!matched_type
&& gfc_match (" complex") == MATCH_YES
))
3928 ts
->type
= BT_COMPLEX
;
3929 ts
->kind
= gfc_default_complex_kind
;
3934 && (strcmp ("doublecomplex", name
) == 0
3935 || (strcmp ("double", name
) == 0
3936 && gfc_match (" complex") == MATCH_YES
)))
3937 || (!matched_type
&& gfc_match (" double complex") == MATCH_YES
))
3939 if (!gfc_notify_std (GFC_STD_GNU
, "DOUBLE COMPLEX at %C"))
3943 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
3944 "intrinsic-type-spec at %C"))
3947 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
3950 ts
->type
= BT_COMPLEX
;
3951 ts
->kind
= gfc_default_double_kind
;
3955 if ((matched_type
&& strcmp ("logical", name
) == 0)
3956 || (!matched_type
&& gfc_match (" logical") == MATCH_YES
))
3958 ts
->type
= BT_LOGICAL
;
3959 ts
->kind
= gfc_default_logical_kind
;
3965 m
= gfc_match_actual_arglist (1, &decl_type_param_list
, true);
3966 if (m
== MATCH_ERROR
)
3969 m
= gfc_match_char (')');
3973 m
= match_record_decl (name
);
3975 if (matched_type
|| m
== MATCH_YES
)
3977 ts
->type
= BT_DERIVED
;
3978 /* We accept record/s/ or type(s) where s is a structure, but we
3979 * don't need all the extra derived-type stuff for structures. */
3980 if (gfc_find_symbol (gfc_dt_upper_string (name
), NULL
, 1, &sym
))
3982 gfc_error ("Type name %qs at %C is ambiguous", name
);
3986 if (sym
&& sym
->attr
.flavor
== FL_DERIVED
3987 && sym
->attr
.pdt_template
3988 && gfc_current_state () != COMP_DERIVED
)
3990 m
= gfc_get_pdt_instance (decl_type_param_list
, &sym
, NULL
);
3993 gcc_assert (!sym
->attr
.pdt_template
&& sym
->attr
.pdt_type
);
3994 ts
->u
.derived
= sym
;
3995 strcpy (name
, gfc_dt_lower_string (sym
->name
));
3998 if (sym
&& sym
->attr
.flavor
== FL_STRUCT
)
4000 ts
->u
.derived
= sym
;
4003 /* Actually a derived type. */
4008 /* Match nested STRUCTURE declarations; only valid within another
4009 structure declaration. */
4010 if (flag_dec_structure
4011 && (gfc_current_state () == COMP_STRUCTURE
4012 || gfc_current_state () == COMP_MAP
))
4014 m
= gfc_match (" structure");
4017 m
= gfc_match_structure_decl ();
4020 /* gfc_new_block is updated by match_structure_decl. */
4021 ts
->type
= BT_DERIVED
;
4022 ts
->u
.derived
= gfc_new_block
;
4026 if (m
== MATCH_ERROR
)
4030 /* Match CLASS declarations. */
4031 m
= gfc_match (" class ( * )");
4032 if (m
== MATCH_ERROR
)
4034 else if (m
== MATCH_YES
)
4038 ts
->type
= BT_CLASS
;
4039 gfc_find_symbol ("STAR", gfc_current_ns
, 1, &upe
);
4042 upe
= gfc_new_symbol ("STAR", gfc_current_ns
);
4043 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "STAR");
4045 gfc_set_sym_referenced (upe
);
4047 upe
->ts
.type
= BT_VOID
;
4048 upe
->attr
.unlimited_polymorphic
= 1;
4049 /* This is essential to force the construction of
4050 unlimited polymorphic component class containers. */
4051 upe
->attr
.zero_comp
= 1;
4052 if (!gfc_add_flavor (&upe
->attr
, FL_DERIVED
, NULL
,
4053 &gfc_current_locus
))
4058 st
= gfc_get_tbp_symtree (&gfc_current_ns
->sym_root
, "STAR");
4062 ts
->u
.derived
= upe
;
4066 m
= gfc_match (" class (");
4069 m
= gfc_match ("%n", name
);
4075 ts
->type
= BT_CLASS
;
4077 if (!gfc_notify_std (GFC_STD_F2003
, "CLASS statement at %C"))
4080 m
= gfc_match_actual_arglist (1, &decl_type_param_list
, true);
4081 if (m
== MATCH_ERROR
)
4084 m
= gfc_match_char (')');
4089 /* Defer association of the derived type until the end of the
4090 specification block. However, if the derived type can be
4091 found, add it to the typespec. */
4092 if (gfc_matching_function
)
4094 ts
->u
.derived
= NULL
;
4095 if (gfc_current_state () != COMP_INTERFACE
4096 && !gfc_find_symbol (name
, NULL
, 1, &sym
) && sym
)
4098 sym
= gfc_find_dt_in_generic (sym
);
4099 ts
->u
.derived
= sym
;
4104 /* Search for the name but allow the components to be defined later. If
4105 type = -1, this typespec has been seen in a function declaration but
4106 the type could not be accessed at that point. The actual derived type is
4107 stored in a symtree with the first letter of the name capitalized; the
4108 symtree with the all lower-case name contains the associated
4109 generic function. */
4110 dt_name
= gfc_dt_upper_string (name
);
4115 gfc_get_ha_symbol (name
, &sym
);
4116 if (sym
->generic
&& gfc_find_symbol (dt_name
, NULL
, 0, &dt_sym
))
4118 gfc_error ("Type name %qs at %C is ambiguous", name
);
4121 if (sym
->generic
&& !dt_sym
)
4122 dt_sym
= gfc_find_dt_in_generic (sym
);
4124 /* Host associated PDTs can get confused with their constructors
4125 because they ar instantiated in the template's namespace. */
4128 if (gfc_find_symbol (dt_name
, NULL
, 1, &dt_sym
))
4130 gfc_error ("Type name %qs at %C is ambiguous", name
);
4133 if (dt_sym
&& !dt_sym
->attr
.pdt_type
)
4137 else if (ts
->kind
== -1)
4139 int iface
= gfc_state_stack
->previous
->state
!= COMP_INTERFACE
4140 || gfc_current_ns
->has_import_set
;
4141 gfc_find_symbol (name
, NULL
, iface
, &sym
);
4142 if (sym
&& sym
->generic
&& gfc_find_symbol (dt_name
, NULL
, 1, &dt_sym
))
4144 gfc_error ("Type name %qs at %C is ambiguous", name
);
4147 if (sym
&& sym
->generic
&& !dt_sym
)
4148 dt_sym
= gfc_find_dt_in_generic (sym
);
4155 if ((sym
->attr
.flavor
!= FL_UNKNOWN
&& sym
->attr
.flavor
!= FL_STRUCT
4156 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.generic
))
4157 || sym
->attr
.subroutine
)
4159 gfc_error ("Type name %qs at %C conflicts with previously declared "
4160 "entity at %L, which has the same name", name
,
4165 if (sym
&& sym
->attr
.flavor
== FL_DERIVED
4166 && sym
->attr
.pdt_template
4167 && gfc_current_state () != COMP_DERIVED
)
4169 m
= gfc_get_pdt_instance (decl_type_param_list
, &sym
, NULL
);
4172 gcc_assert (!sym
->attr
.pdt_template
&& sym
->attr
.pdt_type
);
4173 ts
->u
.derived
= sym
;
4174 strcpy (name
, gfc_dt_lower_string (sym
->name
));
4177 gfc_save_symbol_data (sym
);
4178 gfc_set_sym_referenced (sym
);
4179 if (!sym
->attr
.generic
4180 && !gfc_add_generic (&sym
->attr
, sym
->name
, NULL
))
4183 if (!sym
->attr
.function
4184 && !gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
4187 if (dt_sym
&& dt_sym
->attr
.flavor
== FL_DERIVED
4188 && dt_sym
->attr
.pdt_template
4189 && gfc_current_state () != COMP_DERIVED
)
4191 m
= gfc_get_pdt_instance (decl_type_param_list
, &dt_sym
, NULL
);
4194 gcc_assert (!dt_sym
->attr
.pdt_template
&& dt_sym
->attr
.pdt_type
);
4199 gfc_interface
*intr
, *head
;
4201 /* Use upper case to save the actual derived-type symbol. */
4202 gfc_get_symbol (dt_name
, NULL
, &dt_sym
);
4203 dt_sym
->name
= gfc_get_string ("%s", sym
->name
);
4204 head
= sym
->generic
;
4205 intr
= gfc_get_interface ();
4207 intr
->where
= gfc_current_locus
;
4209 sym
->generic
= intr
;
4210 sym
->attr
.if_source
= IFSRC_DECL
;
4213 gfc_save_symbol_data (dt_sym
);
4215 gfc_set_sym_referenced (dt_sym
);
4217 if (dt_sym
->attr
.flavor
!= FL_DERIVED
&& dt_sym
->attr
.flavor
!= FL_STRUCT
4218 && !gfc_add_flavor (&dt_sym
->attr
, FL_DERIVED
, sym
->name
, NULL
))
4221 ts
->u
.derived
= dt_sym
;
4227 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
4228 "intrinsic-type-spec at %C"))
4231 /* For all types except double, derived and character, look for an
4232 optional kind specifier. MATCH_NO is actually OK at this point. */
4233 if (implicit_flag
== 1)
4235 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
4241 if (gfc_current_form
== FORM_FREE
)
4243 c
= gfc_peek_ascii_char ();
4244 if (!gfc_is_whitespace (c
) && c
!= '*' && c
!= '('
4245 && c
!= ':' && c
!= ',')
4247 if (matched_type
&& c
== ')')
4249 gfc_next_ascii_char ();
4256 m
= gfc_match_kind_spec (ts
, false);
4257 if (m
== MATCH_NO
&& ts
->type
!= BT_CHARACTER
)
4259 m
= gfc_match_old_kind_spec (ts
);
4260 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) == -1)
4264 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
4267 /* Defer association of the KIND expression of function results
4268 until after USE and IMPORT statements. */
4269 if ((gfc_current_state () == COMP_NONE
&& gfc_error_flag_test ())
4270 || gfc_matching_function
)
4274 m
= MATCH_YES
; /* No kind specifier found. */
4280 /* Match an IMPLICIT NONE statement. Actually, this statement is
4281 already matched in parse.c, or we would not end up here in the
4282 first place. So the only thing we need to check, is if there is
4283 trailing garbage. If not, the match is successful. */
4286 gfc_match_implicit_none (void)
4290 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4292 bool external
= false;
4293 locus cur_loc
= gfc_current_locus
;
4295 if (gfc_current_ns
->seen_implicit_none
4296 || gfc_current_ns
->has_implicit_none_export
)
4298 gfc_error ("Duplicate IMPLICIT NONE statement at %C");
4302 gfc_gobble_whitespace ();
4303 c
= gfc_peek_ascii_char ();
4306 (void) gfc_next_ascii_char ();
4307 if (!gfc_notify_std (GFC_STD_F2018
, "IMPORT NONE with spec list at %C"))
4310 gfc_gobble_whitespace ();
4311 if (gfc_peek_ascii_char () == ')')
4313 (void) gfc_next_ascii_char ();
4319 m
= gfc_match (" %n", name
);
4323 if (strcmp (name
, "type") == 0)
4325 else if (strcmp (name
, "external") == 0)
4330 gfc_gobble_whitespace ();
4331 c
= gfc_next_ascii_char ();
4342 if (gfc_match_eos () != MATCH_YES
)
4345 gfc_set_implicit_none (type
, external
, &cur_loc
);
4351 /* Match the letter range(s) of an IMPLICIT statement. */
4354 match_implicit_range (void)
4360 cur_loc
= gfc_current_locus
;
4362 gfc_gobble_whitespace ();
4363 c
= gfc_next_ascii_char ();
4366 gfc_error ("Missing character range in IMPLICIT at %C");
4373 gfc_gobble_whitespace ();
4374 c1
= gfc_next_ascii_char ();
4378 gfc_gobble_whitespace ();
4379 c
= gfc_next_ascii_char ();
4384 inner
= 0; /* Fall through. */
4391 gfc_gobble_whitespace ();
4392 c2
= gfc_next_ascii_char ();
4396 gfc_gobble_whitespace ();
4397 c
= gfc_next_ascii_char ();
4399 if ((c
!= ',') && (c
!= ')'))
4412 gfc_error ("Letters must be in alphabetic order in "
4413 "IMPLICIT statement at %C");
4417 /* See if we can add the newly matched range to the pending
4418 implicits from this IMPLICIT statement. We do not check for
4419 conflicts with whatever earlier IMPLICIT statements may have
4420 set. This is done when we've successfully finished matching
4422 if (!gfc_add_new_implicit_range (c1
, c2
))
4429 gfc_syntax_error (ST_IMPLICIT
);
4431 gfc_current_locus
= cur_loc
;
4436 /* Match an IMPLICIT statement, storing the types for
4437 gfc_set_implicit() if the statement is accepted by the parser.
4438 There is a strange looking, but legal syntactic construction
4439 possible. It looks like:
4441 IMPLICIT INTEGER (a-b) (c-d)
4443 This is legal if "a-b" is a constant expression that happens to
4444 equal one of the legal kinds for integers. The real problem
4445 happens with an implicit specification that looks like:
4447 IMPLICIT INTEGER (a-b)
4449 In this case, a typespec matcher that is "greedy" (as most of the
4450 matchers are) gobbles the character range as a kindspec, leaving
4451 nothing left. We therefore have to go a bit more slowly in the
4452 matching process by inhibiting the kindspec checking during
4453 typespec matching and checking for a kind later. */
4456 gfc_match_implicit (void)
4463 if (gfc_current_ns
->seen_implicit_none
)
4465 gfc_error ("IMPLICIT statement at %C following an IMPLICIT NONE (type) "
4472 /* We don't allow empty implicit statements. */
4473 if (gfc_match_eos () == MATCH_YES
)
4475 gfc_error ("Empty IMPLICIT statement at %C");
4481 /* First cleanup. */
4482 gfc_clear_new_implicit ();
4484 /* A basic type is mandatory here. */
4485 m
= gfc_match_decl_type_spec (&ts
, 1);
4486 if (m
== MATCH_ERROR
)
4491 cur_loc
= gfc_current_locus
;
4492 m
= match_implicit_range ();
4496 /* We may have <TYPE> (<RANGE>). */
4497 gfc_gobble_whitespace ();
4498 c
= gfc_peek_ascii_char ();
4499 if (c
== ',' || c
== '\n' || c
== ';' || c
== '!')
4501 /* Check for CHARACTER with no length parameter. */
4502 if (ts
.type
== BT_CHARACTER
&& !ts
.u
.cl
)
4504 ts
.kind
= gfc_default_character_kind
;
4505 ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4506 ts
.u
.cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
,
4510 /* Record the Successful match. */
4511 if (!gfc_merge_new_implicit (&ts
))
4514 c
= gfc_next_ascii_char ();
4515 else if (gfc_match_eos () == MATCH_ERROR
)
4520 gfc_current_locus
= cur_loc
;
4523 /* Discard the (incorrectly) matched range. */
4524 gfc_clear_new_implicit ();
4526 /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
4527 if (ts
.type
== BT_CHARACTER
)
4528 m
= gfc_match_char_spec (&ts
);
4531 m
= gfc_match_kind_spec (&ts
, false);
4534 m
= gfc_match_old_kind_spec (&ts
);
4535 if (m
== MATCH_ERROR
)
4541 if (m
== MATCH_ERROR
)
4544 m
= match_implicit_range ();
4545 if (m
== MATCH_ERROR
)
4550 gfc_gobble_whitespace ();
4551 c
= gfc_next_ascii_char ();
4552 if (c
!= ',' && gfc_match_eos () != MATCH_YES
)
4555 if (!gfc_merge_new_implicit (&ts
))
4563 gfc_syntax_error (ST_IMPLICIT
);
4571 gfc_match_import (void)
4573 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4578 if (gfc_current_ns
->proc_name
== NULL
4579 || gfc_current_ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
4581 gfc_error ("IMPORT statement at %C only permitted in "
4582 "an INTERFACE body");
4586 if (gfc_current_ns
->proc_name
->attr
.module_procedure
)
4588 gfc_error ("F2008: C1210 IMPORT statement at %C is not permitted "
4589 "in a module procedure interface body");
4593 if (!gfc_notify_std (GFC_STD_F2003
, "IMPORT statement at %C"))
4596 if (gfc_match_eos () == MATCH_YES
)
4598 /* All host variables should be imported. */
4599 gfc_current_ns
->has_import_set
= 1;
4603 if (gfc_match (" ::") == MATCH_YES
)
4605 if (gfc_match_eos () == MATCH_YES
)
4607 gfc_error ("Expecting list of named entities at %C");
4615 m
= gfc_match (" %n", name
);
4619 if (gfc_current_ns
->parent
!= NULL
4620 && gfc_find_symbol (name
, gfc_current_ns
->parent
, 1, &sym
))
4622 gfc_error ("Type name %qs at %C is ambiguous", name
);
4625 else if (!sym
&& gfc_current_ns
->proc_name
->ns
->parent
!= NULL
4626 && gfc_find_symbol (name
,
4627 gfc_current_ns
->proc_name
->ns
->parent
,
4630 gfc_error ("Type name %qs at %C is ambiguous", name
);
4636 gfc_error ("Cannot IMPORT %qs from host scoping unit "
4637 "at %C - does not exist.", name
);
4641 if (gfc_find_symtree (gfc_current_ns
->sym_root
, name
))
4643 gfc_warning (0, "%qs is already IMPORTed from host scoping unit "
4648 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, name
);
4651 sym
->attr
.imported
= 1;
4653 if (sym
->attr
.generic
&& (sym
= gfc_find_dt_in_generic (sym
)))
4655 /* The actual derived type is stored in a symtree with the first
4656 letter of the name capitalized; the symtree with the all
4657 lower-case name contains the associated generic function. */
4658 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
,
4659 gfc_dt_upper_string (name
));
4662 sym
->attr
.imported
= 1;
4675 if (gfc_match_eos () == MATCH_YES
)
4677 if (gfc_match_char (',') != MATCH_YES
)
4684 gfc_error ("Syntax error in IMPORT statement at %C");
4689 /* A minimal implementation of gfc_match without whitespace, escape
4690 characters or variable arguments. Returns true if the next
4691 characters match the TARGET template exactly. */
4694 match_string_p (const char *target
)
4698 for (p
= target
; *p
; p
++)
4699 if ((char) gfc_next_ascii_char () != *p
)
4704 /* Matches an attribute specification including array specs. If
4705 successful, leaves the variables current_attr and current_as
4706 holding the specification. Also sets the colon_seen variable for
4707 later use by matchers associated with initializations.
4709 This subroutine is a little tricky in the sense that we don't know
4710 if we really have an attr-spec until we hit the double colon.
4711 Until that time, we can only return MATCH_NO. This forces us to
4712 check for duplicate specification at this level. */
4715 match_attr_spec (void)
4717 /* Modifiers that can exist in a type statement. */
4719 { GFC_DECL_BEGIN
= 0,
4720 DECL_ALLOCATABLE
= GFC_DECL_BEGIN
, DECL_DIMENSION
, DECL_EXTERNAL
,
4721 DECL_IN
, DECL_OUT
, DECL_INOUT
, DECL_INTRINSIC
, DECL_OPTIONAL
,
4722 DECL_PARAMETER
, DECL_POINTER
, DECL_PROTECTED
, DECL_PRIVATE
,
4723 DECL_STATIC
, DECL_AUTOMATIC
,
4724 DECL_PUBLIC
, DECL_SAVE
, DECL_TARGET
, DECL_VALUE
, DECL_VOLATILE
,
4725 DECL_IS_BIND_C
, DECL_CODIMENSION
, DECL_ASYNCHRONOUS
, DECL_CONTIGUOUS
,
4726 DECL_LEN
, DECL_KIND
, DECL_NONE
, GFC_DECL_END
/* Sentinel */
4729 /* GFC_DECL_END is the sentinel, index starts at 0. */
4730 #define NUM_DECL GFC_DECL_END
4732 locus start
, seen_at
[NUM_DECL
];
4739 gfc_clear_attr (¤t_attr
);
4740 start
= gfc_current_locus
;
4746 /* See if we get all of the keywords up to the final double colon. */
4747 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
4755 gfc_gobble_whitespace ();
4757 ch
= gfc_next_ascii_char ();
4760 /* This is the successful exit condition for the loop. */
4761 if (gfc_next_ascii_char () == ':')
4766 gfc_gobble_whitespace ();
4767 switch (gfc_peek_ascii_char ())
4770 gfc_next_ascii_char ();
4771 switch (gfc_next_ascii_char ())
4774 if (match_string_p ("locatable"))
4776 /* Matched "allocatable". */
4777 d
= DECL_ALLOCATABLE
;
4782 if (match_string_p ("ynchronous"))
4784 /* Matched "asynchronous". */
4785 d
= DECL_ASYNCHRONOUS
;
4790 if (match_string_p ("tomatic"))
4792 /* Matched "automatic". */
4800 /* Try and match the bind(c). */
4801 m
= gfc_match_bind_c (NULL
, true);
4804 else if (m
== MATCH_ERROR
)
4809 gfc_next_ascii_char ();
4810 if ('o' != gfc_next_ascii_char ())
4812 switch (gfc_next_ascii_char ())
4815 if (match_string_p ("imension"))
4817 d
= DECL_CODIMENSION
;
4822 if (match_string_p ("tiguous"))
4824 d
= DECL_CONTIGUOUS
;
4831 if (match_string_p ("dimension"))
4836 if (match_string_p ("external"))
4841 if (match_string_p ("int"))
4843 ch
= gfc_next_ascii_char ();
4846 if (match_string_p ("nt"))
4848 /* Matched "intent". */
4849 /* TODO: Call match_intent_spec from here. */
4850 if (gfc_match (" ( in out )") == MATCH_YES
)
4852 else if (gfc_match (" ( in )") == MATCH_YES
)
4854 else if (gfc_match (" ( out )") == MATCH_YES
)
4860 if (match_string_p ("insic"))
4862 /* Matched "intrinsic". */
4870 if (match_string_p ("kind"))
4875 if (match_string_p ("len"))
4880 if (match_string_p ("optional"))
4885 gfc_next_ascii_char ();
4886 switch (gfc_next_ascii_char ())
4889 if (match_string_p ("rameter"))
4891 /* Matched "parameter". */
4897 if (match_string_p ("inter"))
4899 /* Matched "pointer". */
4905 ch
= gfc_next_ascii_char ();
4908 if (match_string_p ("vate"))
4910 /* Matched "private". */
4916 if (match_string_p ("tected"))
4918 /* Matched "protected". */
4925 if (match_string_p ("blic"))
4927 /* Matched "public". */
4935 gfc_next_ascii_char ();
4936 switch (gfc_next_ascii_char ())
4939 if (match_string_p ("ve"))
4941 /* Matched "save". */
4947 if (match_string_p ("atic"))
4949 /* Matched "static". */
4957 if (match_string_p ("target"))
4962 gfc_next_ascii_char ();
4963 ch
= gfc_next_ascii_char ();
4966 if (match_string_p ("lue"))
4968 /* Matched "value". */
4974 if (match_string_p ("latile"))
4976 /* Matched "volatile". */
4984 /* No double colon and no recognizable decl_type, so assume that
4985 we've been looking at something else the whole time. */
4992 /* Check to make sure any parens are paired up correctly. */
4993 if (gfc_match_parens () == MATCH_ERROR
)
5000 seen_at
[d
] = gfc_current_locus
;
5002 if (d
== DECL_DIMENSION
|| d
== DECL_CODIMENSION
)
5004 gfc_array_spec
*as
= NULL
;
5006 m
= gfc_match_array_spec (&as
, d
== DECL_DIMENSION
,
5007 d
== DECL_CODIMENSION
);
5009 if (current_as
== NULL
)
5011 else if (m
== MATCH_YES
)
5013 if (!merge_array_spec (as
, current_as
, false))
5020 if (d
== DECL_CODIMENSION
)
5021 gfc_error ("Missing codimension specification at %C");
5023 gfc_error ("Missing dimension specification at %C");
5027 if (m
== MATCH_ERROR
)
5032 /* Since we've seen a double colon, we have to be looking at an
5033 attr-spec. This means that we can now issue errors. */
5034 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
5039 case DECL_ALLOCATABLE
:
5040 attr
= "ALLOCATABLE";
5042 case DECL_ASYNCHRONOUS
:
5043 attr
= "ASYNCHRONOUS";
5045 case DECL_CODIMENSION
:
5046 attr
= "CODIMENSION";
5048 case DECL_CONTIGUOUS
:
5049 attr
= "CONTIGUOUS";
5051 case DECL_DIMENSION
:
5058 attr
= "INTENT (IN)";
5061 attr
= "INTENT (OUT)";
5064 attr
= "INTENT (IN OUT)";
5066 case DECL_INTRINSIC
:
5078 case DECL_PARAMETER
:
5084 case DECL_PROTECTED
:
5099 case DECL_AUTOMATIC
:
5105 case DECL_IS_BIND_C
:
5115 attr
= NULL
; /* This shouldn't happen. */
5118 gfc_error ("Duplicate %s attribute at %L", attr
, &seen_at
[d
]);
5123 /* Now that we've dealt with duplicate attributes, add the attributes
5124 to the current attribute. */
5125 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
5132 if ((d
== DECL_STATIC
|| d
== DECL_AUTOMATIC
)
5133 && !flag_dec_static
)
5135 gfc_error ("%s at %L is a DEC extension, enable with "
5137 d
== DECL_STATIC
? "STATIC" : "AUTOMATIC", &seen_at
[d
]);
5141 /* Allow SAVE with STATIC, but don't complain. */
5142 if (d
== DECL_STATIC
&& seen
[DECL_SAVE
])
5145 if (gfc_current_state () == COMP_DERIVED
5146 && d
!= DECL_DIMENSION
&& d
!= DECL_CODIMENSION
5147 && d
!= DECL_POINTER
&& d
!= DECL_PRIVATE
5148 && d
!= DECL_PUBLIC
&& d
!= DECL_CONTIGUOUS
&& d
!= DECL_NONE
)
5150 if (d
== DECL_ALLOCATABLE
)
5152 if (!gfc_notify_std (GFC_STD_F2003
, "ALLOCATABLE "
5153 "attribute at %C in a TYPE definition"))
5159 else if (d
== DECL_KIND
)
5161 if (!gfc_notify_std (GFC_STD_F2003
, "KIND "
5162 "attribute at %C in a TYPE definition"))
5167 if (current_ts
.type
!= BT_INTEGER
)
5169 gfc_error ("Component with KIND attribute at %C must be "
5174 if (current_ts
.kind
!= gfc_default_integer_kind
)
5176 gfc_error ("Component with KIND attribute at %C must be "
5177 "default integer kind (%d)",
5178 gfc_default_integer_kind
);
5183 else if (d
== DECL_LEN
)
5185 if (!gfc_notify_std (GFC_STD_F2003
, "LEN "
5186 "attribute at %C in a TYPE definition"))
5191 if (current_ts
.type
!= BT_INTEGER
)
5193 gfc_error ("Component with LEN attribute at %C must be "
5198 if (current_ts
.kind
!= gfc_default_integer_kind
)
5200 gfc_error ("Component with LEN attribute at %C must be "
5201 "default integer kind (%d)",
5202 gfc_default_integer_kind
);
5209 gfc_error ("Attribute at %L is not allowed in a TYPE definition",
5216 if ((d
== DECL_PRIVATE
|| d
== DECL_PUBLIC
)
5217 && gfc_current_state () != COMP_MODULE
)
5219 if (d
== DECL_PRIVATE
)
5223 if (gfc_current_state () == COMP_DERIVED
5224 && gfc_state_stack
->previous
5225 && gfc_state_stack
->previous
->state
== COMP_MODULE
)
5227 if (!gfc_notify_std (GFC_STD_F2003
, "Attribute %s "
5228 "at %L in a TYPE definition", attr
,
5237 gfc_error ("%s attribute at %L is not allowed outside of the "
5238 "specification part of a module", attr
, &seen_at
[d
]);
5244 if (gfc_current_state () != COMP_DERIVED
5245 && (d
== DECL_KIND
|| d
== DECL_LEN
))
5247 gfc_error ("Attribute at %L is not allowed outside a TYPE "
5248 "definition", &seen_at
[d
]);
5255 case DECL_ALLOCATABLE
:
5256 t
= gfc_add_allocatable (¤t_attr
, &seen_at
[d
]);
5259 case DECL_ASYNCHRONOUS
:
5260 if (!gfc_notify_std (GFC_STD_F2003
, "ASYNCHRONOUS attribute at %C"))
5263 t
= gfc_add_asynchronous (¤t_attr
, NULL
, &seen_at
[d
]);
5266 case DECL_CODIMENSION
:
5267 t
= gfc_add_codimension (¤t_attr
, NULL
, &seen_at
[d
]);
5270 case DECL_CONTIGUOUS
:
5271 if (!gfc_notify_std (GFC_STD_F2008
, "CONTIGUOUS attribute at %C"))
5274 t
= gfc_add_contiguous (¤t_attr
, NULL
, &seen_at
[d
]);
5277 case DECL_DIMENSION
:
5278 t
= gfc_add_dimension (¤t_attr
, NULL
, &seen_at
[d
]);
5282 t
= gfc_add_external (¤t_attr
, &seen_at
[d
]);
5286 t
= gfc_add_intent (¤t_attr
, INTENT_IN
, &seen_at
[d
]);
5290 t
= gfc_add_intent (¤t_attr
, INTENT_OUT
, &seen_at
[d
]);
5294 t
= gfc_add_intent (¤t_attr
, INTENT_INOUT
, &seen_at
[d
]);
5297 case DECL_INTRINSIC
:
5298 t
= gfc_add_intrinsic (¤t_attr
, &seen_at
[d
]);
5302 t
= gfc_add_optional (¤t_attr
, &seen_at
[d
]);
5306 t
= gfc_add_kind (¤t_attr
, &seen_at
[d
]);
5310 t
= gfc_add_len (¤t_attr
, &seen_at
[d
]);
5313 case DECL_PARAMETER
:
5314 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, &seen_at
[d
]);
5318 t
= gfc_add_pointer (¤t_attr
, &seen_at
[d
]);
5321 case DECL_PROTECTED
:
5322 if (gfc_current_state () != COMP_MODULE
5323 || (gfc_current_ns
->proc_name
5324 && gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
))
5326 gfc_error ("PROTECTED at %C only allowed in specification "
5327 "part of a module");
5332 if (!gfc_notify_std (GFC_STD_F2003
, "PROTECTED attribute at %C"))
5335 t
= gfc_add_protected (¤t_attr
, NULL
, &seen_at
[d
]);
5339 t
= gfc_add_access (¤t_attr
, ACCESS_PRIVATE
, NULL
,
5344 t
= gfc_add_access (¤t_attr
, ACCESS_PUBLIC
, NULL
,
5350 t
= gfc_add_save (¤t_attr
, SAVE_EXPLICIT
, NULL
, &seen_at
[d
]);
5353 case DECL_AUTOMATIC
:
5354 t
= gfc_add_automatic (¤t_attr
, NULL
, &seen_at
[d
]);
5358 t
= gfc_add_target (¤t_attr
, &seen_at
[d
]);
5361 case DECL_IS_BIND_C
:
5362 t
= gfc_add_is_bind_c(¤t_attr
, NULL
, &seen_at
[d
], 0);
5366 if (!gfc_notify_std (GFC_STD_F2003
, "VALUE attribute at %C"))
5369 t
= gfc_add_value (¤t_attr
, NULL
, &seen_at
[d
]);
5373 if (!gfc_notify_std (GFC_STD_F2003
, "VOLATILE attribute at %C"))
5376 t
= gfc_add_volatile (¤t_attr
, NULL
, &seen_at
[d
]);
5380 gfc_internal_error ("match_attr_spec(): Bad attribute");
5390 /* Since Fortran 2008 module variables implicitly have the SAVE attribute. */
5391 if ((gfc_current_state () == COMP_MODULE
5392 || gfc_current_state () == COMP_SUBMODULE
)
5393 && !current_attr
.save
5394 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
5395 current_attr
.save
= SAVE_IMPLICIT
;
5401 gfc_current_locus
= start
;
5402 gfc_free_array_spec (current_as
);
5409 /* Set the binding label, dest_label, either with the binding label
5410 stored in the given gfc_typespec, ts, or if none was provided, it
5411 will be the symbol name in all lower case, as required by the draft
5412 (J3/04-007, section 15.4.1). If a binding label was given and
5413 there is more than one argument (num_idents), it is an error. */
5416 set_binding_label (const char **dest_label
, const char *sym_name
,
5419 if (num_idents
> 1 && has_name_equals
)
5421 gfc_error ("Multiple identifiers provided with "
5422 "single NAME= specifier at %C");
5426 if (curr_binding_label
)
5427 /* Binding label given; store in temp holder till have sym. */
5428 *dest_label
= curr_binding_label
;
5431 /* No binding label given, and the NAME= specifier did not exist,
5432 which means there was no NAME="". */
5433 if (sym_name
!= NULL
&& has_name_equals
== 0)
5434 *dest_label
= IDENTIFIER_POINTER (get_identifier (sym_name
));
5441 /* Set the status of the given common block as being BIND(C) or not,
5442 depending on the given parameter, is_bind_c. */
5445 set_com_block_bind_c (gfc_common_head
*com_block
, int is_bind_c
)
5447 com_block
->is_bind_c
= is_bind_c
;
5452 /* Verify that the given gfc_typespec is for a C interoperable type. */
5455 gfc_verify_c_interop (gfc_typespec
*ts
)
5457 if (ts
->type
== BT_DERIVED
&& ts
->u
.derived
!= NULL
)
5458 return (ts
->u
.derived
->ts
.is_c_interop
|| ts
->u
.derived
->attr
.is_bind_c
)
5460 else if (ts
->type
== BT_CLASS
)
5462 else if (ts
->is_c_interop
!= 1 && ts
->type
!= BT_ASSUMED
)
5469 /* Verify that the variables of a given common block, which has been
5470 defined with the attribute specifier bind(c), to be of a C
5471 interoperable type. Errors will be reported here, if
5475 verify_com_block_vars_c_interop (gfc_common_head
*com_block
)
5477 gfc_symbol
*curr_sym
= NULL
;
5480 curr_sym
= com_block
->head
;
5482 /* Make sure we have at least one symbol. */
5483 if (curr_sym
== NULL
)
5486 /* Here we know we have a symbol, so we'll execute this loop
5490 /* The second to last param, 1, says this is in a common block. */
5491 retval
= verify_bind_c_sym (curr_sym
, &(curr_sym
->ts
), 1, com_block
);
5492 curr_sym
= curr_sym
->common_next
;
5493 } while (curr_sym
!= NULL
);
5499 /* Verify that a given BIND(C) symbol is C interoperable. If it is not,
5500 an appropriate error message is reported. */
5503 verify_bind_c_sym (gfc_symbol
*tmp_sym
, gfc_typespec
*ts
,
5504 int is_in_common
, gfc_common_head
*com_block
)
5506 bool bind_c_function
= false;
5509 if (tmp_sym
->attr
.function
&& tmp_sym
->attr
.is_bind_c
)
5510 bind_c_function
= true;
5512 if (tmp_sym
->attr
.function
&& tmp_sym
->result
!= NULL
)
5514 tmp_sym
= tmp_sym
->result
;
5515 /* Make sure it wasn't an implicitly typed result. */
5516 if (tmp_sym
->attr
.implicit_type
&& warn_c_binding_type
)
5518 gfc_warning (OPT_Wc_binding_type
,
5519 "Implicitly declared BIND(C) function %qs at "
5520 "%L may not be C interoperable", tmp_sym
->name
,
5521 &tmp_sym
->declared_at
);
5522 tmp_sym
->ts
.f90_type
= tmp_sym
->ts
.type
;
5523 /* Mark it as C interoperable to prevent duplicate warnings. */
5524 tmp_sym
->ts
.is_c_interop
= 1;
5525 tmp_sym
->attr
.is_c_interop
= 1;
5529 /* Here, we know we have the bind(c) attribute, so if we have
5530 enough type info, then verify that it's a C interop kind.
5531 The info could be in the symbol already, or possibly still in
5532 the given ts (current_ts), so look in both. */
5533 if (tmp_sym
->ts
.type
!= BT_UNKNOWN
|| ts
->type
!= BT_UNKNOWN
)
5535 if (!gfc_verify_c_interop (&(tmp_sym
->ts
)))
5537 /* See if we're dealing with a sym in a common block or not. */
5538 if (is_in_common
== 1 && warn_c_binding_type
)
5540 gfc_warning (OPT_Wc_binding_type
,
5541 "Variable %qs in common block %qs at %L "
5542 "may not be a C interoperable "
5543 "kind though common block %qs is BIND(C)",
5544 tmp_sym
->name
, com_block
->name
,
5545 &(tmp_sym
->declared_at
), com_block
->name
);
5549 if (tmp_sym
->ts
.type
== BT_DERIVED
|| ts
->type
== BT_DERIVED
)
5550 gfc_error ("Type declaration %qs at %L is not C "
5551 "interoperable but it is BIND(C)",
5552 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5553 else if (warn_c_binding_type
)
5554 gfc_warning (OPT_Wc_binding_type
, "Variable %qs at %L "
5555 "may not be a C interoperable "
5556 "kind but it is BIND(C)",
5557 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5561 /* Variables declared w/in a common block can't be bind(c)
5562 since there's no way for C to see these variables, so there's
5563 semantically no reason for the attribute. */
5564 if (is_in_common
== 1 && tmp_sym
->attr
.is_bind_c
== 1)
5566 gfc_error ("Variable %qs in common block %qs at "
5567 "%L cannot be declared with BIND(C) "
5568 "since it is not a global",
5569 tmp_sym
->name
, com_block
->name
,
5570 &(tmp_sym
->declared_at
));
5574 /* Scalar variables that are bind(c) can not have the pointer
5575 or allocatable attributes. */
5576 if (tmp_sym
->attr
.is_bind_c
== 1)
5578 if (tmp_sym
->attr
.pointer
== 1)
5580 gfc_error ("Variable %qs at %L cannot have both the "
5581 "POINTER and BIND(C) attributes",
5582 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5586 if (tmp_sym
->attr
.allocatable
== 1)
5588 gfc_error ("Variable %qs at %L cannot have both the "
5589 "ALLOCATABLE and BIND(C) attributes",
5590 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5596 /* If it is a BIND(C) function, make sure the return value is a
5597 scalar value. The previous tests in this function made sure
5598 the type is interoperable. */
5599 if (bind_c_function
&& tmp_sym
->as
!= NULL
)
5600 gfc_error ("Return type of BIND(C) function %qs at %L cannot "
5601 "be an array", tmp_sym
->name
, &(tmp_sym
->declared_at
));
5603 /* BIND(C) functions can not return a character string. */
5604 if (bind_c_function
&& tmp_sym
->ts
.type
== BT_CHARACTER
)
5605 if (tmp_sym
->ts
.u
.cl
== NULL
|| tmp_sym
->ts
.u
.cl
->length
== NULL
5606 || tmp_sym
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
5607 || mpz_cmp_si (tmp_sym
->ts
.u
.cl
->length
->value
.integer
, 1) != 0)
5608 gfc_error ("Return type of BIND(C) function %qs at %L cannot "
5609 "be a character string", tmp_sym
->name
,
5610 &(tmp_sym
->declared_at
));
5613 /* See if the symbol has been marked as private. If it has, make sure
5614 there is no binding label and warn the user if there is one. */
5615 if (tmp_sym
->attr
.access
== ACCESS_PRIVATE
5616 && tmp_sym
->binding_label
)
5617 /* Use gfc_warning_now because we won't say that the symbol fails
5618 just because of this. */
5619 gfc_warning_now (0, "Symbol %qs at %L is marked PRIVATE but has been "
5620 "given the binding label %qs", tmp_sym
->name
,
5621 &(tmp_sym
->declared_at
), tmp_sym
->binding_label
);
5627 /* Set the appropriate fields for a symbol that's been declared as
5628 BIND(C) (the is_bind_c flag and the binding label), and verify that
5629 the type is C interoperable. Errors are reported by the functions
5630 used to set/test these fields. */
5633 set_verify_bind_c_sym (gfc_symbol
*tmp_sym
, int num_idents
)
5637 /* TODO: Do we need to make sure the vars aren't marked private? */
5639 /* Set the is_bind_c bit in symbol_attribute. */
5640 gfc_add_is_bind_c (&(tmp_sym
->attr
), tmp_sym
->name
, &gfc_current_locus
, 0);
5642 if (!set_binding_label (&tmp_sym
->binding_label
, tmp_sym
->name
, num_idents
))
5649 /* Set the fields marking the given common block as BIND(C), including
5650 a binding label, and report any errors encountered. */
5653 set_verify_bind_c_com_block (gfc_common_head
*com_block
, int num_idents
)
5657 /* destLabel, common name, typespec (which may have binding label). */
5658 if (!set_binding_label (&com_block
->binding_label
, com_block
->name
,
5662 /* Set the given common block (com_block) to being bind(c) (1). */
5663 set_com_block_bind_c (com_block
, 1);
5669 /* Retrieve the list of one or more identifiers that the given bind(c)
5670 attribute applies to. */
5673 get_bind_c_idents (void)
5675 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5677 gfc_symbol
*tmp_sym
= NULL
;
5679 gfc_common_head
*com_block
= NULL
;
5681 if (gfc_match_name (name
) == MATCH_YES
)
5683 found_id
= MATCH_YES
;
5684 gfc_get_ha_symbol (name
, &tmp_sym
);
5686 else if (match_common_name (name
) == MATCH_YES
)
5688 found_id
= MATCH_YES
;
5689 com_block
= gfc_get_common (name
, 0);
5693 gfc_error ("Need either entity or common block name for "
5694 "attribute specification statement at %C");
5698 /* Save the current identifier and look for more. */
5701 /* Increment the number of identifiers found for this spec stmt. */
5704 /* Make sure we have a sym or com block, and verify that it can
5705 be bind(c). Set the appropriate field(s) and look for more
5707 if (tmp_sym
!= NULL
|| com_block
!= NULL
)
5709 if (tmp_sym
!= NULL
)
5711 if (!set_verify_bind_c_sym (tmp_sym
, num_idents
))
5716 if (!set_verify_bind_c_com_block (com_block
, num_idents
))
5720 /* Look to see if we have another identifier. */
5722 if (gfc_match_eos () == MATCH_YES
)
5723 found_id
= MATCH_NO
;
5724 else if (gfc_match_char (',') != MATCH_YES
)
5725 found_id
= MATCH_NO
;
5726 else if (gfc_match_name (name
) == MATCH_YES
)
5728 found_id
= MATCH_YES
;
5729 gfc_get_ha_symbol (name
, &tmp_sym
);
5731 else if (match_common_name (name
) == MATCH_YES
)
5733 found_id
= MATCH_YES
;
5734 com_block
= gfc_get_common (name
, 0);
5738 gfc_error ("Missing entity or common block name for "
5739 "attribute specification statement at %C");
5745 gfc_internal_error ("Missing symbol");
5747 } while (found_id
== MATCH_YES
);
5749 /* if we get here we were successful */
5754 /* Try and match a BIND(C) attribute specification statement. */
5757 gfc_match_bind_c_stmt (void)
5759 match found_match
= MATCH_NO
;
5764 /* This may not be necessary. */
5766 /* Clear the temporary binding label holder. */
5767 curr_binding_label
= NULL
;
5769 /* Look for the bind(c). */
5770 found_match
= gfc_match_bind_c (NULL
, true);
5772 if (found_match
== MATCH_YES
)
5774 if (!gfc_notify_std (GFC_STD_F2003
, "BIND(C) statement at %C"))
5777 /* Look for the :: now, but it is not required. */
5780 /* Get the identifier(s) that needs to be updated. This may need to
5781 change to hand the flag(s) for the attr specified so all identifiers
5782 found can have all appropriate parts updated (assuming that the same
5783 spec stmt can have multiple attrs, such as both bind(c) and
5785 if (!get_bind_c_idents ())
5786 /* Error message should have printed already. */
5794 /* Match a data declaration statement. */
5797 gfc_match_data_decl (void)
5803 type_param_spec_list
= NULL
;
5804 decl_type_param_list
= NULL
;
5806 num_idents_on_line
= 0;
5808 m
= gfc_match_decl_type_spec (¤t_ts
, 0);
5812 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
5813 && !gfc_comp_struct (gfc_current_state ()))
5815 sym
= gfc_use_derived (current_ts
.u
.derived
);
5823 current_ts
.u
.derived
= sym
;
5826 m
= match_attr_spec ();
5827 if (m
== MATCH_ERROR
)
5833 if (current_ts
.type
== BT_CLASS
5834 && current_ts
.u
.derived
->attr
.unlimited_polymorphic
)
5837 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
5838 && current_ts
.u
.derived
->components
== NULL
5839 && !current_ts
.u
.derived
->attr
.zero_comp
)
5842 if (current_attr
.pointer
&& gfc_comp_struct (gfc_current_state ()))
5845 if (current_attr
.allocatable
&& gfc_current_state () == COMP_DERIVED
5846 && current_ts
.u
.derived
== gfc_current_block ())
5849 gfc_find_symbol (current_ts
.u
.derived
->name
,
5850 current_ts
.u
.derived
->ns
, 1, &sym
);
5852 /* Any symbol that we find had better be a type definition
5853 which has its components defined, or be a structure definition
5854 actively being parsed. */
5855 if (sym
!= NULL
&& gfc_fl_struct (sym
->attr
.flavor
)
5856 && (current_ts
.u
.derived
->components
!= NULL
5857 || current_ts
.u
.derived
->attr
.zero_comp
5858 || current_ts
.u
.derived
== gfc_new_block
))
5861 gfc_error ("Derived type at %C has not been previously defined "
5862 "and so cannot appear in a derived type definition");
5868 /* If we have an old-style character declaration, and no new-style
5869 attribute specifications, then there a comma is optional between
5870 the type specification and the variable list. */
5871 if (m
== MATCH_NO
&& current_ts
.type
== BT_CHARACTER
&& old_char_selector
)
5872 gfc_match_char (',');
5874 /* Give the types/attributes to symbols that follow. Give the element
5875 a number so that repeat character length expressions can be copied. */
5879 num_idents_on_line
++;
5880 m
= variable_decl (elem
++);
5881 if (m
== MATCH_ERROR
)
5886 if (gfc_match_eos () == MATCH_YES
)
5888 if (gfc_match_char (',') != MATCH_YES
)
5892 if (!gfc_error_flag_test ())
5894 /* An anonymous structure declaration is unambiguous; if we matched one
5895 according to gfc_match_structure_decl, we need to return MATCH_YES
5896 here to avoid confusing the remaining matchers, even if there was an
5897 error during variable_decl. We must flush any such errors. Note this
5898 causes the parser to gracefully continue parsing the remaining input
5899 as a structure body, which likely follows. */
5900 if (current_ts
.type
== BT_DERIVED
&& current_ts
.u
.derived
5901 && gfc_fl_struct (current_ts
.u
.derived
->attr
.flavor
))
5903 gfc_error_now ("Syntax error in anonymous structure declaration"
5905 /* Skip the bad variable_decl and line up for the start of the
5907 gfc_error_recovery ();
5912 gfc_error ("Syntax error in data declaration at %C");
5917 gfc_free_data_all (gfc_current_ns
);
5920 if (saved_kind_expr
)
5921 gfc_free_expr (saved_kind_expr
);
5922 if (type_param_spec_list
)
5923 gfc_free_actual_arglist (type_param_spec_list
);
5924 if (decl_type_param_list
)
5925 gfc_free_actual_arglist (decl_type_param_list
);
5926 saved_kind_expr
= NULL
;
5927 gfc_free_array_spec (current_as
);
5933 /* Match a prefix associated with a function or subroutine
5934 declaration. If the typespec pointer is nonnull, then a typespec
5935 can be matched. Note that if nothing matches, MATCH_YES is
5936 returned (the null string was matched). */
5939 gfc_match_prefix (gfc_typespec
*ts
)
5945 gfc_clear_attr (¤t_attr
);
5947 seen_impure
= false;
5949 gcc_assert (!gfc_matching_prefix
);
5950 gfc_matching_prefix
= true;
5954 found_prefix
= false;
5956 /* MODULE is a prefix like PURE, ELEMENTAL, etc., having a
5957 corresponding attribute seems natural and distinguishes these
5958 procedures from procedure types of PROC_MODULE, which these are
5960 if (gfc_match ("module% ") == MATCH_YES
)
5962 if (!gfc_notify_std (GFC_STD_F2008
, "MODULE prefix at %C"))
5965 current_attr
.module_procedure
= 1;
5966 found_prefix
= true;
5969 if (!seen_type
&& ts
!= NULL
5970 && gfc_match_decl_type_spec (ts
, 0) == MATCH_YES
5971 && gfc_match_space () == MATCH_YES
)
5975 found_prefix
= true;
5978 if (gfc_match ("elemental% ") == MATCH_YES
)
5980 if (!gfc_add_elemental (¤t_attr
, NULL
))
5983 found_prefix
= true;
5986 if (gfc_match ("pure% ") == MATCH_YES
)
5988 if (!gfc_add_pure (¤t_attr
, NULL
))
5991 found_prefix
= true;
5994 if (gfc_match ("recursive% ") == MATCH_YES
)
5996 if (!gfc_add_recursive (¤t_attr
, NULL
))
5999 found_prefix
= true;
6002 /* IMPURE is a somewhat special case, as it needs not set an actual
6003 attribute but rather only prevents ELEMENTAL routines from being
6004 automatically PURE. */
6005 if (gfc_match ("impure% ") == MATCH_YES
)
6007 if (!gfc_notify_std (GFC_STD_F2008
, "IMPURE procedure at %C"))
6011 found_prefix
= true;
6014 while (found_prefix
);
6016 /* IMPURE and PURE must not both appear, of course. */
6017 if (seen_impure
&& current_attr
.pure
)
6019 gfc_error ("PURE and IMPURE must not appear both at %C");
6023 /* If IMPURE it not seen but the procedure is ELEMENTAL, mark it as PURE. */
6024 if (!seen_impure
&& current_attr
.elemental
&& !current_attr
.pure
)
6026 if (!gfc_add_pure (¤t_attr
, NULL
))
6030 /* At this point, the next item is not a prefix. */
6031 gcc_assert (gfc_matching_prefix
);
6033 gfc_matching_prefix
= false;
6037 gcc_assert (gfc_matching_prefix
);
6038 gfc_matching_prefix
= false;
6043 /* Copy attributes matched by gfc_match_prefix() to attributes on a symbol. */
6046 copy_prefix (symbol_attribute
*dest
, locus
*where
)
6048 if (dest
->module_procedure
)
6050 if (current_attr
.elemental
)
6051 dest
->elemental
= 1;
6053 if (current_attr
.pure
)
6056 if (current_attr
.recursive
)
6057 dest
->recursive
= 1;
6059 /* Module procedures are unusual in that the 'dest' is copied from
6060 the interface declaration. However, this is an oportunity to
6061 check that the submodule declaration is compliant with the
6063 if (dest
->elemental
&& !current_attr
.elemental
)
6065 gfc_error ("ELEMENTAL prefix in MODULE PROCEDURE interface is "
6066 "missing at %L", where
);
6070 if (dest
->pure
&& !current_attr
.pure
)
6072 gfc_error ("PURE prefix in MODULE PROCEDURE interface is "
6073 "missing at %L", where
);
6077 if (dest
->recursive
&& !current_attr
.recursive
)
6079 gfc_error ("RECURSIVE prefix in MODULE PROCEDURE interface is "
6080 "missing at %L", where
);
6087 if (current_attr
.elemental
&& !gfc_add_elemental (dest
, where
))
6090 if (current_attr
.pure
&& !gfc_add_pure (dest
, where
))
6093 if (current_attr
.recursive
&& !gfc_add_recursive (dest
, where
))
6100 /* Match a formal argument list or, if typeparam is true, a
6101 type_param_name_list. */
6104 gfc_match_formal_arglist (gfc_symbol
*progname
, int st_flag
,
6105 int null_flag
, bool typeparam
)
6107 gfc_formal_arglist
*head
, *tail
, *p
, *q
;
6108 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6111 gfc_formal_arglist
*formal
= NULL
;
6115 /* Keep the interface formal argument list and null it so that the
6116 matching for the new declaration can be done. The numbers and
6117 names of the arguments are checked here. The interface formal
6118 arguments are retained in formal_arglist and the characteristics
6119 are compared in resolve.c(resolve_fl_procedure). See the remark
6120 in get_proc_name about the eventual need to copy the formal_arglist
6121 and populate the formal namespace of the interface symbol. */
6122 if (progname
->attr
.module_procedure
6123 && progname
->attr
.host_assoc
)
6125 formal
= progname
->formal
;
6126 progname
->formal
= NULL
;
6129 if (gfc_match_char ('(') != MATCH_YES
)
6136 if (gfc_match_char (')') == MATCH_YES
)
6141 if (gfc_match_char ('*') == MATCH_YES
)
6144 if (!typeparam
&& !gfc_notify_std (GFC_STD_F95_OBS
,
6145 "Alternate-return argument at %C"))
6151 gfc_error_now ("A parameter name is required at %C");
6155 m
= gfc_match_name (name
);
6159 gfc_error_now ("A parameter name is required at %C");
6163 if (!typeparam
&& gfc_get_symbol (name
, NULL
, &sym
))
6166 && gfc_get_symbol (name
, progname
->f2k_derived
, &sym
))
6170 p
= gfc_get_formal_arglist ();
6182 /* We don't add the VARIABLE flavor because the name could be a
6183 dummy procedure. We don't apply these attributes to formal
6184 arguments of statement functions. */
6185 if (sym
!= NULL
&& !st_flag
6186 && (!gfc_add_dummy(&sym
->attr
, sym
->name
, NULL
)
6187 || !gfc_missing_attr (&sym
->attr
, NULL
)))
6193 /* The name of a program unit can be in a different namespace,
6194 so check for it explicitly. After the statement is accepted,
6195 the name is checked for especially in gfc_get_symbol(). */
6196 if (gfc_new_block
!= NULL
&& sym
!= NULL
&& !typeparam
6197 && strcmp (sym
->name
, gfc_new_block
->name
) == 0)
6199 gfc_error ("Name %qs at %C is the name of the procedure",
6205 if (gfc_match_char (')') == MATCH_YES
)
6208 m
= gfc_match_char (',');
6212 gfc_error_now ("Expected parameter list in type declaration "
6215 gfc_error ("Unexpected junk in formal argument list at %C");
6221 /* Check for duplicate symbols in the formal argument list. */
6224 for (p
= head
; p
->next
; p
= p
->next
)
6229 for (q
= p
->next
; q
; q
= q
->next
)
6230 if (p
->sym
== q
->sym
)
6233 gfc_error_now ("Duplicate name %qs in parameter "
6234 "list at %C", p
->sym
->name
);
6236 gfc_error ("Duplicate symbol %qs in formal argument "
6237 "list at %C", p
->sym
->name
);
6245 if (!gfc_add_explicit_interface (progname
, IFSRC_DECL
, head
, NULL
))
6251 /* gfc_error_now used in following and return with MATCH_YES because
6252 doing otherwise results in a cascade of extraneous errors and in
6253 some cases an ICE in symbol.c(gfc_release_symbol). */
6254 if (progname
->attr
.module_procedure
&& progname
->attr
.host_assoc
)
6256 bool arg_count_mismatch
= false;
6258 if (!formal
&& head
)
6259 arg_count_mismatch
= true;
6261 /* Abbreviated module procedure declaration is not meant to have any
6262 formal arguments! */
6263 if (!progname
->abr_modproc_decl
&& formal
&& !head
)
6264 arg_count_mismatch
= true;
6266 for (p
= formal
, q
= head
; p
&& q
; p
= p
->next
, q
= q
->next
)
6268 if ((p
->next
!= NULL
&& q
->next
== NULL
)
6269 || (p
->next
== NULL
&& q
->next
!= NULL
))
6270 arg_count_mismatch
= true;
6271 else if ((p
->sym
== NULL
&& q
->sym
== NULL
)
6272 || strcmp (p
->sym
->name
, q
->sym
->name
) == 0)
6275 gfc_error_now ("Mismatch in MODULE PROCEDURE formal "
6276 "argument names (%s/%s) at %C",
6277 p
->sym
->name
, q
->sym
->name
);
6280 if (arg_count_mismatch
)
6281 gfc_error_now ("Mismatch in number of MODULE PROCEDURE "
6282 "formal arguments at %C");
6288 gfc_free_formal_arglist (head
);
6293 /* Match a RESULT specification following a function declaration or
6294 ENTRY statement. Also matches the end-of-statement. */
6297 match_result (gfc_symbol
*function
, gfc_symbol
**result
)
6299 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6303 if (gfc_match (" result (") != MATCH_YES
)
6306 m
= gfc_match_name (name
);
6310 /* Get the right paren, and that's it because there could be the
6311 bind(c) attribute after the result clause. */
6312 if (gfc_match_char (')') != MATCH_YES
)
6314 /* TODO: should report the missing right paren here. */
6318 if (strcmp (function
->name
, name
) == 0)
6320 gfc_error ("RESULT variable at %C must be different than function name");
6324 if (gfc_get_symbol (name
, NULL
, &r
))
6327 if (!gfc_add_result (&r
->attr
, r
->name
, NULL
))
6336 /* Match a function suffix, which could be a combination of a result
6337 clause and BIND(C), either one, or neither. The draft does not
6338 require them to come in a specific order. */
6341 gfc_match_suffix (gfc_symbol
*sym
, gfc_symbol
**result
)
6343 match is_bind_c
; /* Found bind(c). */
6344 match is_result
; /* Found result clause. */
6345 match found_match
; /* Status of whether we've found a good match. */
6346 char peek_char
; /* Character we're going to peek at. */
6347 bool allow_binding_name
;
6349 /* Initialize to having found nothing. */
6350 found_match
= MATCH_NO
;
6351 is_bind_c
= MATCH_NO
;
6352 is_result
= MATCH_NO
;
6354 /* Get the next char to narrow between result and bind(c). */
6355 gfc_gobble_whitespace ();
6356 peek_char
= gfc_peek_ascii_char ();
6358 /* C binding names are not allowed for internal procedures. */
6359 if (gfc_current_state () == COMP_CONTAINS
6360 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
6361 allow_binding_name
= false;
6363 allow_binding_name
= true;
6368 /* Look for result clause. */
6369 is_result
= match_result (sym
, result
);
6370 if (is_result
== MATCH_YES
)
6372 /* Now see if there is a bind(c) after it. */
6373 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
6374 /* We've found the result clause and possibly bind(c). */
6375 found_match
= MATCH_YES
;
6378 /* This should only be MATCH_ERROR. */
6379 found_match
= is_result
;
6382 /* Look for bind(c) first. */
6383 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
6384 if (is_bind_c
== MATCH_YES
)
6386 /* Now see if a result clause followed it. */
6387 is_result
= match_result (sym
, result
);
6388 found_match
= MATCH_YES
;
6392 /* Should only be a MATCH_ERROR if we get here after seeing 'b'. */
6393 found_match
= MATCH_ERROR
;
6397 gfc_error ("Unexpected junk after function declaration at %C");
6398 found_match
= MATCH_ERROR
;
6402 if (is_bind_c
== MATCH_YES
)
6404 /* Fortran 2008 draft allows BIND(C) for internal procedures. */
6405 if (gfc_current_state () == COMP_CONTAINS
6406 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
6407 && !gfc_notify_std (GFC_STD_F2008
, "BIND(C) attribute "
6408 "at %L may not be specified for an internal "
6409 "procedure", &gfc_current_locus
))
6412 if (!gfc_add_is_bind_c (&(sym
->attr
), sym
->name
, &gfc_current_locus
, 1))
6420 /* Procedure pointer return value without RESULT statement:
6421 Add "hidden" result variable named "ppr@". */
6424 add_hidden_procptr_result (gfc_symbol
*sym
)
6428 if (gfc_notification_std (GFC_STD_F2003
) == ERROR
)
6431 /* First usage case: PROCEDURE and EXTERNAL statements. */
6432 case1
= gfc_current_state () == COMP_FUNCTION
&& gfc_current_block ()
6433 && strcmp (gfc_current_block ()->name
, sym
->name
) == 0
6434 && sym
->attr
.external
;
6435 /* Second usage case: INTERFACE statements. */
6436 case2
= gfc_current_state () == COMP_INTERFACE
&& gfc_state_stack
->previous
6437 && gfc_state_stack
->previous
->state
== COMP_FUNCTION
6438 && strcmp (gfc_state_stack
->previous
->sym
->name
, sym
->name
) == 0;
6444 gfc_get_sym_tree ("ppr@", gfc_current_ns
, &stree
, false);
6448 gfc_get_sym_tree ("ppr@", gfc_current_ns
->parent
, &stree
, false);
6449 st2
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "ppr@");
6450 st2
->n
.sym
= stree
->n
.sym
;
6451 stree
->n
.sym
->refs
++;
6453 sym
->result
= stree
->n
.sym
;
6455 sym
->result
->attr
.proc_pointer
= sym
->attr
.proc_pointer
;
6456 sym
->result
->attr
.pointer
= sym
->attr
.pointer
;
6457 sym
->result
->attr
.external
= sym
->attr
.external
;
6458 sym
->result
->attr
.referenced
= sym
->attr
.referenced
;
6459 sym
->result
->ts
= sym
->ts
;
6460 sym
->attr
.proc_pointer
= 0;
6461 sym
->attr
.pointer
= 0;
6462 sym
->attr
.external
= 0;
6463 if (sym
->result
->attr
.external
&& sym
->result
->attr
.pointer
)
6465 sym
->result
->attr
.pointer
= 0;
6466 sym
->result
->attr
.proc_pointer
= 1;
6469 return gfc_add_result (&sym
->result
->attr
, sym
->result
->name
, NULL
);
6471 /* POINTER after PROCEDURE/EXTERNAL/INTERFACE statement. */
6472 else if (sym
->attr
.function
&& !sym
->attr
.external
&& sym
->attr
.pointer
6473 && sym
->result
&& sym
->result
!= sym
&& sym
->result
->attr
.external
6474 && sym
== gfc_current_ns
->proc_name
6475 && sym
== sym
->result
->ns
->proc_name
6476 && strcmp ("ppr@", sym
->result
->name
) == 0)
6478 sym
->result
->attr
.proc_pointer
= 1;
6479 sym
->attr
.pointer
= 0;
6487 /* Match the interface for a PROCEDURE declaration,
6488 including brackets (R1212). */
6491 match_procedure_interface (gfc_symbol
**proc_if
)
6495 locus old_loc
, entry_loc
;
6496 gfc_namespace
*old_ns
= gfc_current_ns
;
6497 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6499 old_loc
= entry_loc
= gfc_current_locus
;
6500 gfc_clear_ts (¤t_ts
);
6502 if (gfc_match (" (") != MATCH_YES
)
6504 gfc_current_locus
= entry_loc
;
6508 /* Get the type spec. for the procedure interface. */
6509 old_loc
= gfc_current_locus
;
6510 m
= gfc_match_decl_type_spec (¤t_ts
, 0);
6511 gfc_gobble_whitespace ();
6512 if (m
== MATCH_YES
|| (m
== MATCH_NO
&& gfc_peek_ascii_char () == ')'))
6515 if (m
== MATCH_ERROR
)
6518 /* Procedure interface is itself a procedure. */
6519 gfc_current_locus
= old_loc
;
6520 m
= gfc_match_name (name
);
6522 /* First look to see if it is already accessible in the current
6523 namespace because it is use associated or contained. */
6525 if (gfc_find_sym_tree (name
, NULL
, 0, &st
))
6528 /* If it is still not found, then try the parent namespace, if it
6529 exists and create the symbol there if it is still not found. */
6530 if (gfc_current_ns
->parent
)
6531 gfc_current_ns
= gfc_current_ns
->parent
;
6532 if (st
== NULL
&& gfc_get_ha_sym_tree (name
, &st
))
6535 gfc_current_ns
= old_ns
;
6536 *proc_if
= st
->n
.sym
;
6541 /* Resolve interface if possible. That way, attr.procedure is only set
6542 if it is declared by a later procedure-declaration-stmt, which is
6543 invalid per F08:C1216 (cf. resolve_procedure_interface). */
6544 while ((*proc_if
)->ts
.interface
6545 && *proc_if
!= (*proc_if
)->ts
.interface
)
6546 *proc_if
= (*proc_if
)->ts
.interface
;
6548 if ((*proc_if
)->attr
.flavor
== FL_UNKNOWN
6549 && (*proc_if
)->ts
.type
== BT_UNKNOWN
6550 && !gfc_add_flavor (&(*proc_if
)->attr
, FL_PROCEDURE
,
6551 (*proc_if
)->name
, NULL
))
6556 if (gfc_match (" )") != MATCH_YES
)
6558 gfc_current_locus
= entry_loc
;
6566 /* Match a PROCEDURE declaration (R1211). */
6569 match_procedure_decl (void)
6572 gfc_symbol
*sym
, *proc_if
= NULL
;
6574 gfc_expr
*initializer
= NULL
;
6576 /* Parse interface (with brackets). */
6577 m
= match_procedure_interface (&proc_if
);
6581 /* Parse attributes (with colons). */
6582 m
= match_attr_spec();
6583 if (m
== MATCH_ERROR
)
6586 if (proc_if
&& proc_if
->attr
.is_bind_c
&& !current_attr
.is_bind_c
)
6588 current_attr
.is_bind_c
= 1;
6589 has_name_equals
= 0;
6590 curr_binding_label
= NULL
;
6593 /* Get procedure symbols. */
6596 m
= gfc_match_symbol (&sym
, 0);
6599 else if (m
== MATCH_ERROR
)
6602 /* Add current_attr to the symbol attributes. */
6603 if (!gfc_copy_attr (&sym
->attr
, ¤t_attr
, NULL
))
6606 if (sym
->attr
.is_bind_c
)
6608 /* Check for C1218. */
6609 if (!proc_if
|| !proc_if
->attr
.is_bind_c
)
6611 gfc_error ("BIND(C) attribute at %C requires "
6612 "an interface with BIND(C)");
6615 /* Check for C1217. */
6616 if (has_name_equals
&& sym
->attr
.pointer
)
6618 gfc_error ("BIND(C) procedure with NAME may not have "
6619 "POINTER attribute at %C");
6622 if (has_name_equals
&& sym
->attr
.dummy
)
6624 gfc_error ("Dummy procedure at %C may not have "
6625 "BIND(C) attribute with NAME");
6628 /* Set binding label for BIND(C). */
6629 if (!set_binding_label (&sym
->binding_label
, sym
->name
, num
))
6633 if (!gfc_add_external (&sym
->attr
, NULL
))
6636 if (add_hidden_procptr_result (sym
))
6639 if (!gfc_add_proc (&sym
->attr
, sym
->name
, NULL
))
6642 /* Set interface. */
6643 if (proc_if
!= NULL
)
6645 if (sym
->ts
.type
!= BT_UNKNOWN
)
6647 gfc_error ("Procedure %qs at %L already has basic type of %s",
6648 sym
->name
, &gfc_current_locus
,
6649 gfc_basic_typename (sym
->ts
.type
));
6652 sym
->ts
.interface
= proc_if
;
6653 sym
->attr
.untyped
= 1;
6654 sym
->attr
.if_source
= IFSRC_IFBODY
;
6656 else if (current_ts
.type
!= BT_UNKNOWN
)
6658 if (!gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
6660 sym
->ts
.interface
= gfc_new_symbol ("", gfc_current_ns
);
6661 sym
->ts
.interface
->ts
= current_ts
;
6662 sym
->ts
.interface
->attr
.flavor
= FL_PROCEDURE
;
6663 sym
->ts
.interface
->attr
.function
= 1;
6664 sym
->attr
.function
= 1;
6665 sym
->attr
.if_source
= IFSRC_UNKNOWN
;
6668 if (gfc_match (" =>") == MATCH_YES
)
6670 if (!current_attr
.pointer
)
6672 gfc_error ("Initialization at %C isn't for a pointer variable");
6677 m
= match_pointer_init (&initializer
, 1);
6681 if (!add_init_expr_to_sym (sym
->name
, &initializer
, &gfc_current_locus
))
6686 if (gfc_match_eos () == MATCH_YES
)
6688 if (gfc_match_char (',') != MATCH_YES
)
6693 gfc_error ("Syntax error in PROCEDURE statement at %C");
6697 /* Free stuff up and return. */
6698 gfc_free_expr (initializer
);
6704 match_binding_attributes (gfc_typebound_proc
* ba
, bool generic
, bool ppc
);
6707 /* Match a procedure pointer component declaration (R445). */
6710 match_ppc_decl (void)
6713 gfc_symbol
*proc_if
= NULL
;
6717 gfc_expr
*initializer
= NULL
;
6718 gfc_typebound_proc
* tb
;
6719 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6721 /* Parse interface (with brackets). */
6722 m
= match_procedure_interface (&proc_if
);
6726 /* Parse attributes. */
6727 tb
= XCNEW (gfc_typebound_proc
);
6728 tb
->where
= gfc_current_locus
;
6729 m
= match_binding_attributes (tb
, false, true);
6730 if (m
== MATCH_ERROR
)
6733 gfc_clear_attr (¤t_attr
);
6734 current_attr
.procedure
= 1;
6735 current_attr
.proc_pointer
= 1;
6736 current_attr
.access
= tb
->access
;
6737 current_attr
.flavor
= FL_PROCEDURE
;
6739 /* Match the colons (required). */
6740 if (gfc_match (" ::") != MATCH_YES
)
6742 gfc_error ("Expected %<::%> after binding-attributes at %C");
6746 /* Check for C450. */
6747 if (!tb
->nopass
&& proc_if
== NULL
)
6749 gfc_error("NOPASS or explicit interface required at %C");
6753 if (!gfc_notify_std (GFC_STD_F2003
, "Procedure pointer component at %C"))
6756 /* Match PPC names. */
6760 m
= gfc_match_name (name
);
6763 else if (m
== MATCH_ERROR
)
6766 if (!gfc_add_component (gfc_current_block(), name
, &c
))
6769 /* Add current_attr to the symbol attributes. */
6770 if (!gfc_copy_attr (&c
->attr
, ¤t_attr
, NULL
))
6773 if (!gfc_add_external (&c
->attr
, NULL
))
6776 if (!gfc_add_proc (&c
->attr
, name
, NULL
))
6783 c
->tb
= XCNEW (gfc_typebound_proc
);
6784 c
->tb
->where
= gfc_current_locus
;
6788 /* Set interface. */
6789 if (proc_if
!= NULL
)
6791 c
->ts
.interface
= proc_if
;
6792 c
->attr
.untyped
= 1;
6793 c
->attr
.if_source
= IFSRC_IFBODY
;
6795 else if (ts
.type
!= BT_UNKNOWN
)
6798 c
->ts
.interface
= gfc_new_symbol ("", gfc_current_ns
);
6799 c
->ts
.interface
->result
= c
->ts
.interface
;
6800 c
->ts
.interface
->ts
= ts
;
6801 c
->ts
.interface
->attr
.flavor
= FL_PROCEDURE
;
6802 c
->ts
.interface
->attr
.function
= 1;
6803 c
->attr
.function
= 1;
6804 c
->attr
.if_source
= IFSRC_UNKNOWN
;
6807 if (gfc_match (" =>") == MATCH_YES
)
6809 m
= match_pointer_init (&initializer
, 1);
6812 gfc_free_expr (initializer
);
6815 c
->initializer
= initializer
;
6818 if (gfc_match_eos () == MATCH_YES
)
6820 if (gfc_match_char (',') != MATCH_YES
)
6825 gfc_error ("Syntax error in procedure pointer component at %C");
6830 /* Match a PROCEDURE declaration inside an interface (R1206). */
6833 match_procedure_in_interface (void)
6837 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6840 if (current_interface
.type
== INTERFACE_NAMELESS
6841 || current_interface
.type
== INTERFACE_ABSTRACT
)
6843 gfc_error ("PROCEDURE at %C must be in a generic interface");
6847 /* Check if the F2008 optional double colon appears. */
6848 gfc_gobble_whitespace ();
6849 old_locus
= gfc_current_locus
;
6850 if (gfc_match ("::") == MATCH_YES
)
6852 if (!gfc_notify_std (GFC_STD_F2008
, "double colon in "
6853 "MODULE PROCEDURE statement at %L", &old_locus
))
6857 gfc_current_locus
= old_locus
;
6861 m
= gfc_match_name (name
);
6864 else if (m
== MATCH_ERROR
)
6866 if (gfc_get_symbol (name
, gfc_current_ns
->parent
, &sym
))
6869 if (!gfc_add_interface (sym
))
6872 if (gfc_match_eos () == MATCH_YES
)
6874 if (gfc_match_char (',') != MATCH_YES
)
6881 gfc_error ("Syntax error in PROCEDURE statement at %C");
6886 /* General matcher for PROCEDURE declarations. */
6888 static match
match_procedure_in_type (void);
6891 gfc_match_procedure (void)
6895 switch (gfc_current_state ())
6900 case COMP_SUBMODULE
:
6901 case COMP_SUBROUTINE
:
6904 m
= match_procedure_decl ();
6906 case COMP_INTERFACE
:
6907 m
= match_procedure_in_interface ();
6910 m
= match_ppc_decl ();
6912 case COMP_DERIVED_CONTAINS
:
6913 m
= match_procedure_in_type ();
6922 if (!gfc_notify_std (GFC_STD_F2003
, "PROCEDURE statement at %C"))
6929 /* Warn if a matched procedure has the same name as an intrinsic; this is
6930 simply a wrapper around gfc_warn_intrinsic_shadow that interprets the current
6931 parser-state-stack to find out whether we're in a module. */
6934 do_warn_intrinsic_shadow (const gfc_symbol
* sym
, bool func
)
6938 in_module
= (gfc_state_stack
->previous
6939 && (gfc_state_stack
->previous
->state
== COMP_MODULE
6940 || gfc_state_stack
->previous
->state
== COMP_SUBMODULE
));
6942 gfc_warn_intrinsic_shadow (sym
, in_module
, func
);
6946 /* Match a function declaration. */
6949 gfc_match_function_decl (void)
6951 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6952 gfc_symbol
*sym
, *result
;
6956 match found_match
; /* Status returned by match func. */
6958 if (gfc_current_state () != COMP_NONE
6959 && gfc_current_state () != COMP_INTERFACE
6960 && gfc_current_state () != COMP_CONTAINS
)
6963 gfc_clear_ts (¤t_ts
);
6965 old_loc
= gfc_current_locus
;
6967 m
= gfc_match_prefix (¤t_ts
);
6970 gfc_current_locus
= old_loc
;
6974 if (gfc_match ("function% %n", name
) != MATCH_YES
)
6976 gfc_current_locus
= old_loc
;
6980 if (get_proc_name (name
, &sym
, false))
6983 if (add_hidden_procptr_result (sym
))
6986 if (current_attr
.module_procedure
)
6987 sym
->attr
.module_procedure
= 1;
6989 gfc_new_block
= sym
;
6991 m
= gfc_match_formal_arglist (sym
, 0, 0);
6994 gfc_error ("Expected formal argument list in function "
6995 "definition at %C");
6999 else if (m
== MATCH_ERROR
)
7004 /* According to the draft, the bind(c) and result clause can
7005 come in either order after the formal_arg_list (i.e., either
7006 can be first, both can exist together or by themselves or neither
7007 one). Therefore, the match_result can't match the end of the
7008 string, and check for the bind(c) or result clause in either order. */
7009 found_match
= gfc_match_eos ();
7011 /* Make sure that it isn't already declared as BIND(C). If it is, it
7012 must have been marked BIND(C) with a BIND(C) attribute and that is
7013 not allowed for procedures. */
7014 if (sym
->attr
.is_bind_c
== 1)
7016 sym
->attr
.is_bind_c
= 0;
7017 if (sym
->old_symbol
!= NULL
)
7018 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7019 "variables or common blocks",
7020 &(sym
->old_symbol
->declared_at
));
7022 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7023 "variables or common blocks", &gfc_current_locus
);
7026 if (found_match
!= MATCH_YES
)
7028 /* If we haven't found the end-of-statement, look for a suffix. */
7029 suffix_match
= gfc_match_suffix (sym
, &result
);
7030 if (suffix_match
== MATCH_YES
)
7031 /* Need to get the eos now. */
7032 found_match
= gfc_match_eos ();
7034 found_match
= suffix_match
;
7037 if(found_match
!= MATCH_YES
)
7041 /* Make changes to the symbol. */
7044 if (!gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
7047 if (!gfc_missing_attr (&sym
->attr
, NULL
))
7050 if (!copy_prefix (&sym
->attr
, &sym
->declared_at
))
7052 if(!sym
->attr
.module_procedure
)
7058 /* Delay matching the function characteristics until after the
7059 specification block by signalling kind=-1. */
7060 sym
->declared_at
= old_loc
;
7061 if (current_ts
.type
!= BT_UNKNOWN
)
7062 current_ts
.kind
= -1;
7064 current_ts
.kind
= 0;
7068 if (current_ts
.type
!= BT_UNKNOWN
7069 && !gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
7075 if (current_ts
.type
!= BT_UNKNOWN
7076 && !gfc_add_type (result
, ¤t_ts
, &gfc_current_locus
))
7078 sym
->result
= result
;
7081 /* Warn if this procedure has the same name as an intrinsic. */
7082 do_warn_intrinsic_shadow (sym
, true);
7088 gfc_current_locus
= old_loc
;
7093 /* This is mostly a copy of parse.c(add_global_procedure) but modified to
7094 pass the name of the entry, rather than the gfc_current_block name, and
7095 to return false upon finding an existing global entry. */
7098 add_global_entry (const char *name
, const char *binding_label
, bool sub
,
7102 enum gfc_symbol_type type
;
7104 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
7106 /* Only in Fortran 2003: For procedures with a binding label also the Fortran
7107 name is a global identifier. */
7108 if (!binding_label
|| gfc_notification_std (GFC_STD_F2008
))
7110 s
= gfc_get_gsymbol (name
);
7112 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= type
))
7114 gfc_global_used (s
, where
);
7123 s
->ns
= gfc_current_ns
;
7127 /* Don't add the symbol multiple times. */
7129 && (!gfc_notification_std (GFC_STD_F2008
)
7130 || strcmp (name
, binding_label
) != 0))
7132 s
= gfc_get_gsymbol (binding_label
);
7134 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= type
))
7136 gfc_global_used (s
, where
);
7143 s
->binding_label
= binding_label
;
7146 s
->ns
= gfc_current_ns
;
7154 /* Match an ENTRY statement. */
7157 gfc_match_entry (void)
7162 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7163 gfc_compile_state state
;
7167 bool module_procedure
;
7171 m
= gfc_match_name (name
);
7175 if (!gfc_notify_std (GFC_STD_F2008_OBS
, "ENTRY statement at %C"))
7178 state
= gfc_current_state ();
7179 if (state
!= COMP_SUBROUTINE
&& state
!= COMP_FUNCTION
)
7184 gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
7187 gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
7189 case COMP_SUBMODULE
:
7190 gfc_error ("ENTRY statement at %C cannot appear within a SUBMODULE");
7192 case COMP_BLOCK_DATA
:
7193 gfc_error ("ENTRY statement at %C cannot appear within "
7196 case COMP_INTERFACE
:
7197 gfc_error ("ENTRY statement at %C cannot appear within "
7200 case COMP_STRUCTURE
:
7201 gfc_error ("ENTRY statement at %C cannot appear within "
7202 "a STRUCTURE block");
7205 gfc_error ("ENTRY statement at %C cannot appear within "
7206 "a DERIVED TYPE block");
7209 gfc_error ("ENTRY statement at %C cannot appear within "
7210 "an IF-THEN block");
7213 case COMP_DO_CONCURRENT
:
7214 gfc_error ("ENTRY statement at %C cannot appear within "
7218 gfc_error ("ENTRY statement at %C cannot appear within "
7222 gfc_error ("ENTRY statement at %C cannot appear within "
7226 gfc_error ("ENTRY statement at %C cannot appear within "
7230 gfc_error ("ENTRY statement at %C cannot appear within "
7231 "a contained subprogram");
7234 gfc_error ("Unexpected ENTRY statement at %C");
7239 if ((state
== COMP_SUBROUTINE
|| state
== COMP_FUNCTION
)
7240 && gfc_state_stack
->previous
->state
== COMP_INTERFACE
)
7242 gfc_error ("ENTRY statement at %C cannot appear within an INTERFACE");
7246 module_procedure
= gfc_current_ns
->parent
!= NULL
7247 && gfc_current_ns
->parent
->proc_name
7248 && gfc_current_ns
->parent
->proc_name
->attr
.flavor
7251 if (gfc_current_ns
->parent
!= NULL
7252 && gfc_current_ns
->parent
->proc_name
7253 && !module_procedure
)
7255 gfc_error("ENTRY statement at %C cannot appear in a "
7256 "contained procedure");
7260 /* Module function entries need special care in get_proc_name
7261 because previous references within the function will have
7262 created symbols attached to the current namespace. */
7263 if (get_proc_name (name
, &entry
,
7264 gfc_current_ns
->parent
!= NULL
7265 && module_procedure
))
7268 proc
= gfc_current_block ();
7270 /* Make sure that it isn't already declared as BIND(C). If it is, it
7271 must have been marked BIND(C) with a BIND(C) attribute and that is
7272 not allowed for procedures. */
7273 if (entry
->attr
.is_bind_c
== 1)
7275 entry
->attr
.is_bind_c
= 0;
7276 if (entry
->old_symbol
!= NULL
)
7277 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7278 "variables or common blocks",
7279 &(entry
->old_symbol
->declared_at
));
7281 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7282 "variables or common blocks", &gfc_current_locus
);
7285 /* Check what next non-whitespace character is so we can tell if there
7286 is the required parens if we have a BIND(C). */
7287 old_loc
= gfc_current_locus
;
7288 gfc_gobble_whitespace ();
7289 peek_char
= gfc_peek_ascii_char ();
7291 if (state
== COMP_SUBROUTINE
)
7293 m
= gfc_match_formal_arglist (entry
, 0, 1);
7297 /* Call gfc_match_bind_c with allow_binding_name = true as ENTRY can
7298 never be an internal procedure. */
7299 is_bind_c
= gfc_match_bind_c (entry
, true);
7300 if (is_bind_c
== MATCH_ERROR
)
7302 if (is_bind_c
== MATCH_YES
)
7304 if (peek_char
!= '(')
7306 gfc_error ("Missing required parentheses before BIND(C) at %C");
7309 if (!gfc_add_is_bind_c (&(entry
->attr
), entry
->name
,
7310 &(entry
->declared_at
), 1))
7314 if (!gfc_current_ns
->parent
7315 && !add_global_entry (name
, entry
->binding_label
, true,
7319 /* An entry in a subroutine. */
7320 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
7321 || !gfc_add_subroutine (&entry
->attr
, entry
->name
, NULL
))
7326 /* An entry in a function.
7327 We need to take special care because writing
7332 ENTRY f() RESULT (r)
7334 ENTRY f RESULT (r). */
7335 if (gfc_match_eos () == MATCH_YES
)
7337 gfc_current_locus
= old_loc
;
7338 /* Match the empty argument list, and add the interface to
7340 m
= gfc_match_formal_arglist (entry
, 0, 1);
7343 m
= gfc_match_formal_arglist (entry
, 0, 0);
7350 if (gfc_match_eos () == MATCH_YES
)
7352 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
7353 || !gfc_add_function (&entry
->attr
, entry
->name
, NULL
))
7356 entry
->result
= entry
;
7360 m
= gfc_match_suffix (entry
, &result
);
7362 gfc_syntax_error (ST_ENTRY
);
7368 if (!gfc_add_result (&result
->attr
, result
->name
, NULL
)
7369 || !gfc_add_entry (&entry
->attr
, result
->name
, NULL
)
7370 || !gfc_add_function (&entry
->attr
, result
->name
, NULL
))
7372 entry
->result
= result
;
7376 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
7377 || !gfc_add_function (&entry
->attr
, entry
->name
, NULL
))
7379 entry
->result
= entry
;
7383 if (!gfc_current_ns
->parent
7384 && !add_global_entry (name
, entry
->binding_label
, false,
7389 if (gfc_match_eos () != MATCH_YES
)
7391 gfc_syntax_error (ST_ENTRY
);
7395 entry
->attr
.recursive
= proc
->attr
.recursive
;
7396 entry
->attr
.elemental
= proc
->attr
.elemental
;
7397 entry
->attr
.pure
= proc
->attr
.pure
;
7399 el
= gfc_get_entry_list ();
7401 el
->next
= gfc_current_ns
->entries
;
7402 gfc_current_ns
->entries
= el
;
7404 el
->id
= el
->next
->id
+ 1;
7408 new_st
.op
= EXEC_ENTRY
;
7409 new_st
.ext
.entry
= el
;
7415 /* Match a subroutine statement, including optional prefixes. */
7418 gfc_match_subroutine (void)
7420 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7425 bool allow_binding_name
;
7427 if (gfc_current_state () != COMP_NONE
7428 && gfc_current_state () != COMP_INTERFACE
7429 && gfc_current_state () != COMP_CONTAINS
)
7432 m
= gfc_match_prefix (NULL
);
7436 m
= gfc_match ("subroutine% %n", name
);
7440 if (get_proc_name (name
, &sym
, false))
7443 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
7444 the symbol existed before. */
7445 sym
->declared_at
= gfc_current_locus
;
7447 if (current_attr
.module_procedure
)
7448 sym
->attr
.module_procedure
= 1;
7450 if (add_hidden_procptr_result (sym
))
7453 gfc_new_block
= sym
;
7455 /* Check what next non-whitespace character is so we can tell if there
7456 is the required parens if we have a BIND(C). */
7457 gfc_gobble_whitespace ();
7458 peek_char
= gfc_peek_ascii_char ();
7460 if (!gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
))
7463 if (gfc_match_formal_arglist (sym
, 0, 1) != MATCH_YES
)
7466 /* Make sure that it isn't already declared as BIND(C). If it is, it
7467 must have been marked BIND(C) with a BIND(C) attribute and that is
7468 not allowed for procedures. */
7469 if (sym
->attr
.is_bind_c
== 1)
7471 sym
->attr
.is_bind_c
= 0;
7472 if (sym
->old_symbol
!= NULL
)
7473 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7474 "variables or common blocks",
7475 &(sym
->old_symbol
->declared_at
));
7477 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7478 "variables or common blocks", &gfc_current_locus
);
7481 /* C binding names are not allowed for internal procedures. */
7482 if (gfc_current_state () == COMP_CONTAINS
7483 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
7484 allow_binding_name
= false;
7486 allow_binding_name
= true;
7488 /* Here, we are just checking if it has the bind(c) attribute, and if
7489 so, then we need to make sure it's all correct. If it doesn't,
7490 we still need to continue matching the rest of the subroutine line. */
7491 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
7492 if (is_bind_c
== MATCH_ERROR
)
7494 /* There was an attempt at the bind(c), but it was wrong. An
7495 error message should have been printed w/in the gfc_match_bind_c
7496 so here we'll just return the MATCH_ERROR. */
7500 if (is_bind_c
== MATCH_YES
)
7502 /* The following is allowed in the Fortran 2008 draft. */
7503 if (gfc_current_state () == COMP_CONTAINS
7504 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
7505 && !gfc_notify_std (GFC_STD_F2008
, "BIND(C) attribute "
7506 "at %L may not be specified for an internal "
7507 "procedure", &gfc_current_locus
))
7510 if (peek_char
!= '(')
7512 gfc_error ("Missing required parentheses before BIND(C) at %C");
7515 if (!gfc_add_is_bind_c (&(sym
->attr
), sym
->name
,
7516 &(sym
->declared_at
), 1))
7520 if (gfc_match_eos () != MATCH_YES
)
7522 gfc_syntax_error (ST_SUBROUTINE
);
7526 if (!copy_prefix (&sym
->attr
, &sym
->declared_at
))
7528 if(!sym
->attr
.module_procedure
)
7534 /* Warn if it has the same name as an intrinsic. */
7535 do_warn_intrinsic_shadow (sym
, false);
7541 /* Check that the NAME identifier in a BIND attribute or statement
7542 is conform to C identifier rules. */
7545 check_bind_name_identifier (char **name
)
7547 char *n
= *name
, *p
;
7549 /* Remove leading spaces. */
7553 /* On an empty string, free memory and set name to NULL. */
7561 /* Remove trailing spaces. */
7562 p
= n
+ strlen(n
) - 1;
7566 /* Insert the identifier into the symbol table. */
7571 /* Now check that identifier is valid under C rules. */
7574 gfc_error ("Invalid C identifier in NAME= specifier at %C");
7579 if (!(ISALNUM (*p
) || *p
== '_' || *p
== '$'))
7581 gfc_error ("Invalid C identifier in NAME= specifier at %C");
7589 /* Match a BIND(C) specifier, with the optional 'name=' specifier if
7590 given, and set the binding label in either the given symbol (if not
7591 NULL), or in the current_ts. The symbol may be NULL because we may
7592 encounter the BIND(C) before the declaration itself. Return
7593 MATCH_NO if what we're looking at isn't a BIND(C) specifier,
7594 MATCH_ERROR if it is a BIND(C) clause but an error was encountered,
7595 or MATCH_YES if the specifier was correct and the binding label and
7596 bind(c) fields were set correctly for the given symbol or the
7597 current_ts. If allow_binding_name is false, no binding name may be
7601 gfc_match_bind_c (gfc_symbol
*sym
, bool allow_binding_name
)
7603 char *binding_label
= NULL
;
7606 /* Initialize the flag that specifies whether we encountered a NAME=
7607 specifier or not. */
7608 has_name_equals
= 0;
7610 /* This much we have to be able to match, in this order, if
7611 there is a bind(c) label. */
7612 if (gfc_match (" bind ( c ") != MATCH_YES
)
7615 /* Now see if there is a binding label, or if we've reached the
7616 end of the bind(c) attribute without one. */
7617 if (gfc_match_char (',') == MATCH_YES
)
7619 if (gfc_match (" name = ") != MATCH_YES
)
7621 gfc_error ("Syntax error in NAME= specifier for binding label "
7623 /* should give an error message here */
7627 has_name_equals
= 1;
7629 if (gfc_match_init_expr (&e
) != MATCH_YES
)
7635 if (!gfc_simplify_expr(e
, 0))
7637 gfc_error ("NAME= specifier at %C should be a constant expression");
7642 if (e
->expr_type
!= EXPR_CONSTANT
|| e
->ts
.type
!= BT_CHARACTER
7643 || e
->ts
.kind
!= gfc_default_character_kind
|| e
->rank
!= 0)
7645 gfc_error ("NAME= specifier at %C should be a scalar of "
7646 "default character kind");
7651 // Get a C string from the Fortran string constant
7652 binding_label
= gfc_widechar_to_char (e
->value
.character
.string
,
7653 e
->value
.character
.length
);
7656 // Check that it is valid (old gfc_match_name_C)
7657 if (check_bind_name_identifier (&binding_label
) != MATCH_YES
)
7661 /* Get the required right paren. */
7662 if (gfc_match_char (')') != MATCH_YES
)
7664 gfc_error ("Missing closing paren for binding label at %C");
7668 if (has_name_equals
&& !allow_binding_name
)
7670 gfc_error ("No binding name is allowed in BIND(C) at %C");
7674 if (has_name_equals
&& sym
!= NULL
&& sym
->attr
.dummy
)
7676 gfc_error ("For dummy procedure %s, no binding name is "
7677 "allowed in BIND(C) at %C", sym
->name
);
7682 /* Save the binding label to the symbol. If sym is null, we're
7683 probably matching the typespec attributes of a declaration and
7684 haven't gotten the name yet, and therefore, no symbol yet. */
7688 sym
->binding_label
= binding_label
;
7690 curr_binding_label
= binding_label
;
7692 else if (allow_binding_name
)
7694 /* No binding label, but if symbol isn't null, we
7695 can set the label for it here.
7696 If name="" or allow_binding_name is false, no C binding name is
7698 if (sym
!= NULL
&& sym
->name
!= NULL
&& has_name_equals
== 0)
7699 sym
->binding_label
= IDENTIFIER_POINTER (get_identifier (sym
->name
));
7702 if (has_name_equals
&& gfc_current_state () == COMP_INTERFACE
7703 && current_interface
.type
== INTERFACE_ABSTRACT
)
7705 gfc_error ("NAME not allowed on BIND(C) for ABSTRACT INTERFACE at %C");
7713 /* Return nonzero if we're currently compiling a contained procedure. */
7716 contained_procedure (void)
7718 gfc_state_data
*s
= gfc_state_stack
;
7720 if ((s
->state
== COMP_SUBROUTINE
|| s
->state
== COMP_FUNCTION
)
7721 && s
->previous
!= NULL
&& s
->previous
->state
== COMP_CONTAINS
)
7727 /* Set the kind of each enumerator. The kind is selected such that it is
7728 interoperable with the corresponding C enumeration type, making
7729 sure that -fshort-enums is honored. */
7734 enumerator_history
*current_history
= NULL
;
7738 if (max_enum
== NULL
|| enum_history
== NULL
)
7741 if (!flag_short_enums
)
7747 kind
= gfc_integer_kinds
[i
++].kind
;
7749 while (kind
< gfc_c_int_kind
7750 && gfc_check_integer_range (max_enum
->initializer
->value
.integer
,
7753 current_history
= enum_history
;
7754 while (current_history
!= NULL
)
7756 current_history
->sym
->ts
.kind
= kind
;
7757 current_history
= current_history
->next
;
7762 /* Match any of the various end-block statements. Returns the type of
7763 END to the caller. The END INTERFACE, END IF, END DO, END SELECT
7764 and END BLOCK statements cannot be replaced by a single END statement. */
7767 gfc_match_end (gfc_statement
*st
)
7769 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7770 gfc_compile_state state
;
7772 const char *block_name
;
7776 gfc_namespace
*parent_ns
, *ns
, *prev_ns
;
7777 gfc_namespace
**nsp
;
7778 bool abreviated_modproc_decl
= false;
7779 bool got_matching_end
= false;
7781 old_loc
= gfc_current_locus
;
7782 if (gfc_match ("end") != MATCH_YES
)
7785 state
= gfc_current_state ();
7786 block_name
= gfc_current_block () == NULL
7787 ? NULL
: gfc_current_block ()->name
;
7791 case COMP_ASSOCIATE
:
7793 if (!strncmp (block_name
, "block@", strlen("block@")))
7798 case COMP_DERIVED_CONTAINS
:
7799 state
= gfc_state_stack
->previous
->state
;
7800 block_name
= gfc_state_stack
->previous
->sym
== NULL
7801 ? NULL
: gfc_state_stack
->previous
->sym
->name
;
7802 abreviated_modproc_decl
= gfc_state_stack
->previous
->sym
7803 && gfc_state_stack
->previous
->sym
->abr_modproc_decl
;
7810 if (!abreviated_modproc_decl
)
7811 abreviated_modproc_decl
= gfc_current_block ()
7812 && gfc_current_block ()->abr_modproc_decl
;
7818 *st
= ST_END_PROGRAM
;
7819 target
= " program";
7823 case COMP_SUBROUTINE
:
7824 *st
= ST_END_SUBROUTINE
;
7825 if (!abreviated_modproc_decl
)
7826 target
= " subroutine";
7828 target
= " procedure";
7829 eos_ok
= !contained_procedure ();
7833 *st
= ST_END_FUNCTION
;
7834 if (!abreviated_modproc_decl
)
7835 target
= " function";
7837 target
= " procedure";
7838 eos_ok
= !contained_procedure ();
7841 case COMP_BLOCK_DATA
:
7842 *st
= ST_END_BLOCK_DATA
;
7843 target
= " block data";
7848 *st
= ST_END_MODULE
;
7853 case COMP_SUBMODULE
:
7854 *st
= ST_END_SUBMODULE
;
7855 target
= " submodule";
7859 case COMP_INTERFACE
:
7860 *st
= ST_END_INTERFACE
;
7861 target
= " interface";
7877 case COMP_STRUCTURE
:
7878 *st
= ST_END_STRUCTURE
;
7879 target
= " structure";
7884 case COMP_DERIVED_CONTAINS
:
7890 case COMP_ASSOCIATE
:
7891 *st
= ST_END_ASSOCIATE
;
7892 target
= " associate";
7909 case COMP_DO_CONCURRENT
:
7916 *st
= ST_END_CRITICAL
;
7917 target
= " critical";
7922 case COMP_SELECT_TYPE
:
7923 *st
= ST_END_SELECT
;
7929 *st
= ST_END_FORALL
;
7944 last_initializer
= NULL
;
7946 gfc_free_enum_history ();
7950 gfc_error ("Unexpected END statement at %C");
7954 old_loc
= gfc_current_locus
;
7955 if (gfc_match_eos () == MATCH_YES
)
7957 if (!eos_ok
&& (*st
== ST_END_SUBROUTINE
|| *st
== ST_END_FUNCTION
))
7959 if (!gfc_notify_std (GFC_STD_F2008
, "END statement "
7960 "instead of %s statement at %L",
7961 abreviated_modproc_decl
? "END PROCEDURE"
7962 : gfc_ascii_statement(*st
), &old_loc
))
7967 /* We would have required END [something]. */
7968 gfc_error ("%s statement expected at %L",
7969 gfc_ascii_statement (*st
), &old_loc
);
7976 /* Verify that we've got the sort of end-block that we're expecting. */
7977 if (gfc_match (target
) != MATCH_YES
)
7979 gfc_error ("Expecting %s statement at %L", abreviated_modproc_decl
7980 ? "END PROCEDURE" : gfc_ascii_statement(*st
), &old_loc
);
7984 got_matching_end
= true;
7986 old_loc
= gfc_current_locus
;
7987 /* If we're at the end, make sure a block name wasn't required. */
7988 if (gfc_match_eos () == MATCH_YES
)
7991 if (*st
!= ST_ENDDO
&& *st
!= ST_ENDIF
&& *st
!= ST_END_SELECT
7992 && *st
!= ST_END_FORALL
&& *st
!= ST_END_WHERE
&& *st
!= ST_END_BLOCK
7993 && *st
!= ST_END_ASSOCIATE
&& *st
!= ST_END_CRITICAL
)
7999 gfc_error ("Expected block name of %qs in %s statement at %L",
8000 block_name
, gfc_ascii_statement (*st
), &old_loc
);
8005 /* END INTERFACE has a special handler for its several possible endings. */
8006 if (*st
== ST_END_INTERFACE
)
8007 return gfc_match_end_interface ();
8009 /* We haven't hit the end of statement, so what is left must be an
8011 m
= gfc_match_space ();
8013 m
= gfc_match_name (name
);
8016 gfc_error ("Expected terminating name at %C");
8020 if (block_name
== NULL
)
8023 /* We have to pick out the declared submodule name from the composite
8024 required by F2008:11.2.3 para 2, which ends in the declared name. */
8025 if (state
== COMP_SUBMODULE
)
8026 block_name
= strchr (block_name
, '.') + 1;
8028 if (strcmp (name
, block_name
) != 0 && strcmp (block_name
, "ppr@") != 0)
8030 gfc_error ("Expected label %qs for %s statement at %C", block_name
,
8031 gfc_ascii_statement (*st
));
8034 /* Procedure pointer as function result. */
8035 else if (strcmp (block_name
, "ppr@") == 0
8036 && strcmp (name
, gfc_current_block ()->ns
->proc_name
->name
) != 0)
8038 gfc_error ("Expected label %qs for %s statement at %C",
8039 gfc_current_block ()->ns
->proc_name
->name
,
8040 gfc_ascii_statement (*st
));
8044 if (gfc_match_eos () == MATCH_YES
)
8048 gfc_syntax_error (*st
);
8051 gfc_current_locus
= old_loc
;
8053 /* If we are missing an END BLOCK, we created a half-ready namespace.
8054 Remove it from the parent namespace's sibling list. */
8056 while (state
== COMP_BLOCK
&& !got_matching_end
)
8058 parent_ns
= gfc_current_ns
->parent
;
8060 nsp
= &(gfc_state_stack
->previous
->tail
->ext
.block
.ns
);
8066 if (ns
== gfc_current_ns
)
8068 if (prev_ns
== NULL
)
8071 prev_ns
->sibling
= ns
->sibling
;
8077 gfc_free_namespace (gfc_current_ns
);
8078 gfc_current_ns
= parent_ns
;
8079 gfc_state_stack
= gfc_state_stack
->previous
;
8080 state
= gfc_current_state ();
8088 /***************** Attribute declaration statements ****************/
8090 /* Set the attribute of a single variable. */
8095 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8098 /* Workaround -Wmaybe-uninitialized false positive during
8099 profiledbootstrap by initializing them. */
8100 gfc_symbol
*sym
= NULL
;
8106 m
= gfc_match_name (name
);
8110 if (find_special (name
, &sym
, false))
8113 if (!check_function_name (name
))
8119 var_locus
= gfc_current_locus
;
8121 /* Deal with possible array specification for certain attributes. */
8122 if (current_attr
.dimension
8123 || current_attr
.codimension
8124 || current_attr
.allocatable
8125 || current_attr
.pointer
8126 || current_attr
.target
)
8128 m
= gfc_match_array_spec (&as
, !current_attr
.codimension
,
8129 !current_attr
.dimension
8130 && !current_attr
.pointer
8131 && !current_attr
.target
);
8132 if (m
== MATCH_ERROR
)
8135 if (current_attr
.dimension
&& m
== MATCH_NO
)
8137 gfc_error ("Missing array specification at %L in DIMENSION "
8138 "statement", &var_locus
);
8143 if (current_attr
.dimension
&& sym
->value
)
8145 gfc_error ("Dimensions specified for %s at %L after its "
8146 "initialization", sym
->name
, &var_locus
);
8151 if (current_attr
.codimension
&& m
== MATCH_NO
)
8153 gfc_error ("Missing array specification at %L in CODIMENSION "
8154 "statement", &var_locus
);
8159 if ((current_attr
.allocatable
|| current_attr
.pointer
)
8160 && (m
== MATCH_YES
) && (as
->type
!= AS_DEFERRED
))
8162 gfc_error ("Array specification must be deferred at %L", &var_locus
);
8168 /* Update symbol table. DIMENSION attribute is set in
8169 gfc_set_array_spec(). For CLASS variables, this must be applied
8170 to the first component, or '_data' field. */
8171 if (sym
->ts
.type
== BT_CLASS
&& sym
->ts
.u
.derived
->attr
.is_class
)
8173 if (!gfc_copy_attr (&CLASS_DATA(sym
)->attr
, ¤t_attr
, &var_locus
))
8181 if (current_attr
.dimension
== 0 && current_attr
.codimension
== 0
8182 && !gfc_copy_attr (&sym
->attr
, ¤t_attr
, &var_locus
))
8189 if (sym
->ts
.type
== BT_CLASS
8190 && !gfc_build_class_symbol (&sym
->ts
, &sym
->attr
, &sym
->as
))
8196 if (!gfc_set_array_spec (sym
, as
, &var_locus
))
8202 if (sym
->attr
.cray_pointee
&& sym
->as
!= NULL
)
8204 /* Fix the array spec. */
8205 m
= gfc_mod_pointee_as (sym
->as
);
8206 if (m
== MATCH_ERROR
)
8210 if (!gfc_add_attribute (&sym
->attr
, &var_locus
))
8216 if ((current_attr
.external
|| current_attr
.intrinsic
)
8217 && sym
->attr
.flavor
!= FL_PROCEDURE
8218 && !gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, NULL
))
8224 add_hidden_procptr_result (sym
);
8229 gfc_free_array_spec (as
);
8234 /* Generic attribute declaration subroutine. Used for attributes that
8235 just have a list of names. */
8242 /* Gobble the optional double colon, by simply ignoring the result
8252 if (gfc_match_eos () == MATCH_YES
)
8258 if (gfc_match_char (',') != MATCH_YES
)
8260 gfc_error ("Unexpected character in variable list at %C");
8270 /* This routine matches Cray Pointer declarations of the form:
8271 pointer ( <pointer>, <pointee> )
8273 pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...
8274 The pointer, if already declared, should be an integer. Otherwise, we
8275 set it as BT_INTEGER with kind gfc_index_integer_kind. The pointee may
8276 be either a scalar, or an array declaration. No space is allocated for
8277 the pointee. For the statement
8278 pointer (ipt, ar(10))
8279 any subsequent uses of ar will be translated (in C-notation) as
8280 ar(i) => ((<type> *) ipt)(i)
8281 After gimplification, pointee variable will disappear in the code. */
8284 cray_pointer_decl (void)
8287 gfc_array_spec
*as
= NULL
;
8288 gfc_symbol
*cptr
; /* Pointer symbol. */
8289 gfc_symbol
*cpte
; /* Pointee symbol. */
8295 if (gfc_match_char ('(') != MATCH_YES
)
8297 gfc_error ("Expected %<(%> at %C");
8301 /* Match pointer. */
8302 var_locus
= gfc_current_locus
;
8303 gfc_clear_attr (¤t_attr
);
8304 gfc_add_cray_pointer (¤t_attr
, &var_locus
);
8305 current_ts
.type
= BT_INTEGER
;
8306 current_ts
.kind
= gfc_index_integer_kind
;
8308 m
= gfc_match_symbol (&cptr
, 0);
8311 gfc_error ("Expected variable name at %C");
8315 if (!gfc_add_cray_pointer (&cptr
->attr
, &var_locus
))
8318 gfc_set_sym_referenced (cptr
);
8320 if (cptr
->ts
.type
== BT_UNKNOWN
) /* Override the type, if necessary. */
8322 cptr
->ts
.type
= BT_INTEGER
;
8323 cptr
->ts
.kind
= gfc_index_integer_kind
;
8325 else if (cptr
->ts
.type
!= BT_INTEGER
)
8327 gfc_error ("Cray pointer at %C must be an integer");
8330 else if (cptr
->ts
.kind
< gfc_index_integer_kind
)
8331 gfc_warning (0, "Cray pointer at %C has %d bytes of precision;"
8332 " memory addresses require %d bytes",
8333 cptr
->ts
.kind
, gfc_index_integer_kind
);
8335 if (gfc_match_char (',') != MATCH_YES
)
8337 gfc_error ("Expected \",\" at %C");
8341 /* Match Pointee. */
8342 var_locus
= gfc_current_locus
;
8343 gfc_clear_attr (¤t_attr
);
8344 gfc_add_cray_pointee (¤t_attr
, &var_locus
);
8345 current_ts
.type
= BT_UNKNOWN
;
8346 current_ts
.kind
= 0;
8348 m
= gfc_match_symbol (&cpte
, 0);
8351 gfc_error ("Expected variable name at %C");
8355 /* Check for an optional array spec. */
8356 m
= gfc_match_array_spec (&as
, true, false);
8357 if (m
== MATCH_ERROR
)
8359 gfc_free_array_spec (as
);
8362 else if (m
== MATCH_NO
)
8364 gfc_free_array_spec (as
);
8368 if (!gfc_add_cray_pointee (&cpte
->attr
, &var_locus
))
8371 gfc_set_sym_referenced (cpte
);
8373 if (cpte
->as
== NULL
)
8375 if (!gfc_set_array_spec (cpte
, as
, &var_locus
))
8376 gfc_internal_error ("Couldn't set Cray pointee array spec.");
8378 else if (as
!= NULL
)
8380 gfc_error ("Duplicate array spec for Cray pointee at %C");
8381 gfc_free_array_spec (as
);
8387 if (cpte
->as
!= NULL
)
8389 /* Fix array spec. */
8390 m
= gfc_mod_pointee_as (cpte
->as
);
8391 if (m
== MATCH_ERROR
)
8395 /* Point the Pointee at the Pointer. */
8396 cpte
->cp_pointer
= cptr
;
8398 if (gfc_match_char (')') != MATCH_YES
)
8400 gfc_error ("Expected \")\" at %C");
8403 m
= gfc_match_char (',');
8405 done
= true; /* Stop searching for more declarations. */
8409 if (m
== MATCH_ERROR
/* Failed when trying to find ',' above. */
8410 || gfc_match_eos () != MATCH_YES
)
8412 gfc_error ("Expected %<,%> or end of statement at %C");
8420 gfc_match_external (void)
8423 gfc_clear_attr (¤t_attr
);
8424 current_attr
.external
= 1;
8426 return attr_decl ();
8431 gfc_match_intent (void)
8435 /* This is not allowed within a BLOCK construct! */
8436 if (gfc_current_state () == COMP_BLOCK
)
8438 gfc_error ("INTENT is not allowed inside of BLOCK at %C");
8442 intent
= match_intent_spec ();
8443 if (intent
== INTENT_UNKNOWN
)
8446 gfc_clear_attr (¤t_attr
);
8447 current_attr
.intent
= intent
;
8449 return attr_decl ();
8454 gfc_match_intrinsic (void)
8457 gfc_clear_attr (¤t_attr
);
8458 current_attr
.intrinsic
= 1;
8460 return attr_decl ();
8465 gfc_match_optional (void)
8467 /* This is not allowed within a BLOCK construct! */
8468 if (gfc_current_state () == COMP_BLOCK
)
8470 gfc_error ("OPTIONAL is not allowed inside of BLOCK at %C");
8474 gfc_clear_attr (¤t_attr
);
8475 current_attr
.optional
= 1;
8477 return attr_decl ();
8482 gfc_match_pointer (void)
8484 gfc_gobble_whitespace ();
8485 if (gfc_peek_ascii_char () == '(')
8487 if (!flag_cray_pointer
)
8489 gfc_error ("Cray pointer declaration at %C requires -fcray-pointer "
8493 return cray_pointer_decl ();
8497 gfc_clear_attr (¤t_attr
);
8498 current_attr
.pointer
= 1;
8500 return attr_decl ();
8506 gfc_match_allocatable (void)
8508 gfc_clear_attr (¤t_attr
);
8509 current_attr
.allocatable
= 1;
8511 return attr_decl ();
8516 gfc_match_codimension (void)
8518 gfc_clear_attr (¤t_attr
);
8519 current_attr
.codimension
= 1;
8521 return attr_decl ();
8526 gfc_match_contiguous (void)
8528 if (!gfc_notify_std (GFC_STD_F2008
, "CONTIGUOUS statement at %C"))
8531 gfc_clear_attr (¤t_attr
);
8532 current_attr
.contiguous
= 1;
8534 return attr_decl ();
8539 gfc_match_dimension (void)
8541 gfc_clear_attr (¤t_attr
);
8542 current_attr
.dimension
= 1;
8544 return attr_decl ();
8549 gfc_match_target (void)
8551 gfc_clear_attr (¤t_attr
);
8552 current_attr
.target
= 1;
8554 return attr_decl ();
8558 /* Match the list of entities being specified in a PUBLIC or PRIVATE
8562 access_attr_decl (gfc_statement st
)
8564 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8565 interface_type type
;
8567 gfc_symbol
*sym
, *dt_sym
;
8568 gfc_intrinsic_op op
;
8571 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
8576 m
= gfc_match_generic_spec (&type
, name
, &op
);
8579 if (m
== MATCH_ERROR
)
8584 case INTERFACE_NAMELESS
:
8585 case INTERFACE_ABSTRACT
:
8588 case INTERFACE_GENERIC
:
8589 case INTERFACE_DTIO
:
8591 if (gfc_get_symbol (name
, NULL
, &sym
))
8594 if (type
== INTERFACE_DTIO
8595 && gfc_current_ns
->proc_name
8596 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
8597 && sym
->attr
.flavor
== FL_UNKNOWN
)
8598 sym
->attr
.flavor
= FL_PROCEDURE
;
8600 if (!gfc_add_access (&sym
->attr
,
8602 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
,
8606 if (sym
->attr
.generic
&& (dt_sym
= gfc_find_dt_in_generic (sym
))
8607 && !gfc_add_access (&dt_sym
->attr
,
8609 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
,
8615 case INTERFACE_INTRINSIC_OP
:
8616 if (gfc_current_ns
->operator_access
[op
] == ACCESS_UNKNOWN
)
8618 gfc_intrinsic_op other_op
;
8620 gfc_current_ns
->operator_access
[op
] =
8621 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
8623 /* Handle the case if there is another op with the same
8624 function, for INTRINSIC_EQ vs. INTRINSIC_EQ_OS and so on. */
8625 other_op
= gfc_equivalent_op (op
);
8627 if (other_op
!= INTRINSIC_NONE
)
8628 gfc_current_ns
->operator_access
[other_op
] =
8629 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
8634 gfc_error ("Access specification of the %s operator at %C has "
8635 "already been specified", gfc_op2string (op
));
8641 case INTERFACE_USER_OP
:
8642 uop
= gfc_get_uop (name
);
8644 if (uop
->access
== ACCESS_UNKNOWN
)
8646 uop
->access
= (st
== ST_PUBLIC
)
8647 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
8651 gfc_error ("Access specification of the .%s. operator at %C "
8652 "has already been specified", sym
->name
);
8659 if (gfc_match_char (',') == MATCH_NO
)
8663 if (gfc_match_eos () != MATCH_YES
)
8668 gfc_syntax_error (st
);
8676 gfc_match_protected (void)
8681 if (!gfc_current_ns
->proc_name
8682 || gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
8684 gfc_error ("PROTECTED at %C only allowed in specification "
8685 "part of a module");
8690 if (!gfc_notify_std (GFC_STD_F2003
, "PROTECTED statement at %C"))
8693 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
8698 if (gfc_match_eos () == MATCH_YES
)
8703 m
= gfc_match_symbol (&sym
, 0);
8707 if (!gfc_add_protected (&sym
->attr
, sym
->name
, &gfc_current_locus
))
8719 if (gfc_match_eos () == MATCH_YES
)
8721 if (gfc_match_char (',') != MATCH_YES
)
8728 gfc_error ("Syntax error in PROTECTED statement at %C");
8733 /* The PRIVATE statement is a bit weird in that it can be an attribute
8734 declaration, but also works as a standalone statement inside of a
8735 type declaration or a module. */
8738 gfc_match_private (gfc_statement
*st
)
8741 if (gfc_match ("private") != MATCH_YES
)
8744 if (gfc_current_state () != COMP_MODULE
8745 && !(gfc_current_state () == COMP_DERIVED
8746 && gfc_state_stack
->previous
8747 && gfc_state_stack
->previous
->state
== COMP_MODULE
)
8748 && !(gfc_current_state () == COMP_DERIVED_CONTAINS
8749 && gfc_state_stack
->previous
&& gfc_state_stack
->previous
->previous
8750 && gfc_state_stack
->previous
->previous
->state
== COMP_MODULE
))
8752 gfc_error ("PRIVATE statement at %C is only allowed in the "
8753 "specification part of a module");
8757 if (gfc_current_state () == COMP_DERIVED
)
8759 if (gfc_match_eos () == MATCH_YES
)
8765 gfc_syntax_error (ST_PRIVATE
);
8769 if (gfc_match_eos () == MATCH_YES
)
8776 return access_attr_decl (ST_PRIVATE
);
8781 gfc_match_public (gfc_statement
*st
)
8784 if (gfc_match ("public") != MATCH_YES
)
8787 if (gfc_current_state () != COMP_MODULE
)
8789 gfc_error ("PUBLIC statement at %C is only allowed in the "
8790 "specification part of a module");
8794 if (gfc_match_eos () == MATCH_YES
)
8801 return access_attr_decl (ST_PUBLIC
);
8805 /* Workhorse for gfc_match_parameter. */
8815 m
= gfc_match_symbol (&sym
, 0);
8817 gfc_error ("Expected variable name at %C in PARAMETER statement");
8822 if (gfc_match_char ('=') == MATCH_NO
)
8824 gfc_error ("Expected = sign in PARAMETER statement at %C");
8828 m
= gfc_match_init_expr (&init
);
8830 gfc_error ("Expected expression at %C in PARAMETER statement");
8834 if (sym
->ts
.type
== BT_UNKNOWN
8835 && !gfc_set_default_type (sym
, 1, NULL
))
8841 if (!gfc_check_assign_symbol (sym
, NULL
, init
)
8842 || !gfc_add_flavor (&sym
->attr
, FL_PARAMETER
, sym
->name
, NULL
))
8850 gfc_error ("Initializing already initialized variable at %C");
8855 t
= add_init_expr_to_sym (sym
->name
, &init
, &gfc_current_locus
);
8856 return (t
) ? MATCH_YES
: MATCH_ERROR
;
8859 gfc_free_expr (init
);
8864 /* Match a parameter statement, with the weird syntax that these have. */
8867 gfc_match_parameter (void)
8869 const char *term
= " )%t";
8872 if (gfc_match_char ('(') == MATCH_NO
)
8874 /* With legacy PARAMETER statements, don't expect a terminating ')'. */
8875 if (!gfc_notify_std (GFC_STD_LEGACY
, "PARAMETER without '()' at %C"))
8886 if (gfc_match (term
) == MATCH_YES
)
8889 if (gfc_match_char (',') != MATCH_YES
)
8891 gfc_error ("Unexpected characters in PARAMETER statement at %C");
8902 gfc_match_automatic (void)
8906 bool seen_symbol
= false;
8908 if (!flag_dec_static
)
8910 gfc_error ("%s at %C is a DEC extension, enable with "
8921 m
= gfc_match_symbol (&sym
, 0);
8931 if (!gfc_add_automatic (&sym
->attr
, sym
->name
, &gfc_current_locus
))
8937 if (gfc_match_eos () == MATCH_YES
)
8939 if (gfc_match_char (',') != MATCH_YES
)
8945 gfc_error ("Expected entity-list in AUTOMATIC statement at %C");
8952 gfc_error ("Syntax error in AUTOMATIC statement at %C");
8958 gfc_match_static (void)
8962 bool seen_symbol
= false;
8964 if (!flag_dec_static
)
8966 gfc_error ("%s at %C is a DEC extension, enable with "
8976 m
= gfc_match_symbol (&sym
, 0);
8986 if (!gfc_add_save (&sym
->attr
, SAVE_EXPLICIT
, sym
->name
,
8987 &gfc_current_locus
))
8993 if (gfc_match_eos () == MATCH_YES
)
8995 if (gfc_match_char (',') != MATCH_YES
)
9001 gfc_error ("Expected entity-list in STATIC statement at %C");
9008 gfc_error ("Syntax error in STATIC statement at %C");
9013 /* Save statements have a special syntax. */
9016 gfc_match_save (void)
9018 char n
[GFC_MAX_SYMBOL_LEN
+1];
9023 if (gfc_match_eos () == MATCH_YES
)
9025 if (gfc_current_ns
->seen_save
)
9027 if (!gfc_notify_std (GFC_STD_LEGACY
, "Blanket SAVE statement at %C "
9028 "follows previous SAVE statement"))
9032 gfc_current_ns
->save_all
= gfc_current_ns
->seen_save
= 1;
9036 if (gfc_current_ns
->save_all
)
9038 if (!gfc_notify_std (GFC_STD_LEGACY
, "SAVE statement at %C follows "
9039 "blanket SAVE statement"))
9047 m
= gfc_match_symbol (&sym
, 0);
9051 if (!gfc_add_save (&sym
->attr
, SAVE_EXPLICIT
, sym
->name
,
9052 &gfc_current_locus
))
9063 m
= gfc_match (" / %n /", &n
);
9064 if (m
== MATCH_ERROR
)
9069 c
= gfc_get_common (n
, 0);
9072 gfc_current_ns
->seen_save
= 1;
9075 if (gfc_match_eos () == MATCH_YES
)
9077 if (gfc_match_char (',') != MATCH_YES
)
9084 gfc_error ("Syntax error in SAVE statement at %C");
9090 gfc_match_value (void)
9095 /* This is not allowed within a BLOCK construct! */
9096 if (gfc_current_state () == COMP_BLOCK
)
9098 gfc_error ("VALUE is not allowed inside of BLOCK at %C");
9102 if (!gfc_notify_std (GFC_STD_F2003
, "VALUE statement at %C"))
9105 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
9110 if (gfc_match_eos () == MATCH_YES
)
9115 m
= gfc_match_symbol (&sym
, 0);
9119 if (!gfc_add_value (&sym
->attr
, sym
->name
, &gfc_current_locus
))
9131 if (gfc_match_eos () == MATCH_YES
)
9133 if (gfc_match_char (',') != MATCH_YES
)
9140 gfc_error ("Syntax error in VALUE statement at %C");
9146 gfc_match_volatile (void)
9152 if (!gfc_notify_std (GFC_STD_F2003
, "VOLATILE statement at %C"))
9155 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
9160 if (gfc_match_eos () == MATCH_YES
)
9165 /* VOLATILE is special because it can be added to host-associated
9166 symbols locally. Except for coarrays. */
9167 m
= gfc_match_symbol (&sym
, 1);
9171 name
= XCNEWVAR (char, strlen (sym
->name
) + 1);
9172 strcpy (name
, sym
->name
);
9173 if (!check_function_name (name
))
9175 /* F2008, C560+C561. VOLATILE for host-/use-associated variable or
9176 for variable in a BLOCK which is defined outside of the BLOCK. */
9177 if (sym
->ns
!= gfc_current_ns
&& sym
->attr
.codimension
)
9179 gfc_error ("Specifying VOLATILE for coarray variable %qs at "
9180 "%C, which is use-/host-associated", sym
->name
);
9183 if (!gfc_add_volatile (&sym
->attr
, sym
->name
, &gfc_current_locus
))
9195 if (gfc_match_eos () == MATCH_YES
)
9197 if (gfc_match_char (',') != MATCH_YES
)
9204 gfc_error ("Syntax error in VOLATILE statement at %C");
9210 gfc_match_asynchronous (void)
9216 if (!gfc_notify_std (GFC_STD_F2003
, "ASYNCHRONOUS statement at %C"))
9219 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
9224 if (gfc_match_eos () == MATCH_YES
)
9229 /* ASYNCHRONOUS is special because it can be added to host-associated
9231 m
= gfc_match_symbol (&sym
, 1);
9235 name
= XCNEWVAR (char, strlen (sym
->name
) + 1);
9236 strcpy (name
, sym
->name
);
9237 if (!check_function_name (name
))
9239 if (!gfc_add_asynchronous (&sym
->attr
, sym
->name
, &gfc_current_locus
))
9251 if (gfc_match_eos () == MATCH_YES
)
9253 if (gfc_match_char (',') != MATCH_YES
)
9260 gfc_error ("Syntax error in ASYNCHRONOUS statement at %C");
9265 /* Match a module procedure statement in a submodule. */
9268 gfc_match_submod_proc (void)
9270 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9271 gfc_symbol
*sym
, *fsym
;
9273 gfc_formal_arglist
*formal
, *head
, *tail
;
9275 if (gfc_current_state () != COMP_CONTAINS
9276 || !(gfc_state_stack
->previous
9277 && (gfc_state_stack
->previous
->state
== COMP_SUBMODULE
9278 || gfc_state_stack
->previous
->state
== COMP_MODULE
)))
9281 m
= gfc_match (" module% procedure% %n", name
);
9285 if (!gfc_notify_std (GFC_STD_F2008
, "MODULE PROCEDURE declaration "
9289 if (get_proc_name (name
, &sym
, false))
9292 /* Make sure that the result field is appropriately filled, even though
9293 the result symbol will be replaced later on. */
9294 if (sym
->tlink
&& sym
->tlink
->attr
.function
)
9296 if (sym
->tlink
->result
9297 && sym
->tlink
->result
!= sym
->tlink
)
9298 sym
->result
= sym
->tlink
->result
;
9303 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
9304 the symbol existed before. */
9305 sym
->declared_at
= gfc_current_locus
;
9307 if (!sym
->attr
.module_procedure
)
9310 /* Signal match_end to expect "end procedure". */
9311 sym
->abr_modproc_decl
= 1;
9313 /* Change from IFSRC_IFBODY coming from the interface declaration. */
9314 sym
->attr
.if_source
= IFSRC_DECL
;
9316 gfc_new_block
= sym
;
9318 /* Make a new formal arglist with the symbols in the procedure
9321 for (formal
= sym
->formal
; formal
&& formal
->sym
; formal
= formal
->next
)
9323 if (formal
== sym
->formal
)
9324 head
= tail
= gfc_get_formal_arglist ();
9327 tail
->next
= gfc_get_formal_arglist ();
9331 if (gfc_copy_dummy_sym (&fsym
, formal
->sym
, 0))
9335 gfc_set_sym_referenced (fsym
);
9338 /* The dummy symbols get cleaned up, when the formal_namespace of the
9339 interface declaration is cleared. This allows us to add the
9340 explicit interface as is done for other type of procedure. */
9341 if (!gfc_add_explicit_interface (sym
, IFSRC_DECL
, head
,
9342 &gfc_current_locus
))
9345 if (gfc_match_eos () != MATCH_YES
)
9347 gfc_syntax_error (ST_MODULE_PROC
);
9354 gfc_free_formal_arglist (head
);
9359 /* Match a module procedure statement. Note that we have to modify
9360 symbols in the parent's namespace because the current one was there
9361 to receive symbols that are in an interface's formal argument list. */
9364 gfc_match_modproc (void)
9366 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9370 gfc_namespace
*module_ns
;
9371 gfc_interface
*old_interface_head
, *interface
;
9373 if (gfc_state_stack
->state
!= COMP_INTERFACE
9374 || gfc_state_stack
->previous
== NULL
9375 || current_interface
.type
== INTERFACE_NAMELESS
9376 || current_interface
.type
== INTERFACE_ABSTRACT
)
9378 gfc_error ("MODULE PROCEDURE at %C must be in a generic module "
9383 module_ns
= gfc_current_ns
->parent
;
9384 for (; module_ns
; module_ns
= module_ns
->parent
)
9385 if (module_ns
->proc_name
->attr
.flavor
== FL_MODULE
9386 || module_ns
->proc_name
->attr
.flavor
== FL_PROGRAM
9387 || (module_ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
9388 && !module_ns
->proc_name
->attr
.contained
))
9391 if (module_ns
== NULL
)
9394 /* Store the current state of the interface. We will need it if we
9395 end up with a syntax error and need to recover. */
9396 old_interface_head
= gfc_current_interface_head ();
9398 /* Check if the F2008 optional double colon appears. */
9399 gfc_gobble_whitespace ();
9400 old_locus
= gfc_current_locus
;
9401 if (gfc_match ("::") == MATCH_YES
)
9403 if (!gfc_notify_std (GFC_STD_F2008
, "double colon in "
9404 "MODULE PROCEDURE statement at %L", &old_locus
))
9408 gfc_current_locus
= old_locus
;
9413 old_locus
= gfc_current_locus
;
9415 m
= gfc_match_name (name
);
9421 /* Check for syntax error before starting to add symbols to the
9422 current namespace. */
9423 if (gfc_match_eos () == MATCH_YES
)
9426 if (!last
&& gfc_match_char (',') != MATCH_YES
)
9429 /* Now we're sure the syntax is valid, we process this item
9431 if (gfc_get_symbol (name
, module_ns
, &sym
))
9434 if (sym
->attr
.intrinsic
)
9436 gfc_error ("Intrinsic procedure at %L cannot be a MODULE "
9437 "PROCEDURE", &old_locus
);
9441 if (sym
->attr
.proc
!= PROC_MODULE
9442 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
9445 if (!gfc_add_interface (sym
))
9448 sym
->attr
.mod_proc
= 1;
9449 sym
->declared_at
= old_locus
;
9458 /* Restore the previous state of the interface. */
9459 interface
= gfc_current_interface_head ();
9460 gfc_set_current_interface_head (old_interface_head
);
9462 /* Free the new interfaces. */
9463 while (interface
!= old_interface_head
)
9465 gfc_interface
*i
= interface
->next
;
9470 /* And issue a syntax error. */
9471 gfc_syntax_error (ST_MODULE_PROC
);
9476 /* Check a derived type that is being extended. */
9479 check_extended_derived_type (char *name
)
9481 gfc_symbol
*extended
;
9483 if (gfc_find_symbol (name
, gfc_current_ns
, 1, &extended
))
9485 gfc_error ("Ambiguous symbol in TYPE definition at %C");
9489 extended
= gfc_find_dt_in_generic (extended
);
9494 gfc_error ("Symbol %qs at %C has not been previously defined", name
);
9498 if (extended
->attr
.flavor
!= FL_DERIVED
)
9500 gfc_error ("%qs in EXTENDS expression at %C is not a "
9501 "derived type", name
);
9505 if (extended
->attr
.is_bind_c
)
9507 gfc_error ("%qs cannot be extended at %C because it "
9508 "is BIND(C)", extended
->name
);
9512 if (extended
->attr
.sequence
)
9514 gfc_error ("%qs cannot be extended at %C because it "
9515 "is a SEQUENCE type", extended
->name
);
9523 /* Match the optional attribute specifiers for a type declaration.
9524 Return MATCH_ERROR if an error is encountered in one of the handled
9525 attributes (public, private, bind(c)), MATCH_NO if what's found is
9526 not a handled attribute, and MATCH_YES otherwise. TODO: More error
9527 checking on attribute conflicts needs to be done. */
9530 gfc_get_type_attr_spec (symbol_attribute
*attr
, char *name
)
9532 /* See if the derived type is marked as private. */
9533 if (gfc_match (" , private") == MATCH_YES
)
9535 if (gfc_current_state () != COMP_MODULE
)
9537 gfc_error ("Derived type at %C can only be PRIVATE in the "
9538 "specification part of a module");
9542 if (!gfc_add_access (attr
, ACCESS_PRIVATE
, NULL
, NULL
))
9545 else if (gfc_match (" , public") == MATCH_YES
)
9547 if (gfc_current_state () != COMP_MODULE
)
9549 gfc_error ("Derived type at %C can only be PUBLIC in the "
9550 "specification part of a module");
9554 if (!gfc_add_access (attr
, ACCESS_PUBLIC
, NULL
, NULL
))
9557 else if (gfc_match (" , bind ( c )") == MATCH_YES
)
9559 /* If the type is defined to be bind(c) it then needs to make
9560 sure that all fields are interoperable. This will
9561 need to be a semantic check on the finished derived type.
9562 See 15.2.3 (lines 9-12) of F2003 draft. */
9563 if (!gfc_add_is_bind_c (attr
, NULL
, &gfc_current_locus
, 0))
9566 /* TODO: attr conflicts need to be checked, probably in symbol.c. */
9568 else if (gfc_match (" , abstract") == MATCH_YES
)
9570 if (!gfc_notify_std (GFC_STD_F2003
, "ABSTRACT type at %C"))
9573 if (!gfc_add_abstract (attr
, &gfc_current_locus
))
9576 else if (name
&& gfc_match (" , extends ( %n )", name
) == MATCH_YES
)
9578 if (!gfc_add_extension (attr
, &gfc_current_locus
))
9584 /* If we get here, something matched. */
9589 /* Common function for type declaration blocks similar to derived types, such
9590 as STRUCTURES and MAPs. Unlike derived types, a structure type
9591 does NOT have a generic symbol matching the name given by the user.
9592 STRUCTUREs can share names with variables and PARAMETERs so we must allow
9593 for the creation of an independent symbol.
9594 Other parameters are a message to prefix errors with, the name of the new
9595 type to be created, and the flavor to add to the resulting symbol. */
9598 get_struct_decl (const char *name
, sym_flavor fl
, locus
*decl
,
9599 gfc_symbol
**result
)
9604 gcc_assert (name
[0] == (char) TOUPPER (name
[0]));
9609 where
= gfc_current_locus
;
9611 if (gfc_get_symbol (name
, NULL
, &sym
))
9616 gfc_internal_error ("Failed to create structure type '%s' at %C", name
);
9620 if (sym
->components
!= NULL
|| sym
->attr
.zero_comp
)
9622 gfc_error ("Type definition of %qs at %C was already defined at %L",
9623 sym
->name
, &sym
->declared_at
);
9627 sym
->declared_at
= where
;
9629 if (sym
->attr
.flavor
!= fl
9630 && !gfc_add_flavor (&sym
->attr
, fl
, sym
->name
, NULL
))
9633 if (!sym
->hash_value
)
9634 /* Set the hash for the compound name for this type. */
9635 sym
->hash_value
= gfc_hash_value (sym
);
9637 /* Normally the type is expected to have been completely parsed by the time
9638 a field declaration with this type is seen. For unions, maps, and nested
9639 structure declarations, we need to indicate that it is okay that we
9640 haven't seen any components yet. This will be updated after the structure
9642 sym
->attr
.zero_comp
= 0;
9644 /* Structures always act like derived-types with the SEQUENCE attribute */
9645 gfc_add_sequence (&sym
->attr
, sym
->name
, NULL
);
9647 if (result
) *result
= sym
;
9653 /* Match the opening of a MAP block. Like a struct within a union in C;
9654 behaves identical to STRUCTURE blocks. */
9657 gfc_match_map (void)
9659 /* Counter used to give unique internal names to map structures. */
9660 static unsigned int gfc_map_id
= 0;
9661 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9665 old_loc
= gfc_current_locus
;
9667 if (gfc_match_eos () != MATCH_YES
)
9669 gfc_error ("Junk after MAP statement at %C");
9670 gfc_current_locus
= old_loc
;
9674 /* Map blocks are anonymous so we make up unique names for the symbol table
9675 which are invalid Fortran identifiers. */
9676 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "MM$%u", gfc_map_id
++);
9678 if (!get_struct_decl (name
, FL_STRUCT
, &old_loc
, &sym
))
9681 gfc_new_block
= sym
;
9687 /* Match the opening of a UNION block. */
9690 gfc_match_union (void)
9692 /* Counter used to give unique internal names to union types. */
9693 static unsigned int gfc_union_id
= 0;
9694 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9698 old_loc
= gfc_current_locus
;
9700 if (gfc_match_eos () != MATCH_YES
)
9702 gfc_error ("Junk after UNION statement at %C");
9703 gfc_current_locus
= old_loc
;
9707 /* Unions are anonymous so we make up unique names for the symbol table
9708 which are invalid Fortran identifiers. */
9709 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "UU$%u", gfc_union_id
++);
9711 if (!get_struct_decl (name
, FL_UNION
, &old_loc
, &sym
))
9714 gfc_new_block
= sym
;
9720 /* Match the beginning of a STRUCTURE declaration. This is similar to
9721 matching the beginning of a derived type declaration with a few
9722 twists. The resulting type symbol has no access control or other
9723 interesting attributes. */
9726 gfc_match_structure_decl (void)
9728 /* Counter used to give unique internal names to anonymous structures. */
9729 static unsigned int gfc_structure_id
= 0;
9730 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9735 if (!flag_dec_structure
)
9737 gfc_error ("%s at %C is a DEC extension, enable with "
9738 "%<-fdec-structure%>",
9745 m
= gfc_match (" /%n/", name
);
9748 /* Non-nested structure declarations require a structure name. */
9749 if (!gfc_comp_struct (gfc_current_state ()))
9751 gfc_error ("Structure name expected in non-nested structure "
9752 "declaration at %C");
9755 /* This is an anonymous structure; make up a unique name for it
9756 (upper-case letters never make it to symbol names from the source).
9757 The important thing is initializing the type variable
9758 and setting gfc_new_symbol, which is immediately used by
9759 parse_structure () and variable_decl () to add components of
9761 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "SS$%u", gfc_structure_id
++);
9764 where
= gfc_current_locus
;
9765 /* No field list allowed after non-nested structure declaration. */
9766 if (!gfc_comp_struct (gfc_current_state ())
9767 && gfc_match_eos () != MATCH_YES
)
9769 gfc_error ("Junk after non-nested STRUCTURE statement at %C");
9773 /* Make sure the name is not the name of an intrinsic type. */
9774 if (gfc_is_intrinsic_typename (name
))
9776 gfc_error ("Structure name %qs at %C cannot be the same as an"
9777 " intrinsic type", name
);
9781 /* Store the actual type symbol for the structure with an upper-case first
9782 letter (an invalid Fortran identifier). */
9784 if (!get_struct_decl (gfc_dt_upper_string (name
), FL_STRUCT
, &where
, &sym
))
9787 gfc_new_block
= sym
;
9792 /* This function does some work to determine which matcher should be used to
9793 * match a statement beginning with "TYPE". This is used to disambiguate TYPE
9794 * as an alias for PRINT from derived type declarations, TYPE IS statements,
9795 * and derived type data declarations. */
9798 gfc_match_type (gfc_statement
*st
)
9800 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9804 /* Requires -fdec. */
9808 m
= gfc_match ("type");
9811 /* If we already have an error in the buffer, it is probably from failing to
9812 * match a derived type data declaration. Let it happen. */
9813 else if (gfc_error_flag_test ())
9816 old_loc
= gfc_current_locus
;
9819 /* If we see an attribute list before anything else it's definitely a derived
9820 * type declaration. */
9821 if (gfc_match (" ,") == MATCH_YES
|| gfc_match (" ::") == MATCH_YES
)
9823 gfc_current_locus
= old_loc
;
9824 *st
= ST_DERIVED_DECL
;
9825 return gfc_match_derived_decl ();
9828 /* By now "TYPE" has already been matched. If we do not see a name, this may
9829 * be something like "TYPE *" or "TYPE <fmt>". */
9830 m
= gfc_match_name (name
);
9833 /* Let print match if it can, otherwise throw an error from
9834 * gfc_match_derived_decl. */
9835 gfc_current_locus
= old_loc
;
9836 if (gfc_match_print () == MATCH_YES
)
9841 gfc_current_locus
= old_loc
;
9842 *st
= ST_DERIVED_DECL
;
9843 return gfc_match_derived_decl ();
9846 /* A derived type declaration requires an EOS. Without it, assume print. */
9847 m
= gfc_match_eos ();
9850 /* Check manually for TYPE IS (... - this is invalid print syntax. */
9851 if (strncmp ("is", name
, 3) == 0
9852 && gfc_match (" (", name
) == MATCH_YES
)
9854 gfc_current_locus
= old_loc
;
9855 gcc_assert (gfc_match (" is") == MATCH_YES
);
9857 return gfc_match_type_is ();
9859 gfc_current_locus
= old_loc
;
9861 return gfc_match_print ();
9865 /* By now we have "TYPE <name> <EOS>". Check first if the name is an
9866 * intrinsic typename - if so let gfc_match_derived_decl dump an error.
9867 * Otherwise if gfc_match_derived_decl fails it's probably an existing
9868 * symbol which can be printed. */
9869 gfc_current_locus
= old_loc
;
9870 m
= gfc_match_derived_decl ();
9871 if (gfc_is_intrinsic_typename (name
) || m
== MATCH_YES
)
9873 *st
= ST_DERIVED_DECL
;
9876 gfc_current_locus
= old_loc
;
9878 return gfc_match_print ();
9885 /* Match the beginning of a derived type declaration. If a type name
9886 was the result of a function, then it is possible to have a symbol
9887 already to be known as a derived type yet have no components. */
9890 gfc_match_derived_decl (void)
9892 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9893 char parent
[GFC_MAX_SYMBOL_LEN
+ 1];
9894 symbol_attribute attr
;
9895 gfc_symbol
*sym
, *gensym
;
9896 gfc_symbol
*extended
;
9898 match is_type_attr_spec
= MATCH_NO
;
9899 bool seen_attr
= false;
9900 gfc_interface
*intr
= NULL
, *head
;
9901 bool parameterized_type
= false;
9902 bool seen_colons
= false;
9904 if (gfc_comp_struct (gfc_current_state ()))
9909 gfc_clear_attr (&attr
);
9914 is_type_attr_spec
= gfc_get_type_attr_spec (&attr
, parent
);
9915 if (is_type_attr_spec
== MATCH_ERROR
)
9917 if (is_type_attr_spec
== MATCH_YES
)
9919 } while (is_type_attr_spec
== MATCH_YES
);
9921 /* Deal with derived type extensions. The extension attribute has
9922 been added to 'attr' but now the parent type must be found and
9925 extended
= check_extended_derived_type (parent
);
9927 if (parent
[0] && !extended
)
9930 m
= gfc_match (" ::");
9937 gfc_error ("Expected :: in TYPE definition at %C");
9941 m
= gfc_match (" %n ", name
);
9945 /* Make sure that we don't identify TYPE IS (...) as a parameterized
9946 derived type named 'is'.
9947 TODO Expand the check, when 'name' = "is" by matching " (tname) "
9948 and checking if this is a(n intrinsic) typename. his picks up
9949 misplaced TYPE IS statements such as in select_type_1.f03. */
9950 if (gfc_peek_ascii_char () == '(')
9952 if (gfc_current_state () == COMP_SELECT_TYPE
9953 || (!seen_colons
&& !strcmp (name
, "is")))
9955 parameterized_type
= true;
9958 m
= gfc_match_eos ();
9959 if (m
!= MATCH_YES
&& !parameterized_type
)
9962 /* Make sure the name is not the name of an intrinsic type. */
9963 if (gfc_is_intrinsic_typename (name
))
9965 gfc_error ("Type name %qs at %C cannot be the same as an intrinsic "
9970 if (gfc_get_symbol (name
, NULL
, &gensym
))
9973 if (!gensym
->attr
.generic
&& gensym
->ts
.type
!= BT_UNKNOWN
)
9975 if (gensym
->ts
.u
.derived
)
9976 gfc_error ("Derived type name %qs at %C already has a basic type "
9977 "of %s", gensym
->name
, gfc_typename (&gensym
->ts
));
9979 gfc_error ("Derived type name %qs at %C already has a basic type",
9984 if (!gensym
->attr
.generic
9985 && !gfc_add_generic (&gensym
->attr
, gensym
->name
, NULL
))
9988 if (!gensym
->attr
.function
9989 && !gfc_add_function (&gensym
->attr
, gensym
->name
, NULL
))
9992 sym
= gfc_find_dt_in_generic (gensym
);
9994 if (sym
&& (sym
->components
!= NULL
|| sym
->attr
.zero_comp
))
9996 gfc_error ("Derived type definition of %qs at %C has already been "
9997 "defined", sym
->name
);
10003 /* Use upper case to save the actual derived-type symbol. */
10004 gfc_get_symbol (gfc_dt_upper_string (gensym
->name
), NULL
, &sym
);
10005 sym
->name
= gfc_get_string ("%s", gensym
->name
);
10006 head
= gensym
->generic
;
10007 intr
= gfc_get_interface ();
10009 intr
->where
= gfc_current_locus
;
10010 intr
->sym
->declared_at
= gfc_current_locus
;
10012 gensym
->generic
= intr
;
10013 gensym
->attr
.if_source
= IFSRC_DECL
;
10016 /* The symbol may already have the derived attribute without the
10017 components. The ways this can happen is via a function
10018 definition, an INTRINSIC statement or a subtype in another
10019 derived type that is a pointer. The first part of the AND clause
10020 is true if the symbol is not the return value of a function. */
10021 if (sym
->attr
.flavor
!= FL_DERIVED
10022 && !gfc_add_flavor (&sym
->attr
, FL_DERIVED
, sym
->name
, NULL
))
10023 return MATCH_ERROR
;
10025 if (attr
.access
!= ACCESS_UNKNOWN
10026 && !gfc_add_access (&sym
->attr
, attr
.access
, sym
->name
, NULL
))
10027 return MATCH_ERROR
;
10028 else if (sym
->attr
.access
== ACCESS_UNKNOWN
10029 && gensym
->attr
.access
!= ACCESS_UNKNOWN
10030 && !gfc_add_access (&sym
->attr
, gensym
->attr
.access
,
10032 return MATCH_ERROR
;
10034 if (sym
->attr
.access
!= ACCESS_UNKNOWN
10035 && gensym
->attr
.access
== ACCESS_UNKNOWN
)
10036 gensym
->attr
.access
= sym
->attr
.access
;
10038 /* See if the derived type was labeled as bind(c). */
10039 if (attr
.is_bind_c
!= 0)
10040 sym
->attr
.is_bind_c
= attr
.is_bind_c
;
10042 /* Construct the f2k_derived namespace if it is not yet there. */
10043 if (!sym
->f2k_derived
)
10044 sym
->f2k_derived
= gfc_get_namespace (NULL
, 0);
10046 if (parameterized_type
)
10048 /* Ignore error or mismatches by going to the end of the statement
10049 in order to avoid the component declarations causing problems. */
10050 m
= gfc_match_formal_arglist (sym
, 0, 0, true);
10051 if (m
!= MATCH_YES
)
10052 gfc_error_recovery ();
10053 m
= gfc_match_eos ();
10054 if (m
!= MATCH_YES
)
10056 gfc_error_recovery ();
10057 gfc_error_now ("Garbage after PARAMETERIZED TYPE declaration at %C");
10059 sym
->attr
.pdt_template
= 1;
10062 if (extended
&& !sym
->components
)
10065 gfc_formal_arglist
*f
, *g
, *h
;
10067 /* Add the extended derived type as the first component. */
10068 gfc_add_component (sym
, parent
, &p
);
10070 gfc_set_sym_referenced (extended
);
10072 p
->ts
.type
= BT_DERIVED
;
10073 p
->ts
.u
.derived
= extended
;
10074 p
->initializer
= gfc_default_initializer (&p
->ts
);
10076 /* Set extension level. */
10077 if (extended
->attr
.extension
== 255)
10079 /* Since the extension field is 8 bit wide, we can only have
10080 up to 255 extension levels. */
10081 gfc_error ("Maximum extension level reached with type %qs at %L",
10082 extended
->name
, &extended
->declared_at
);
10083 return MATCH_ERROR
;
10085 sym
->attr
.extension
= extended
->attr
.extension
+ 1;
10087 /* Provide the links between the extended type and its extension. */
10088 if (!extended
->f2k_derived
)
10089 extended
->f2k_derived
= gfc_get_namespace (NULL
, 0);
10091 /* Copy the extended type-param-name-list from the extended type,
10092 append those of the extension and add the whole lot to the
10094 if (extended
->attr
.pdt_template
)
10097 sym
->attr
.pdt_template
= 1;
10098 for (f
= extended
->formal
; f
; f
= f
->next
)
10100 if (f
== extended
->formal
)
10102 g
= gfc_get_formal_arglist ();
10107 g
->next
= gfc_get_formal_arglist ();
10112 g
->next
= sym
->formal
;
10117 if (!sym
->hash_value
)
10118 /* Set the hash for the compound name for this type. */
10119 sym
->hash_value
= gfc_hash_value (sym
);
10121 /* Take over the ABSTRACT attribute. */
10122 sym
->attr
.abstract
= attr
.abstract
;
10124 gfc_new_block
= sym
;
10130 /* Cray Pointees can be declared as:
10131 pointer (ipt, a (n,m,...,*)) */
10134 gfc_mod_pointee_as (gfc_array_spec
*as
)
10136 as
->cray_pointee
= true; /* This will be useful to know later. */
10137 if (as
->type
== AS_ASSUMED_SIZE
)
10138 as
->cp_was_assumed
= true;
10139 else if (as
->type
== AS_ASSUMED_SHAPE
)
10141 gfc_error ("Cray Pointee at %C cannot be assumed shape array");
10142 return MATCH_ERROR
;
10148 /* Match the enum definition statement, here we are trying to match
10149 the first line of enum definition statement.
10150 Returns MATCH_YES if match is found. */
10153 gfc_match_enum (void)
10157 m
= gfc_match_eos ();
10158 if (m
!= MATCH_YES
)
10161 if (!gfc_notify_std (GFC_STD_F2003
, "ENUM and ENUMERATOR at %C"))
10162 return MATCH_ERROR
;
10168 /* Returns an initializer whose value is one higher than the value of the
10169 LAST_INITIALIZER argument. If the argument is NULL, the
10170 initializers value will be set to zero. The initializer's kind
10171 will be set to gfc_c_int_kind.
10173 If -fshort-enums is given, the appropriate kind will be selected
10174 later after all enumerators have been parsed. A warning is issued
10175 here if an initializer exceeds gfc_c_int_kind. */
10178 enum_initializer (gfc_expr
*last_initializer
, locus where
)
10181 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_c_int_kind
, &where
);
10183 mpz_init (result
->value
.integer
);
10185 if (last_initializer
!= NULL
)
10187 mpz_add_ui (result
->value
.integer
, last_initializer
->value
.integer
, 1);
10188 result
->where
= last_initializer
->where
;
10190 if (gfc_check_integer_range (result
->value
.integer
,
10191 gfc_c_int_kind
) != ARITH_OK
)
10193 gfc_error ("Enumerator exceeds the C integer type at %C");
10199 /* Control comes here, if it's the very first enumerator and no
10200 initializer has been given. It will be initialized to zero. */
10201 mpz_set_si (result
->value
.integer
, 0);
10208 /* Match a variable name with an optional initializer. When this
10209 subroutine is called, a variable is expected to be parsed next.
10210 Depending on what is happening at the moment, updates either the
10211 symbol table or the current interface. */
10214 enumerator_decl (void)
10216 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10217 gfc_expr
*initializer
;
10218 gfc_array_spec
*as
= NULL
;
10225 initializer
= NULL
;
10226 old_locus
= gfc_current_locus
;
10228 /* When we get here, we've just matched a list of attributes and
10229 maybe a type and a double colon. The next thing we expect to see
10230 is the name of the symbol. */
10231 m
= gfc_match_name (name
);
10232 if (m
!= MATCH_YES
)
10235 var_locus
= gfc_current_locus
;
10237 /* OK, we've successfully matched the declaration. Now put the
10238 symbol in the current namespace. If we fail to create the symbol,
10240 if (!build_sym (name
, NULL
, false, &as
, &var_locus
))
10246 /* The double colon must be present in order to have initializers.
10247 Otherwise the statement is ambiguous with an assignment statement. */
10250 if (gfc_match_char ('=') == MATCH_YES
)
10252 m
= gfc_match_init_expr (&initializer
);
10255 gfc_error ("Expected an initialization expression at %C");
10259 if (m
!= MATCH_YES
)
10264 /* If we do not have an initializer, the initialization value of the
10265 previous enumerator (stored in last_initializer) is incremented
10266 by 1 and is used to initialize the current enumerator. */
10267 if (initializer
== NULL
)
10268 initializer
= enum_initializer (last_initializer
, old_locus
);
10270 if (initializer
== NULL
|| initializer
->ts
.type
!= BT_INTEGER
)
10272 gfc_error ("ENUMERATOR %L not initialized with integer expression",
10278 /* Store this current initializer, for the next enumerator variable
10279 to be parsed. add_init_expr_to_sym() zeros initializer, so we
10280 use last_initializer below. */
10281 last_initializer
= initializer
;
10282 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
10284 /* Maintain enumerator history. */
10285 gfc_find_symbol (name
, NULL
, 0, &sym
);
10286 create_enum_history (sym
, last_initializer
);
10288 return (t
) ? MATCH_YES
: MATCH_ERROR
;
10291 /* Free stuff up and return. */
10292 gfc_free_expr (initializer
);
10298 /* Match the enumerator definition statement. */
10301 gfc_match_enumerator_def (void)
10306 gfc_clear_ts (¤t_ts
);
10308 m
= gfc_match (" enumerator");
10309 if (m
!= MATCH_YES
)
10312 m
= gfc_match (" :: ");
10313 if (m
== MATCH_ERROR
)
10316 colon_seen
= (m
== MATCH_YES
);
10318 if (gfc_current_state () != COMP_ENUM
)
10320 gfc_error ("ENUM definition statement expected before %C");
10321 gfc_free_enum_history ();
10322 return MATCH_ERROR
;
10325 (¤t_ts
)->type
= BT_INTEGER
;
10326 (¤t_ts
)->kind
= gfc_c_int_kind
;
10328 gfc_clear_attr (¤t_attr
);
10329 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, NULL
);
10338 m
= enumerator_decl ();
10339 if (m
== MATCH_ERROR
)
10341 gfc_free_enum_history ();
10347 if (gfc_match_eos () == MATCH_YES
)
10349 if (gfc_match_char (',') != MATCH_YES
)
10353 if (gfc_current_state () == COMP_ENUM
)
10355 gfc_free_enum_history ();
10356 gfc_error ("Syntax error in ENUMERATOR definition at %C");
10361 gfc_free_array_spec (current_as
);
10368 /* Match binding attributes. */
10371 match_binding_attributes (gfc_typebound_proc
* ba
, bool generic
, bool ppc
)
10373 bool found_passing
= false;
10374 bool seen_ptr
= false;
10375 match m
= MATCH_YES
;
10377 /* Initialize to defaults. Do so even before the MATCH_NO check so that in
10378 this case the defaults are in there. */
10379 ba
->access
= ACCESS_UNKNOWN
;
10380 ba
->pass_arg
= NULL
;
10381 ba
->pass_arg_num
= 0;
10383 ba
->non_overridable
= 0;
10387 /* If we find a comma, we believe there are binding attributes. */
10388 m
= gfc_match_char (',');
10394 /* Access specifier. */
10396 m
= gfc_match (" public");
10397 if (m
== MATCH_ERROR
)
10399 if (m
== MATCH_YES
)
10401 if (ba
->access
!= ACCESS_UNKNOWN
)
10403 gfc_error ("Duplicate access-specifier at %C");
10407 ba
->access
= ACCESS_PUBLIC
;
10411 m
= gfc_match (" private");
10412 if (m
== MATCH_ERROR
)
10414 if (m
== MATCH_YES
)
10416 if (ba
->access
!= ACCESS_UNKNOWN
)
10418 gfc_error ("Duplicate access-specifier at %C");
10422 ba
->access
= ACCESS_PRIVATE
;
10426 /* If inside GENERIC, the following is not allowed. */
10431 m
= gfc_match (" nopass");
10432 if (m
== MATCH_ERROR
)
10434 if (m
== MATCH_YES
)
10438 gfc_error ("Binding attributes already specify passing,"
10439 " illegal NOPASS at %C");
10443 found_passing
= true;
10448 /* PASS possibly including argument. */
10449 m
= gfc_match (" pass");
10450 if (m
== MATCH_ERROR
)
10452 if (m
== MATCH_YES
)
10454 char arg
[GFC_MAX_SYMBOL_LEN
+ 1];
10458 gfc_error ("Binding attributes already specify passing,"
10459 " illegal PASS at %C");
10463 m
= gfc_match (" ( %n )", arg
);
10464 if (m
== MATCH_ERROR
)
10466 if (m
== MATCH_YES
)
10467 ba
->pass_arg
= gfc_get_string ("%s", arg
);
10468 gcc_assert ((m
== MATCH_YES
) == (ba
->pass_arg
!= NULL
));
10470 found_passing
= true;
10477 /* POINTER flag. */
10478 m
= gfc_match (" pointer");
10479 if (m
== MATCH_ERROR
)
10481 if (m
== MATCH_YES
)
10485 gfc_error ("Duplicate POINTER attribute at %C");
10495 /* NON_OVERRIDABLE flag. */
10496 m
= gfc_match (" non_overridable");
10497 if (m
== MATCH_ERROR
)
10499 if (m
== MATCH_YES
)
10501 if (ba
->non_overridable
)
10503 gfc_error ("Duplicate NON_OVERRIDABLE at %C");
10507 ba
->non_overridable
= 1;
10511 /* DEFERRED flag. */
10512 m
= gfc_match (" deferred");
10513 if (m
== MATCH_ERROR
)
10515 if (m
== MATCH_YES
)
10519 gfc_error ("Duplicate DEFERRED at %C");
10530 /* Nothing matching found. */
10532 gfc_error ("Expected access-specifier at %C");
10534 gfc_error ("Expected binding attribute at %C");
10537 while (gfc_match_char (',') == MATCH_YES
);
10539 /* NON_OVERRIDABLE and DEFERRED exclude themselves. */
10540 if (ba
->non_overridable
&& ba
->deferred
)
10542 gfc_error ("NON_OVERRIDABLE and DEFERRED can't both appear at %C");
10549 if (ba
->access
== ACCESS_UNKNOWN
)
10550 ba
->access
= gfc_typebound_default_access
;
10552 if (ppc
&& !seen_ptr
)
10554 gfc_error ("POINTER attribute is required for procedure pointer component"
10562 return MATCH_ERROR
;
10566 /* Match a PROCEDURE specific binding inside a derived type. */
10569 match_procedure_in_type (void)
10571 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10572 char target_buf
[GFC_MAX_SYMBOL_LEN
+ 1];
10573 char* target
= NULL
, *ifc
= NULL
;
10574 gfc_typebound_proc tb
;
10578 gfc_symtree
* stree
;
10583 /* Check current state. */
10584 gcc_assert (gfc_state_stack
->state
== COMP_DERIVED_CONTAINS
);
10585 block
= gfc_state_stack
->previous
->sym
;
10586 gcc_assert (block
);
10588 /* Try to match PROCEDURE(interface). */
10589 if (gfc_match (" (") == MATCH_YES
)
10591 m
= gfc_match_name (target_buf
);
10592 if (m
== MATCH_ERROR
)
10594 if (m
!= MATCH_YES
)
10596 gfc_error ("Interface-name expected after %<(%> at %C");
10597 return MATCH_ERROR
;
10600 if (gfc_match (" )") != MATCH_YES
)
10602 gfc_error ("%<)%> expected at %C");
10603 return MATCH_ERROR
;
10609 /* Construct the data structure. */
10610 memset (&tb
, 0, sizeof (tb
));
10611 tb
.where
= gfc_current_locus
;
10613 /* Match binding attributes. */
10614 m
= match_binding_attributes (&tb
, false, false);
10615 if (m
== MATCH_ERROR
)
10617 seen_attrs
= (m
== MATCH_YES
);
10619 /* Check that attribute DEFERRED is given if an interface is specified. */
10620 if (tb
.deferred
&& !ifc
)
10622 gfc_error ("Interface must be specified for DEFERRED binding at %C");
10623 return MATCH_ERROR
;
10625 if (ifc
&& !tb
.deferred
)
10627 gfc_error ("PROCEDURE(interface) at %C should be declared DEFERRED");
10628 return MATCH_ERROR
;
10631 /* Match the colons. */
10632 m
= gfc_match (" ::");
10633 if (m
== MATCH_ERROR
)
10635 seen_colons
= (m
== MATCH_YES
);
10636 if (seen_attrs
&& !seen_colons
)
10638 gfc_error ("Expected %<::%> after binding-attributes at %C");
10639 return MATCH_ERROR
;
10642 /* Match the binding names. */
10645 m
= gfc_match_name (name
);
10646 if (m
== MATCH_ERROR
)
10650 gfc_error ("Expected binding name at %C");
10651 return MATCH_ERROR
;
10654 if (num
>1 && !gfc_notify_std (GFC_STD_F2008
, "PROCEDURE list at %C"))
10655 return MATCH_ERROR
;
10657 /* Try to match the '=> target', if it's there. */
10659 m
= gfc_match (" =>");
10660 if (m
== MATCH_ERROR
)
10662 if (m
== MATCH_YES
)
10666 gfc_error ("%<=> target%> is invalid for DEFERRED binding at %C");
10667 return MATCH_ERROR
;
10672 gfc_error ("%<::%> needed in PROCEDURE binding with explicit target"
10674 return MATCH_ERROR
;
10677 m
= gfc_match_name (target_buf
);
10678 if (m
== MATCH_ERROR
)
10682 gfc_error ("Expected binding target after %<=>%> at %C");
10683 return MATCH_ERROR
;
10685 target
= target_buf
;
10688 /* If no target was found, it has the same name as the binding. */
10692 /* Get the namespace to insert the symbols into. */
10693 ns
= block
->f2k_derived
;
10696 /* If the binding is DEFERRED, check that the containing type is ABSTRACT. */
10697 if (tb
.deferred
&& !block
->attr
.abstract
)
10699 gfc_error ("Type %qs containing DEFERRED binding at %C "
10700 "is not ABSTRACT", block
->name
);
10701 return MATCH_ERROR
;
10704 /* See if we already have a binding with this name in the symtree which
10705 would be an error. If a GENERIC already targeted this binding, it may
10706 be already there but then typebound is still NULL. */
10707 stree
= gfc_find_symtree (ns
->tb_sym_root
, name
);
10708 if (stree
&& stree
->n
.tb
)
10710 gfc_error ("There is already a procedure with binding name %qs for "
10711 "the derived type %qs at %C", name
, block
->name
);
10712 return MATCH_ERROR
;
10715 /* Insert it and set attributes. */
10719 stree
= gfc_new_symtree (&ns
->tb_sym_root
, name
);
10720 gcc_assert (stree
);
10722 stree
->n
.tb
= gfc_get_typebound_proc (&tb
);
10724 if (gfc_get_sym_tree (target
, gfc_current_ns
, &stree
->n
.tb
->u
.specific
,
10726 return MATCH_ERROR
;
10727 gfc_set_sym_referenced (stree
->n
.tb
->u
.specific
->n
.sym
);
10728 gfc_add_flavor(&stree
->n
.tb
->u
.specific
->n
.sym
->attr
, FL_PROCEDURE
,
10729 target
, &stree
->n
.tb
->u
.specific
->n
.sym
->declared_at
);
10731 if (gfc_match_eos () == MATCH_YES
)
10733 if (gfc_match_char (',') != MATCH_YES
)
10738 gfc_error ("Syntax error in PROCEDURE statement at %C");
10739 return MATCH_ERROR
;
10743 /* Match a GENERIC procedure binding inside a derived type. */
10746 gfc_match_generic (void)
10748 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10749 char bind_name
[GFC_MAX_SYMBOL_LEN
+ 16]; /* Allow space for OPERATOR(...). */
10751 gfc_typebound_proc tbattr
; /* Used for match_binding_attributes. */
10752 gfc_typebound_proc
* tb
;
10754 interface_type op_type
;
10755 gfc_intrinsic_op op
;
10758 /* Check current state. */
10759 if (gfc_current_state () == COMP_DERIVED
)
10761 gfc_error ("GENERIC at %C must be inside a derived-type CONTAINS");
10762 return MATCH_ERROR
;
10764 if (gfc_current_state () != COMP_DERIVED_CONTAINS
)
10766 block
= gfc_state_stack
->previous
->sym
;
10767 ns
= block
->f2k_derived
;
10768 gcc_assert (block
&& ns
);
10770 memset (&tbattr
, 0, sizeof (tbattr
));
10771 tbattr
.where
= gfc_current_locus
;
10773 /* See if we get an access-specifier. */
10774 m
= match_binding_attributes (&tbattr
, true, false);
10775 if (m
== MATCH_ERROR
)
10778 /* Now the colons, those are required. */
10779 if (gfc_match (" ::") != MATCH_YES
)
10781 gfc_error ("Expected %<::%> at %C");
10785 /* Match the binding name; depending on type (operator / generic) format
10786 it for future error messages into bind_name. */
10788 m
= gfc_match_generic_spec (&op_type
, name
, &op
);
10789 if (m
== MATCH_ERROR
)
10790 return MATCH_ERROR
;
10793 gfc_error ("Expected generic name or operator descriptor at %C");
10799 case INTERFACE_GENERIC
:
10800 case INTERFACE_DTIO
:
10801 snprintf (bind_name
, sizeof (bind_name
), "%s", name
);
10804 case INTERFACE_USER_OP
:
10805 snprintf (bind_name
, sizeof (bind_name
), "OPERATOR(.%s.)", name
);
10808 case INTERFACE_INTRINSIC_OP
:
10809 snprintf (bind_name
, sizeof (bind_name
), "OPERATOR(%s)",
10810 gfc_op2string (op
));
10813 case INTERFACE_NAMELESS
:
10814 gfc_error ("Malformed GENERIC statement at %C");
10819 gcc_unreachable ();
10822 /* Match the required =>. */
10823 if (gfc_match (" =>") != MATCH_YES
)
10825 gfc_error ("Expected %<=>%> at %C");
10829 /* Try to find existing GENERIC binding with this name / for this operator;
10830 if there is something, check that it is another GENERIC and then extend
10831 it rather than building a new node. Otherwise, create it and put it
10832 at the right position. */
10836 case INTERFACE_DTIO
:
10837 case INTERFACE_USER_OP
:
10838 case INTERFACE_GENERIC
:
10840 const bool is_op
= (op_type
== INTERFACE_USER_OP
);
10843 st
= gfc_find_symtree (is_op
? ns
->tb_uop_root
: ns
->tb_sym_root
, name
);
10844 tb
= st
? st
->n
.tb
: NULL
;
10848 case INTERFACE_INTRINSIC_OP
:
10849 tb
= ns
->tb_op
[op
];
10853 gcc_unreachable ();
10858 if (!tb
->is_generic
)
10860 gcc_assert (op_type
== INTERFACE_GENERIC
);
10861 gfc_error ("There's already a non-generic procedure with binding name"
10862 " %qs for the derived type %qs at %C",
10863 bind_name
, block
->name
);
10867 if (tb
->access
!= tbattr
.access
)
10869 gfc_error ("Binding at %C must have the same access as already"
10870 " defined binding %qs", bind_name
);
10876 tb
= gfc_get_typebound_proc (NULL
);
10877 tb
->where
= gfc_current_locus
;
10878 tb
->access
= tbattr
.access
;
10879 tb
->is_generic
= 1;
10880 tb
->u
.generic
= NULL
;
10884 case INTERFACE_DTIO
:
10885 case INTERFACE_GENERIC
:
10886 case INTERFACE_USER_OP
:
10888 const bool is_op
= (op_type
== INTERFACE_USER_OP
);
10889 gfc_symtree
* st
= gfc_get_tbp_symtree (is_op
? &ns
->tb_uop_root
:
10890 &ns
->tb_sym_root
, name
);
10897 case INTERFACE_INTRINSIC_OP
:
10898 ns
->tb_op
[op
] = tb
;
10902 gcc_unreachable ();
10906 /* Now, match all following names as specific targets. */
10909 gfc_symtree
* target_st
;
10910 gfc_tbp_generic
* target
;
10912 m
= gfc_match_name (name
);
10913 if (m
== MATCH_ERROR
)
10917 gfc_error ("Expected specific binding name at %C");
10921 target_st
= gfc_get_tbp_symtree (&ns
->tb_sym_root
, name
);
10923 /* See if this is a duplicate specification. */
10924 for (target
= tb
->u
.generic
; target
; target
= target
->next
)
10925 if (target_st
== target
->specific_st
)
10927 gfc_error ("%qs already defined as specific binding for the"
10928 " generic %qs at %C", name
, bind_name
);
10932 target
= gfc_get_tbp_generic ();
10933 target
->specific_st
= target_st
;
10934 target
->specific
= NULL
;
10935 target
->next
= tb
->u
.generic
;
10936 target
->is_operator
= ((op_type
== INTERFACE_USER_OP
)
10937 || (op_type
== INTERFACE_INTRINSIC_OP
));
10938 tb
->u
.generic
= target
;
10940 while (gfc_match (" ,") == MATCH_YES
);
10942 /* Here should be the end. */
10943 if (gfc_match_eos () != MATCH_YES
)
10945 gfc_error ("Junk after GENERIC binding at %C");
10952 return MATCH_ERROR
;
10956 /* Match a FINAL declaration inside a derived type. */
10959 gfc_match_final_decl (void)
10961 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10964 gfc_namespace
* module_ns
;
10968 if (gfc_current_form
== FORM_FREE
)
10970 char c
= gfc_peek_ascii_char ();
10971 if (!gfc_is_whitespace (c
) && c
!= ':')
10975 if (gfc_state_stack
->state
!= COMP_DERIVED_CONTAINS
)
10977 if (gfc_current_form
== FORM_FIXED
)
10980 gfc_error ("FINAL declaration at %C must be inside a derived type "
10981 "CONTAINS section");
10982 return MATCH_ERROR
;
10985 block
= gfc_state_stack
->previous
->sym
;
10986 gcc_assert (block
);
10988 if (!gfc_state_stack
->previous
|| !gfc_state_stack
->previous
->previous
10989 || gfc_state_stack
->previous
->previous
->state
!= COMP_MODULE
)
10991 gfc_error ("Derived type declaration with FINAL at %C must be in the"
10992 " specification part of a MODULE");
10993 return MATCH_ERROR
;
10996 module_ns
= gfc_current_ns
;
10997 gcc_assert (module_ns
);
10998 gcc_assert (module_ns
->proc_name
->attr
.flavor
== FL_MODULE
);
11000 /* Match optional ::, don't care about MATCH_YES or MATCH_NO. */
11001 if (gfc_match (" ::") == MATCH_ERROR
)
11002 return MATCH_ERROR
;
11004 /* Match the sequence of procedure names. */
11011 if (first
&& gfc_match_eos () == MATCH_YES
)
11013 gfc_error ("Empty FINAL at %C");
11014 return MATCH_ERROR
;
11017 m
= gfc_match_name (name
);
11020 gfc_error ("Expected module procedure name at %C");
11021 return MATCH_ERROR
;
11023 else if (m
!= MATCH_YES
)
11024 return MATCH_ERROR
;
11026 if (gfc_match_eos () == MATCH_YES
)
11028 if (!last
&& gfc_match_char (',') != MATCH_YES
)
11030 gfc_error ("Expected %<,%> at %C");
11031 return MATCH_ERROR
;
11034 if (gfc_get_symbol (name
, module_ns
, &sym
))
11036 gfc_error ("Unknown procedure name %qs at %C", name
);
11037 return MATCH_ERROR
;
11040 /* Mark the symbol as module procedure. */
11041 if (sym
->attr
.proc
!= PROC_MODULE
11042 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
11043 return MATCH_ERROR
;
11045 /* Check if we already have this symbol in the list, this is an error. */
11046 for (f
= block
->f2k_derived
->finalizers
; f
; f
= f
->next
)
11047 if (f
->proc_sym
== sym
)
11049 gfc_error ("%qs at %C is already defined as FINAL procedure",
11051 return MATCH_ERROR
;
11054 /* Add this symbol to the list of finalizers. */
11055 gcc_assert (block
->f2k_derived
);
11057 f
= XCNEW (gfc_finalizer
);
11059 f
->proc_tree
= NULL
;
11060 f
->where
= gfc_current_locus
;
11061 f
->next
= block
->f2k_derived
->finalizers
;
11062 block
->f2k_derived
->finalizers
= f
;
11072 const ext_attr_t ext_attr_list
[] = {
11073 { "dllimport", EXT_ATTR_DLLIMPORT
, "dllimport" },
11074 { "dllexport", EXT_ATTR_DLLEXPORT
, "dllexport" },
11075 { "cdecl", EXT_ATTR_CDECL
, "cdecl" },
11076 { "stdcall", EXT_ATTR_STDCALL
, "stdcall" },
11077 { "fastcall", EXT_ATTR_FASTCALL
, "fastcall" },
11078 { "no_arg_check", EXT_ATTR_NO_ARG_CHECK
, NULL
},
11079 { NULL
, EXT_ATTR_LAST
, NULL
}
11082 /* Match a !GCC$ ATTRIBUTES statement of the form:
11083 !GCC$ ATTRIBUTES attribute-list :: var-name [, var-name] ...
11084 When we come here, we have already matched the !GCC$ ATTRIBUTES string.
11086 TODO: We should support all GCC attributes using the same syntax for
11087 the attribute list, i.e. the list in C
11088 __attributes(( attribute-list ))
11090 !GCC$ ATTRIBUTES attribute-list ::
11091 Cf. c-parser.c's c_parser_attributes; the data can then directly be
11094 As there is absolutely no risk of confusion, we should never return
11097 gfc_match_gcc_attributes (void)
11099 symbol_attribute attr
;
11100 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
11105 gfc_clear_attr (&attr
);
11110 if (gfc_match_name (name
) != MATCH_YES
)
11111 return MATCH_ERROR
;
11113 for (id
= 0; id
< EXT_ATTR_LAST
; id
++)
11114 if (strcmp (name
, ext_attr_list
[id
].name
) == 0)
11117 if (id
== EXT_ATTR_LAST
)
11119 gfc_error ("Unknown attribute in !GCC$ ATTRIBUTES statement at %C");
11120 return MATCH_ERROR
;
11123 if (!gfc_add_ext_attribute (&attr
, (ext_attr_id_t
)id
, &gfc_current_locus
))
11124 return MATCH_ERROR
;
11126 gfc_gobble_whitespace ();
11127 ch
= gfc_next_ascii_char ();
11130 /* This is the successful exit condition for the loop. */
11131 if (gfc_next_ascii_char () == ':')
11141 if (gfc_match_eos () == MATCH_YES
)
11146 m
= gfc_match_name (name
);
11147 if (m
!= MATCH_YES
)
11150 if (find_special (name
, &sym
, true))
11151 return MATCH_ERROR
;
11153 sym
->attr
.ext_attr
|= attr
.ext_attr
;
11155 if (gfc_match_eos () == MATCH_YES
)
11158 if (gfc_match_char (',') != MATCH_YES
)
11165 gfc_error ("Syntax error in !GCC$ ATTRIBUTES statement at %C");
11166 return MATCH_ERROR
;
11170 /* Match a !GCC$ UNROLL statement of the form:
11173 The parameter n is the number of times we are supposed to unroll.
11175 When we come here, we have already matched the !GCC$ UNROLL string. */
11177 gfc_match_gcc_unroll (void)
11181 if (gfc_match_small_int (&value
) == MATCH_YES
)
11183 if (value
< 0 || value
> USHRT_MAX
)
11185 gfc_error ("%<GCC unroll%> directive requires a"
11186 " non-negative integral constant"
11187 " less than or equal to %u at %C",
11190 return MATCH_ERROR
;
11192 if (gfc_match_eos () == MATCH_YES
)
11194 directive_unroll
= value
== 0 ? 1 : value
;
11199 gfc_error ("Syntax error in !GCC$ UNROLL directive at %C");
11200 return MATCH_ERROR
;