1 /* Declaration statement matcher
2 Copyright (C) 2002-2016 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
;
58 /* The current binding label (if any). */
59 static const char* curr_binding_label
;
60 /* Need to know how many identifiers are on the current data declaration
61 line in case we're given the BIND(C) attribute with a NAME= specifier. */
62 static int num_idents_on_line
;
63 /* Need to know if a NAME= specifier was found during gfc_match_bind_c so we
64 can supply a name if the curr_binding_label is nil and NAME= was not. */
65 static int has_name_equals
= 0;
67 /* Initializer of the previous enumerator. */
69 static gfc_expr
*last_initializer
;
71 /* History of all the enumerators is maintained, so that
72 kind values of all the enumerators could be updated depending
73 upon the maximum initialized value. */
75 typedef struct enumerator_history
78 gfc_expr
*initializer
;
79 struct enumerator_history
*next
;
83 /* Header of enum history chain. */
85 static enumerator_history
*enum_history
= NULL
;
87 /* Pointer of enum history node containing largest initializer. */
89 static enumerator_history
*max_enum
= NULL
;
91 /* gfc_new_block points to the symbol of a newly matched block. */
93 gfc_symbol
*gfc_new_block
;
95 bool gfc_matching_function
;
98 /********************* DATA statement subroutines *********************/
100 static bool in_match_data
= false;
103 gfc_in_match_data (void)
105 return in_match_data
;
109 set_in_match_data (bool set_value
)
111 in_match_data
= set_value
;
114 /* Free a gfc_data_variable structure and everything beneath it. */
117 free_variable (gfc_data_variable
*p
)
119 gfc_data_variable
*q
;
124 gfc_free_expr (p
->expr
);
125 gfc_free_iterator (&p
->iter
, 0);
126 free_variable (p
->list
);
132 /* Free a gfc_data_value structure and everything beneath it. */
135 free_value (gfc_data_value
*p
)
142 mpz_clear (p
->repeat
);
143 gfc_free_expr (p
->expr
);
149 /* Free a list of gfc_data structures. */
152 gfc_free_data (gfc_data
*p
)
159 free_variable (p
->var
);
160 free_value (p
->value
);
166 /* Free all data in a namespace. */
169 gfc_free_data_all (gfc_namespace
*ns
)
181 /* Reject data parsed since the last restore point was marked. */
184 gfc_reject_data (gfc_namespace
*ns
)
188 while (ns
->data
&& ns
->data
!= ns
->old_data
)
196 static match
var_element (gfc_data_variable
*);
198 /* Match a list of variables terminated by an iterator and a right
202 var_list (gfc_data_variable
*parent
)
204 gfc_data_variable
*tail
, var
;
207 m
= var_element (&var
);
208 if (m
== MATCH_ERROR
)
213 tail
= gfc_get_data_variable ();
220 if (gfc_match_char (',') != MATCH_YES
)
223 m
= gfc_match_iterator (&parent
->iter
, 1);
226 if (m
== MATCH_ERROR
)
229 m
= var_element (&var
);
230 if (m
== MATCH_ERROR
)
235 tail
->next
= gfc_get_data_variable ();
241 if (gfc_match_char (')') != MATCH_YES
)
246 gfc_syntax_error (ST_DATA
);
251 /* Match a single element in a data variable list, which can be a
252 variable-iterator list. */
255 var_element (gfc_data_variable
*new_var
)
260 memset (new_var
, 0, sizeof (gfc_data_variable
));
262 if (gfc_match_char ('(') == MATCH_YES
)
263 return var_list (new_var
);
265 m
= gfc_match_variable (&new_var
->expr
, 0);
269 sym
= new_var
->expr
->symtree
->n
.sym
;
271 /* Symbol should already have an associated type. */
272 if (!gfc_check_symbol_typed (sym
, gfc_current_ns
, false, gfc_current_locus
))
275 if (!sym
->attr
.function
&& gfc_current_ns
->parent
276 && gfc_current_ns
->parent
== sym
->ns
)
278 gfc_error ("Host associated variable %qs may not be in the DATA "
279 "statement at %C", sym
->name
);
283 if (gfc_current_state () != COMP_BLOCK_DATA
284 && sym
->attr
.in_common
285 && !gfc_notify_std (GFC_STD_GNU
, "initialization of "
286 "common block variable %qs in DATA statement at %C",
290 if (!gfc_add_data (&sym
->attr
, sym
->name
, &new_var
->expr
->where
))
297 /* Match the top-level list of data variables. */
300 top_var_list (gfc_data
*d
)
302 gfc_data_variable var
, *tail
, *new_var
;
309 m
= var_element (&var
);
312 if (m
== MATCH_ERROR
)
315 new_var
= gfc_get_data_variable ();
321 tail
->next
= new_var
;
325 if (gfc_match_char ('/') == MATCH_YES
)
327 if (gfc_match_char (',') != MATCH_YES
)
334 gfc_syntax_error (ST_DATA
);
335 gfc_free_data_all (gfc_current_ns
);
341 match_data_constant (gfc_expr
**result
)
343 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
344 gfc_symbol
*sym
, *dt_sym
= NULL
;
349 m
= gfc_match_literal_constant (&expr
, 1);
356 if (m
== MATCH_ERROR
)
359 m
= gfc_match_null (result
);
363 old_loc
= gfc_current_locus
;
365 /* Should this be a structure component, try to match it
366 before matching a name. */
367 m
= gfc_match_rvalue (result
);
368 if (m
== MATCH_ERROR
)
371 if (m
== MATCH_YES
&& (*result
)->expr_type
== EXPR_STRUCTURE
)
373 if (!gfc_simplify_expr (*result
, 0))
377 else if (m
== MATCH_YES
)
378 gfc_free_expr (*result
);
380 gfc_current_locus
= old_loc
;
382 m
= gfc_match_name (name
);
386 if (gfc_find_symbol (name
, NULL
, 1, &sym
))
389 if (sym
&& sym
->attr
.generic
)
390 dt_sym
= gfc_find_dt_in_generic (sym
);
393 || (sym
->attr
.flavor
!= FL_PARAMETER
394 && (!dt_sym
|| !gfc_fl_struct (dt_sym
->attr
.flavor
))))
396 gfc_error ("Symbol %qs must be a PARAMETER in DATA statement at %C",
400 else if (dt_sym
&& gfc_fl_struct (dt_sym
->attr
.flavor
))
401 return gfc_match_structure_constructor (dt_sym
, result
);
403 /* Check to see if the value is an initialization array expression. */
404 if (sym
->value
->expr_type
== EXPR_ARRAY
)
406 gfc_current_locus
= old_loc
;
408 m
= gfc_match_init_expr (result
);
409 if (m
== MATCH_ERROR
)
414 if (!gfc_simplify_expr (*result
, 0))
417 if ((*result
)->expr_type
== EXPR_CONSTANT
)
421 gfc_error ("Invalid initializer %s in Data statement at %C", name
);
427 *result
= gfc_copy_expr (sym
->value
);
432 /* Match a list of values in a DATA statement. The leading '/' has
433 already been seen at this point. */
436 top_val_list (gfc_data
*data
)
438 gfc_data_value
*new_val
, *tail
;
446 m
= match_data_constant (&expr
);
449 if (m
== MATCH_ERROR
)
452 new_val
= gfc_get_data_value ();
453 mpz_init (new_val
->repeat
);
456 data
->value
= new_val
;
458 tail
->next
= new_val
;
462 if (expr
->ts
.type
!= BT_INTEGER
|| gfc_match_char ('*') != MATCH_YES
)
465 mpz_set_ui (tail
->repeat
, 1);
469 mpz_set (tail
->repeat
, expr
->value
.integer
);
470 gfc_free_expr (expr
);
472 m
= match_data_constant (&tail
->expr
);
475 if (m
== MATCH_ERROR
)
479 if (gfc_match_char ('/') == MATCH_YES
)
481 if (gfc_match_char (',') == MATCH_NO
)
488 gfc_syntax_error (ST_DATA
);
489 gfc_free_data_all (gfc_current_ns
);
494 /* Matches an old style initialization. */
497 match_old_style_init (const char *name
)
504 /* Set up data structure to hold initializers. */
505 gfc_find_sym_tree (name
, NULL
, 0, &st
);
508 newdata
= gfc_get_data ();
509 newdata
->var
= gfc_get_data_variable ();
510 newdata
->var
->expr
= gfc_get_variable_expr (st
);
511 newdata
->where
= gfc_current_locus
;
513 /* Match initial value list. This also eats the terminal '/'. */
514 m
= top_val_list (newdata
);
523 gfc_error ("Initialization at %C is not allowed in a PURE procedure");
527 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
529 /* Mark the variable as having appeared in a data statement. */
530 if (!gfc_add_data (&sym
->attr
, sym
->name
, &sym
->declared_at
))
536 /* Chain in namespace list of DATA initializers. */
537 newdata
->next
= gfc_current_ns
->data
;
538 gfc_current_ns
->data
= newdata
;
544 /* Match the stuff following a DATA statement. If ERROR_FLAG is set,
545 we are matching a DATA statement and are therefore issuing an error
546 if we encounter something unexpected, if not, we're trying to match
547 an old-style initialization expression of the form INTEGER I /2/. */
550 gfc_match_data (void)
555 /* Before parsing the rest of a DATA statement, check F2008:c1206. */
556 if ((gfc_current_state () == COMP_FUNCTION
557 || gfc_current_state () == COMP_SUBROUTINE
)
558 && gfc_state_stack
->previous
->state
== COMP_INTERFACE
)
560 gfc_error ("DATA statement at %C cannot appear within an INTERFACE");
564 set_in_match_data (true);
568 new_data
= gfc_get_data ();
569 new_data
->where
= gfc_current_locus
;
571 m
= top_var_list (new_data
);
575 m
= top_val_list (new_data
);
579 new_data
->next
= gfc_current_ns
->data
;
580 gfc_current_ns
->data
= new_data
;
582 if (gfc_match_eos () == MATCH_YES
)
585 gfc_match_char (','); /* Optional comma */
588 set_in_match_data (false);
592 gfc_error ("DATA statement at %C is not allowed in a PURE procedure");
595 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
600 set_in_match_data (false);
601 gfc_free_data (new_data
);
606 /************************ Declaration statements *********************/
609 /* Like gfc_match_init_expr, but matches a 'clist' (old-style initialization
610 list). The difference here is the expression is a list of constants
611 and is surrounded by '/'.
612 The typespec ts must match the typespec of the variable which the
613 clist is initializing.
614 The arrayspec tells whether this should match a list of constants
615 corresponding to array elements or a scalar (as == NULL). */
618 match_clist_expr (gfc_expr
**result
, gfc_typespec
*ts
, gfc_array_spec
*as
)
620 gfc_constructor_base array_head
= NULL
;
621 gfc_expr
*expr
= NULL
;
630 mpz_init_set_ui (repeat
, 0);
632 scalar
= !as
|| !as
->rank
;
634 /* We have already matched '/' - now look for a constant list, as with
635 top_val_list from decl.c, but append the result to an array. */
636 if (gfc_match ("/") == MATCH_YES
)
638 gfc_error ("Empty old style initializer list at %C");
642 where
= gfc_current_locus
;
645 m
= match_data_constant (&expr
);
647 expr
= NULL
; /* match_data_constant may set expr to garbage */
650 if (m
== MATCH_ERROR
)
653 /* Found r in repeat spec r*c; look for the constant to repeat. */
654 if ( gfc_match_char ('*') == MATCH_YES
)
658 gfc_error ("Repeat spec invalid in scalar initializer at %C");
661 if (expr
->ts
.type
!= BT_INTEGER
)
663 gfc_error ("Repeat spec must be an integer at %C");
666 mpz_set (repeat
, expr
->value
.integer
);
667 gfc_free_expr (expr
);
670 m
= match_data_constant (&expr
);
672 gfc_error ("Expected data constant after repeat spec at %C");
676 /* No repeat spec, we matched the data constant itself. */
678 mpz_set_ui (repeat
, 1);
682 /* Add the constant initializer as many times as repeated. */
683 for (; mpz_cmp_ui (repeat
, 0) > 0; mpz_sub_ui (repeat
, repeat
, 1))
685 /* Make sure types of elements match */
686 if(ts
&& !gfc_compare_types (&expr
->ts
, ts
)
687 && !gfc_convert_type (expr
, ts
, 1))
690 gfc_constructor_append_expr (&array_head
,
691 gfc_copy_expr (expr
), &gfc_current_locus
);
694 gfc_free_expr (expr
);
698 /* For scalar initializers quit after one element. */
701 if(gfc_match_char ('/') != MATCH_YES
)
703 gfc_error ("End of scalar initializer expected at %C");
709 if (gfc_match_char ('/') == MATCH_YES
)
711 if (gfc_match_char (',') == MATCH_NO
)
715 /* Set up expr as an array constructor. */
718 expr
= gfc_get_array_expr (ts
->type
, ts
->kind
, &where
);
720 expr
->value
.constructor
= array_head
;
722 expr
->rank
= as
->rank
;
723 expr
->shape
= gfc_get_shape (expr
->rank
);
725 /* Validate sizes. */
726 gcc_assert (gfc_array_size (expr
, &size
));
727 gcc_assert (spec_size (as
, &repeat
));
728 cmp
= mpz_cmp (size
, repeat
);
730 gfc_error ("Not enough elements in array initializer at %C");
732 gfc_error ("Too many elements in array initializer at %C");
737 /* Make sure scalar types match. */
738 else if (!gfc_compare_types (&expr
->ts
, ts
)
739 && !gfc_convert_type (expr
, ts
, 1))
743 expr
->ts
.u
.cl
->length_from_typespec
= 1;
751 gfc_error ("Syntax error in old style initializer list at %C");
755 expr
->value
.constructor
= NULL
;
756 gfc_free_expr (expr
);
757 gfc_constructor_free (array_head
);
764 /* Auxiliary function to merge DIMENSION and CODIMENSION array specs. */
767 merge_array_spec (gfc_array_spec
*from
, gfc_array_spec
*to
, bool copy
)
771 if ((from
->type
== AS_ASSUMED_RANK
&& to
->corank
)
772 || (to
->type
== AS_ASSUMED_RANK
&& from
->corank
))
774 gfc_error ("The assumed-rank array at %C shall not have a codimension");
778 if (to
->rank
== 0 && from
->rank
> 0)
780 to
->rank
= from
->rank
;
781 to
->type
= from
->type
;
782 to
->cray_pointee
= from
->cray_pointee
;
783 to
->cp_was_assumed
= from
->cp_was_assumed
;
785 for (i
= 0; i
< to
->corank
; i
++)
787 to
->lower
[from
->rank
+ i
] = to
->lower
[i
];
788 to
->upper
[from
->rank
+ i
] = to
->upper
[i
];
790 for (i
= 0; i
< from
->rank
; i
++)
794 to
->lower
[i
] = gfc_copy_expr (from
->lower
[i
]);
795 to
->upper
[i
] = gfc_copy_expr (from
->upper
[i
]);
799 to
->lower
[i
] = from
->lower
[i
];
800 to
->upper
[i
] = from
->upper
[i
];
804 else if (to
->corank
== 0 && from
->corank
> 0)
806 to
->corank
= from
->corank
;
807 to
->cotype
= from
->cotype
;
809 for (i
= 0; i
< from
->corank
; i
++)
813 to
->lower
[to
->rank
+ i
] = gfc_copy_expr (from
->lower
[i
]);
814 to
->upper
[to
->rank
+ i
] = gfc_copy_expr (from
->upper
[i
]);
818 to
->lower
[to
->rank
+ i
] = from
->lower
[i
];
819 to
->upper
[to
->rank
+ i
] = from
->upper
[i
];
828 /* Match an intent specification. Since this can only happen after an
829 INTENT word, a legal intent-spec must follow. */
832 match_intent_spec (void)
835 if (gfc_match (" ( in out )") == MATCH_YES
)
837 if (gfc_match (" ( in )") == MATCH_YES
)
839 if (gfc_match (" ( out )") == MATCH_YES
)
842 gfc_error ("Bad INTENT specification at %C");
843 return INTENT_UNKNOWN
;
847 /* Matches a character length specification, which is either a
848 specification expression, '*', or ':'. */
851 char_len_param_value (gfc_expr
**expr
, bool *deferred
)
858 if (gfc_match_char ('*') == MATCH_YES
)
861 if (gfc_match_char (':') == MATCH_YES
)
863 if (!gfc_notify_std (GFC_STD_F2003
, "deferred type parameter at %C"))
871 m
= gfc_match_expr (expr
);
873 if (m
== MATCH_NO
|| m
== MATCH_ERROR
)
876 if (!gfc_expr_check_typed (*expr
, gfc_current_ns
, false))
879 if ((*expr
)->expr_type
== EXPR_FUNCTION
)
881 if ((*expr
)->ts
.type
== BT_INTEGER
882 || ((*expr
)->ts
.type
== BT_UNKNOWN
883 && strcmp((*expr
)->symtree
->name
, "null") != 0))
888 else if ((*expr
)->expr_type
== EXPR_CONSTANT
)
890 /* F2008, 4.4.3.1: The length is a type parameter; its kind is
891 processor dependent and its value is greater than or equal to zero.
892 F2008, 4.4.3.2: If the character length parameter value evaluates
893 to a negative value, the length of character entities declared
896 if ((*expr
)->ts
.type
== BT_INTEGER
)
898 if (mpz_cmp_si ((*expr
)->value
.integer
, 0) < 0)
899 mpz_set_si ((*expr
)->value
.integer
, 0);
904 else if ((*expr
)->expr_type
== EXPR_ARRAY
)
906 else if ((*expr
)->expr_type
== EXPR_VARIABLE
)
910 e
= gfc_copy_expr (*expr
);
912 /* This catches the invalid code "[character(m(2:3)) :: 'x', 'y']",
913 which causes an ICE if gfc_reduce_init_expr() is called. */
914 if (e
->ref
&& e
->ref
->type
== REF_ARRAY
915 && e
->ref
->u
.ar
.type
== AR_UNKNOWN
916 && e
->ref
->u
.ar
.dimen_type
[0] == DIMEN_RANGE
)
919 gfc_reduce_init_expr (e
);
921 if ((e
->ref
&& e
->ref
->type
== REF_ARRAY
922 && e
->ref
->u
.ar
.type
!= AR_ELEMENT
)
923 || (!e
->ref
&& e
->expr_type
== EXPR_ARRAY
))
935 gfc_error ("Scalar INTEGER expression expected at %L", &(*expr
)->where
);
940 /* A character length is a '*' followed by a literal integer or a
941 char_len_param_value in parenthesis. */
944 match_char_length (gfc_expr
**expr
, bool *deferred
, bool obsolescent_check
)
950 m
= gfc_match_char ('*');
954 m
= gfc_match_small_literal_int (&length
, NULL
);
955 if (m
== MATCH_ERROR
)
960 if (obsolescent_check
961 && !gfc_notify_std (GFC_STD_F95_OBS
, "Old-style character length at %C"))
963 *expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, length
);
967 if (gfc_match_char ('(') == MATCH_NO
)
970 m
= char_len_param_value (expr
, deferred
);
971 if (m
!= MATCH_YES
&& gfc_matching_function
)
977 if (m
== MATCH_ERROR
)
982 if (gfc_match_char (')') == MATCH_NO
)
984 gfc_free_expr (*expr
);
992 gfc_error ("Syntax error in character length specification at %C");
997 /* Special subroutine for finding a symbol. Check if the name is found
998 in the current name space. If not, and we're compiling a function or
999 subroutine and the parent compilation unit is an interface, then check
1000 to see if the name we've been given is the name of the interface
1001 (located in another namespace). */
1004 find_special (const char *name
, gfc_symbol
**result
, bool allow_subroutine
)
1010 i
= gfc_get_sym_tree (name
, NULL
, &st
, allow_subroutine
);
1013 *result
= st
? st
->n
.sym
: NULL
;
1017 if (gfc_current_state () != COMP_SUBROUTINE
1018 && gfc_current_state () != COMP_FUNCTION
)
1021 s
= gfc_state_stack
->previous
;
1025 if (s
->state
!= COMP_INTERFACE
)
1028 goto end
; /* Nameless interface. */
1030 if (strcmp (name
, s
->sym
->name
) == 0)
1041 /* Special subroutine for getting a symbol node associated with a
1042 procedure name, used in SUBROUTINE and FUNCTION statements. The
1043 symbol is created in the parent using with symtree node in the
1044 child unit pointing to the symbol. If the current namespace has no
1045 parent, then the symbol is just created in the current unit. */
1048 get_proc_name (const char *name
, gfc_symbol
**result
, bool module_fcn_entry
)
1054 /* Module functions have to be left in their own namespace because
1055 they have potentially (almost certainly!) already been referenced.
1056 In this sense, they are rather like external functions. This is
1057 fixed up in resolve.c(resolve_entries), where the symbol name-
1058 space is set to point to the master function, so that the fake
1059 result mechanism can work. */
1060 if (module_fcn_entry
)
1062 /* Present if entry is declared to be a module procedure. */
1063 rc
= gfc_find_symbol (name
, gfc_current_ns
->parent
, 0, result
);
1065 if (*result
== NULL
)
1066 rc
= gfc_get_symbol (name
, NULL
, result
);
1067 else if (!gfc_get_symbol (name
, NULL
, &sym
) && sym
1068 && (*result
)->ts
.type
== BT_UNKNOWN
1069 && sym
->attr
.flavor
== FL_UNKNOWN
)
1070 /* Pick up the typespec for the entry, if declared in the function
1071 body. Note that this symbol is FL_UNKNOWN because it will
1072 only have appeared in a type declaration. The local symtree
1073 is set to point to the module symbol and a unique symtree
1074 to the local version. This latter ensures a correct clearing
1077 /* If the ENTRY proceeds its specification, we need to ensure
1078 that this does not raise a "has no IMPLICIT type" error. */
1079 if (sym
->ts
.type
== BT_UNKNOWN
)
1080 sym
->attr
.untyped
= 1;
1082 (*result
)->ts
= sym
->ts
;
1084 /* Put the symbol in the procedure namespace so that, should
1085 the ENTRY precede its specification, the specification
1087 (*result
)->ns
= gfc_current_ns
;
1089 gfc_find_sym_tree (name
, gfc_current_ns
, 0, &st
);
1090 st
->n
.sym
= *result
;
1091 st
= gfc_get_unique_symtree (gfc_current_ns
);
1097 rc
= gfc_get_symbol (name
, gfc_current_ns
->parent
, result
);
1103 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
1106 if (sym
->attr
.module_procedure
1107 && sym
->attr
.if_source
== IFSRC_IFBODY
)
1109 /* Create a partially populated interface symbol to carry the
1110 characteristics of the procedure and the result. */
1111 sym
->ts
.interface
= gfc_new_symbol (name
, sym
->ns
);
1112 gfc_add_type (sym
->ts
.interface
, &(sym
->ts
),
1113 &gfc_current_locus
);
1114 gfc_copy_attr (&sym
->ts
.interface
->attr
, &sym
->attr
, NULL
);
1115 if (sym
->attr
.dimension
)
1116 sym
->ts
.interface
->as
= gfc_copy_array_spec (sym
->as
);
1118 /* Ideally, at this point, a copy would be made of the formal
1119 arguments and their namespace. However, this does not appear
1120 to be necessary, albeit at the expense of not being able to
1121 use gfc_compare_interfaces directly. */
1123 if (sym
->result
&& sym
->result
!= sym
)
1125 sym
->ts
.interface
->result
= sym
->result
;
1128 else if (sym
->result
)
1130 sym
->ts
.interface
->result
= sym
->ts
.interface
;
1133 else if (sym
&& !sym
->gfc_new
1134 && gfc_current_state () != COMP_INTERFACE
)
1136 /* Trap another encompassed procedure with the same name. All
1137 these conditions are necessary to avoid picking up an entry
1138 whose name clashes with that of the encompassing procedure;
1139 this is handled using gsymbols to register unique, globally
1140 accessible names. */
1141 if (sym
->attr
.flavor
!= 0
1142 && sym
->attr
.proc
!= 0
1143 && (sym
->attr
.subroutine
|| sym
->attr
.function
)
1144 && sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
1145 gfc_error_now ("Procedure %qs at %C is already defined at %L",
1146 name
, &sym
->declared_at
);
1148 /* Trap a procedure with a name the same as interface in the
1149 encompassing scope. */
1150 if (sym
->attr
.generic
!= 0
1151 && (sym
->attr
.subroutine
|| sym
->attr
.function
)
1152 && !sym
->attr
.mod_proc
)
1153 gfc_error_now ("Name %qs at %C is already defined"
1154 " as a generic interface at %L",
1155 name
, &sym
->declared_at
);
1157 /* Trap declarations of attributes in encompassing scope. The
1158 signature for this is that ts.kind is set. Legitimate
1159 references only set ts.type. */
1160 if (sym
->ts
.kind
!= 0
1161 && !sym
->attr
.implicit_type
1162 && sym
->attr
.proc
== 0
1163 && gfc_current_ns
->parent
!= NULL
1164 && sym
->attr
.access
== 0
1165 && !module_fcn_entry
)
1166 gfc_error_now ("Procedure %qs at %C has an explicit interface "
1167 "and must not have attributes declared at %L",
1168 name
, &sym
->declared_at
);
1171 if (gfc_current_ns
->parent
== NULL
|| *result
== NULL
)
1174 /* Module function entries will already have a symtree in
1175 the current namespace but will need one at module level. */
1176 if (module_fcn_entry
)
1178 /* Present if entry is declared to be a module procedure. */
1179 rc
= gfc_find_sym_tree (name
, gfc_current_ns
->parent
, 0, &st
);
1181 st
= gfc_new_symtree (&gfc_current_ns
->parent
->sym_root
, name
);
1184 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, name
);
1189 /* See if the procedure should be a module procedure. */
1191 if (((sym
->ns
->proc_name
!= NULL
1192 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
1193 && sym
->attr
.proc
!= PROC_MODULE
)
1194 || (module_fcn_entry
&& sym
->attr
.proc
!= PROC_MODULE
))
1195 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
1202 /* Verify that the given symbol representing a parameter is C
1203 interoperable, by checking to see if it was marked as such after
1204 its declaration. If the given symbol is not interoperable, a
1205 warning is reported, thus removing the need to return the status to
1206 the calling function. The standard does not require the user use
1207 one of the iso_c_binding named constants to declare an
1208 interoperable parameter, but we can't be sure if the param is C
1209 interop or not if the user doesn't. For example, integer(4) may be
1210 legal Fortran, but doesn't have meaning in C. It may interop with
1211 a number of the C types, which causes a problem because the
1212 compiler can't know which one. This code is almost certainly not
1213 portable, and the user will get what they deserve if the C type
1214 across platforms isn't always interoperable with integer(4). If
1215 the user had used something like integer(c_int) or integer(c_long),
1216 the compiler could have automatically handled the varying sizes
1217 across platforms. */
1220 gfc_verify_c_interop_param (gfc_symbol
*sym
)
1222 int is_c_interop
= 0;
1225 /* We check implicitly typed variables in symbol.c:gfc_set_default_type().
1226 Don't repeat the checks here. */
1227 if (sym
->attr
.implicit_type
)
1230 /* For subroutines or functions that are passed to a BIND(C) procedure,
1231 they're interoperable if they're BIND(C) and their params are all
1233 if (sym
->attr
.flavor
== FL_PROCEDURE
)
1235 if (sym
->attr
.is_bind_c
== 0)
1237 gfc_error_now ("Procedure %qs at %L must have the BIND(C) "
1238 "attribute to be C interoperable", sym
->name
,
1239 &(sym
->declared_at
));
1244 if (sym
->attr
.is_c_interop
== 1)
1245 /* We've already checked this procedure; don't check it again. */
1248 return verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
1253 /* See if we've stored a reference to a procedure that owns sym. */
1254 if (sym
->ns
!= NULL
&& sym
->ns
->proc_name
!= NULL
)
1256 if (sym
->ns
->proc_name
->attr
.is_bind_c
== 1)
1258 is_c_interop
= (gfc_verify_c_interop(&(sym
->ts
)) ? 1 : 0);
1260 if (is_c_interop
!= 1)
1262 /* Make personalized messages to give better feedback. */
1263 if (sym
->ts
.type
== BT_DERIVED
)
1264 gfc_error ("Variable %qs at %L is a dummy argument to the "
1265 "BIND(C) procedure %qs but is not C interoperable "
1266 "because derived type %qs is not C interoperable",
1267 sym
->name
, &(sym
->declared_at
),
1268 sym
->ns
->proc_name
->name
,
1269 sym
->ts
.u
.derived
->name
);
1270 else if (sym
->ts
.type
== BT_CLASS
)
1271 gfc_error ("Variable %qs at %L is a dummy argument to the "
1272 "BIND(C) procedure %qs but is not C interoperable "
1273 "because it is polymorphic",
1274 sym
->name
, &(sym
->declared_at
),
1275 sym
->ns
->proc_name
->name
);
1276 else if (warn_c_binding_type
)
1277 gfc_warning (OPT_Wc_binding_type
,
1278 "Variable %qs at %L is a dummy argument of the "
1279 "BIND(C) procedure %qs but may not be C "
1281 sym
->name
, &(sym
->declared_at
),
1282 sym
->ns
->proc_name
->name
);
1285 /* Character strings are only C interoperable if they have a
1287 if (sym
->ts
.type
== BT_CHARACTER
)
1289 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
1290 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
1291 || mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
1293 gfc_error ("Character argument %qs at %L "
1294 "must be length 1 because "
1295 "procedure %qs is BIND(C)",
1296 sym
->name
, &sym
->declared_at
,
1297 sym
->ns
->proc_name
->name
);
1302 /* We have to make sure that any param to a bind(c) routine does
1303 not have the allocatable, pointer, or optional attributes,
1304 according to J3/04-007, section 5.1. */
1305 if (sym
->attr
.allocatable
== 1
1306 && !gfc_notify_std (GFC_STD_F2008_TS
, "Variable %qs at %L with "
1307 "ALLOCATABLE attribute in procedure %qs "
1308 "with BIND(C)", sym
->name
,
1309 &(sym
->declared_at
),
1310 sym
->ns
->proc_name
->name
))
1313 if (sym
->attr
.pointer
== 1
1314 && !gfc_notify_std (GFC_STD_F2008_TS
, "Variable %qs at %L with "
1315 "POINTER attribute in procedure %qs "
1316 "with BIND(C)", sym
->name
,
1317 &(sym
->declared_at
),
1318 sym
->ns
->proc_name
->name
))
1321 if ((sym
->attr
.allocatable
|| sym
->attr
.pointer
) && !sym
->as
)
1323 gfc_error ("Scalar variable %qs at %L with POINTER or "
1324 "ALLOCATABLE in procedure %qs with BIND(C) is not yet"
1325 " supported", sym
->name
, &(sym
->declared_at
),
1326 sym
->ns
->proc_name
->name
);
1330 if (sym
->attr
.optional
== 1 && sym
->attr
.value
)
1332 gfc_error ("Variable %qs at %L cannot have both the OPTIONAL "
1333 "and the VALUE attribute because procedure %qs "
1334 "is BIND(C)", sym
->name
, &(sym
->declared_at
),
1335 sym
->ns
->proc_name
->name
);
1338 else if (sym
->attr
.optional
== 1
1339 && !gfc_notify_std (GFC_STD_F2008_TS
, "Variable %qs "
1340 "at %L with OPTIONAL attribute in "
1341 "procedure %qs which is BIND(C)",
1342 sym
->name
, &(sym
->declared_at
),
1343 sym
->ns
->proc_name
->name
))
1346 /* Make sure that if it has the dimension attribute, that it is
1347 either assumed size or explicit shape. Deferred shape is already
1348 covered by the pointer/allocatable attribute. */
1349 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SHAPE
1350 && !gfc_notify_std (GFC_STD_F2008_TS
, "Assumed-shape array %qs "
1351 "at %L as dummy argument to the BIND(C) "
1352 "procedure %qs at %L", sym
->name
,
1353 &(sym
->declared_at
),
1354 sym
->ns
->proc_name
->name
,
1355 &(sym
->ns
->proc_name
->declared_at
)))
1365 /* Function called by variable_decl() that adds a name to the symbol table. */
1368 build_sym (const char *name
, gfc_charlen
*cl
, bool cl_deferred
,
1369 gfc_array_spec
**as
, locus
*var_locus
)
1371 symbol_attribute attr
;
1375 if (gfc_get_symbol (name
, NULL
, &sym
))
1378 /* Check if the name has already been defined as a type. The
1379 first letter of the symtree will be in upper case then. Of
1380 course, this is only necessary if the upper case letter is
1381 actually different. */
1383 upper
= TOUPPER(name
[0]);
1384 if (upper
!= name
[0])
1386 char u_name
[GFC_MAX_SYMBOL_LEN
+ 1];
1390 nlen
= strlen(name
);
1391 gcc_assert (nlen
<= GFC_MAX_SYMBOL_LEN
);
1392 strncpy (u_name
, name
, nlen
+ 1);
1395 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, u_name
);
1397 /* STRUCTURE types can alias symbol names */
1398 if (st
!= 0 && st
->n
.sym
->attr
.flavor
!= FL_STRUCT
)
1400 gfc_error ("Symbol %qs at %C also declared as a type at %L", name
,
1401 &st
->n
.sym
->declared_at
);
1406 /* Start updating the symbol table. Add basic type attribute if present. */
1407 if (current_ts
.type
!= BT_UNKNOWN
1408 && (sym
->attr
.implicit_type
== 0
1409 || !gfc_compare_types (&sym
->ts
, ¤t_ts
))
1410 && !gfc_add_type (sym
, ¤t_ts
, var_locus
))
1413 if (sym
->ts
.type
== BT_CHARACTER
)
1416 sym
->ts
.deferred
= cl_deferred
;
1419 /* Add dimension attribute if present. */
1420 if (!gfc_set_array_spec (sym
, *as
, var_locus
))
1424 /* Add attribute to symbol. The copy is so that we can reset the
1425 dimension attribute. */
1426 attr
= current_attr
;
1428 attr
.codimension
= 0;
1430 if (!gfc_copy_attr (&sym
->attr
, &attr
, var_locus
))
1433 /* Finish any work that may need to be done for the binding label,
1434 if it's a bind(c). The bind(c) attr is found before the symbol
1435 is made, and before the symbol name (for data decls), so the
1436 current_ts is holding the binding label, or nothing if the
1437 name= attr wasn't given. Therefore, test here if we're dealing
1438 with a bind(c) and make sure the binding label is set correctly. */
1439 if (sym
->attr
.is_bind_c
== 1)
1441 if (!sym
->binding_label
)
1443 /* Set the binding label and verify that if a NAME= was specified
1444 then only one identifier was in the entity-decl-list. */
1445 if (!set_binding_label (&sym
->binding_label
, sym
->name
,
1446 num_idents_on_line
))
1451 /* See if we know we're in a common block, and if it's a bind(c)
1452 common then we need to make sure we're an interoperable type. */
1453 if (sym
->attr
.in_common
== 1)
1455 /* Test the common block object. */
1456 if (sym
->common_block
!= NULL
&& sym
->common_block
->is_bind_c
== 1
1457 && sym
->ts
.is_c_interop
!= 1)
1459 gfc_error_now ("Variable %qs in common block %qs at %C "
1460 "must be declared with a C interoperable "
1461 "kind since common block %qs is BIND(C)",
1462 sym
->name
, sym
->common_block
->name
,
1463 sym
->common_block
->name
);
1468 sym
->attr
.implied_index
= 0;
1470 if (sym
->ts
.type
== BT_CLASS
)
1471 return gfc_build_class_symbol (&sym
->ts
, &sym
->attr
, &sym
->as
);
1477 /* Set character constant to the given length. The constant will be padded or
1478 truncated. If we're inside an array constructor without a typespec, we
1479 additionally check that all elements have the same length; check_len -1
1480 means no checking. */
1483 gfc_set_constant_character_len (int len
, gfc_expr
*expr
, int check_len
)
1488 gcc_assert (expr
->expr_type
== EXPR_CONSTANT
);
1490 if (expr
->ts
.type
!= BT_CHARACTER
)
1493 slen
= expr
->value
.character
.length
;
1496 s
= gfc_get_wide_string (len
+ 1);
1497 memcpy (s
, expr
->value
.character
.string
,
1498 MIN (len
, slen
) * sizeof (gfc_char_t
));
1500 gfc_wide_memset (&s
[slen
], ' ', len
- slen
);
1502 if (warn_character_truncation
&& slen
> len
)
1503 gfc_warning_now (OPT_Wcharacter_truncation
,
1504 "CHARACTER expression at %L is being truncated "
1505 "(%d/%d)", &expr
->where
, slen
, len
);
1507 /* Apply the standard by 'hand' otherwise it gets cleared for
1509 if (check_len
!= -1 && slen
!= check_len
1510 && !(gfc_option
.allow_std
& GFC_STD_GNU
))
1511 gfc_error_now ("The CHARACTER elements of the array constructor "
1512 "at %L must have the same length (%d/%d)",
1513 &expr
->where
, slen
, check_len
);
1516 free (expr
->value
.character
.string
);
1517 expr
->value
.character
.string
= s
;
1518 expr
->value
.character
.length
= len
;
1523 /* Function to create and update the enumerator history
1524 using the information passed as arguments.
1525 Pointer "max_enum" is also updated, to point to
1526 enum history node containing largest initializer.
1528 SYM points to the symbol node of enumerator.
1529 INIT points to its enumerator value. */
1532 create_enum_history (gfc_symbol
*sym
, gfc_expr
*init
)
1534 enumerator_history
*new_enum_history
;
1535 gcc_assert (sym
!= NULL
&& init
!= NULL
);
1537 new_enum_history
= XCNEW (enumerator_history
);
1539 new_enum_history
->sym
= sym
;
1540 new_enum_history
->initializer
= init
;
1541 new_enum_history
->next
= NULL
;
1543 if (enum_history
== NULL
)
1545 enum_history
= new_enum_history
;
1546 max_enum
= enum_history
;
1550 new_enum_history
->next
= enum_history
;
1551 enum_history
= new_enum_history
;
1553 if (mpz_cmp (max_enum
->initializer
->value
.integer
,
1554 new_enum_history
->initializer
->value
.integer
) < 0)
1555 max_enum
= new_enum_history
;
1560 /* Function to free enum kind history. */
1563 gfc_free_enum_history (void)
1565 enumerator_history
*current
= enum_history
;
1566 enumerator_history
*next
;
1568 while (current
!= NULL
)
1570 next
= current
->next
;
1575 enum_history
= NULL
;
1579 /* Function called by variable_decl() that adds an initialization
1580 expression to a symbol. */
1583 add_init_expr_to_sym (const char *name
, gfc_expr
**initp
, locus
*var_locus
)
1585 symbol_attribute attr
;
1590 if (find_special (name
, &sym
, false))
1595 /* If this symbol is confirming an implicit parameter type,
1596 then an initialization expression is not allowed. */
1597 if (attr
.flavor
== FL_PARAMETER
1598 && sym
->value
!= NULL
1601 gfc_error ("Initializer not allowed for PARAMETER %qs at %C",
1608 /* An initializer is required for PARAMETER declarations. */
1609 if (attr
.flavor
== FL_PARAMETER
)
1611 gfc_error ("PARAMETER at %L is missing an initializer", var_locus
);
1617 /* If a variable appears in a DATA block, it cannot have an
1621 gfc_error ("Variable %qs at %C with an initializer already "
1622 "appears in a DATA statement", sym
->name
);
1626 /* Check if the assignment can happen. This has to be put off
1627 until later for derived type variables and procedure pointers. */
1628 if (!gfc_bt_struct (sym
->ts
.type
) && !gfc_bt_struct (init
->ts
.type
)
1629 && sym
->ts
.type
!= BT_CLASS
&& init
->ts
.type
!= BT_CLASS
1630 && !sym
->attr
.proc_pointer
1631 && !gfc_check_assign_symbol (sym
, NULL
, init
))
1634 if (sym
->ts
.type
== BT_CHARACTER
&& sym
->ts
.u
.cl
1635 && init
->ts
.type
== BT_CHARACTER
)
1637 /* Update symbol character length according initializer. */
1638 if (!gfc_check_assign_symbol (sym
, NULL
, init
))
1641 if (sym
->ts
.u
.cl
->length
== NULL
)
1644 /* If there are multiple CHARACTER variables declared on the
1645 same line, we don't want them to share the same length. */
1646 sym
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1648 if (sym
->attr
.flavor
== FL_PARAMETER
)
1650 if (init
->expr_type
== EXPR_CONSTANT
)
1652 clen
= init
->value
.character
.length
;
1653 sym
->ts
.u
.cl
->length
1654 = gfc_get_int_expr (gfc_default_integer_kind
,
1657 else if (init
->expr_type
== EXPR_ARRAY
)
1660 clen
= mpz_get_si (init
->ts
.u
.cl
->length
->value
.integer
);
1661 else if (init
->value
.constructor
)
1664 c
= gfc_constructor_first (init
->value
.constructor
);
1665 clen
= c
->expr
->value
.character
.length
;
1669 sym
->ts
.u
.cl
->length
1670 = gfc_get_int_expr (gfc_default_integer_kind
,
1673 else if (init
->ts
.u
.cl
&& init
->ts
.u
.cl
->length
)
1674 sym
->ts
.u
.cl
->length
=
1675 gfc_copy_expr (sym
->value
->ts
.u
.cl
->length
);
1678 /* Update initializer character length according symbol. */
1679 else if (sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1683 if (!gfc_specification_expr (sym
->ts
.u
.cl
->length
))
1686 len
= mpz_get_si (sym
->ts
.u
.cl
->length
->value
.integer
);
1688 if (init
->expr_type
== EXPR_CONSTANT
)
1689 gfc_set_constant_character_len (len
, init
, -1);
1690 else if (init
->expr_type
== EXPR_ARRAY
)
1694 /* Build a new charlen to prevent simplification from
1695 deleting the length before it is resolved. */
1696 init
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1697 init
->ts
.u
.cl
->length
= gfc_copy_expr (sym
->ts
.u
.cl
->length
);
1699 for (c
= gfc_constructor_first (init
->value
.constructor
);
1700 c
; c
= gfc_constructor_next (c
))
1701 gfc_set_constant_character_len (len
, c
->expr
, -1);
1706 /* If sym is implied-shape, set its upper bounds from init. */
1707 if (sym
->attr
.flavor
== FL_PARAMETER
&& sym
->attr
.dimension
1708 && sym
->as
->type
== AS_IMPLIED_SHAPE
)
1712 if (init
->rank
== 0)
1714 gfc_error ("Can't initialize implied-shape array at %L"
1715 " with scalar", &sym
->declared_at
);
1719 /* Shape should be present, we get an initialization expression. */
1720 gcc_assert (init
->shape
);
1722 for (dim
= 0; dim
< sym
->as
->rank
; ++dim
)
1725 gfc_expr
*e
, *lower
;
1727 lower
= sym
->as
->lower
[dim
];
1729 /* If the lower bound is an array element from another
1730 parameterized array, then it is marked with EXPR_VARIABLE and
1731 is an initialization expression. Try to reduce it. */
1732 if (lower
->expr_type
== EXPR_VARIABLE
)
1733 gfc_reduce_init_expr (lower
);
1735 if (lower
->expr_type
== EXPR_CONSTANT
)
1737 /* All dimensions must be without upper bound. */
1738 gcc_assert (!sym
->as
->upper
[dim
]);
1741 e
= gfc_get_constant_expr (BT_INTEGER
, k
, &sym
->declared_at
);
1742 mpz_add (e
->value
.integer
, lower
->value
.integer
,
1744 mpz_sub_ui (e
->value
.integer
, e
->value
.integer
, 1);
1745 sym
->as
->upper
[dim
] = e
;
1749 gfc_error ("Non-constant lower bound in implied-shape"
1750 " declaration at %L", &lower
->where
);
1755 sym
->as
->type
= AS_EXPLICIT
;
1758 /* Need to check if the expression we initialized this
1759 to was one of the iso_c_binding named constants. If so,
1760 and we're a parameter (constant), let it be iso_c.
1762 integer(c_int), parameter :: my_int = c_int
1763 integer(my_int) :: my_int_2
1764 If we mark my_int as iso_c (since we can see it's value
1765 is equal to one of the named constants), then my_int_2
1766 will be considered C interoperable. */
1767 if (sym
->ts
.type
!= BT_CHARACTER
&& !gfc_bt_struct (sym
->ts
.type
))
1769 sym
->ts
.is_iso_c
|= init
->ts
.is_iso_c
;
1770 sym
->ts
.is_c_interop
|= init
->ts
.is_c_interop
;
1771 /* attr bits needed for module files. */
1772 sym
->attr
.is_iso_c
|= init
->ts
.is_iso_c
;
1773 sym
->attr
.is_c_interop
|= init
->ts
.is_c_interop
;
1774 if (init
->ts
.is_iso_c
)
1775 sym
->ts
.f90_type
= init
->ts
.f90_type
;
1778 /* Add initializer. Make sure we keep the ranks sane. */
1779 if (sym
->attr
.dimension
&& init
->rank
== 0)
1784 if (sym
->attr
.flavor
== FL_PARAMETER
1785 && init
->expr_type
== EXPR_CONSTANT
1786 && spec_size (sym
->as
, &size
)
1787 && mpz_cmp_si (size
, 0) > 0)
1789 array
= gfc_get_array_expr (init
->ts
.type
, init
->ts
.kind
,
1791 for (n
= 0; n
< (int)mpz_get_si (size
); n
++)
1792 gfc_constructor_append_expr (&array
->value
.constructor
,
1795 : gfc_copy_expr (init
),
1798 array
->shape
= gfc_get_shape (sym
->as
->rank
);
1799 for (n
= 0; n
< sym
->as
->rank
; n
++)
1800 spec_dimen_size (sym
->as
, n
, &array
->shape
[n
]);
1805 init
->rank
= sym
->as
->rank
;
1809 if (sym
->attr
.save
== SAVE_NONE
)
1810 sym
->attr
.save
= SAVE_IMPLICIT
;
1818 /* Function called by variable_decl() that adds a name to a structure
1822 build_struct (const char *name
, gfc_charlen
*cl
, gfc_expr
**init
,
1823 gfc_array_spec
**as
)
1829 /* F03:C438/C439. If the current symbol is of the same derived type that we're
1830 constructing, it must have the pointer attribute. */
1831 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
1832 && current_ts
.u
.derived
== gfc_current_block ()
1833 && current_attr
.pointer
== 0)
1835 gfc_error ("Component at %C must have the POINTER attribute");
1839 if (gfc_current_block ()->attr
.pointer
&& (*as
)->rank
!= 0)
1841 if ((*as
)->type
!= AS_DEFERRED
&& (*as
)->type
!= AS_EXPLICIT
)
1843 gfc_error ("Array component of structure at %C must have explicit "
1844 "or deferred shape");
1849 /* If we are in a nested union/map definition, gfc_add_component will not
1850 properly find repeated components because:
1851 (i) gfc_add_component does a flat search, where components of unions
1852 and maps are implicity chained so nested components may conflict.
1853 (ii) Unions and maps are not linked as components of their parent
1854 structures until after they are parsed.
1855 For (i) we use gfc_find_component which searches recursively, and for (ii)
1856 we search each block directly from the parse stack until we find the top
1859 s
= gfc_state_stack
;
1860 if (s
->state
== COMP_UNION
|| s
->state
== COMP_MAP
)
1862 while (s
->state
== COMP_UNION
|| gfc_comp_struct (s
->state
))
1864 c
= gfc_find_component (s
->sym
, name
, true, true, NULL
);
1867 gfc_error_now ("Component '%s' at %C already declared at %L",
1871 /* Break after we've searched the entire chain. */
1872 if (s
->state
== COMP_DERIVED
|| s
->state
== COMP_STRUCTURE
)
1878 if (!gfc_add_component (gfc_current_block(), name
, &c
))
1882 if (c
->ts
.type
== BT_CHARACTER
)
1884 c
->attr
= current_attr
;
1886 c
->initializer
= *init
;
1893 c
->attr
.codimension
= 1;
1895 c
->attr
.dimension
= 1;
1899 /* Should this ever get more complicated, combine with similar section
1900 in add_init_expr_to_sym into a separate function. */
1901 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.pointer
&& c
->initializer
1903 && c
->ts
.u
.cl
->length
&& c
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1907 gcc_assert (c
->ts
.u
.cl
&& c
->ts
.u
.cl
->length
);
1908 gcc_assert (c
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
);
1909 gcc_assert (c
->ts
.u
.cl
->length
->ts
.type
== BT_INTEGER
);
1911 len
= mpz_get_si (c
->ts
.u
.cl
->length
->value
.integer
);
1913 if (c
->initializer
->expr_type
== EXPR_CONSTANT
)
1914 gfc_set_constant_character_len (len
, c
->initializer
, -1);
1915 else if (mpz_cmp (c
->ts
.u
.cl
->length
->value
.integer
,
1916 c
->initializer
->ts
.u
.cl
->length
->value
.integer
))
1918 gfc_constructor
*ctor
;
1919 ctor
= gfc_constructor_first (c
->initializer
->value
.constructor
);
1924 bool has_ts
= (c
->initializer
->ts
.u
.cl
1925 && c
->initializer
->ts
.u
.cl
->length_from_typespec
);
1927 /* Remember the length of the first element for checking
1928 that all elements *in the constructor* have the same
1929 length. This need not be the length of the LHS! */
1930 gcc_assert (ctor
->expr
->expr_type
== EXPR_CONSTANT
);
1931 gcc_assert (ctor
->expr
->ts
.type
== BT_CHARACTER
);
1932 first_len
= ctor
->expr
->value
.character
.length
;
1934 for ( ; ctor
; ctor
= gfc_constructor_next (ctor
))
1935 if (ctor
->expr
->expr_type
== EXPR_CONSTANT
)
1937 gfc_set_constant_character_len (len
, ctor
->expr
,
1938 has_ts
? -1 : first_len
);
1939 ctor
->expr
->ts
.u
.cl
->length
= gfc_copy_expr (c
->ts
.u
.cl
->length
);
1945 /* Check array components. */
1946 if (!c
->attr
.dimension
)
1949 if (c
->attr
.pointer
)
1951 if (c
->as
->type
!= AS_DEFERRED
)
1953 gfc_error ("Pointer array component of structure at %C must have a "
1958 else if (c
->attr
.allocatable
)
1960 if (c
->as
->type
!= AS_DEFERRED
)
1962 gfc_error ("Allocatable component of structure at %C must have a "
1969 if (c
->as
->type
!= AS_EXPLICIT
)
1971 gfc_error ("Array component of structure at %C must have an "
1978 if (c
->ts
.type
== BT_CLASS
)
1980 bool t2
= gfc_build_class_symbol (&c
->ts
, &c
->attr
, &c
->as
);
1990 /* Match a 'NULL()', and possibly take care of some side effects. */
1993 gfc_match_null (gfc_expr
**result
)
1996 match m
, m2
= MATCH_NO
;
1998 if ((m
= gfc_match (" null ( )")) == MATCH_ERROR
)
2004 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2006 if ((m2
= gfc_match (" null (")) != MATCH_YES
)
2009 old_loc
= gfc_current_locus
;
2010 if ((m2
= gfc_match (" %n ) ", name
)) == MATCH_ERROR
)
2013 && ((m2
= gfc_match (" mold = %n )", name
)) == MATCH_ERROR
))
2017 gfc_current_locus
= old_loc
;
2022 /* The NULL symbol now has to be/become an intrinsic function. */
2023 if (gfc_get_symbol ("null", NULL
, &sym
))
2025 gfc_error ("NULL() initialization at %C is ambiguous");
2029 gfc_intrinsic_symbol (sym
);
2031 if (sym
->attr
.proc
!= PROC_INTRINSIC
2032 && !(sym
->attr
.use_assoc
&& sym
->attr
.intrinsic
)
2033 && (!gfc_add_procedure(&sym
->attr
, PROC_INTRINSIC
, sym
->name
, NULL
)
2034 || !gfc_add_function (&sym
->attr
, sym
->name
, NULL
)))
2037 *result
= gfc_get_null_expr (&gfc_current_locus
);
2039 /* Invalid per F2008, C512. */
2040 if (m2
== MATCH_YES
)
2042 gfc_error ("NULL() initialization at %C may not have MOLD");
2050 /* Match the initialization expr for a data pointer or procedure pointer. */
2053 match_pointer_init (gfc_expr
**init
, int procptr
)
2057 if (gfc_pure (NULL
) && !gfc_comp_struct (gfc_state_stack
->state
))
2059 gfc_error ("Initialization of pointer at %C is not allowed in "
2060 "a PURE procedure");
2063 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
2065 /* Match NULL() initialization. */
2066 m
= gfc_match_null (init
);
2070 /* Match non-NULL initialization. */
2071 gfc_matching_ptr_assignment
= !procptr
;
2072 gfc_matching_procptr_assignment
= procptr
;
2073 m
= gfc_match_rvalue (init
);
2074 gfc_matching_ptr_assignment
= 0;
2075 gfc_matching_procptr_assignment
= 0;
2076 if (m
== MATCH_ERROR
)
2078 else if (m
== MATCH_NO
)
2080 gfc_error ("Error in pointer initialization at %C");
2084 if (!procptr
&& !gfc_resolve_expr (*init
))
2087 if (!gfc_notify_std (GFC_STD_F2008
, "non-NULL pointer "
2088 "initialization at %C"))
2096 check_function_name (char *name
)
2098 /* In functions that have a RESULT variable defined, the function name always
2099 refers to function calls. Therefore, the name is not allowed to appear in
2100 specification statements. When checking this, be careful about
2101 'hidden' procedure pointer results ('ppr@'). */
2103 if (gfc_current_state () == COMP_FUNCTION
)
2105 gfc_symbol
*block
= gfc_current_block ();
2106 if (block
&& block
->result
&& block
->result
!= block
2107 && strcmp (block
->result
->name
, "ppr@") != 0
2108 && strcmp (block
->name
, name
) == 0)
2110 gfc_error ("Function name %qs not allowed at %C", name
);
2119 /* Match a variable name with an optional initializer. When this
2120 subroutine is called, a variable is expected to be parsed next.
2121 Depending on what is happening at the moment, updates either the
2122 symbol table or the current interface. */
2125 variable_decl (int elem
)
2127 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2128 gfc_expr
*initializer
, *char_len
;
2130 gfc_array_spec
*cp_as
; /* Extra copy for Cray Pointees. */
2142 /* When we get here, we've just matched a list of attributes and
2143 maybe a type and a double colon. The next thing we expect to see
2144 is the name of the symbol. */
2145 m
= gfc_match_name (name
);
2149 var_locus
= gfc_current_locus
;
2151 /* Now we could see the optional array spec. or character length. */
2152 m
= gfc_match_array_spec (&as
, true, true);
2153 if (m
== MATCH_ERROR
)
2157 as
= gfc_copy_array_spec (current_as
);
2159 && !merge_array_spec (current_as
, as
, true))
2165 if (flag_cray_pointer
)
2166 cp_as
= gfc_copy_array_spec (as
);
2168 /* At this point, we know for sure if the symbol is PARAMETER and can thus
2169 determine (and check) whether it can be implied-shape. If it
2170 was parsed as assumed-size, change it because PARAMETERs can not
2174 if (as
->type
== AS_IMPLIED_SHAPE
&& current_attr
.flavor
!= FL_PARAMETER
)
2177 gfc_error ("Non-PARAMETER symbol %qs at %L can't be implied-shape",
2182 if (as
->type
== AS_ASSUMED_SIZE
&& as
->rank
== 1
2183 && current_attr
.flavor
== FL_PARAMETER
)
2184 as
->type
= AS_IMPLIED_SHAPE
;
2186 if (as
->type
== AS_IMPLIED_SHAPE
2187 && !gfc_notify_std (GFC_STD_F2008
, "Implied-shape array at %L",
2197 cl_deferred
= false;
2199 if (current_ts
.type
== BT_CHARACTER
)
2201 switch (match_char_length (&char_len
, &cl_deferred
, false))
2204 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2206 cl
->length
= char_len
;
2209 /* Non-constant lengths need to be copied after the first
2210 element. Also copy assumed lengths. */
2213 && (current_ts
.u
.cl
->length
== NULL
2214 || current_ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
2216 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2217 cl
->length
= gfc_copy_expr (current_ts
.u
.cl
->length
);
2220 cl
= current_ts
.u
.cl
;
2222 cl_deferred
= current_ts
.deferred
;
2231 /* The dummy arguments and result of the abreviated form of MODULE
2232 PROCEDUREs, used in SUBMODULES should not be redefined. */
2233 if (gfc_current_ns
->proc_name
2234 && gfc_current_ns
->proc_name
->abr_modproc_decl
)
2236 gfc_find_symbol (name
, gfc_current_ns
, 1, &sym
);
2237 if (sym
!= NULL
&& (sym
->attr
.dummy
|| sym
->attr
.result
))
2240 gfc_error ("%qs at %C is a redefinition of the declaration "
2241 "in the corresponding interface for MODULE "
2242 "PROCEDURE %qs", sym
->name
,
2243 gfc_current_ns
->proc_name
->name
);
2248 /* If this symbol has already shown up in a Cray Pointer declaration,
2249 and this is not a component declaration,
2250 then we want to set the type & bail out. */
2251 if (flag_cray_pointer
&& !gfc_comp_struct (gfc_current_state ()))
2253 gfc_find_symbol (name
, gfc_current_ns
, 1, &sym
);
2254 if (sym
!= NULL
&& sym
->attr
.cray_pointee
)
2256 sym
->ts
.type
= current_ts
.type
;
2257 sym
->ts
.kind
= current_ts
.kind
;
2259 sym
->ts
.u
.derived
= current_ts
.u
.derived
;
2260 sym
->ts
.is_c_interop
= current_ts
.is_c_interop
;
2261 sym
->ts
.is_iso_c
= current_ts
.is_iso_c
;
2264 /* Check to see if we have an array specification. */
2267 if (sym
->as
!= NULL
)
2269 gfc_error ("Duplicate array spec for Cray pointee at %C");
2270 gfc_free_array_spec (cp_as
);
2276 if (!gfc_set_array_spec (sym
, cp_as
, &var_locus
))
2277 gfc_internal_error ("Couldn't set pointee array spec.");
2279 /* Fix the array spec. */
2280 m
= gfc_mod_pointee_as (sym
->as
);
2281 if (m
== MATCH_ERROR
)
2289 gfc_free_array_spec (cp_as
);
2293 /* Procedure pointer as function result. */
2294 if (gfc_current_state () == COMP_FUNCTION
2295 && strcmp ("ppr@", gfc_current_block ()->name
) == 0
2296 && strcmp (name
, gfc_current_block ()->ns
->proc_name
->name
) == 0)
2297 strcpy (name
, "ppr@");
2299 if (gfc_current_state () == COMP_FUNCTION
2300 && strcmp (name
, gfc_current_block ()->name
) == 0
2301 && gfc_current_block ()->result
2302 && strcmp ("ppr@", gfc_current_block ()->result
->name
) == 0)
2303 strcpy (name
, "ppr@");
2305 /* OK, we've successfully matched the declaration. Now put the
2306 symbol in the current namespace, because it might be used in the
2307 optional initialization expression for this symbol, e.g. this is
2310 integer, parameter :: i = huge(i)
2312 This is only true for parameters or variables of a basic type.
2313 For components of derived types, it is not true, so we don't
2314 create a symbol for those yet. If we fail to create the symbol,
2316 if (!gfc_comp_struct (gfc_current_state ())
2317 && !build_sym (name
, cl
, cl_deferred
, &as
, &var_locus
))
2323 if (!check_function_name (name
))
2329 /* We allow old-style initializations of the form
2330 integer i /2/, j(4) /3*3, 1/
2331 (if no colon has been seen). These are different from data
2332 statements in that initializers are only allowed to apply to the
2333 variable immediately preceding, i.e.
2335 is not allowed. Therefore we have to do some work manually, that
2336 could otherwise be left to the matchers for DATA statements. */
2338 if (!colon_seen
&& gfc_match (" /") == MATCH_YES
)
2340 if (!gfc_notify_std (GFC_STD_GNU
, "Old-style "
2341 "initialization at %C"))
2344 /* Allow old style initializations for components of STRUCTUREs and MAPs
2345 but not components of derived types. */
2346 else if (gfc_current_state () == COMP_DERIVED
)
2348 gfc_error ("Invalid old style initialization for derived type "
2354 /* For structure components, read the initializer as a special
2355 expression and let the rest of this function apply the initializer
2357 else if (gfc_comp_struct (gfc_current_state ()))
2359 m
= match_clist_expr (&initializer
, ¤t_ts
, as
);
2361 gfc_error ("Syntax error in old style initialization of %s at %C",
2367 /* Otherwise we treat the old style initialization just like a
2368 DATA declaration for the current variable. */
2370 return match_old_style_init (name
);
2373 /* The double colon must be present in order to have initializers.
2374 Otherwise the statement is ambiguous with an assignment statement. */
2377 if (gfc_match (" =>") == MATCH_YES
)
2379 if (!current_attr
.pointer
)
2381 gfc_error ("Initialization at %C isn't for a pointer variable");
2386 m
= match_pointer_init (&initializer
, 0);
2390 else if (gfc_match_char ('=') == MATCH_YES
)
2392 if (current_attr
.pointer
)
2394 gfc_error ("Pointer initialization at %C requires %<=>%>, "
2400 m
= gfc_match_init_expr (&initializer
);
2403 gfc_error ("Expected an initialization expression at %C");
2407 if (current_attr
.flavor
!= FL_PARAMETER
&& gfc_pure (NULL
)
2408 && !gfc_comp_struct (gfc_state_stack
->state
))
2410 gfc_error ("Initialization of variable at %C is not allowed in "
2411 "a PURE procedure");
2415 if (current_attr
.flavor
!= FL_PARAMETER
2416 && !gfc_comp_struct (gfc_state_stack
->state
))
2417 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
2424 if (initializer
!= NULL
&& current_attr
.allocatable
2425 && gfc_comp_struct (gfc_current_state ()))
2427 gfc_error ("Initialization of allocatable component at %C is not "
2433 /* Add the initializer. Note that it is fine if initializer is
2434 NULL here, because we sometimes also need to check if a
2435 declaration *must* have an initialization expression. */
2436 if (!gfc_comp_struct (gfc_current_state ()))
2437 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
2440 if (current_ts
.type
== BT_DERIVED
2441 && !current_attr
.pointer
&& !initializer
)
2442 initializer
= gfc_default_initializer (¤t_ts
);
2443 t
= build_struct (name
, cl
, &initializer
, &as
);
2445 /* If we match a nested structure definition we expect to see the
2446 * body even if the variable declarations blow up, so we need to keep
2447 * the structure declaration around. */
2448 if (gfc_new_block
&& gfc_new_block
->attr
.flavor
== FL_STRUCT
)
2449 gfc_commit_symbol (gfc_new_block
);
2452 m
= (t
) ? MATCH_YES
: MATCH_ERROR
;
2455 /* Free stuff up and return. */
2456 gfc_free_expr (initializer
);
2457 gfc_free_array_spec (as
);
2463 /* Match an extended-f77 "TYPESPEC*bytesize"-style kind specification.
2464 This assumes that the byte size is equal to the kind number for
2465 non-COMPLEX types, and equal to twice the kind number for COMPLEX. */
2468 gfc_match_old_kind_spec (gfc_typespec
*ts
)
2473 if (gfc_match_char ('*') != MATCH_YES
)
2476 m
= gfc_match_small_literal_int (&ts
->kind
, NULL
);
2480 original_kind
= ts
->kind
;
2482 /* Massage the kind numbers for complex types. */
2483 if (ts
->type
== BT_COMPLEX
)
2487 gfc_error ("Old-style type declaration %s*%d not supported at %C",
2488 gfc_basic_typename (ts
->type
), original_kind
);
2495 if (ts
->type
== BT_INTEGER
&& ts
->kind
== 4 && flag_integer4_kind
== 8)
2498 if (ts
->type
== BT_REAL
|| ts
->type
== BT_COMPLEX
)
2502 if (flag_real4_kind
== 8)
2504 if (flag_real4_kind
== 10)
2506 if (flag_real4_kind
== 16)
2512 if (flag_real8_kind
== 4)
2514 if (flag_real8_kind
== 10)
2516 if (flag_real8_kind
== 16)
2521 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
2523 gfc_error ("Old-style type declaration %s*%d not supported at %C",
2524 gfc_basic_typename (ts
->type
), original_kind
);
2528 if (!gfc_notify_std (GFC_STD_GNU
,
2529 "Nonstandard type declaration %s*%d at %C",
2530 gfc_basic_typename(ts
->type
), original_kind
))
2537 /* Match a kind specification. Since kinds are generally optional, we
2538 usually return MATCH_NO if something goes wrong. If a "kind="
2539 string is found, then we know we have an error. */
2542 gfc_match_kind_spec (gfc_typespec
*ts
, bool kind_expr_only
)
2554 where
= loc
= gfc_current_locus
;
2559 if (gfc_match_char ('(') == MATCH_NO
)
2562 /* Also gobbles optional text. */
2563 if (gfc_match (" kind = ") == MATCH_YES
)
2566 loc
= gfc_current_locus
;
2569 n
= gfc_match_init_expr (&e
);
2573 if (gfc_matching_function
)
2575 /* The function kind expression might include use associated or
2576 imported parameters and try again after the specification
2578 if (gfc_match_char (')') != MATCH_YES
)
2580 gfc_error ("Missing right parenthesis at %C");
2586 gfc_undo_symbols ();
2591 /* ....or else, the match is real. */
2593 gfc_error ("Expected initialization expression at %C");
2601 gfc_error ("Expected scalar initialization expression at %C");
2606 msg
= gfc_extract_int (e
, &ts
->kind
);
2615 /* Before throwing away the expression, let's see if we had a
2616 C interoperable kind (and store the fact). */
2617 if (e
->ts
.is_c_interop
== 1)
2619 /* Mark this as C interoperable if being declared with one
2620 of the named constants from iso_c_binding. */
2621 ts
->is_c_interop
= e
->ts
.is_iso_c
;
2622 ts
->f90_type
= e
->ts
.f90_type
;
2628 /* Ignore errors to this point, if we've gotten here. This means
2629 we ignore the m=MATCH_ERROR from above. */
2630 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
2632 gfc_error ("Kind %d not supported for type %s at %C", ts
->kind
,
2633 gfc_basic_typename (ts
->type
));
2634 gfc_current_locus
= where
;
2638 /* Warn if, e.g., c_int is used for a REAL variable, but not
2639 if, e.g., c_double is used for COMPLEX as the standard
2640 explicitly says that the kind type parameter for complex and real
2641 variable is the same, i.e. c_float == c_float_complex. */
2642 if (ts
->f90_type
!= BT_UNKNOWN
&& ts
->f90_type
!= ts
->type
2643 && !((ts
->f90_type
== BT_REAL
&& ts
->type
== BT_COMPLEX
)
2644 || (ts
->f90_type
== BT_COMPLEX
&& ts
->type
== BT_REAL
)))
2645 gfc_warning_now (0, "C kind type parameter is for type %s but type at %L "
2646 "is %s", gfc_basic_typename (ts
->f90_type
), &where
,
2647 gfc_basic_typename (ts
->type
));
2649 gfc_gobble_whitespace ();
2650 if ((c
= gfc_next_ascii_char ()) != ')'
2651 && (ts
->type
!= BT_CHARACTER
|| c
!= ','))
2653 if (ts
->type
== BT_CHARACTER
)
2654 gfc_error ("Missing right parenthesis or comma at %C");
2656 gfc_error ("Missing right parenthesis at %C");
2660 /* All tests passed. */
2663 if(m
== MATCH_ERROR
)
2664 gfc_current_locus
= where
;
2666 if (ts
->type
== BT_INTEGER
&& ts
->kind
== 4 && flag_integer4_kind
== 8)
2669 if (ts
->type
== BT_REAL
|| ts
->type
== BT_COMPLEX
)
2673 if (flag_real4_kind
== 8)
2675 if (flag_real4_kind
== 10)
2677 if (flag_real4_kind
== 16)
2683 if (flag_real8_kind
== 4)
2685 if (flag_real8_kind
== 10)
2687 if (flag_real8_kind
== 16)
2692 /* Return what we know from the test(s). */
2697 gfc_current_locus
= where
;
2703 match_char_kind (int * kind
, int * is_iso_c
)
2712 where
= gfc_current_locus
;
2714 n
= gfc_match_init_expr (&e
);
2716 if (n
!= MATCH_YES
&& gfc_matching_function
)
2718 /* The expression might include use-associated or imported
2719 parameters and try again after the specification
2722 gfc_undo_symbols ();
2727 gfc_error ("Expected initialization expression at %C");
2733 gfc_error ("Expected scalar initialization expression at %C");
2738 msg
= gfc_extract_int (e
, kind
);
2739 *is_iso_c
= e
->ts
.is_iso_c
;
2749 /* Ignore errors to this point, if we've gotten here. This means
2750 we ignore the m=MATCH_ERROR from above. */
2751 if (gfc_validate_kind (BT_CHARACTER
, *kind
, true) < 0)
2753 gfc_error ("Kind %d is not supported for CHARACTER at %C", *kind
);
2757 /* All tests passed. */
2760 if (m
== MATCH_ERROR
)
2761 gfc_current_locus
= where
;
2763 /* Return what we know from the test(s). */
2768 gfc_current_locus
= where
;
2773 /* Match the various kind/length specifications in a CHARACTER
2774 declaration. We don't return MATCH_NO. */
2777 gfc_match_char_spec (gfc_typespec
*ts
)
2779 int kind
, seen_length
, is_iso_c
;
2791 /* Try the old-style specification first. */
2792 old_char_selector
= 0;
2794 m
= match_char_length (&len
, &deferred
, true);
2798 old_char_selector
= 1;
2803 m
= gfc_match_char ('(');
2806 m
= MATCH_YES
; /* Character without length is a single char. */
2810 /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ). */
2811 if (gfc_match (" kind =") == MATCH_YES
)
2813 m
= match_char_kind (&kind
, &is_iso_c
);
2815 if (m
== MATCH_ERROR
)
2820 if (gfc_match (" , len =") == MATCH_NO
)
2823 m
= char_len_param_value (&len
, &deferred
);
2826 if (m
== MATCH_ERROR
)
2833 /* Try to match "LEN = <len-param>" or "LEN = <len-param>, KIND = <int>". */
2834 if (gfc_match (" len =") == MATCH_YES
)
2836 m
= char_len_param_value (&len
, &deferred
);
2839 if (m
== MATCH_ERROR
)
2843 if (gfc_match_char (')') == MATCH_YES
)
2846 if (gfc_match (" , kind =") != MATCH_YES
)
2849 if (match_char_kind (&kind
, &is_iso_c
) == MATCH_ERROR
)
2855 /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ). */
2856 m
= char_len_param_value (&len
, &deferred
);
2859 if (m
== MATCH_ERROR
)
2863 m
= gfc_match_char (')');
2867 if (gfc_match_char (',') != MATCH_YES
)
2870 gfc_match (" kind ="); /* Gobble optional text. */
2872 m
= match_char_kind (&kind
, &is_iso_c
);
2873 if (m
== MATCH_ERROR
)
2879 /* Require a right-paren at this point. */
2880 m
= gfc_match_char (')');
2885 gfc_error ("Syntax error in CHARACTER declaration at %C");
2887 gfc_free_expr (len
);
2891 /* Deal with character functions after USE and IMPORT statements. */
2892 if (gfc_matching_function
)
2894 gfc_free_expr (len
);
2895 gfc_undo_symbols ();
2901 gfc_free_expr (len
);
2905 /* Do some final massaging of the length values. */
2906 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2908 if (seen_length
== 0)
2909 cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
2914 ts
->kind
= kind
== 0 ? gfc_default_character_kind
: kind
;
2915 ts
->deferred
= deferred
;
2917 /* We have to know if it was a C interoperable kind so we can
2918 do accurate type checking of bind(c) procs, etc. */
2920 /* Mark this as C interoperable if being declared with one
2921 of the named constants from iso_c_binding. */
2922 ts
->is_c_interop
= is_iso_c
;
2923 else if (len
!= NULL
)
2924 /* Here, we might have parsed something such as: character(c_char)
2925 In this case, the parsing code above grabs the c_char when
2926 looking for the length (line 1690, roughly). it's the last
2927 testcase for parsing the kind params of a character variable.
2928 However, it's not actually the length. this seems like it
2930 To see if the user used a C interop kind, test the expr
2931 of the so called length, and see if it's C interoperable. */
2932 ts
->is_c_interop
= len
->ts
.is_iso_c
;
2938 /* Matches a RECORD declaration. */
2941 match_record_decl (const char *name
)
2944 old_loc
= gfc_current_locus
;
2946 if (gfc_match (" record") == MATCH_YES
)
2948 if (!gfc_option
.flag_dec_structure
)
2950 gfc_current_locus
= old_loc
;
2951 gfc_error ("RECORD at %C is an extension, enable it with "
2955 if (gfc_match (" /%n/", name
) != MATCH_YES
)
2957 gfc_error ("Structure name expected after RECORD at %C");
2958 gfc_current_locus
= old_loc
;
2964 gfc_current_locus
= old_loc
;
2968 /* Matches a declaration-type-spec (F03:R502). If successful, sets the ts
2969 structure to the matched specification. This is necessary for FUNCTION and
2970 IMPLICIT statements.
2972 If implicit_flag is nonzero, then we don't check for the optional
2973 kind specification. Not doing so is needed for matching an IMPLICIT
2974 statement correctly. */
2977 gfc_match_decl_type_spec (gfc_typespec
*ts
, int implicit_flag
)
2979 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2980 gfc_symbol
*sym
, *dt_sym
;
2983 bool seen_deferred_kind
, matched_type
;
2984 const char *dt_name
;
2986 /* A belt and braces check that the typespec is correctly being treated
2987 as a deferred characteristic association. */
2988 seen_deferred_kind
= (gfc_current_state () == COMP_FUNCTION
)
2989 && (gfc_current_block ()->result
->ts
.kind
== -1)
2990 && (ts
->kind
== -1);
2992 if (seen_deferred_kind
)
2995 /* Clear the current binding label, in case one is given. */
2996 curr_binding_label
= NULL
;
2998 if (gfc_match (" byte") == MATCH_YES
)
3000 if (!gfc_notify_std (GFC_STD_GNU
, "BYTE type at %C"))
3003 if (gfc_validate_kind (BT_INTEGER
, 1, true) < 0)
3005 gfc_error ("BYTE type used at %C "
3006 "is not available on the target machine");
3010 ts
->type
= BT_INTEGER
;
3016 m
= gfc_match (" type (");
3017 matched_type
= (m
== MATCH_YES
);
3020 gfc_gobble_whitespace ();
3021 if (gfc_peek_ascii_char () == '*')
3023 if ((m
= gfc_match ("*)")) != MATCH_YES
)
3025 if (gfc_comp_struct (gfc_current_state ()))
3027 gfc_error ("Assumed type at %C is not allowed for components");
3030 if (!gfc_notify_std (GFC_STD_F2008_TS
, "Assumed type "
3033 ts
->type
= BT_ASSUMED
;
3037 m
= gfc_match ("%n", name
);
3038 matched_type
= (m
== MATCH_YES
);
3041 if ((matched_type
&& strcmp ("integer", name
) == 0)
3042 || (!matched_type
&& gfc_match (" integer") == MATCH_YES
))
3044 ts
->type
= BT_INTEGER
;
3045 ts
->kind
= gfc_default_integer_kind
;
3049 if ((matched_type
&& strcmp ("character", name
) == 0)
3050 || (!matched_type
&& gfc_match (" character") == MATCH_YES
))
3053 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
3054 "intrinsic-type-spec at %C"))
3057 ts
->type
= BT_CHARACTER
;
3058 if (implicit_flag
== 0)
3059 m
= gfc_match_char_spec (ts
);
3063 if (matched_type
&& m
== MATCH_YES
&& gfc_match_char (')') != MATCH_YES
)
3069 if ((matched_type
&& strcmp ("real", name
) == 0)
3070 || (!matched_type
&& gfc_match (" real") == MATCH_YES
))
3073 ts
->kind
= gfc_default_real_kind
;
3078 && (strcmp ("doubleprecision", name
) == 0
3079 || (strcmp ("double", name
) == 0
3080 && gfc_match (" precision") == MATCH_YES
)))
3081 || (!matched_type
&& gfc_match (" double precision") == MATCH_YES
))
3084 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
3085 "intrinsic-type-spec at %C"))
3087 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
3091 ts
->kind
= gfc_default_double_kind
;
3095 if ((matched_type
&& strcmp ("complex", name
) == 0)
3096 || (!matched_type
&& gfc_match (" complex") == MATCH_YES
))
3098 ts
->type
= BT_COMPLEX
;
3099 ts
->kind
= gfc_default_complex_kind
;
3104 && (strcmp ("doublecomplex", name
) == 0
3105 || (strcmp ("double", name
) == 0
3106 && gfc_match (" complex") == MATCH_YES
)))
3107 || (!matched_type
&& gfc_match (" double complex") == MATCH_YES
))
3109 if (!gfc_notify_std (GFC_STD_GNU
, "DOUBLE COMPLEX at %C"))
3113 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
3114 "intrinsic-type-spec at %C"))
3117 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
3120 ts
->type
= BT_COMPLEX
;
3121 ts
->kind
= gfc_default_double_kind
;
3125 if ((matched_type
&& strcmp ("logical", name
) == 0)
3126 || (!matched_type
&& gfc_match (" logical") == MATCH_YES
))
3128 ts
->type
= BT_LOGICAL
;
3129 ts
->kind
= gfc_default_logical_kind
;
3134 m
= gfc_match_char (')');
3137 m
= match_record_decl (name
);
3139 if (matched_type
|| m
== MATCH_YES
)
3141 ts
->type
= BT_DERIVED
;
3142 /* We accept record/s/ or type(s) where s is a structure, but we
3143 * don't need all the extra derived-type stuff for structures. */
3144 if (gfc_find_symbol (gfc_dt_upper_string (name
), NULL
, 1, &sym
))
3146 gfc_error ("Type name '%s' at %C is ambiguous", name
);
3149 if (sym
&& sym
->attr
.flavor
== FL_STRUCT
)
3151 ts
->u
.derived
= sym
;
3154 /* Actually a derived type. */
3159 /* Match nested STRUCTURE declarations; only valid within another
3160 structure declaration. */
3161 m
= gfc_match (" structure");
3162 if (m
== MATCH_ERROR
)
3164 else if (m
== MATCH_YES
)
3166 if ( gfc_current_state () != COMP_STRUCTURE
3167 && gfc_current_state () != COMP_MAP
)
3170 m
= gfc_match_structure_decl ();
3173 /* gfc_new_block is updated by match_structure_decl. */
3174 ts
->type
= BT_DERIVED
;
3175 ts
->u
.derived
= gfc_new_block
;
3181 /* Match CLASS declarations. */
3182 m
= gfc_match (" class ( * )");
3183 if (m
== MATCH_ERROR
)
3185 else if (m
== MATCH_YES
)
3189 ts
->type
= BT_CLASS
;
3190 gfc_find_symbol ("STAR", gfc_current_ns
, 1, &upe
);
3193 upe
= gfc_new_symbol ("STAR", gfc_current_ns
);
3194 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "STAR");
3196 gfc_set_sym_referenced (upe
);
3198 upe
->ts
.type
= BT_VOID
;
3199 upe
->attr
.unlimited_polymorphic
= 1;
3200 /* This is essential to force the construction of
3201 unlimited polymorphic component class containers. */
3202 upe
->attr
.zero_comp
= 1;
3203 if (!gfc_add_flavor (&upe
->attr
, FL_DERIVED
, NULL
,
3204 &gfc_current_locus
))
3209 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, "STAR");
3211 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "STAR");
3215 ts
->u
.derived
= upe
;
3219 m
= gfc_match (" class ( %n )", name
);
3222 ts
->type
= BT_CLASS
;
3224 if (!gfc_notify_std (GFC_STD_F2003
, "CLASS statement at %C"))
3228 /* Defer association of the derived type until the end of the
3229 specification block. However, if the derived type can be
3230 found, add it to the typespec. */
3231 if (gfc_matching_function
)
3233 ts
->u
.derived
= NULL
;
3234 if (gfc_current_state () != COMP_INTERFACE
3235 && !gfc_find_symbol (name
, NULL
, 1, &sym
) && sym
)
3237 sym
= gfc_find_dt_in_generic (sym
);
3238 ts
->u
.derived
= sym
;
3243 /* Search for the name but allow the components to be defined later. If
3244 type = -1, this typespec has been seen in a function declaration but
3245 the type could not be accessed at that point. The actual derived type is
3246 stored in a symtree with the first letter of the name capitalized; the
3247 symtree with the all lower-case name contains the associated
3248 generic function. */
3249 dt_name
= gfc_dt_upper_string (name
);
3254 gfc_get_ha_symbol (name
, &sym
);
3255 if (sym
->generic
&& gfc_find_symbol (dt_name
, NULL
, 0, &dt_sym
))
3257 gfc_error ("Type name %qs at %C is ambiguous", name
);
3260 if (sym
->generic
&& !dt_sym
)
3261 dt_sym
= gfc_find_dt_in_generic (sym
);
3263 else if (ts
->kind
== -1)
3265 int iface
= gfc_state_stack
->previous
->state
!= COMP_INTERFACE
3266 || gfc_current_ns
->has_import_set
;
3267 gfc_find_symbol (name
, NULL
, iface
, &sym
);
3268 if (sym
&& sym
->generic
&& gfc_find_symbol (dt_name
, NULL
, 1, &dt_sym
))
3270 gfc_error ("Type name %qs at %C is ambiguous", name
);
3273 if (sym
&& sym
->generic
&& !dt_sym
)
3274 dt_sym
= gfc_find_dt_in_generic (sym
);
3281 if ((sym
->attr
.flavor
!= FL_UNKNOWN
&& sym
->attr
.flavor
!= FL_STRUCT
3282 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.generic
))
3283 || sym
->attr
.subroutine
)
3285 gfc_error ("Type name %qs at %C conflicts with previously declared "
3286 "entity at %L, which has the same name", name
,
3291 gfc_save_symbol_data (sym
);
3292 gfc_set_sym_referenced (sym
);
3293 if (!sym
->attr
.generic
3294 && !gfc_add_generic (&sym
->attr
, sym
->name
, NULL
))
3297 if (!sym
->attr
.function
3298 && !gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
3303 gfc_interface
*intr
, *head
;
3305 /* Use upper case to save the actual derived-type symbol. */
3306 gfc_get_symbol (dt_name
, NULL
, &dt_sym
);
3307 dt_sym
->name
= gfc_get_string (sym
->name
);
3308 head
= sym
->generic
;
3309 intr
= gfc_get_interface ();
3311 intr
->where
= gfc_current_locus
;
3313 sym
->generic
= intr
;
3314 sym
->attr
.if_source
= IFSRC_DECL
;
3317 gfc_save_symbol_data (dt_sym
);
3319 gfc_set_sym_referenced (dt_sym
);
3321 if (dt_sym
->attr
.flavor
!= FL_DERIVED
&& dt_sym
->attr
.flavor
!= FL_STRUCT
3322 && !gfc_add_flavor (&dt_sym
->attr
, FL_DERIVED
, sym
->name
, NULL
))
3325 ts
->u
.derived
= dt_sym
;
3331 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
3332 "intrinsic-type-spec at %C"))
3335 /* For all types except double, derived and character, look for an
3336 optional kind specifier. MATCH_NO is actually OK at this point. */
3337 if (implicit_flag
== 1)
3339 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
3345 if (gfc_current_form
== FORM_FREE
)
3347 c
= gfc_peek_ascii_char ();
3348 if (!gfc_is_whitespace (c
) && c
!= '*' && c
!= '('
3349 && c
!= ':' && c
!= ',')
3351 if (matched_type
&& c
== ')')
3353 gfc_next_ascii_char ();
3360 m
= gfc_match_kind_spec (ts
, false);
3361 if (m
== MATCH_NO
&& ts
->type
!= BT_CHARACTER
)
3363 m
= gfc_match_old_kind_spec (ts
);
3364 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) == -1)
3368 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
3371 /* Defer association of the KIND expression of function results
3372 until after USE and IMPORT statements. */
3373 if ((gfc_current_state () == COMP_NONE
&& gfc_error_flag_test ())
3374 || gfc_matching_function
)
3378 m
= MATCH_YES
; /* No kind specifier found. */
3384 /* Match an IMPLICIT NONE statement. Actually, this statement is
3385 already matched in parse.c, or we would not end up here in the
3386 first place. So the only thing we need to check, is if there is
3387 trailing garbage. If not, the match is successful. */
3390 gfc_match_implicit_none (void)
3394 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3396 bool external
= false;
3397 locus cur_loc
= gfc_current_locus
;
3399 if (gfc_current_ns
->seen_implicit_none
3400 || gfc_current_ns
->has_implicit_none_export
)
3402 gfc_error ("Duplicate IMPLICIT NONE statement at %C");
3406 gfc_gobble_whitespace ();
3407 c
= gfc_peek_ascii_char ();
3410 (void) gfc_next_ascii_char ();
3411 if (!gfc_notify_std (GFC_STD_F2015
, "IMPORT NONE with spec list at %C"))
3414 gfc_gobble_whitespace ();
3415 if (gfc_peek_ascii_char () == ')')
3417 (void) gfc_next_ascii_char ();
3423 m
= gfc_match (" %n", name
);
3427 if (strcmp (name
, "type") == 0)
3429 else if (strcmp (name
, "external") == 0)
3434 gfc_gobble_whitespace ();
3435 c
= gfc_next_ascii_char ();
3446 if (gfc_match_eos () != MATCH_YES
)
3449 gfc_set_implicit_none (type
, external
, &cur_loc
);
3455 /* Match the letter range(s) of an IMPLICIT statement. */
3458 match_implicit_range (void)
3464 cur_loc
= gfc_current_locus
;
3466 gfc_gobble_whitespace ();
3467 c
= gfc_next_ascii_char ();
3470 gfc_error ("Missing character range in IMPLICIT at %C");
3477 gfc_gobble_whitespace ();
3478 c1
= gfc_next_ascii_char ();
3482 gfc_gobble_whitespace ();
3483 c
= gfc_next_ascii_char ();
3488 inner
= 0; /* Fall through. */
3495 gfc_gobble_whitespace ();
3496 c2
= gfc_next_ascii_char ();
3500 gfc_gobble_whitespace ();
3501 c
= gfc_next_ascii_char ();
3503 if ((c
!= ',') && (c
!= ')'))
3516 gfc_error ("Letters must be in alphabetic order in "
3517 "IMPLICIT statement at %C");
3521 /* See if we can add the newly matched range to the pending
3522 implicits from this IMPLICIT statement. We do not check for
3523 conflicts with whatever earlier IMPLICIT statements may have
3524 set. This is done when we've successfully finished matching
3526 if (!gfc_add_new_implicit_range (c1
, c2
))
3533 gfc_syntax_error (ST_IMPLICIT
);
3535 gfc_current_locus
= cur_loc
;
3540 /* Match an IMPLICIT statement, storing the types for
3541 gfc_set_implicit() if the statement is accepted by the parser.
3542 There is a strange looking, but legal syntactic construction
3543 possible. It looks like:
3545 IMPLICIT INTEGER (a-b) (c-d)
3547 This is legal if "a-b" is a constant expression that happens to
3548 equal one of the legal kinds for integers. The real problem
3549 happens with an implicit specification that looks like:
3551 IMPLICIT INTEGER (a-b)
3553 In this case, a typespec matcher that is "greedy" (as most of the
3554 matchers are) gobbles the character range as a kindspec, leaving
3555 nothing left. We therefore have to go a bit more slowly in the
3556 matching process by inhibiting the kindspec checking during
3557 typespec matching and checking for a kind later. */
3560 gfc_match_implicit (void)
3567 if (gfc_current_ns
->seen_implicit_none
)
3569 gfc_error ("IMPLICIT statement at %C following an IMPLICIT NONE (type) "
3576 /* We don't allow empty implicit statements. */
3577 if (gfc_match_eos () == MATCH_YES
)
3579 gfc_error ("Empty IMPLICIT statement at %C");
3585 /* First cleanup. */
3586 gfc_clear_new_implicit ();
3588 /* A basic type is mandatory here. */
3589 m
= gfc_match_decl_type_spec (&ts
, 1);
3590 if (m
== MATCH_ERROR
)
3595 cur_loc
= gfc_current_locus
;
3596 m
= match_implicit_range ();
3600 /* We may have <TYPE> (<RANGE>). */
3601 gfc_gobble_whitespace ();
3602 c
= gfc_peek_ascii_char ();
3603 if (c
== ',' || c
== '\n' || c
== ';' || c
== '!')
3605 /* Check for CHARACTER with no length parameter. */
3606 if (ts
.type
== BT_CHARACTER
&& !ts
.u
.cl
)
3608 ts
.kind
= gfc_default_character_kind
;
3609 ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
3610 ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
,
3614 /* Record the Successful match. */
3615 if (!gfc_merge_new_implicit (&ts
))
3618 c
= gfc_next_ascii_char ();
3619 else if (gfc_match_eos () == MATCH_ERROR
)
3624 gfc_current_locus
= cur_loc
;
3627 /* Discard the (incorrectly) matched range. */
3628 gfc_clear_new_implicit ();
3630 /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
3631 if (ts
.type
== BT_CHARACTER
)
3632 m
= gfc_match_char_spec (&ts
);
3635 m
= gfc_match_kind_spec (&ts
, false);
3638 m
= gfc_match_old_kind_spec (&ts
);
3639 if (m
== MATCH_ERROR
)
3645 if (m
== MATCH_ERROR
)
3648 m
= match_implicit_range ();
3649 if (m
== MATCH_ERROR
)
3654 gfc_gobble_whitespace ();
3655 c
= gfc_next_ascii_char ();
3656 if (c
!= ',' && gfc_match_eos () != MATCH_YES
)
3659 if (!gfc_merge_new_implicit (&ts
))
3667 gfc_syntax_error (ST_IMPLICIT
);
3675 gfc_match_import (void)
3677 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3682 if (gfc_current_ns
->proc_name
== NULL
3683 || gfc_current_ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
3685 gfc_error ("IMPORT statement at %C only permitted in "
3686 "an INTERFACE body");
3690 if (gfc_current_ns
->proc_name
->attr
.module_procedure
)
3692 gfc_error ("F2008: C1210 IMPORT statement at %C is not permitted "
3693 "in a module procedure interface body");
3697 if (!gfc_notify_std (GFC_STD_F2003
, "IMPORT statement at %C"))
3700 if (gfc_match_eos () == MATCH_YES
)
3702 /* All host variables should be imported. */
3703 gfc_current_ns
->has_import_set
= 1;
3707 if (gfc_match (" ::") == MATCH_YES
)
3709 if (gfc_match_eos () == MATCH_YES
)
3711 gfc_error ("Expecting list of named entities at %C");
3719 m
= gfc_match (" %n", name
);
3723 if (gfc_current_ns
->parent
!= NULL
3724 && gfc_find_symbol (name
, gfc_current_ns
->parent
, 1, &sym
))
3726 gfc_error ("Type name %qs at %C is ambiguous", name
);
3729 else if (!sym
&& gfc_current_ns
->proc_name
->ns
->parent
!= NULL
3730 && gfc_find_symbol (name
,
3731 gfc_current_ns
->proc_name
->ns
->parent
,
3734 gfc_error ("Type name %qs at %C is ambiguous", name
);
3740 gfc_error ("Cannot IMPORT %qs from host scoping unit "
3741 "at %C - does not exist.", name
);
3745 if (gfc_find_symtree (gfc_current_ns
->sym_root
, name
))
3747 gfc_warning (0, "%qs is already IMPORTed from host scoping unit "
3752 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, name
);
3755 sym
->attr
.imported
= 1;
3757 if (sym
->attr
.generic
&& (sym
= gfc_find_dt_in_generic (sym
)))
3759 /* The actual derived type is stored in a symtree with the first
3760 letter of the name capitalized; the symtree with the all
3761 lower-case name contains the associated generic function. */
3762 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
,
3763 gfc_dt_upper_string (name
));
3766 sym
->attr
.imported
= 1;
3779 if (gfc_match_eos () == MATCH_YES
)
3781 if (gfc_match_char (',') != MATCH_YES
)
3788 gfc_error ("Syntax error in IMPORT statement at %C");
3793 /* A minimal implementation of gfc_match without whitespace, escape
3794 characters or variable arguments. Returns true if the next
3795 characters match the TARGET template exactly. */
3798 match_string_p (const char *target
)
3802 for (p
= target
; *p
; p
++)
3803 if ((char) gfc_next_ascii_char () != *p
)
3808 /* Matches an attribute specification including array specs. If
3809 successful, leaves the variables current_attr and current_as
3810 holding the specification. Also sets the colon_seen variable for
3811 later use by matchers associated with initializations.
3813 This subroutine is a little tricky in the sense that we don't know
3814 if we really have an attr-spec until we hit the double colon.
3815 Until that time, we can only return MATCH_NO. This forces us to
3816 check for duplicate specification at this level. */
3819 match_attr_spec (void)
3821 /* Modifiers that can exist in a type statement. */
3823 { GFC_DECL_BEGIN
= 0,
3824 DECL_ALLOCATABLE
= GFC_DECL_BEGIN
, DECL_DIMENSION
, DECL_EXTERNAL
,
3825 DECL_IN
, DECL_OUT
, DECL_INOUT
, DECL_INTRINSIC
, DECL_OPTIONAL
,
3826 DECL_PARAMETER
, DECL_POINTER
, DECL_PROTECTED
, DECL_PRIVATE
,
3827 DECL_PUBLIC
, DECL_SAVE
, DECL_TARGET
, DECL_VALUE
, DECL_VOLATILE
,
3828 DECL_IS_BIND_C
, DECL_CODIMENSION
, DECL_ASYNCHRONOUS
, DECL_CONTIGUOUS
,
3829 DECL_NONE
, GFC_DECL_END
/* Sentinel */
3832 /* GFC_DECL_END is the sentinel, index starts at 0. */
3833 #define NUM_DECL GFC_DECL_END
3835 locus start
, seen_at
[NUM_DECL
];
3842 gfc_clear_attr (¤t_attr
);
3843 start
= gfc_current_locus
;
3848 /* See if we get all of the keywords up to the final double colon. */
3849 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
3857 gfc_gobble_whitespace ();
3859 ch
= gfc_next_ascii_char ();
3862 /* This is the successful exit condition for the loop. */
3863 if (gfc_next_ascii_char () == ':')
3868 gfc_gobble_whitespace ();
3869 switch (gfc_peek_ascii_char ())
3872 gfc_next_ascii_char ();
3873 switch (gfc_next_ascii_char ())
3876 if (match_string_p ("locatable"))
3878 /* Matched "allocatable". */
3879 d
= DECL_ALLOCATABLE
;
3884 if (match_string_p ("ynchronous"))
3886 /* Matched "asynchronous". */
3887 d
= DECL_ASYNCHRONOUS
;
3894 /* Try and match the bind(c). */
3895 m
= gfc_match_bind_c (NULL
, true);
3898 else if (m
== MATCH_ERROR
)
3903 gfc_next_ascii_char ();
3904 if ('o' != gfc_next_ascii_char ())
3906 switch (gfc_next_ascii_char ())
3909 if (match_string_p ("imension"))
3911 d
= DECL_CODIMENSION
;
3915 if (match_string_p ("tiguous"))
3917 d
= DECL_CONTIGUOUS
;
3924 if (match_string_p ("dimension"))
3929 if (match_string_p ("external"))
3934 if (match_string_p ("int"))
3936 ch
= gfc_next_ascii_char ();
3939 if (match_string_p ("nt"))
3941 /* Matched "intent". */
3942 /* TODO: Call match_intent_spec from here. */
3943 if (gfc_match (" ( in out )") == MATCH_YES
)
3945 else if (gfc_match (" ( in )") == MATCH_YES
)
3947 else if (gfc_match (" ( out )") == MATCH_YES
)
3953 if (match_string_p ("insic"))
3955 /* Matched "intrinsic". */
3963 if (match_string_p ("optional"))
3968 gfc_next_ascii_char ();
3969 switch (gfc_next_ascii_char ())
3972 if (match_string_p ("rameter"))
3974 /* Matched "parameter". */
3980 if (match_string_p ("inter"))
3982 /* Matched "pointer". */
3988 ch
= gfc_next_ascii_char ();
3991 if (match_string_p ("vate"))
3993 /* Matched "private". */
3999 if (match_string_p ("tected"))
4001 /* Matched "protected". */
4008 if (match_string_p ("blic"))
4010 /* Matched "public". */
4018 if (match_string_p ("save"))
4023 if (match_string_p ("target"))
4028 gfc_next_ascii_char ();
4029 ch
= gfc_next_ascii_char ();
4032 if (match_string_p ("lue"))
4034 /* Matched "value". */
4040 if (match_string_p ("latile"))
4042 /* Matched "volatile". */
4050 /* No double colon and no recognizable decl_type, so assume that
4051 we've been looking at something else the whole time. */
4058 /* Check to make sure any parens are paired up correctly. */
4059 if (gfc_match_parens () == MATCH_ERROR
)
4066 seen_at
[d
] = gfc_current_locus
;
4068 if (d
== DECL_DIMENSION
|| d
== DECL_CODIMENSION
)
4070 gfc_array_spec
*as
= NULL
;
4072 m
= gfc_match_array_spec (&as
, d
== DECL_DIMENSION
,
4073 d
== DECL_CODIMENSION
);
4075 if (current_as
== NULL
)
4077 else if (m
== MATCH_YES
)
4079 if (!merge_array_spec (as
, current_as
, false))
4086 if (d
== DECL_CODIMENSION
)
4087 gfc_error ("Missing codimension specification at %C");
4089 gfc_error ("Missing dimension specification at %C");
4093 if (m
== MATCH_ERROR
)
4098 /* Since we've seen a double colon, we have to be looking at an
4099 attr-spec. This means that we can now issue errors. */
4100 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
4105 case DECL_ALLOCATABLE
:
4106 attr
= "ALLOCATABLE";
4108 case DECL_ASYNCHRONOUS
:
4109 attr
= "ASYNCHRONOUS";
4111 case DECL_CODIMENSION
:
4112 attr
= "CODIMENSION";
4114 case DECL_CONTIGUOUS
:
4115 attr
= "CONTIGUOUS";
4117 case DECL_DIMENSION
:
4124 attr
= "INTENT (IN)";
4127 attr
= "INTENT (OUT)";
4130 attr
= "INTENT (IN OUT)";
4132 case DECL_INTRINSIC
:
4138 case DECL_PARAMETER
:
4144 case DECL_PROTECTED
:
4159 case DECL_IS_BIND_C
:
4169 attr
= NULL
; /* This shouldn't happen. */
4172 gfc_error ("Duplicate %s attribute at %L", attr
, &seen_at
[d
]);
4177 /* Now that we've dealt with duplicate attributes, add the attributes
4178 to the current attribute. */
4179 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
4184 if (gfc_current_state () == COMP_DERIVED
4185 && d
!= DECL_DIMENSION
&& d
!= DECL_CODIMENSION
4186 && d
!= DECL_POINTER
&& d
!= DECL_PRIVATE
4187 && d
!= DECL_PUBLIC
&& d
!= DECL_CONTIGUOUS
&& d
!= DECL_NONE
)
4189 if (d
== DECL_ALLOCATABLE
)
4191 if (!gfc_notify_std (GFC_STD_F2003
, "ALLOCATABLE "
4192 "attribute at %C in a TYPE definition"))
4200 gfc_error ("Attribute at %L is not allowed in a TYPE definition",
4207 if ((d
== DECL_PRIVATE
|| d
== DECL_PUBLIC
)
4208 && gfc_current_state () != COMP_MODULE
)
4210 if (d
== DECL_PRIVATE
)
4214 if (gfc_current_state () == COMP_DERIVED
4215 && gfc_state_stack
->previous
4216 && gfc_state_stack
->previous
->state
== COMP_MODULE
)
4218 if (!gfc_notify_std (GFC_STD_F2003
, "Attribute %s "
4219 "at %L in a TYPE definition", attr
,
4228 gfc_error ("%s attribute at %L is not allowed outside of the "
4229 "specification part of a module", attr
, &seen_at
[d
]);
4237 case DECL_ALLOCATABLE
:
4238 t
= gfc_add_allocatable (¤t_attr
, &seen_at
[d
]);
4241 case DECL_ASYNCHRONOUS
:
4242 if (!gfc_notify_std (GFC_STD_F2003
, "ASYNCHRONOUS attribute at %C"))
4245 t
= gfc_add_asynchronous (¤t_attr
, NULL
, &seen_at
[d
]);
4248 case DECL_CODIMENSION
:
4249 t
= gfc_add_codimension (¤t_attr
, NULL
, &seen_at
[d
]);
4252 case DECL_CONTIGUOUS
:
4253 if (!gfc_notify_std (GFC_STD_F2008
, "CONTIGUOUS attribute at %C"))
4256 t
= gfc_add_contiguous (¤t_attr
, NULL
, &seen_at
[d
]);
4259 case DECL_DIMENSION
:
4260 t
= gfc_add_dimension (¤t_attr
, NULL
, &seen_at
[d
]);
4264 t
= gfc_add_external (¤t_attr
, &seen_at
[d
]);
4268 t
= gfc_add_intent (¤t_attr
, INTENT_IN
, &seen_at
[d
]);
4272 t
= gfc_add_intent (¤t_attr
, INTENT_OUT
, &seen_at
[d
]);
4276 t
= gfc_add_intent (¤t_attr
, INTENT_INOUT
, &seen_at
[d
]);
4279 case DECL_INTRINSIC
:
4280 t
= gfc_add_intrinsic (¤t_attr
, &seen_at
[d
]);
4284 t
= gfc_add_optional (¤t_attr
, &seen_at
[d
]);
4287 case DECL_PARAMETER
:
4288 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, &seen_at
[d
]);
4292 t
= gfc_add_pointer (¤t_attr
, &seen_at
[d
]);
4295 case DECL_PROTECTED
:
4296 if (gfc_current_state () != COMP_MODULE
4297 || (gfc_current_ns
->proc_name
4298 && gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
))
4300 gfc_error ("PROTECTED at %C only allowed in specification "
4301 "part of a module");
4306 if (!gfc_notify_std (GFC_STD_F2003
, "PROTECTED attribute at %C"))
4309 t
= gfc_add_protected (¤t_attr
, NULL
, &seen_at
[d
]);
4313 t
= gfc_add_access (¤t_attr
, ACCESS_PRIVATE
, NULL
,
4318 t
= gfc_add_access (¤t_attr
, ACCESS_PUBLIC
, NULL
,
4323 t
= gfc_add_save (¤t_attr
, SAVE_EXPLICIT
, NULL
, &seen_at
[d
]);
4327 t
= gfc_add_target (¤t_attr
, &seen_at
[d
]);
4330 case DECL_IS_BIND_C
:
4331 t
= gfc_add_is_bind_c(¤t_attr
, NULL
, &seen_at
[d
], 0);
4335 if (!gfc_notify_std (GFC_STD_F2003
, "VALUE attribute at %C"))
4338 t
= gfc_add_value (¤t_attr
, NULL
, &seen_at
[d
]);
4342 if (!gfc_notify_std (GFC_STD_F2003
, "VOLATILE attribute at %C"))
4345 t
= gfc_add_volatile (¤t_attr
, NULL
, &seen_at
[d
]);
4349 gfc_internal_error ("match_attr_spec(): Bad attribute");
4359 /* Since Fortran 2008 module variables implicitly have the SAVE attribute. */
4360 if ((gfc_current_state () == COMP_MODULE
4361 || gfc_current_state () == COMP_SUBMODULE
)
4362 && !current_attr
.save
4363 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
4364 current_attr
.save
= SAVE_IMPLICIT
;
4370 gfc_current_locus
= start
;
4371 gfc_free_array_spec (current_as
);
4377 /* Set the binding label, dest_label, either with the binding label
4378 stored in the given gfc_typespec, ts, or if none was provided, it
4379 will be the symbol name in all lower case, as required by the draft
4380 (J3/04-007, section 15.4.1). If a binding label was given and
4381 there is more than one argument (num_idents), it is an error. */
4384 set_binding_label (const char **dest_label
, const char *sym_name
,
4387 if (num_idents
> 1 && has_name_equals
)
4389 gfc_error ("Multiple identifiers provided with "
4390 "single NAME= specifier at %C");
4394 if (curr_binding_label
)
4395 /* Binding label given; store in temp holder till have sym. */
4396 *dest_label
= curr_binding_label
;
4399 /* No binding label given, and the NAME= specifier did not exist,
4400 which means there was no NAME="". */
4401 if (sym_name
!= NULL
&& has_name_equals
== 0)
4402 *dest_label
= IDENTIFIER_POINTER (get_identifier (sym_name
));
4409 /* Set the status of the given common block as being BIND(C) or not,
4410 depending on the given parameter, is_bind_c. */
4413 set_com_block_bind_c (gfc_common_head
*com_block
, int is_bind_c
)
4415 com_block
->is_bind_c
= is_bind_c
;
4420 /* Verify that the given gfc_typespec is for a C interoperable type. */
4423 gfc_verify_c_interop (gfc_typespec
*ts
)
4425 if (ts
->type
== BT_DERIVED
&& ts
->u
.derived
!= NULL
)
4426 return (ts
->u
.derived
->ts
.is_c_interop
|| ts
->u
.derived
->attr
.is_bind_c
)
4428 else if (ts
->type
== BT_CLASS
)
4430 else if (ts
->is_c_interop
!= 1 && ts
->type
!= BT_ASSUMED
)
4437 /* Verify that the variables of a given common block, which has been
4438 defined with the attribute specifier bind(c), to be of a C
4439 interoperable type. Errors will be reported here, if
4443 verify_com_block_vars_c_interop (gfc_common_head
*com_block
)
4445 gfc_symbol
*curr_sym
= NULL
;
4448 curr_sym
= com_block
->head
;
4450 /* Make sure we have at least one symbol. */
4451 if (curr_sym
== NULL
)
4454 /* Here we know we have a symbol, so we'll execute this loop
4458 /* The second to last param, 1, says this is in a common block. */
4459 retval
= verify_bind_c_sym (curr_sym
, &(curr_sym
->ts
), 1, com_block
);
4460 curr_sym
= curr_sym
->common_next
;
4461 } while (curr_sym
!= NULL
);
4467 /* Verify that a given BIND(C) symbol is C interoperable. If it is not,
4468 an appropriate error message is reported. */
4471 verify_bind_c_sym (gfc_symbol
*tmp_sym
, gfc_typespec
*ts
,
4472 int is_in_common
, gfc_common_head
*com_block
)
4474 bool bind_c_function
= false;
4477 if (tmp_sym
->attr
.function
&& tmp_sym
->attr
.is_bind_c
)
4478 bind_c_function
= true;
4480 if (tmp_sym
->attr
.function
&& tmp_sym
->result
!= NULL
)
4482 tmp_sym
= tmp_sym
->result
;
4483 /* Make sure it wasn't an implicitly typed result. */
4484 if (tmp_sym
->attr
.implicit_type
&& warn_c_binding_type
)
4486 gfc_warning (OPT_Wc_binding_type
,
4487 "Implicitly declared BIND(C) function %qs at "
4488 "%L may not be C interoperable", tmp_sym
->name
,
4489 &tmp_sym
->declared_at
);
4490 tmp_sym
->ts
.f90_type
= tmp_sym
->ts
.type
;
4491 /* Mark it as C interoperable to prevent duplicate warnings. */
4492 tmp_sym
->ts
.is_c_interop
= 1;
4493 tmp_sym
->attr
.is_c_interop
= 1;
4497 /* Here, we know we have the bind(c) attribute, so if we have
4498 enough type info, then verify that it's a C interop kind.
4499 The info could be in the symbol already, or possibly still in
4500 the given ts (current_ts), so look in both. */
4501 if (tmp_sym
->ts
.type
!= BT_UNKNOWN
|| ts
->type
!= BT_UNKNOWN
)
4503 if (!gfc_verify_c_interop (&(tmp_sym
->ts
)))
4505 /* See if we're dealing with a sym in a common block or not. */
4506 if (is_in_common
== 1 && warn_c_binding_type
)
4508 gfc_warning (OPT_Wc_binding_type
,
4509 "Variable %qs in common block %qs at %L "
4510 "may not be a C interoperable "
4511 "kind though common block %qs is BIND(C)",
4512 tmp_sym
->name
, com_block
->name
,
4513 &(tmp_sym
->declared_at
), com_block
->name
);
4517 if (tmp_sym
->ts
.type
== BT_DERIVED
|| ts
->type
== BT_DERIVED
)
4518 gfc_error ("Type declaration %qs at %L is not C "
4519 "interoperable but it is BIND(C)",
4520 tmp_sym
->name
, &(tmp_sym
->declared_at
));
4521 else if (warn_c_binding_type
)
4522 gfc_warning (OPT_Wc_binding_type
, "Variable %qs at %L "
4523 "may not be a C interoperable "
4524 "kind but it is BIND(C)",
4525 tmp_sym
->name
, &(tmp_sym
->declared_at
));
4529 /* Variables declared w/in a common block can't be bind(c)
4530 since there's no way for C to see these variables, so there's
4531 semantically no reason for the attribute. */
4532 if (is_in_common
== 1 && tmp_sym
->attr
.is_bind_c
== 1)
4534 gfc_error ("Variable %qs in common block %qs at "
4535 "%L cannot be declared with BIND(C) "
4536 "since it is not a global",
4537 tmp_sym
->name
, com_block
->name
,
4538 &(tmp_sym
->declared_at
));
4542 /* Scalar variables that are bind(c) can not have the pointer
4543 or allocatable attributes. */
4544 if (tmp_sym
->attr
.is_bind_c
== 1)
4546 if (tmp_sym
->attr
.pointer
== 1)
4548 gfc_error ("Variable %qs at %L cannot have both the "
4549 "POINTER and BIND(C) attributes",
4550 tmp_sym
->name
, &(tmp_sym
->declared_at
));
4554 if (tmp_sym
->attr
.allocatable
== 1)
4556 gfc_error ("Variable %qs at %L cannot have both the "
4557 "ALLOCATABLE and BIND(C) attributes",
4558 tmp_sym
->name
, &(tmp_sym
->declared_at
));
4564 /* If it is a BIND(C) function, make sure the return value is a
4565 scalar value. The previous tests in this function made sure
4566 the type is interoperable. */
4567 if (bind_c_function
&& tmp_sym
->as
!= NULL
)
4568 gfc_error ("Return type of BIND(C) function %qs at %L cannot "
4569 "be an array", tmp_sym
->name
, &(tmp_sym
->declared_at
));
4571 /* BIND(C) functions can not return a character string. */
4572 if (bind_c_function
&& tmp_sym
->ts
.type
== BT_CHARACTER
)
4573 if (tmp_sym
->ts
.u
.cl
== NULL
|| tmp_sym
->ts
.u
.cl
->length
== NULL
4574 || tmp_sym
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
4575 || mpz_cmp_si (tmp_sym
->ts
.u
.cl
->length
->value
.integer
, 1) != 0)
4576 gfc_error ("Return type of BIND(C) function %qs at %L cannot "
4577 "be a character string", tmp_sym
->name
,
4578 &(tmp_sym
->declared_at
));
4581 /* See if the symbol has been marked as private. If it has, make sure
4582 there is no binding label and warn the user if there is one. */
4583 if (tmp_sym
->attr
.access
== ACCESS_PRIVATE
4584 && tmp_sym
->binding_label
)
4585 /* Use gfc_warning_now because we won't say that the symbol fails
4586 just because of this. */
4587 gfc_warning_now (0, "Symbol %qs at %L is marked PRIVATE but has been "
4588 "given the binding label %qs", tmp_sym
->name
,
4589 &(tmp_sym
->declared_at
), tmp_sym
->binding_label
);
4595 /* Set the appropriate fields for a symbol that's been declared as
4596 BIND(C) (the is_bind_c flag and the binding label), and verify that
4597 the type is C interoperable. Errors are reported by the functions
4598 used to set/test these fields. */
4601 set_verify_bind_c_sym (gfc_symbol
*tmp_sym
, int num_idents
)
4605 /* TODO: Do we need to make sure the vars aren't marked private? */
4607 /* Set the is_bind_c bit in symbol_attribute. */
4608 gfc_add_is_bind_c (&(tmp_sym
->attr
), tmp_sym
->name
, &gfc_current_locus
, 0);
4610 if (!set_binding_label (&tmp_sym
->binding_label
, tmp_sym
->name
, num_idents
))
4617 /* Set the fields marking the given common block as BIND(C), including
4618 a binding label, and report any errors encountered. */
4621 set_verify_bind_c_com_block (gfc_common_head
*com_block
, int num_idents
)
4625 /* destLabel, common name, typespec (which may have binding label). */
4626 if (!set_binding_label (&com_block
->binding_label
, com_block
->name
,
4630 /* Set the given common block (com_block) to being bind(c) (1). */
4631 set_com_block_bind_c (com_block
, 1);
4637 /* Retrieve the list of one or more identifiers that the given bind(c)
4638 attribute applies to. */
4641 get_bind_c_idents (void)
4643 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4645 gfc_symbol
*tmp_sym
= NULL
;
4647 gfc_common_head
*com_block
= NULL
;
4649 if (gfc_match_name (name
) == MATCH_YES
)
4651 found_id
= MATCH_YES
;
4652 gfc_get_ha_symbol (name
, &tmp_sym
);
4654 else if (match_common_name (name
) == MATCH_YES
)
4656 found_id
= MATCH_YES
;
4657 com_block
= gfc_get_common (name
, 0);
4661 gfc_error ("Need either entity or common block name for "
4662 "attribute specification statement at %C");
4666 /* Save the current identifier and look for more. */
4669 /* Increment the number of identifiers found for this spec stmt. */
4672 /* Make sure we have a sym or com block, and verify that it can
4673 be bind(c). Set the appropriate field(s) and look for more
4675 if (tmp_sym
!= NULL
|| com_block
!= NULL
)
4677 if (tmp_sym
!= NULL
)
4679 if (!set_verify_bind_c_sym (tmp_sym
, num_idents
))
4684 if (!set_verify_bind_c_com_block (com_block
, num_idents
))
4688 /* Look to see if we have another identifier. */
4690 if (gfc_match_eos () == MATCH_YES
)
4691 found_id
= MATCH_NO
;
4692 else if (gfc_match_char (',') != MATCH_YES
)
4693 found_id
= MATCH_NO
;
4694 else if (gfc_match_name (name
) == MATCH_YES
)
4696 found_id
= MATCH_YES
;
4697 gfc_get_ha_symbol (name
, &tmp_sym
);
4699 else if (match_common_name (name
) == MATCH_YES
)
4701 found_id
= MATCH_YES
;
4702 com_block
= gfc_get_common (name
, 0);
4706 gfc_error ("Missing entity or common block name for "
4707 "attribute specification statement at %C");
4713 gfc_internal_error ("Missing symbol");
4715 } while (found_id
== MATCH_YES
);
4717 /* if we get here we were successful */
4722 /* Try and match a BIND(C) attribute specification statement. */
4725 gfc_match_bind_c_stmt (void)
4727 match found_match
= MATCH_NO
;
4732 /* This may not be necessary. */
4734 /* Clear the temporary binding label holder. */
4735 curr_binding_label
= NULL
;
4737 /* Look for the bind(c). */
4738 found_match
= gfc_match_bind_c (NULL
, true);
4740 if (found_match
== MATCH_YES
)
4742 if (!gfc_notify_std (GFC_STD_F2003
, "BIND(C) statement at %C"))
4745 /* Look for the :: now, but it is not required. */
4748 /* Get the identifier(s) that needs to be updated. This may need to
4749 change to hand the flag(s) for the attr specified so all identifiers
4750 found can have all appropriate parts updated (assuming that the same
4751 spec stmt can have multiple attrs, such as both bind(c) and
4753 if (!get_bind_c_idents ())
4754 /* Error message should have printed already. */
4762 /* Match a data declaration statement. */
4765 gfc_match_data_decl (void)
4771 num_idents_on_line
= 0;
4773 m
= gfc_match_decl_type_spec (¤t_ts
, 0);
4777 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
4778 && !gfc_comp_struct (gfc_current_state ()))
4780 sym
= gfc_use_derived (current_ts
.u
.derived
);
4788 current_ts
.u
.derived
= sym
;
4791 m
= match_attr_spec ();
4792 if (m
== MATCH_ERROR
)
4798 if (current_ts
.type
== BT_CLASS
4799 && current_ts
.u
.derived
->attr
.unlimited_polymorphic
)
4802 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
4803 && current_ts
.u
.derived
->components
== NULL
4804 && !current_ts
.u
.derived
->attr
.zero_comp
)
4807 if (current_attr
.pointer
&& gfc_comp_struct (gfc_current_state ()))
4810 gfc_find_symbol (current_ts
.u
.derived
->name
,
4811 current_ts
.u
.derived
->ns
, 1, &sym
);
4813 /* Any symbol that we find had better be a type definition
4814 which has its components defined, or be a structure definition
4815 actively being parsed. */
4816 if (sym
!= NULL
&& gfc_fl_struct (sym
->attr
.flavor
)
4817 && (current_ts
.u
.derived
->components
!= NULL
4818 || current_ts
.u
.derived
->attr
.zero_comp
4819 || current_ts
.u
.derived
== gfc_new_block
))
4822 gfc_error ("Derived type at %C has not been previously defined "
4823 "and so cannot appear in a derived type definition");
4829 /* If we have an old-style character declaration, and no new-style
4830 attribute specifications, then there a comma is optional between
4831 the type specification and the variable list. */
4832 if (m
== MATCH_NO
&& current_ts
.type
== BT_CHARACTER
&& old_char_selector
)
4833 gfc_match_char (',');
4835 /* Give the types/attributes to symbols that follow. Give the element
4836 a number so that repeat character length expressions can be copied. */
4840 num_idents_on_line
++;
4841 m
= variable_decl (elem
++);
4842 if (m
== MATCH_ERROR
)
4847 if (gfc_match_eos () == MATCH_YES
)
4849 if (gfc_match_char (',') != MATCH_YES
)
4853 if (!gfc_error_flag_test ())
4854 gfc_error ("Syntax error in data declaration at %C");
4857 gfc_free_data_all (gfc_current_ns
);
4860 gfc_free_array_spec (current_as
);
4866 /* Match a prefix associated with a function or subroutine
4867 declaration. If the typespec pointer is nonnull, then a typespec
4868 can be matched. Note that if nothing matches, MATCH_YES is
4869 returned (the null string was matched). */
4872 gfc_match_prefix (gfc_typespec
*ts
)
4878 gfc_clear_attr (¤t_attr
);
4880 seen_impure
= false;
4882 gcc_assert (!gfc_matching_prefix
);
4883 gfc_matching_prefix
= true;
4887 found_prefix
= false;
4889 /* MODULE is a prefix like PURE, ELEMENTAL, etc., having a
4890 corresponding attribute seems natural and distinguishes these
4891 procedures from procedure types of PROC_MODULE, which these are
4893 if (gfc_match ("module% ") == MATCH_YES
)
4895 if (!gfc_notify_std (GFC_STD_F2008
, "MODULE prefix at %C"))
4898 current_attr
.module_procedure
= 1;
4899 found_prefix
= true;
4902 if (!seen_type
&& ts
!= NULL
4903 && gfc_match_decl_type_spec (ts
, 0) == MATCH_YES
4904 && gfc_match_space () == MATCH_YES
)
4908 found_prefix
= true;
4911 if (gfc_match ("elemental% ") == MATCH_YES
)
4913 if (!gfc_add_elemental (¤t_attr
, NULL
))
4916 found_prefix
= true;
4919 if (gfc_match ("pure% ") == MATCH_YES
)
4921 if (!gfc_add_pure (¤t_attr
, NULL
))
4924 found_prefix
= true;
4927 if (gfc_match ("recursive% ") == MATCH_YES
)
4929 if (!gfc_add_recursive (¤t_attr
, NULL
))
4932 found_prefix
= true;
4935 /* IMPURE is a somewhat special case, as it needs not set an actual
4936 attribute but rather only prevents ELEMENTAL routines from being
4937 automatically PURE. */
4938 if (gfc_match ("impure% ") == MATCH_YES
)
4940 if (!gfc_notify_std (GFC_STD_F2008
, "IMPURE procedure at %C"))
4944 found_prefix
= true;
4947 while (found_prefix
);
4949 /* IMPURE and PURE must not both appear, of course. */
4950 if (seen_impure
&& current_attr
.pure
)
4952 gfc_error ("PURE and IMPURE must not appear both at %C");
4956 /* If IMPURE it not seen but the procedure is ELEMENTAL, mark it as PURE. */
4957 if (!seen_impure
&& current_attr
.elemental
&& !current_attr
.pure
)
4959 if (!gfc_add_pure (¤t_attr
, NULL
))
4963 /* At this point, the next item is not a prefix. */
4964 gcc_assert (gfc_matching_prefix
);
4966 gfc_matching_prefix
= false;
4970 gcc_assert (gfc_matching_prefix
);
4971 gfc_matching_prefix
= false;
4976 /* Copy attributes matched by gfc_match_prefix() to attributes on a symbol. */
4979 copy_prefix (symbol_attribute
*dest
, locus
*where
)
4981 if (current_attr
.pure
&& !gfc_add_pure (dest
, where
))
4984 if (current_attr
.elemental
&& !gfc_add_elemental (dest
, where
))
4987 if (current_attr
.recursive
&& !gfc_add_recursive (dest
, where
))
4994 /* Match a formal argument list. */
4997 gfc_match_formal_arglist (gfc_symbol
*progname
, int st_flag
, int null_flag
)
4999 gfc_formal_arglist
*head
, *tail
, *p
, *q
;
5000 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5003 gfc_formal_arglist
*formal
= NULL
;
5007 /* Keep the interface formal argument list and null it so that the
5008 matching for the new declaration can be done. The numbers and
5009 names of the arguments are checked here. The interface formal
5010 arguments are retained in formal_arglist and the characteristics
5011 are compared in resolve.c(resolve_fl_procedure). See the remark
5012 in get_proc_name about the eventual need to copy the formal_arglist
5013 and populate the formal namespace of the interface symbol. */
5014 if (progname
->attr
.module_procedure
5015 && progname
->attr
.host_assoc
)
5017 formal
= progname
->formal
;
5018 progname
->formal
= NULL
;
5021 if (gfc_match_char ('(') != MATCH_YES
)
5028 if (gfc_match_char (')') == MATCH_YES
)
5033 if (gfc_match_char ('*') == MATCH_YES
)
5036 if (!gfc_notify_std (GFC_STD_F95_OBS
, "Alternate-return argument "
5045 m
= gfc_match_name (name
);
5049 if (gfc_get_symbol (name
, NULL
, &sym
))
5053 p
= gfc_get_formal_arglist ();
5065 /* We don't add the VARIABLE flavor because the name could be a
5066 dummy procedure. We don't apply these attributes to formal
5067 arguments of statement functions. */
5068 if (sym
!= NULL
&& !st_flag
5069 && (!gfc_add_dummy(&sym
->attr
, sym
->name
, NULL
)
5070 || !gfc_missing_attr (&sym
->attr
, NULL
)))
5076 /* The name of a program unit can be in a different namespace,
5077 so check for it explicitly. After the statement is accepted,
5078 the name is checked for especially in gfc_get_symbol(). */
5079 if (gfc_new_block
!= NULL
&& sym
!= NULL
5080 && strcmp (sym
->name
, gfc_new_block
->name
) == 0)
5082 gfc_error ("Name %qs at %C is the name of the procedure",
5088 if (gfc_match_char (')') == MATCH_YES
)
5091 m
= gfc_match_char (',');
5094 gfc_error ("Unexpected junk in formal argument list at %C");
5100 /* Check for duplicate symbols in the formal argument list. */
5103 for (p
= head
; p
->next
; p
= p
->next
)
5108 for (q
= p
->next
; q
; q
= q
->next
)
5109 if (p
->sym
== q
->sym
)
5111 gfc_error ("Duplicate symbol %qs in formal argument list "
5112 "at %C", p
->sym
->name
);
5120 if (!gfc_add_explicit_interface (progname
, IFSRC_DECL
, head
, NULL
))
5126 /* gfc_error_now used in following and return with MATCH_YES because
5127 doing otherwise results in a cascade of extraneous errors and in
5128 some cases an ICE in symbol.c(gfc_release_symbol). */
5129 if (progname
->attr
.module_procedure
&& progname
->attr
.host_assoc
)
5131 bool arg_count_mismatch
= false;
5133 if (!formal
&& head
)
5134 arg_count_mismatch
= true;
5136 /* Abbreviated module procedure declaration is not meant to have any
5137 formal arguments! */
5138 if (!progname
->abr_modproc_decl
&& formal
&& !head
)
5139 arg_count_mismatch
= true;
5141 for (p
= formal
, q
= head
; p
&& q
; p
= p
->next
, q
= q
->next
)
5143 if ((p
->next
!= NULL
&& q
->next
== NULL
)
5144 || (p
->next
== NULL
&& q
->next
!= NULL
))
5145 arg_count_mismatch
= true;
5146 else if ((p
->sym
== NULL
&& q
->sym
== NULL
)
5147 || strcmp (p
->sym
->name
, q
->sym
->name
) == 0)
5150 gfc_error_now ("Mismatch in MODULE PROCEDURE formal "
5151 "argument names (%s/%s) at %C",
5152 p
->sym
->name
, q
->sym
->name
);
5155 if (arg_count_mismatch
)
5156 gfc_error_now ("Mismatch in number of MODULE PROCEDURE "
5157 "formal arguments at %C");
5163 gfc_free_formal_arglist (head
);
5168 /* Match a RESULT specification following a function declaration or
5169 ENTRY statement. Also matches the end-of-statement. */
5172 match_result (gfc_symbol
*function
, gfc_symbol
**result
)
5174 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5178 if (gfc_match (" result (") != MATCH_YES
)
5181 m
= gfc_match_name (name
);
5185 /* Get the right paren, and that's it because there could be the
5186 bind(c) attribute after the result clause. */
5187 if (gfc_match_char (')') != MATCH_YES
)
5189 /* TODO: should report the missing right paren here. */
5193 if (strcmp (function
->name
, name
) == 0)
5195 gfc_error ("RESULT variable at %C must be different than function name");
5199 if (gfc_get_symbol (name
, NULL
, &r
))
5202 if (!gfc_add_result (&r
->attr
, r
->name
, NULL
))
5211 /* Match a function suffix, which could be a combination of a result
5212 clause and BIND(C), either one, or neither. The draft does not
5213 require them to come in a specific order. */
5216 gfc_match_suffix (gfc_symbol
*sym
, gfc_symbol
**result
)
5218 match is_bind_c
; /* Found bind(c). */
5219 match is_result
; /* Found result clause. */
5220 match found_match
; /* Status of whether we've found a good match. */
5221 char peek_char
; /* Character we're going to peek at. */
5222 bool allow_binding_name
;
5224 /* Initialize to having found nothing. */
5225 found_match
= MATCH_NO
;
5226 is_bind_c
= MATCH_NO
;
5227 is_result
= MATCH_NO
;
5229 /* Get the next char to narrow between result and bind(c). */
5230 gfc_gobble_whitespace ();
5231 peek_char
= gfc_peek_ascii_char ();
5233 /* C binding names are not allowed for internal procedures. */
5234 if (gfc_current_state () == COMP_CONTAINS
5235 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
5236 allow_binding_name
= false;
5238 allow_binding_name
= true;
5243 /* Look for result clause. */
5244 is_result
= match_result (sym
, result
);
5245 if (is_result
== MATCH_YES
)
5247 /* Now see if there is a bind(c) after it. */
5248 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
5249 /* We've found the result clause and possibly bind(c). */
5250 found_match
= MATCH_YES
;
5253 /* This should only be MATCH_ERROR. */
5254 found_match
= is_result
;
5257 /* Look for bind(c) first. */
5258 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
5259 if (is_bind_c
== MATCH_YES
)
5261 /* Now see if a result clause followed it. */
5262 is_result
= match_result (sym
, result
);
5263 found_match
= MATCH_YES
;
5267 /* Should only be a MATCH_ERROR if we get here after seeing 'b'. */
5268 found_match
= MATCH_ERROR
;
5272 gfc_error ("Unexpected junk after function declaration at %C");
5273 found_match
= MATCH_ERROR
;
5277 if (is_bind_c
== MATCH_YES
)
5279 /* Fortran 2008 draft allows BIND(C) for internal procedures. */
5280 if (gfc_current_state () == COMP_CONTAINS
5281 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
5282 && !gfc_notify_std (GFC_STD_F2008
, "BIND(C) attribute "
5283 "at %L may not be specified for an internal "
5284 "procedure", &gfc_current_locus
))
5287 if (!gfc_add_is_bind_c (&(sym
->attr
), sym
->name
, &gfc_current_locus
, 1))
5295 /* Procedure pointer return value without RESULT statement:
5296 Add "hidden" result variable named "ppr@". */
5299 add_hidden_procptr_result (gfc_symbol
*sym
)
5303 if (gfc_notification_std (GFC_STD_F2003
) == ERROR
)
5306 /* First usage case: PROCEDURE and EXTERNAL statements. */
5307 case1
= gfc_current_state () == COMP_FUNCTION
&& gfc_current_block ()
5308 && strcmp (gfc_current_block ()->name
, sym
->name
) == 0
5309 && sym
->attr
.external
;
5310 /* Second usage case: INTERFACE statements. */
5311 case2
= gfc_current_state () == COMP_INTERFACE
&& gfc_state_stack
->previous
5312 && gfc_state_stack
->previous
->state
== COMP_FUNCTION
5313 && strcmp (gfc_state_stack
->previous
->sym
->name
, sym
->name
) == 0;
5319 gfc_get_sym_tree ("ppr@", gfc_current_ns
, &stree
, false);
5323 gfc_get_sym_tree ("ppr@", gfc_current_ns
->parent
, &stree
, false);
5324 st2
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "ppr@");
5325 st2
->n
.sym
= stree
->n
.sym
;
5327 sym
->result
= stree
->n
.sym
;
5329 sym
->result
->attr
.proc_pointer
= sym
->attr
.proc_pointer
;
5330 sym
->result
->attr
.pointer
= sym
->attr
.pointer
;
5331 sym
->result
->attr
.external
= sym
->attr
.external
;
5332 sym
->result
->attr
.referenced
= sym
->attr
.referenced
;
5333 sym
->result
->ts
= sym
->ts
;
5334 sym
->attr
.proc_pointer
= 0;
5335 sym
->attr
.pointer
= 0;
5336 sym
->attr
.external
= 0;
5337 if (sym
->result
->attr
.external
&& sym
->result
->attr
.pointer
)
5339 sym
->result
->attr
.pointer
= 0;
5340 sym
->result
->attr
.proc_pointer
= 1;
5343 return gfc_add_result (&sym
->result
->attr
, sym
->result
->name
, NULL
);
5345 /* POINTER after PROCEDURE/EXTERNAL/INTERFACE statement. */
5346 else if (sym
->attr
.function
&& !sym
->attr
.external
&& sym
->attr
.pointer
5347 && sym
->result
&& sym
->result
!= sym
&& sym
->result
->attr
.external
5348 && sym
== gfc_current_ns
->proc_name
5349 && sym
== sym
->result
->ns
->proc_name
5350 && strcmp ("ppr@", sym
->result
->name
) == 0)
5352 sym
->result
->attr
.proc_pointer
= 1;
5353 sym
->attr
.pointer
= 0;
5361 /* Match the interface for a PROCEDURE declaration,
5362 including brackets (R1212). */
5365 match_procedure_interface (gfc_symbol
**proc_if
)
5369 locus old_loc
, entry_loc
;
5370 gfc_namespace
*old_ns
= gfc_current_ns
;
5371 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5373 old_loc
= entry_loc
= gfc_current_locus
;
5374 gfc_clear_ts (¤t_ts
);
5376 if (gfc_match (" (") != MATCH_YES
)
5378 gfc_current_locus
= entry_loc
;
5382 /* Get the type spec. for the procedure interface. */
5383 old_loc
= gfc_current_locus
;
5384 m
= gfc_match_decl_type_spec (¤t_ts
, 0);
5385 gfc_gobble_whitespace ();
5386 if (m
== MATCH_YES
|| (m
== MATCH_NO
&& gfc_peek_ascii_char () == ')'))
5389 if (m
== MATCH_ERROR
)
5392 /* Procedure interface is itself a procedure. */
5393 gfc_current_locus
= old_loc
;
5394 m
= gfc_match_name (name
);
5396 /* First look to see if it is already accessible in the current
5397 namespace because it is use associated or contained. */
5399 if (gfc_find_sym_tree (name
, NULL
, 0, &st
))
5402 /* If it is still not found, then try the parent namespace, if it
5403 exists and create the symbol there if it is still not found. */
5404 if (gfc_current_ns
->parent
)
5405 gfc_current_ns
= gfc_current_ns
->parent
;
5406 if (st
== NULL
&& gfc_get_ha_sym_tree (name
, &st
))
5409 gfc_current_ns
= old_ns
;
5410 *proc_if
= st
->n
.sym
;
5415 /* Resolve interface if possible. That way, attr.procedure is only set
5416 if it is declared by a later procedure-declaration-stmt, which is
5417 invalid per F08:C1216 (cf. resolve_procedure_interface). */
5418 while ((*proc_if
)->ts
.interface
)
5419 *proc_if
= (*proc_if
)->ts
.interface
;
5421 if ((*proc_if
)->attr
.flavor
== FL_UNKNOWN
5422 && (*proc_if
)->ts
.type
== BT_UNKNOWN
5423 && !gfc_add_flavor (&(*proc_if
)->attr
, FL_PROCEDURE
,
5424 (*proc_if
)->name
, NULL
))
5429 if (gfc_match (" )") != MATCH_YES
)
5431 gfc_current_locus
= entry_loc
;
5439 /* Match a PROCEDURE declaration (R1211). */
5442 match_procedure_decl (void)
5445 gfc_symbol
*sym
, *proc_if
= NULL
;
5447 gfc_expr
*initializer
= NULL
;
5449 /* Parse interface (with brackets). */
5450 m
= match_procedure_interface (&proc_if
);
5454 /* Parse attributes (with colons). */
5455 m
= match_attr_spec();
5456 if (m
== MATCH_ERROR
)
5459 if (proc_if
&& proc_if
->attr
.is_bind_c
&& !current_attr
.is_bind_c
)
5461 current_attr
.is_bind_c
= 1;
5462 has_name_equals
= 0;
5463 curr_binding_label
= NULL
;
5466 /* Get procedure symbols. */
5469 m
= gfc_match_symbol (&sym
, 0);
5472 else if (m
== MATCH_ERROR
)
5475 /* Add current_attr to the symbol attributes. */
5476 if (!gfc_copy_attr (&sym
->attr
, ¤t_attr
, NULL
))
5479 if (sym
->attr
.is_bind_c
)
5481 /* Check for C1218. */
5482 if (!proc_if
|| !proc_if
->attr
.is_bind_c
)
5484 gfc_error ("BIND(C) attribute at %C requires "
5485 "an interface with BIND(C)");
5488 /* Check for C1217. */
5489 if (has_name_equals
&& sym
->attr
.pointer
)
5491 gfc_error ("BIND(C) procedure with NAME may not have "
5492 "POINTER attribute at %C");
5495 if (has_name_equals
&& sym
->attr
.dummy
)
5497 gfc_error ("Dummy procedure at %C may not have "
5498 "BIND(C) attribute with NAME");
5501 /* Set binding label for BIND(C). */
5502 if (!set_binding_label (&sym
->binding_label
, sym
->name
, num
))
5506 if (!gfc_add_external (&sym
->attr
, NULL
))
5509 if (add_hidden_procptr_result (sym
))
5512 if (!gfc_add_proc (&sym
->attr
, sym
->name
, NULL
))
5515 /* Set interface. */
5516 if (proc_if
!= NULL
)
5518 if (sym
->ts
.type
!= BT_UNKNOWN
)
5520 gfc_error ("Procedure %qs at %L already has basic type of %s",
5521 sym
->name
, &gfc_current_locus
,
5522 gfc_basic_typename (sym
->ts
.type
));
5525 sym
->ts
.interface
= proc_if
;
5526 sym
->attr
.untyped
= 1;
5527 sym
->attr
.if_source
= IFSRC_IFBODY
;
5529 else if (current_ts
.type
!= BT_UNKNOWN
)
5531 if (!gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
5533 sym
->ts
.interface
= gfc_new_symbol ("", gfc_current_ns
);
5534 sym
->ts
.interface
->ts
= current_ts
;
5535 sym
->ts
.interface
->attr
.flavor
= FL_PROCEDURE
;
5536 sym
->ts
.interface
->attr
.function
= 1;
5537 sym
->attr
.function
= 1;
5538 sym
->attr
.if_source
= IFSRC_UNKNOWN
;
5541 if (gfc_match (" =>") == MATCH_YES
)
5543 if (!current_attr
.pointer
)
5545 gfc_error ("Initialization at %C isn't for a pointer variable");
5550 m
= match_pointer_init (&initializer
, 1);
5554 if (!add_init_expr_to_sym (sym
->name
, &initializer
, &gfc_current_locus
))
5559 if (gfc_match_eos () == MATCH_YES
)
5561 if (gfc_match_char (',') != MATCH_YES
)
5566 gfc_error ("Syntax error in PROCEDURE statement at %C");
5570 /* Free stuff up and return. */
5571 gfc_free_expr (initializer
);
5577 match_binding_attributes (gfc_typebound_proc
* ba
, bool generic
, bool ppc
);
5580 /* Match a procedure pointer component declaration (R445). */
5583 match_ppc_decl (void)
5586 gfc_symbol
*proc_if
= NULL
;
5590 gfc_expr
*initializer
= NULL
;
5591 gfc_typebound_proc
* tb
;
5592 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5594 /* Parse interface (with brackets). */
5595 m
= match_procedure_interface (&proc_if
);
5599 /* Parse attributes. */
5600 tb
= XCNEW (gfc_typebound_proc
);
5601 tb
->where
= gfc_current_locus
;
5602 m
= match_binding_attributes (tb
, false, true);
5603 if (m
== MATCH_ERROR
)
5606 gfc_clear_attr (¤t_attr
);
5607 current_attr
.procedure
= 1;
5608 current_attr
.proc_pointer
= 1;
5609 current_attr
.access
= tb
->access
;
5610 current_attr
.flavor
= FL_PROCEDURE
;
5612 /* Match the colons (required). */
5613 if (gfc_match (" ::") != MATCH_YES
)
5615 gfc_error ("Expected %<::%> after binding-attributes at %C");
5619 /* Check for C450. */
5620 if (!tb
->nopass
&& proc_if
== NULL
)
5622 gfc_error("NOPASS or explicit interface required at %C");
5626 if (!gfc_notify_std (GFC_STD_F2003
, "Procedure pointer component at %C"))
5629 /* Match PPC names. */
5633 m
= gfc_match_name (name
);
5636 else if (m
== MATCH_ERROR
)
5639 if (!gfc_add_component (gfc_current_block(), name
, &c
))
5642 /* Add current_attr to the symbol attributes. */
5643 if (!gfc_copy_attr (&c
->attr
, ¤t_attr
, NULL
))
5646 if (!gfc_add_external (&c
->attr
, NULL
))
5649 if (!gfc_add_proc (&c
->attr
, name
, NULL
))
5656 c
->tb
= XCNEW (gfc_typebound_proc
);
5657 c
->tb
->where
= gfc_current_locus
;
5661 /* Set interface. */
5662 if (proc_if
!= NULL
)
5664 c
->ts
.interface
= proc_if
;
5665 c
->attr
.untyped
= 1;
5666 c
->attr
.if_source
= IFSRC_IFBODY
;
5668 else if (ts
.type
!= BT_UNKNOWN
)
5671 c
->ts
.interface
= gfc_new_symbol ("", gfc_current_ns
);
5672 c
->ts
.interface
->result
= c
->ts
.interface
;
5673 c
->ts
.interface
->ts
= ts
;
5674 c
->ts
.interface
->attr
.flavor
= FL_PROCEDURE
;
5675 c
->ts
.interface
->attr
.function
= 1;
5676 c
->attr
.function
= 1;
5677 c
->attr
.if_source
= IFSRC_UNKNOWN
;
5680 if (gfc_match (" =>") == MATCH_YES
)
5682 m
= match_pointer_init (&initializer
, 1);
5685 gfc_free_expr (initializer
);
5688 c
->initializer
= initializer
;
5691 if (gfc_match_eos () == MATCH_YES
)
5693 if (gfc_match_char (',') != MATCH_YES
)
5698 gfc_error ("Syntax error in procedure pointer component at %C");
5703 /* Match a PROCEDURE declaration inside an interface (R1206). */
5706 match_procedure_in_interface (void)
5710 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5713 if (current_interface
.type
== INTERFACE_NAMELESS
5714 || current_interface
.type
== INTERFACE_ABSTRACT
)
5716 gfc_error ("PROCEDURE at %C must be in a generic interface");
5720 /* Check if the F2008 optional double colon appears. */
5721 gfc_gobble_whitespace ();
5722 old_locus
= gfc_current_locus
;
5723 if (gfc_match ("::") == MATCH_YES
)
5725 if (!gfc_notify_std (GFC_STD_F2008
, "double colon in "
5726 "MODULE PROCEDURE statement at %L", &old_locus
))
5730 gfc_current_locus
= old_locus
;
5734 m
= gfc_match_name (name
);
5737 else if (m
== MATCH_ERROR
)
5739 if (gfc_get_symbol (name
, gfc_current_ns
->parent
, &sym
))
5742 if (!gfc_add_interface (sym
))
5745 if (gfc_match_eos () == MATCH_YES
)
5747 if (gfc_match_char (',') != MATCH_YES
)
5754 gfc_error ("Syntax error in PROCEDURE statement at %C");
5759 /* General matcher for PROCEDURE declarations. */
5761 static match
match_procedure_in_type (void);
5764 gfc_match_procedure (void)
5768 switch (gfc_current_state ())
5773 case COMP_SUBMODULE
:
5774 case COMP_SUBROUTINE
:
5777 m
= match_procedure_decl ();
5779 case COMP_INTERFACE
:
5780 m
= match_procedure_in_interface ();
5783 m
= match_ppc_decl ();
5785 case COMP_DERIVED_CONTAINS
:
5786 m
= match_procedure_in_type ();
5795 if (!gfc_notify_std (GFC_STD_F2003
, "PROCEDURE statement at %C"))
5802 /* Warn if a matched procedure has the same name as an intrinsic; this is
5803 simply a wrapper around gfc_warn_intrinsic_shadow that interprets the current
5804 parser-state-stack to find out whether we're in a module. */
5807 do_warn_intrinsic_shadow (const gfc_symbol
* sym
, bool func
)
5811 in_module
= (gfc_state_stack
->previous
5812 && (gfc_state_stack
->previous
->state
== COMP_MODULE
5813 || gfc_state_stack
->previous
->state
== COMP_SUBMODULE
));
5815 gfc_warn_intrinsic_shadow (sym
, in_module
, func
);
5819 /* Match a function declaration. */
5822 gfc_match_function_decl (void)
5824 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5825 gfc_symbol
*sym
, *result
;
5829 match found_match
; /* Status returned by match func. */
5831 if (gfc_current_state () != COMP_NONE
5832 && gfc_current_state () != COMP_INTERFACE
5833 && gfc_current_state () != COMP_CONTAINS
)
5836 gfc_clear_ts (¤t_ts
);
5838 old_loc
= gfc_current_locus
;
5840 m
= gfc_match_prefix (¤t_ts
);
5843 gfc_current_locus
= old_loc
;
5847 if (gfc_match ("function% %n", name
) != MATCH_YES
)
5849 gfc_current_locus
= old_loc
;
5853 if (get_proc_name (name
, &sym
, false))
5856 if (add_hidden_procptr_result (sym
))
5859 if (current_attr
.module_procedure
)
5860 sym
->attr
.module_procedure
= 1;
5862 gfc_new_block
= sym
;
5864 m
= gfc_match_formal_arglist (sym
, 0, 0);
5867 gfc_error ("Expected formal argument list in function "
5868 "definition at %C");
5872 else if (m
== MATCH_ERROR
)
5877 /* According to the draft, the bind(c) and result clause can
5878 come in either order after the formal_arg_list (i.e., either
5879 can be first, both can exist together or by themselves or neither
5880 one). Therefore, the match_result can't match the end of the
5881 string, and check for the bind(c) or result clause in either order. */
5882 found_match
= gfc_match_eos ();
5884 /* Make sure that it isn't already declared as BIND(C). If it is, it
5885 must have been marked BIND(C) with a BIND(C) attribute and that is
5886 not allowed for procedures. */
5887 if (sym
->attr
.is_bind_c
== 1)
5889 sym
->attr
.is_bind_c
= 0;
5890 if (sym
->old_symbol
!= NULL
)
5891 gfc_error_now ("BIND(C) attribute at %L can only be used for "
5892 "variables or common blocks",
5893 &(sym
->old_symbol
->declared_at
));
5895 gfc_error_now ("BIND(C) attribute at %L can only be used for "
5896 "variables or common blocks", &gfc_current_locus
);
5899 if (found_match
!= MATCH_YES
)
5901 /* If we haven't found the end-of-statement, look for a suffix. */
5902 suffix_match
= gfc_match_suffix (sym
, &result
);
5903 if (suffix_match
== MATCH_YES
)
5904 /* Need to get the eos now. */
5905 found_match
= gfc_match_eos ();
5907 found_match
= suffix_match
;
5910 if(found_match
!= MATCH_YES
)
5914 /* Make changes to the symbol. */
5917 if (!gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
5920 if (!gfc_missing_attr (&sym
->attr
, NULL
))
5923 if (!copy_prefix (&sym
->attr
, &sym
->declared_at
))
5925 if(!sym
->attr
.module_procedure
)
5931 /* Delay matching the function characteristics until after the
5932 specification block by signalling kind=-1. */
5933 sym
->declared_at
= old_loc
;
5934 if (current_ts
.type
!= BT_UNKNOWN
)
5935 current_ts
.kind
= -1;
5937 current_ts
.kind
= 0;
5941 if (current_ts
.type
!= BT_UNKNOWN
5942 && !gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
5948 if (current_ts
.type
!= BT_UNKNOWN
5949 && !gfc_add_type (result
, ¤t_ts
, &gfc_current_locus
))
5951 sym
->result
= result
;
5955 /* Warn if this procedure has the same name as an intrinsic. */
5956 do_warn_intrinsic_shadow (sym
, true);
5962 gfc_current_locus
= old_loc
;
5967 /* This is mostly a copy of parse.c(add_global_procedure) but modified to
5968 pass the name of the entry, rather than the gfc_current_block name, and
5969 to return false upon finding an existing global entry. */
5972 add_global_entry (const char *name
, const char *binding_label
, bool sub
,
5976 enum gfc_symbol_type type
;
5978 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
5980 /* Only in Fortran 2003: For procedures with a binding label also the Fortran
5981 name is a global identifier. */
5982 if (!binding_label
|| gfc_notification_std (GFC_STD_F2008
))
5984 s
= gfc_get_gsymbol (name
);
5986 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= type
))
5988 gfc_global_used (s
, where
);
5997 s
->ns
= gfc_current_ns
;
6001 /* Don't add the symbol multiple times. */
6003 && (!gfc_notification_std (GFC_STD_F2008
)
6004 || strcmp (name
, binding_label
) != 0))
6006 s
= gfc_get_gsymbol (binding_label
);
6008 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= type
))
6010 gfc_global_used (s
, where
);
6017 s
->binding_label
= binding_label
;
6020 s
->ns
= gfc_current_ns
;
6028 /* Match an ENTRY statement. */
6031 gfc_match_entry (void)
6036 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6037 gfc_compile_state state
;
6041 bool module_procedure
;
6045 m
= gfc_match_name (name
);
6049 if (!gfc_notify_std (GFC_STD_F2008_OBS
, "ENTRY statement at %C"))
6052 state
= gfc_current_state ();
6053 if (state
!= COMP_SUBROUTINE
&& state
!= COMP_FUNCTION
)
6058 gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
6061 gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
6063 case COMP_SUBMODULE
:
6064 gfc_error ("ENTRY statement at %C cannot appear within a SUBMODULE");
6066 case COMP_BLOCK_DATA
:
6067 gfc_error ("ENTRY statement at %C cannot appear within "
6070 case COMP_INTERFACE
:
6071 gfc_error ("ENTRY statement at %C cannot appear within "
6074 case COMP_STRUCTURE
:
6075 gfc_error ("ENTRY statement at %C cannot appear within "
6076 "a STRUCTURE block");
6079 gfc_error ("ENTRY statement at %C cannot appear within "
6080 "a DERIVED TYPE block");
6083 gfc_error ("ENTRY statement at %C cannot appear within "
6084 "an IF-THEN block");
6087 case COMP_DO_CONCURRENT
:
6088 gfc_error ("ENTRY statement at %C cannot appear within "
6092 gfc_error ("ENTRY statement at %C cannot appear within "
6096 gfc_error ("ENTRY statement at %C cannot appear within "
6100 gfc_error ("ENTRY statement at %C cannot appear within "
6104 gfc_error ("ENTRY statement at %C cannot appear within "
6105 "a contained subprogram");
6108 gfc_error ("Unexpected ENTRY statement at %C");
6113 if ((state
== COMP_SUBROUTINE
|| state
== COMP_FUNCTION
)
6114 && gfc_state_stack
->previous
->state
== COMP_INTERFACE
)
6116 gfc_error ("ENTRY statement at %C cannot appear within an INTERFACE");
6120 module_procedure
= gfc_current_ns
->parent
!= NULL
6121 && gfc_current_ns
->parent
->proc_name
6122 && gfc_current_ns
->parent
->proc_name
->attr
.flavor
6125 if (gfc_current_ns
->parent
!= NULL
6126 && gfc_current_ns
->parent
->proc_name
6127 && !module_procedure
)
6129 gfc_error("ENTRY statement at %C cannot appear in a "
6130 "contained procedure");
6134 /* Module function entries need special care in get_proc_name
6135 because previous references within the function will have
6136 created symbols attached to the current namespace. */
6137 if (get_proc_name (name
, &entry
,
6138 gfc_current_ns
->parent
!= NULL
6139 && module_procedure
))
6142 proc
= gfc_current_block ();
6144 /* Make sure that it isn't already declared as BIND(C). If it is, it
6145 must have been marked BIND(C) with a BIND(C) attribute and that is
6146 not allowed for procedures. */
6147 if (entry
->attr
.is_bind_c
== 1)
6149 entry
->attr
.is_bind_c
= 0;
6150 if (entry
->old_symbol
!= NULL
)
6151 gfc_error_now ("BIND(C) attribute at %L can only be used for "
6152 "variables or common blocks",
6153 &(entry
->old_symbol
->declared_at
));
6155 gfc_error_now ("BIND(C) attribute at %L can only be used for "
6156 "variables or common blocks", &gfc_current_locus
);
6159 /* Check what next non-whitespace character is so we can tell if there
6160 is the required parens if we have a BIND(C). */
6161 old_loc
= gfc_current_locus
;
6162 gfc_gobble_whitespace ();
6163 peek_char
= gfc_peek_ascii_char ();
6165 if (state
== COMP_SUBROUTINE
)
6167 m
= gfc_match_formal_arglist (entry
, 0, 1);
6171 /* Call gfc_match_bind_c with allow_binding_name = true as ENTRY can
6172 never be an internal procedure. */
6173 is_bind_c
= gfc_match_bind_c (entry
, true);
6174 if (is_bind_c
== MATCH_ERROR
)
6176 if (is_bind_c
== MATCH_YES
)
6178 if (peek_char
!= '(')
6180 gfc_error ("Missing required parentheses before BIND(C) at %C");
6183 if (!gfc_add_is_bind_c (&(entry
->attr
), entry
->name
,
6184 &(entry
->declared_at
), 1))
6188 if (!gfc_current_ns
->parent
6189 && !add_global_entry (name
, entry
->binding_label
, true,
6193 /* An entry in a subroutine. */
6194 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
6195 || !gfc_add_subroutine (&entry
->attr
, entry
->name
, NULL
))
6200 /* An entry in a function.
6201 We need to take special care because writing
6206 ENTRY f() RESULT (r)
6208 ENTRY f RESULT (r). */
6209 if (gfc_match_eos () == MATCH_YES
)
6211 gfc_current_locus
= old_loc
;
6212 /* Match the empty argument list, and add the interface to
6214 m
= gfc_match_formal_arglist (entry
, 0, 1);
6217 m
= gfc_match_formal_arglist (entry
, 0, 0);
6224 if (gfc_match_eos () == MATCH_YES
)
6226 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
6227 || !gfc_add_function (&entry
->attr
, entry
->name
, NULL
))
6230 entry
->result
= entry
;
6234 m
= gfc_match_suffix (entry
, &result
);
6236 gfc_syntax_error (ST_ENTRY
);
6242 if (!gfc_add_result (&result
->attr
, result
->name
, NULL
)
6243 || !gfc_add_entry (&entry
->attr
, result
->name
, NULL
)
6244 || !gfc_add_function (&entry
->attr
, result
->name
, NULL
))
6246 entry
->result
= result
;
6250 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
6251 || !gfc_add_function (&entry
->attr
, entry
->name
, NULL
))
6253 entry
->result
= entry
;
6257 if (!gfc_current_ns
->parent
6258 && !add_global_entry (name
, entry
->binding_label
, false,
6263 if (gfc_match_eos () != MATCH_YES
)
6265 gfc_syntax_error (ST_ENTRY
);
6269 entry
->attr
.recursive
= proc
->attr
.recursive
;
6270 entry
->attr
.elemental
= proc
->attr
.elemental
;
6271 entry
->attr
.pure
= proc
->attr
.pure
;
6273 el
= gfc_get_entry_list ();
6275 el
->next
= gfc_current_ns
->entries
;
6276 gfc_current_ns
->entries
= el
;
6278 el
->id
= el
->next
->id
+ 1;
6282 new_st
.op
= EXEC_ENTRY
;
6283 new_st
.ext
.entry
= el
;
6289 /* Match a subroutine statement, including optional prefixes. */
6292 gfc_match_subroutine (void)
6294 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6299 bool allow_binding_name
;
6301 if (gfc_current_state () != COMP_NONE
6302 && gfc_current_state () != COMP_INTERFACE
6303 && gfc_current_state () != COMP_CONTAINS
)
6306 m
= gfc_match_prefix (NULL
);
6310 m
= gfc_match ("subroutine% %n", name
);
6314 if (get_proc_name (name
, &sym
, false))
6317 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
6318 the symbol existed before. */
6319 sym
->declared_at
= gfc_current_locus
;
6321 if (current_attr
.module_procedure
)
6322 sym
->attr
.module_procedure
= 1;
6324 if (add_hidden_procptr_result (sym
))
6327 gfc_new_block
= sym
;
6329 /* Check what next non-whitespace character is so we can tell if there
6330 is the required parens if we have a BIND(C). */
6331 gfc_gobble_whitespace ();
6332 peek_char
= gfc_peek_ascii_char ();
6334 if (!gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
))
6337 if (gfc_match_formal_arglist (sym
, 0, 1) != MATCH_YES
)
6340 /* Make sure that it isn't already declared as BIND(C). If it is, it
6341 must have been marked BIND(C) with a BIND(C) attribute and that is
6342 not allowed for procedures. */
6343 if (sym
->attr
.is_bind_c
== 1)
6345 sym
->attr
.is_bind_c
= 0;
6346 if (sym
->old_symbol
!= NULL
)
6347 gfc_error_now ("BIND(C) attribute at %L can only be used for "
6348 "variables or common blocks",
6349 &(sym
->old_symbol
->declared_at
));
6351 gfc_error_now ("BIND(C) attribute at %L can only be used for "
6352 "variables or common blocks", &gfc_current_locus
);
6355 /* C binding names are not allowed for internal procedures. */
6356 if (gfc_current_state () == COMP_CONTAINS
6357 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
6358 allow_binding_name
= false;
6360 allow_binding_name
= true;
6362 /* Here, we are just checking if it has the bind(c) attribute, and if
6363 so, then we need to make sure it's all correct. If it doesn't,
6364 we still need to continue matching the rest of the subroutine line. */
6365 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
6366 if (is_bind_c
== MATCH_ERROR
)
6368 /* There was an attempt at the bind(c), but it was wrong. An
6369 error message should have been printed w/in the gfc_match_bind_c
6370 so here we'll just return the MATCH_ERROR. */
6374 if (is_bind_c
== MATCH_YES
)
6376 /* The following is allowed in the Fortran 2008 draft. */
6377 if (gfc_current_state () == COMP_CONTAINS
6378 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
6379 && !gfc_notify_std (GFC_STD_F2008
, "BIND(C) attribute "
6380 "at %L may not be specified for an internal "
6381 "procedure", &gfc_current_locus
))
6384 if (peek_char
!= '(')
6386 gfc_error ("Missing required parentheses before BIND(C) at %C");
6389 if (!gfc_add_is_bind_c (&(sym
->attr
), sym
->name
,
6390 &(sym
->declared_at
), 1))
6394 if (gfc_match_eos () != MATCH_YES
)
6396 gfc_syntax_error (ST_SUBROUTINE
);
6400 if (!copy_prefix (&sym
->attr
, &sym
->declared_at
))
6402 if(!sym
->attr
.module_procedure
)
6408 /* Warn if it has the same name as an intrinsic. */
6409 do_warn_intrinsic_shadow (sym
, false);
6415 /* Check that the NAME identifier in a BIND attribute or statement
6416 is conform to C identifier rules. */
6419 check_bind_name_identifier (char **name
)
6421 char *n
= *name
, *p
;
6423 /* Remove leading spaces. */
6427 /* On an empty string, free memory and set name to NULL. */
6435 /* Remove trailing spaces. */
6436 p
= n
+ strlen(n
) - 1;
6440 /* Insert the identifier into the symbol table. */
6445 /* Now check that identifier is valid under C rules. */
6448 gfc_error ("Invalid C identifier in NAME= specifier at %C");
6453 if (!(ISALNUM (*p
) || *p
== '_' || *p
== '$'))
6455 gfc_error ("Invalid C identifier in NAME= specifier at %C");
6463 /* Match a BIND(C) specifier, with the optional 'name=' specifier if
6464 given, and set the binding label in either the given symbol (if not
6465 NULL), or in the current_ts. The symbol may be NULL because we may
6466 encounter the BIND(C) before the declaration itself. Return
6467 MATCH_NO if what we're looking at isn't a BIND(C) specifier,
6468 MATCH_ERROR if it is a BIND(C) clause but an error was encountered,
6469 or MATCH_YES if the specifier was correct and the binding label and
6470 bind(c) fields were set correctly for the given symbol or the
6471 current_ts. If allow_binding_name is false, no binding name may be
6475 gfc_match_bind_c (gfc_symbol
*sym
, bool allow_binding_name
)
6477 char *binding_label
= NULL
;
6480 /* Initialize the flag that specifies whether we encountered a NAME=
6481 specifier or not. */
6482 has_name_equals
= 0;
6484 /* This much we have to be able to match, in this order, if
6485 there is a bind(c) label. */
6486 if (gfc_match (" bind ( c ") != MATCH_YES
)
6489 /* Now see if there is a binding label, or if we've reached the
6490 end of the bind(c) attribute without one. */
6491 if (gfc_match_char (',') == MATCH_YES
)
6493 if (gfc_match (" name = ") != MATCH_YES
)
6495 gfc_error ("Syntax error in NAME= specifier for binding label "
6497 /* should give an error message here */
6501 has_name_equals
= 1;
6503 if (gfc_match_init_expr (&e
) != MATCH_YES
)
6509 if (!gfc_simplify_expr(e
, 0))
6511 gfc_error ("NAME= specifier at %C should be a constant expression");
6516 if (e
->expr_type
!= EXPR_CONSTANT
|| e
->ts
.type
!= BT_CHARACTER
6517 || e
->ts
.kind
!= gfc_default_character_kind
|| e
->rank
!= 0)
6519 gfc_error ("NAME= specifier at %C should be a scalar of "
6520 "default character kind");
6525 // Get a C string from the Fortran string constant
6526 binding_label
= gfc_widechar_to_char (e
->value
.character
.string
,
6527 e
->value
.character
.length
);
6530 // Check that it is valid (old gfc_match_name_C)
6531 if (check_bind_name_identifier (&binding_label
) != MATCH_YES
)
6535 /* Get the required right paren. */
6536 if (gfc_match_char (')') != MATCH_YES
)
6538 gfc_error ("Missing closing paren for binding label at %C");
6542 if (has_name_equals
&& !allow_binding_name
)
6544 gfc_error ("No binding name is allowed in BIND(C) at %C");
6548 if (has_name_equals
&& sym
!= NULL
&& sym
->attr
.dummy
)
6550 gfc_error ("For dummy procedure %s, no binding name is "
6551 "allowed in BIND(C) at %C", sym
->name
);
6556 /* Save the binding label to the symbol. If sym is null, we're
6557 probably matching the typespec attributes of a declaration and
6558 haven't gotten the name yet, and therefore, no symbol yet. */
6562 sym
->binding_label
= binding_label
;
6564 curr_binding_label
= binding_label
;
6566 else if (allow_binding_name
)
6568 /* No binding label, but if symbol isn't null, we
6569 can set the label for it here.
6570 If name="" or allow_binding_name is false, no C binding name is
6572 if (sym
!= NULL
&& sym
->name
!= NULL
&& has_name_equals
== 0)
6573 sym
->binding_label
= IDENTIFIER_POINTER (get_identifier (sym
->name
));
6576 if (has_name_equals
&& gfc_current_state () == COMP_INTERFACE
6577 && current_interface
.type
== INTERFACE_ABSTRACT
)
6579 gfc_error ("NAME not allowed on BIND(C) for ABSTRACT INTERFACE at %C");
6587 /* Return nonzero if we're currently compiling a contained procedure. */
6590 contained_procedure (void)
6592 gfc_state_data
*s
= gfc_state_stack
;
6594 if ((s
->state
== COMP_SUBROUTINE
|| s
->state
== COMP_FUNCTION
)
6595 && s
->previous
!= NULL
&& s
->previous
->state
== COMP_CONTAINS
)
6601 /* Set the kind of each enumerator. The kind is selected such that it is
6602 interoperable with the corresponding C enumeration type, making
6603 sure that -fshort-enums is honored. */
6608 enumerator_history
*current_history
= NULL
;
6612 if (max_enum
== NULL
|| enum_history
== NULL
)
6615 if (!flag_short_enums
)
6621 kind
= gfc_integer_kinds
[i
++].kind
;
6623 while (kind
< gfc_c_int_kind
6624 && gfc_check_integer_range (max_enum
->initializer
->value
.integer
,
6627 current_history
= enum_history
;
6628 while (current_history
!= NULL
)
6630 current_history
->sym
->ts
.kind
= kind
;
6631 current_history
= current_history
->next
;
6636 /* Match any of the various end-block statements. Returns the type of
6637 END to the caller. The END INTERFACE, END IF, END DO, END SELECT
6638 and END BLOCK statements cannot be replaced by a single END statement. */
6641 gfc_match_end (gfc_statement
*st
)
6643 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6644 gfc_compile_state state
;
6646 const char *block_name
;
6650 gfc_namespace
*parent_ns
, *ns
, *prev_ns
;
6651 gfc_namespace
**nsp
;
6652 bool abreviated_modproc_decl
;
6653 bool got_matching_end
= false;
6655 old_loc
= gfc_current_locus
;
6656 if (gfc_match ("end") != MATCH_YES
)
6659 state
= gfc_current_state ();
6660 block_name
= gfc_current_block () == NULL
6661 ? NULL
: gfc_current_block ()->name
;
6665 case COMP_ASSOCIATE
:
6667 if (!strncmp (block_name
, "block@", strlen("block@")))
6672 case COMP_DERIVED_CONTAINS
:
6673 state
= gfc_state_stack
->previous
->state
;
6674 block_name
= gfc_state_stack
->previous
->sym
== NULL
6675 ? NULL
: gfc_state_stack
->previous
->sym
->name
;
6682 abreviated_modproc_decl
6683 = gfc_current_block ()
6684 && gfc_current_block ()->abr_modproc_decl
;
6690 *st
= ST_END_PROGRAM
;
6691 target
= " program";
6695 case COMP_SUBROUTINE
:
6696 *st
= ST_END_SUBROUTINE
;
6697 if (!abreviated_modproc_decl
)
6698 target
= " subroutine";
6700 target
= " procedure";
6701 eos_ok
= !contained_procedure ();
6705 *st
= ST_END_FUNCTION
;
6706 if (!abreviated_modproc_decl
)
6707 target
= " function";
6709 target
= " procedure";
6710 eos_ok
= !contained_procedure ();
6713 case COMP_BLOCK_DATA
:
6714 *st
= ST_END_BLOCK_DATA
;
6715 target
= " block data";
6720 *st
= ST_END_MODULE
;
6725 case COMP_SUBMODULE
:
6726 *st
= ST_END_SUBMODULE
;
6727 target
= " submodule";
6731 case COMP_INTERFACE
:
6732 *st
= ST_END_INTERFACE
;
6733 target
= " interface";
6749 case COMP_STRUCTURE
:
6750 *st
= ST_END_STRUCTURE
;
6751 target
= " structure";
6756 case COMP_DERIVED_CONTAINS
:
6762 case COMP_ASSOCIATE
:
6763 *st
= ST_END_ASSOCIATE
;
6764 target
= " associate";
6781 case COMP_DO_CONCURRENT
:
6788 *st
= ST_END_CRITICAL
;
6789 target
= " critical";
6794 case COMP_SELECT_TYPE
:
6795 *st
= ST_END_SELECT
;
6801 *st
= ST_END_FORALL
;
6816 last_initializer
= NULL
;
6818 gfc_free_enum_history ();
6822 gfc_error ("Unexpected END statement at %C");
6826 old_loc
= gfc_current_locus
;
6827 if (gfc_match_eos () == MATCH_YES
)
6829 if (!eos_ok
&& (*st
== ST_END_SUBROUTINE
|| *st
== ST_END_FUNCTION
))
6831 if (!gfc_notify_std (GFC_STD_F2008
, "END statement "
6832 "instead of %s statement at %L",
6833 abreviated_modproc_decl
? "END PROCEDURE"
6834 : gfc_ascii_statement(*st
), &old_loc
))
6839 /* We would have required END [something]. */
6840 gfc_error ("%s statement expected at %L",
6841 gfc_ascii_statement (*st
), &old_loc
);
6848 /* Verify that we've got the sort of end-block that we're expecting. */
6849 if (gfc_match (target
) != MATCH_YES
)
6851 gfc_error ("Expecting %s statement at %L", abreviated_modproc_decl
6852 ? "END PROCEDURE" : gfc_ascii_statement(*st
), &old_loc
);
6856 got_matching_end
= true;
6858 old_loc
= gfc_current_locus
;
6859 /* If we're at the end, make sure a block name wasn't required. */
6860 if (gfc_match_eos () == MATCH_YES
)
6863 if (*st
!= ST_ENDDO
&& *st
!= ST_ENDIF
&& *st
!= ST_END_SELECT
6864 && *st
!= ST_END_FORALL
&& *st
!= ST_END_WHERE
&& *st
!= ST_END_BLOCK
6865 && *st
!= ST_END_ASSOCIATE
&& *st
!= ST_END_CRITICAL
)
6871 gfc_error ("Expected block name of %qs in %s statement at %L",
6872 block_name
, gfc_ascii_statement (*st
), &old_loc
);
6877 /* END INTERFACE has a special handler for its several possible endings. */
6878 if (*st
== ST_END_INTERFACE
)
6879 return gfc_match_end_interface ();
6881 /* We haven't hit the end of statement, so what is left must be an
6883 m
= gfc_match_space ();
6885 m
= gfc_match_name (name
);
6888 gfc_error ("Expected terminating name at %C");
6892 if (block_name
== NULL
)
6895 /* We have to pick out the declared submodule name from the composite
6896 required by F2008:11.2.3 para 2, which ends in the declared name. */
6897 if (state
== COMP_SUBMODULE
)
6898 block_name
= strchr (block_name
, '.') + 1;
6900 if (strcmp (name
, block_name
) != 0 && strcmp (block_name
, "ppr@") != 0)
6902 gfc_error ("Expected label %qs for %s statement at %C", block_name
,
6903 gfc_ascii_statement (*st
));
6906 /* Procedure pointer as function result. */
6907 else if (strcmp (block_name
, "ppr@") == 0
6908 && strcmp (name
, gfc_current_block ()->ns
->proc_name
->name
) != 0)
6910 gfc_error ("Expected label %qs for %s statement at %C",
6911 gfc_current_block ()->ns
->proc_name
->name
,
6912 gfc_ascii_statement (*st
));
6916 if (gfc_match_eos () == MATCH_YES
)
6920 gfc_syntax_error (*st
);
6923 gfc_current_locus
= old_loc
;
6925 /* If we are missing an END BLOCK, we created a half-ready namespace.
6926 Remove it from the parent namespace's sibling list. */
6928 while (state
== COMP_BLOCK
&& !got_matching_end
)
6930 parent_ns
= gfc_current_ns
->parent
;
6932 nsp
= &(gfc_state_stack
->previous
->tail
->ext
.block
.ns
);
6938 if (ns
== gfc_current_ns
)
6940 if (prev_ns
== NULL
)
6943 prev_ns
->sibling
= ns
->sibling
;
6949 gfc_free_namespace (gfc_current_ns
);
6950 gfc_current_ns
= parent_ns
;
6951 gfc_state_stack
= gfc_state_stack
->previous
;
6952 state
= gfc_current_state ();
6960 /***************** Attribute declaration statements ****************/
6962 /* Set the attribute of a single variable. */
6967 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6970 /* Workaround -Wmaybe-uninitialized false positive during
6971 profiledbootstrap by initializing them. */
6972 gfc_symbol
*sym
= NULL
;
6978 m
= gfc_match_name (name
);
6982 if (find_special (name
, &sym
, false))
6985 if (!check_function_name (name
))
6991 var_locus
= gfc_current_locus
;
6993 /* Deal with possible array specification for certain attributes. */
6994 if (current_attr
.dimension
6995 || current_attr
.codimension
6996 || current_attr
.allocatable
6997 || current_attr
.pointer
6998 || current_attr
.target
)
7000 m
= gfc_match_array_spec (&as
, !current_attr
.codimension
,
7001 !current_attr
.dimension
7002 && !current_attr
.pointer
7003 && !current_attr
.target
);
7004 if (m
== MATCH_ERROR
)
7007 if (current_attr
.dimension
&& m
== MATCH_NO
)
7009 gfc_error ("Missing array specification at %L in DIMENSION "
7010 "statement", &var_locus
);
7015 if (current_attr
.dimension
&& sym
->value
)
7017 gfc_error ("Dimensions specified for %s at %L after its "
7018 "initialisation", sym
->name
, &var_locus
);
7023 if (current_attr
.codimension
&& m
== MATCH_NO
)
7025 gfc_error ("Missing array specification at %L in CODIMENSION "
7026 "statement", &var_locus
);
7031 if ((current_attr
.allocatable
|| current_attr
.pointer
)
7032 && (m
== MATCH_YES
) && (as
->type
!= AS_DEFERRED
))
7034 gfc_error ("Array specification must be deferred at %L", &var_locus
);
7040 /* Update symbol table. DIMENSION attribute is set in
7041 gfc_set_array_spec(). For CLASS variables, this must be applied
7042 to the first component, or '_data' field. */
7043 if (sym
->ts
.type
== BT_CLASS
&& sym
->ts
.u
.derived
->attr
.is_class
)
7045 if (!gfc_copy_attr (&CLASS_DATA(sym
)->attr
, ¤t_attr
, &var_locus
))
7053 if (current_attr
.dimension
== 0 && current_attr
.codimension
== 0
7054 && !gfc_copy_attr (&sym
->attr
, ¤t_attr
, &var_locus
))
7061 if (sym
->ts
.type
== BT_CLASS
7062 && !gfc_build_class_symbol (&sym
->ts
, &sym
->attr
, &sym
->as
))
7068 if (!gfc_set_array_spec (sym
, as
, &var_locus
))
7074 if (sym
->attr
.cray_pointee
&& sym
->as
!= NULL
)
7076 /* Fix the array spec. */
7077 m
= gfc_mod_pointee_as (sym
->as
);
7078 if (m
== MATCH_ERROR
)
7082 if (!gfc_add_attribute (&sym
->attr
, &var_locus
))
7088 if ((current_attr
.external
|| current_attr
.intrinsic
)
7089 && sym
->attr
.flavor
!= FL_PROCEDURE
7090 && !gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, NULL
))
7096 add_hidden_procptr_result (sym
);
7101 gfc_free_array_spec (as
);
7106 /* Generic attribute declaration subroutine. Used for attributes that
7107 just have a list of names. */
7114 /* Gobble the optional double colon, by simply ignoring the result
7124 if (gfc_match_eos () == MATCH_YES
)
7130 if (gfc_match_char (',') != MATCH_YES
)
7132 gfc_error ("Unexpected character in variable list at %C");
7142 /* This routine matches Cray Pointer declarations of the form:
7143 pointer ( <pointer>, <pointee> )
7145 pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...
7146 The pointer, if already declared, should be an integer. Otherwise, we
7147 set it as BT_INTEGER with kind gfc_index_integer_kind. The pointee may
7148 be either a scalar, or an array declaration. No space is allocated for
7149 the pointee. For the statement
7150 pointer (ipt, ar(10))
7151 any subsequent uses of ar will be translated (in C-notation) as
7152 ar(i) => ((<type> *) ipt)(i)
7153 After gimplification, pointee variable will disappear in the code. */
7156 cray_pointer_decl (void)
7159 gfc_array_spec
*as
= NULL
;
7160 gfc_symbol
*cptr
; /* Pointer symbol. */
7161 gfc_symbol
*cpte
; /* Pointee symbol. */
7167 if (gfc_match_char ('(') != MATCH_YES
)
7169 gfc_error ("Expected %<(%> at %C");
7173 /* Match pointer. */
7174 var_locus
= gfc_current_locus
;
7175 gfc_clear_attr (¤t_attr
);
7176 gfc_add_cray_pointer (¤t_attr
, &var_locus
);
7177 current_ts
.type
= BT_INTEGER
;
7178 current_ts
.kind
= gfc_index_integer_kind
;
7180 m
= gfc_match_symbol (&cptr
, 0);
7183 gfc_error ("Expected variable name at %C");
7187 if (!gfc_add_cray_pointer (&cptr
->attr
, &var_locus
))
7190 gfc_set_sym_referenced (cptr
);
7192 if (cptr
->ts
.type
== BT_UNKNOWN
) /* Override the type, if necessary. */
7194 cptr
->ts
.type
= BT_INTEGER
;
7195 cptr
->ts
.kind
= gfc_index_integer_kind
;
7197 else if (cptr
->ts
.type
!= BT_INTEGER
)
7199 gfc_error ("Cray pointer at %C must be an integer");
7202 else if (cptr
->ts
.kind
< gfc_index_integer_kind
)
7203 gfc_warning (0, "Cray pointer at %C has %d bytes of precision;"
7204 " memory addresses require %d bytes",
7205 cptr
->ts
.kind
, gfc_index_integer_kind
);
7207 if (gfc_match_char (',') != MATCH_YES
)
7209 gfc_error ("Expected \",\" at %C");
7213 /* Match Pointee. */
7214 var_locus
= gfc_current_locus
;
7215 gfc_clear_attr (¤t_attr
);
7216 gfc_add_cray_pointee (¤t_attr
, &var_locus
);
7217 current_ts
.type
= BT_UNKNOWN
;
7218 current_ts
.kind
= 0;
7220 m
= gfc_match_symbol (&cpte
, 0);
7223 gfc_error ("Expected variable name at %C");
7227 /* Check for an optional array spec. */
7228 m
= gfc_match_array_spec (&as
, true, false);
7229 if (m
== MATCH_ERROR
)
7231 gfc_free_array_spec (as
);
7234 else if (m
== MATCH_NO
)
7236 gfc_free_array_spec (as
);
7240 if (!gfc_add_cray_pointee (&cpte
->attr
, &var_locus
))
7243 gfc_set_sym_referenced (cpte
);
7245 if (cpte
->as
== NULL
)
7247 if (!gfc_set_array_spec (cpte
, as
, &var_locus
))
7248 gfc_internal_error ("Couldn't set Cray pointee array spec.");
7250 else if (as
!= NULL
)
7252 gfc_error ("Duplicate array spec for Cray pointee at %C");
7253 gfc_free_array_spec (as
);
7259 if (cpte
->as
!= NULL
)
7261 /* Fix array spec. */
7262 m
= gfc_mod_pointee_as (cpte
->as
);
7263 if (m
== MATCH_ERROR
)
7267 /* Point the Pointee at the Pointer. */
7268 cpte
->cp_pointer
= cptr
;
7270 if (gfc_match_char (')') != MATCH_YES
)
7272 gfc_error ("Expected \")\" at %C");
7275 m
= gfc_match_char (',');
7277 done
= true; /* Stop searching for more declarations. */
7281 if (m
== MATCH_ERROR
/* Failed when trying to find ',' above. */
7282 || gfc_match_eos () != MATCH_YES
)
7284 gfc_error ("Expected %<,%> or end of statement at %C");
7292 gfc_match_external (void)
7295 gfc_clear_attr (¤t_attr
);
7296 current_attr
.external
= 1;
7298 return attr_decl ();
7303 gfc_match_intent (void)
7307 /* This is not allowed within a BLOCK construct! */
7308 if (gfc_current_state () == COMP_BLOCK
)
7310 gfc_error ("INTENT is not allowed inside of BLOCK at %C");
7314 intent
= match_intent_spec ();
7315 if (intent
== INTENT_UNKNOWN
)
7318 gfc_clear_attr (¤t_attr
);
7319 current_attr
.intent
= intent
;
7321 return attr_decl ();
7326 gfc_match_intrinsic (void)
7329 gfc_clear_attr (¤t_attr
);
7330 current_attr
.intrinsic
= 1;
7332 return attr_decl ();
7337 gfc_match_optional (void)
7339 /* This is not allowed within a BLOCK construct! */
7340 if (gfc_current_state () == COMP_BLOCK
)
7342 gfc_error ("OPTIONAL is not allowed inside of BLOCK at %C");
7346 gfc_clear_attr (¤t_attr
);
7347 current_attr
.optional
= 1;
7349 return attr_decl ();
7354 gfc_match_pointer (void)
7356 gfc_gobble_whitespace ();
7357 if (gfc_peek_ascii_char () == '(')
7359 if (!flag_cray_pointer
)
7361 gfc_error ("Cray pointer declaration at %C requires -fcray-pointer "
7365 return cray_pointer_decl ();
7369 gfc_clear_attr (¤t_attr
);
7370 current_attr
.pointer
= 1;
7372 return attr_decl ();
7378 gfc_match_allocatable (void)
7380 gfc_clear_attr (¤t_attr
);
7381 current_attr
.allocatable
= 1;
7383 return attr_decl ();
7388 gfc_match_codimension (void)
7390 gfc_clear_attr (¤t_attr
);
7391 current_attr
.codimension
= 1;
7393 return attr_decl ();
7398 gfc_match_contiguous (void)
7400 if (!gfc_notify_std (GFC_STD_F2008
, "CONTIGUOUS statement at %C"))
7403 gfc_clear_attr (¤t_attr
);
7404 current_attr
.contiguous
= 1;
7406 return attr_decl ();
7411 gfc_match_dimension (void)
7413 gfc_clear_attr (¤t_attr
);
7414 current_attr
.dimension
= 1;
7416 return attr_decl ();
7421 gfc_match_target (void)
7423 gfc_clear_attr (¤t_attr
);
7424 current_attr
.target
= 1;
7426 return attr_decl ();
7430 /* Match the list of entities being specified in a PUBLIC or PRIVATE
7434 access_attr_decl (gfc_statement st
)
7436 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7437 interface_type type
;
7439 gfc_symbol
*sym
, *dt_sym
;
7440 gfc_intrinsic_op op
;
7443 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
7448 m
= gfc_match_generic_spec (&type
, name
, &op
);
7451 if (m
== MATCH_ERROR
)
7456 case INTERFACE_NAMELESS
:
7457 case INTERFACE_ABSTRACT
:
7460 case INTERFACE_GENERIC
:
7461 if (gfc_get_symbol (name
, NULL
, &sym
))
7464 if (!gfc_add_access (&sym
->attr
,
7466 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
,
7470 if (sym
->attr
.generic
&& (dt_sym
= gfc_find_dt_in_generic (sym
))
7471 && !gfc_add_access (&dt_sym
->attr
,
7473 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
,
7479 case INTERFACE_INTRINSIC_OP
:
7480 if (gfc_current_ns
->operator_access
[op
] == ACCESS_UNKNOWN
)
7482 gfc_intrinsic_op other_op
;
7484 gfc_current_ns
->operator_access
[op
] =
7485 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
7487 /* Handle the case if there is another op with the same
7488 function, for INTRINSIC_EQ vs. INTRINSIC_EQ_OS and so on. */
7489 other_op
= gfc_equivalent_op (op
);
7491 if (other_op
!= INTRINSIC_NONE
)
7492 gfc_current_ns
->operator_access
[other_op
] =
7493 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
7498 gfc_error ("Access specification of the %s operator at %C has "
7499 "already been specified", gfc_op2string (op
));
7505 case INTERFACE_USER_OP
:
7506 uop
= gfc_get_uop (name
);
7508 if (uop
->access
== ACCESS_UNKNOWN
)
7510 uop
->access
= (st
== ST_PUBLIC
)
7511 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
7515 gfc_error ("Access specification of the .%s. operator at %C "
7516 "has already been specified", sym
->name
);
7523 if (gfc_match_char (',') == MATCH_NO
)
7527 if (gfc_match_eos () != MATCH_YES
)
7532 gfc_syntax_error (st
);
7540 gfc_match_protected (void)
7545 if (!gfc_current_ns
->proc_name
7546 || gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
7548 gfc_error ("PROTECTED at %C only allowed in specification "
7549 "part of a module");
7554 if (!gfc_notify_std (GFC_STD_F2003
, "PROTECTED statement at %C"))
7557 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
7562 if (gfc_match_eos () == MATCH_YES
)
7567 m
= gfc_match_symbol (&sym
, 0);
7571 if (!gfc_add_protected (&sym
->attr
, sym
->name
, &gfc_current_locus
))
7583 if (gfc_match_eos () == MATCH_YES
)
7585 if (gfc_match_char (',') != MATCH_YES
)
7592 gfc_error ("Syntax error in PROTECTED statement at %C");
7597 /* The PRIVATE statement is a bit weird in that it can be an attribute
7598 declaration, but also works as a standalone statement inside of a
7599 type declaration or a module. */
7602 gfc_match_private (gfc_statement
*st
)
7605 if (gfc_match ("private") != MATCH_YES
)
7608 if (gfc_current_state () != COMP_MODULE
7609 && !(gfc_current_state () == COMP_DERIVED
7610 && gfc_state_stack
->previous
7611 && gfc_state_stack
->previous
->state
== COMP_MODULE
)
7612 && !(gfc_current_state () == COMP_DERIVED_CONTAINS
7613 && gfc_state_stack
->previous
&& gfc_state_stack
->previous
->previous
7614 && gfc_state_stack
->previous
->previous
->state
== COMP_MODULE
))
7616 gfc_error ("PRIVATE statement at %C is only allowed in the "
7617 "specification part of a module");
7621 if (gfc_current_state () == COMP_DERIVED
)
7623 if (gfc_match_eos () == MATCH_YES
)
7629 gfc_syntax_error (ST_PRIVATE
);
7633 if (gfc_match_eos () == MATCH_YES
)
7640 return access_attr_decl (ST_PRIVATE
);
7645 gfc_match_public (gfc_statement
*st
)
7648 if (gfc_match ("public") != MATCH_YES
)
7651 if (gfc_current_state () != COMP_MODULE
)
7653 gfc_error ("PUBLIC statement at %C is only allowed in the "
7654 "specification part of a module");
7658 if (gfc_match_eos () == MATCH_YES
)
7665 return access_attr_decl (ST_PUBLIC
);
7669 /* Workhorse for gfc_match_parameter. */
7679 m
= gfc_match_symbol (&sym
, 0);
7681 gfc_error ("Expected variable name at %C in PARAMETER statement");
7686 if (gfc_match_char ('=') == MATCH_NO
)
7688 gfc_error ("Expected = sign in PARAMETER statement at %C");
7692 m
= gfc_match_init_expr (&init
);
7694 gfc_error ("Expected expression at %C in PARAMETER statement");
7698 if (sym
->ts
.type
== BT_UNKNOWN
7699 && !gfc_set_default_type (sym
, 1, NULL
))
7705 if (!gfc_check_assign_symbol (sym
, NULL
, init
)
7706 || !gfc_add_flavor (&sym
->attr
, FL_PARAMETER
, sym
->name
, NULL
))
7714 gfc_error ("Initializing already initialized variable at %C");
7719 t
= add_init_expr_to_sym (sym
->name
, &init
, &gfc_current_locus
);
7720 return (t
) ? MATCH_YES
: MATCH_ERROR
;
7723 gfc_free_expr (init
);
7728 /* Match a parameter statement, with the weird syntax that these have. */
7731 gfc_match_parameter (void)
7735 if (gfc_match_char ('(') == MATCH_NO
)
7744 if (gfc_match (" )%t") == MATCH_YES
)
7747 if (gfc_match_char (',') != MATCH_YES
)
7749 gfc_error ("Unexpected characters in PARAMETER statement at %C");
7759 /* Save statements have a special syntax. */
7762 gfc_match_save (void)
7764 char n
[GFC_MAX_SYMBOL_LEN
+1];
7769 if (gfc_match_eos () == MATCH_YES
)
7771 if (gfc_current_ns
->seen_save
)
7773 if (!gfc_notify_std (GFC_STD_LEGACY
, "Blanket SAVE statement at %C "
7774 "follows previous SAVE statement"))
7778 gfc_current_ns
->save_all
= gfc_current_ns
->seen_save
= 1;
7782 if (gfc_current_ns
->save_all
)
7784 if (!gfc_notify_std (GFC_STD_LEGACY
, "SAVE statement at %C follows "
7785 "blanket SAVE statement"))
7793 m
= gfc_match_symbol (&sym
, 0);
7797 if (!gfc_add_save (&sym
->attr
, SAVE_EXPLICIT
, sym
->name
,
7798 &gfc_current_locus
))
7809 m
= gfc_match (" / %n /", &n
);
7810 if (m
== MATCH_ERROR
)
7815 c
= gfc_get_common (n
, 0);
7818 gfc_current_ns
->seen_save
= 1;
7821 if (gfc_match_eos () == MATCH_YES
)
7823 if (gfc_match_char (',') != MATCH_YES
)
7830 gfc_error ("Syntax error in SAVE statement at %C");
7836 gfc_match_value (void)
7841 /* This is not allowed within a BLOCK construct! */
7842 if (gfc_current_state () == COMP_BLOCK
)
7844 gfc_error ("VALUE is not allowed inside of BLOCK at %C");
7848 if (!gfc_notify_std (GFC_STD_F2003
, "VALUE statement at %C"))
7851 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
7856 if (gfc_match_eos () == MATCH_YES
)
7861 m
= gfc_match_symbol (&sym
, 0);
7865 if (!gfc_add_value (&sym
->attr
, sym
->name
, &gfc_current_locus
))
7877 if (gfc_match_eos () == MATCH_YES
)
7879 if (gfc_match_char (',') != MATCH_YES
)
7886 gfc_error ("Syntax error in VALUE statement at %C");
7892 gfc_match_volatile (void)
7897 if (!gfc_notify_std (GFC_STD_F2003
, "VOLATILE statement at %C"))
7900 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
7905 if (gfc_match_eos () == MATCH_YES
)
7910 /* VOLATILE is special because it can be added to host-associated
7911 symbols locally. Except for coarrays. */
7912 m
= gfc_match_symbol (&sym
, 1);
7916 /* F2008, C560+C561. VOLATILE for host-/use-associated variable or
7917 for variable in a BLOCK which is defined outside of the BLOCK. */
7918 if (sym
->ns
!= gfc_current_ns
&& sym
->attr
.codimension
)
7920 gfc_error ("Specifying VOLATILE for coarray variable %qs at "
7921 "%C, which is use-/host-associated", sym
->name
);
7924 if (!gfc_add_volatile (&sym
->attr
, sym
->name
, &gfc_current_locus
))
7936 if (gfc_match_eos () == MATCH_YES
)
7938 if (gfc_match_char (',') != MATCH_YES
)
7945 gfc_error ("Syntax error in VOLATILE statement at %C");
7951 gfc_match_asynchronous (void)
7956 if (!gfc_notify_std (GFC_STD_F2003
, "ASYNCHRONOUS statement at %C"))
7959 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
7964 if (gfc_match_eos () == MATCH_YES
)
7969 /* ASYNCHRONOUS is special because it can be added to host-associated
7971 m
= gfc_match_symbol (&sym
, 1);
7975 if (!gfc_add_asynchronous (&sym
->attr
, sym
->name
, &gfc_current_locus
))
7987 if (gfc_match_eos () == MATCH_YES
)
7989 if (gfc_match_char (',') != MATCH_YES
)
7996 gfc_error ("Syntax error in ASYNCHRONOUS statement at %C");
8001 /* Match a module procedure statement in a submodule. */
8004 gfc_match_submod_proc (void)
8006 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8007 gfc_symbol
*sym
, *fsym
;
8009 gfc_formal_arglist
*formal
, *head
, *tail
;
8011 if (gfc_current_state () != COMP_CONTAINS
8012 || !(gfc_state_stack
->previous
8013 && (gfc_state_stack
->previous
->state
== COMP_SUBMODULE
8014 || gfc_state_stack
->previous
->state
== COMP_MODULE
)))
8017 m
= gfc_match (" module% procedure% %n", name
);
8021 if (!gfc_notify_std (GFC_STD_F2008
, "MODULE PROCEDURE declaration "
8025 if (get_proc_name (name
, &sym
, false))
8028 /* Make sure that the result field is appropriately filled, even though
8029 the result symbol will be replaced later on. */
8030 if (sym
->ts
.interface
&& sym
->ts
.interface
->attr
.function
)
8032 if (sym
->ts
.interface
->result
8033 && sym
->ts
.interface
->result
!= sym
->ts
.interface
)
8034 sym
->result
= sym
->ts
.interface
->result
;
8039 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
8040 the symbol existed before. */
8041 sym
->declared_at
= gfc_current_locus
;
8043 if (!sym
->attr
.module_procedure
)
8046 /* Signal match_end to expect "end procedure". */
8047 sym
->abr_modproc_decl
= 1;
8049 /* Change from IFSRC_IFBODY coming from the interface declaration. */
8050 sym
->attr
.if_source
= IFSRC_DECL
;
8052 gfc_new_block
= sym
;
8054 /* Make a new formal arglist with the symbols in the procedure
8057 for (formal
= sym
->formal
; formal
&& formal
->sym
; formal
= formal
->next
)
8059 if (formal
== sym
->formal
)
8060 head
= tail
= gfc_get_formal_arglist ();
8063 tail
->next
= gfc_get_formal_arglist ();
8067 if (gfc_copy_dummy_sym (&fsym
, formal
->sym
, 0))
8071 gfc_set_sym_referenced (fsym
);
8074 /* The dummy symbols get cleaned up, when the formal_namespace of the
8075 interface declaration is cleared. This allows us to add the
8076 explicit interface as is done for other type of procedure. */
8077 if (!gfc_add_explicit_interface (sym
, IFSRC_DECL
, head
,
8078 &gfc_current_locus
))
8081 if (gfc_match_eos () != MATCH_YES
)
8083 gfc_syntax_error (ST_MODULE_PROC
);
8090 gfc_free_formal_arglist (head
);
8095 /* Match a module procedure statement. Note that we have to modify
8096 symbols in the parent's namespace because the current one was there
8097 to receive symbols that are in an interface's formal argument list. */
8100 gfc_match_modproc (void)
8102 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8106 gfc_namespace
*module_ns
;
8107 gfc_interface
*old_interface_head
, *interface
;
8109 if (gfc_state_stack
->state
!= COMP_INTERFACE
8110 || gfc_state_stack
->previous
== NULL
8111 || current_interface
.type
== INTERFACE_NAMELESS
8112 || current_interface
.type
== INTERFACE_ABSTRACT
)
8114 gfc_error ("MODULE PROCEDURE at %C must be in a generic module "
8119 module_ns
= gfc_current_ns
->parent
;
8120 for (; module_ns
; module_ns
= module_ns
->parent
)
8121 if (module_ns
->proc_name
->attr
.flavor
== FL_MODULE
8122 || module_ns
->proc_name
->attr
.flavor
== FL_PROGRAM
8123 || (module_ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
8124 && !module_ns
->proc_name
->attr
.contained
))
8127 if (module_ns
== NULL
)
8130 /* Store the current state of the interface. We will need it if we
8131 end up with a syntax error and need to recover. */
8132 old_interface_head
= gfc_current_interface_head ();
8134 /* Check if the F2008 optional double colon appears. */
8135 gfc_gobble_whitespace ();
8136 old_locus
= gfc_current_locus
;
8137 if (gfc_match ("::") == MATCH_YES
)
8139 if (!gfc_notify_std (GFC_STD_F2008
, "double colon in "
8140 "MODULE PROCEDURE statement at %L", &old_locus
))
8144 gfc_current_locus
= old_locus
;
8149 old_locus
= gfc_current_locus
;
8151 m
= gfc_match_name (name
);
8157 /* Check for syntax error before starting to add symbols to the
8158 current namespace. */
8159 if (gfc_match_eos () == MATCH_YES
)
8162 if (!last
&& gfc_match_char (',') != MATCH_YES
)
8165 /* Now we're sure the syntax is valid, we process this item
8167 if (gfc_get_symbol (name
, module_ns
, &sym
))
8170 if (sym
->attr
.intrinsic
)
8172 gfc_error ("Intrinsic procedure at %L cannot be a MODULE "
8173 "PROCEDURE", &old_locus
);
8177 if (sym
->attr
.proc
!= PROC_MODULE
8178 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
8181 if (!gfc_add_interface (sym
))
8184 sym
->attr
.mod_proc
= 1;
8185 sym
->declared_at
= old_locus
;
8194 /* Restore the previous state of the interface. */
8195 interface
= gfc_current_interface_head ();
8196 gfc_set_current_interface_head (old_interface_head
);
8198 /* Free the new interfaces. */
8199 while (interface
!= old_interface_head
)
8201 gfc_interface
*i
= interface
->next
;
8206 /* And issue a syntax error. */
8207 gfc_syntax_error (ST_MODULE_PROC
);
8212 /* Check a derived type that is being extended. */
8215 check_extended_derived_type (char *name
)
8217 gfc_symbol
*extended
;
8219 if (gfc_find_symbol (name
, gfc_current_ns
, 1, &extended
))
8221 gfc_error ("Ambiguous symbol in TYPE definition at %C");
8225 extended
= gfc_find_dt_in_generic (extended
);
8230 gfc_error ("Symbol %qs at %C has not been previously defined", name
);
8234 if (extended
->attr
.flavor
!= FL_DERIVED
)
8236 gfc_error ("%qs in EXTENDS expression at %C is not a "
8237 "derived type", name
);
8241 if (extended
->attr
.is_bind_c
)
8243 gfc_error ("%qs cannot be extended at %C because it "
8244 "is BIND(C)", extended
->name
);
8248 if (extended
->attr
.sequence
)
8250 gfc_error ("%qs cannot be extended at %C because it "
8251 "is a SEQUENCE type", extended
->name
);
8259 /* Match the optional attribute specifiers for a type declaration.
8260 Return MATCH_ERROR if an error is encountered in one of the handled
8261 attributes (public, private, bind(c)), MATCH_NO if what's found is
8262 not a handled attribute, and MATCH_YES otherwise. TODO: More error
8263 checking on attribute conflicts needs to be done. */
8266 gfc_get_type_attr_spec (symbol_attribute
*attr
, char *name
)
8268 /* See if the derived type is marked as private. */
8269 if (gfc_match (" , private") == MATCH_YES
)
8271 if (gfc_current_state () != COMP_MODULE
)
8273 gfc_error ("Derived type at %C can only be PRIVATE in the "
8274 "specification part of a module");
8278 if (!gfc_add_access (attr
, ACCESS_PRIVATE
, NULL
, NULL
))
8281 else if (gfc_match (" , public") == MATCH_YES
)
8283 if (gfc_current_state () != COMP_MODULE
)
8285 gfc_error ("Derived type at %C can only be PUBLIC in the "
8286 "specification part of a module");
8290 if (!gfc_add_access (attr
, ACCESS_PUBLIC
, NULL
, NULL
))
8293 else if (gfc_match (" , bind ( c )") == MATCH_YES
)
8295 /* If the type is defined to be bind(c) it then needs to make
8296 sure that all fields are interoperable. This will
8297 need to be a semantic check on the finished derived type.
8298 See 15.2.3 (lines 9-12) of F2003 draft. */
8299 if (!gfc_add_is_bind_c (attr
, NULL
, &gfc_current_locus
, 0))
8302 /* TODO: attr conflicts need to be checked, probably in symbol.c. */
8304 else if (gfc_match (" , abstract") == MATCH_YES
)
8306 if (!gfc_notify_std (GFC_STD_F2003
, "ABSTRACT type at %C"))
8309 if (!gfc_add_abstract (attr
, &gfc_current_locus
))
8312 else if (name
&& gfc_match (" , extends ( %n )", name
) == MATCH_YES
)
8314 if (!gfc_add_extension (attr
, &gfc_current_locus
))
8320 /* If we get here, something matched. */
8325 /* Common function for type declaration blocks similar to derived types, such
8326 as STRUCTURES and MAPs. Unlike derived types, a structure type
8327 does NOT have a generic symbol matching the name given by the user.
8328 STRUCTUREs can share names with variables and PARAMETERs so we must allow
8329 for the creation of an independent symbol.
8330 Other parameters are a message to prefix errors with, the name of the new
8331 type to be created, and the flavor to add to the resulting symbol. */
8334 get_struct_decl (const char *name
, sym_flavor fl
, locus
*decl
,
8335 gfc_symbol
**result
)
8340 gcc_assert (name
[0] == (char) TOUPPER (name
[0]));
8345 where
= gfc_current_locus
;
8347 if (gfc_get_symbol (name
, NULL
, &sym
))
8352 gfc_internal_error ("Failed to create structure type '%s' at %C", name
);
8356 if (sym
->components
!= NULL
|| sym
->attr
.zero_comp
)
8358 gfc_error ("Type definition of '%s' at %C was already defined at %L",
8359 sym
->name
, &sym
->declared_at
);
8363 sym
->declared_at
= where
;
8365 if (sym
->attr
.flavor
!= fl
8366 && !gfc_add_flavor (&sym
->attr
, fl
, sym
->name
, NULL
))
8369 if (!sym
->hash_value
)
8370 /* Set the hash for the compound name for this type. */
8371 sym
->hash_value
= gfc_hash_value (sym
);
8373 /* Normally the type is expected to have been completely parsed by the time
8374 a field declaration with this type is seen. For unions, maps, and nested
8375 structure declarations, we need to indicate that it is okay that we
8376 haven't seen any components yet. This will be updated after the structure
8378 sym
->attr
.zero_comp
= 0;
8380 /* Structures always act like derived-types with the SEQUENCE attribute */
8381 gfc_add_sequence (&sym
->attr
, sym
->name
, NULL
);
8383 if (result
) *result
= sym
;
8389 /* Match the opening of a MAP block. Like a struct within a union in C;
8390 behaves identical to STRUCTURE blocks. */
8393 gfc_match_map (void)
8395 /* Counter used to give unique internal names to map structures. */
8396 static unsigned int gfc_map_id
= 0;
8397 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8401 old_loc
= gfc_current_locus
;
8403 if (gfc_match_eos () != MATCH_YES
)
8405 gfc_error ("Junk after MAP statement at %C");
8406 gfc_current_locus
= old_loc
;
8410 /* Map blocks are anonymous so we make up unique names for the symbol table
8411 which are invalid Fortran identifiers. */
8412 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "MM$%u", gfc_map_id
++);
8414 if (!get_struct_decl (name
, FL_STRUCT
, &old_loc
, &sym
))
8417 gfc_new_block
= sym
;
8423 /* Match the opening of a UNION block. */
8426 gfc_match_union (void)
8428 /* Counter used to give unique internal names to union types. */
8429 static unsigned int gfc_union_id
= 0;
8430 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8434 old_loc
= gfc_current_locus
;
8436 if (gfc_match_eos () != MATCH_YES
)
8438 gfc_error ("Junk after UNION statement at %C");
8439 gfc_current_locus
= old_loc
;
8443 /* Unions are anonymous so we make up unique names for the symbol table
8444 which are invalid Fortran identifiers. */
8445 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "UU$%u", gfc_union_id
++);
8447 if (!get_struct_decl (name
, FL_UNION
, &old_loc
, &sym
))
8450 gfc_new_block
= sym
;
8456 /* Match the beginning of a STRUCTURE declaration. This is similar to
8457 matching the beginning of a derived type declaration with a few
8458 twists. The resulting type symbol has no access control or other
8459 interesting attributes. */
8462 gfc_match_structure_decl (void)
8464 /* Counter used to give unique internal names to anonymous structures. */
8465 int gfc_structure_id
= 0;
8466 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8471 if(!gfc_option
.flag_dec_structure
)
8473 gfc_error ("STRUCTURE at %C is a DEC extension, enable with "
8480 m
= gfc_match (" /%n/", name
);
8483 /* Non-nested structure declarations require a structure name. */
8484 if (!gfc_comp_struct (gfc_current_state ()))
8486 gfc_error ("Structure name expected in non-nested structure "
8487 "declaration at %C");
8490 /* This is an anonymous structure; make up a unique name for it
8491 (upper-case letters never make it to symbol names from the source).
8492 The important thing is initializing the type variable
8493 and setting gfc_new_symbol, which is immediately used by
8494 parse_structure () and variable_decl () to add components of
8496 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "SS$%u", gfc_structure_id
++);
8499 where
= gfc_current_locus
;
8500 /* No field list allowed after non-nested structure declaration. */
8501 if (!gfc_comp_struct (gfc_current_state ())
8502 && gfc_match_eos () != MATCH_YES
)
8504 gfc_error ("Junk after non-nested STRUCTURE statement at %C");
8508 /* Make sure the name is not the name of an intrinsic type. */
8509 if (gfc_is_intrinsic_typename (name
))
8511 gfc_error ("Structure name '%s' at %C cannot be the same as an"
8512 " intrinsic type", name
);
8516 /* Store the actual type symbol for the structure with an upper-case first
8517 letter (an invalid Fortran identifier). */
8519 sprintf (name
, gfc_dt_upper_string (name
));
8520 if (!get_struct_decl (name
, FL_STRUCT
, &where
, &sym
))
8523 gfc_new_block
= sym
;
8527 /* Match the beginning of a derived type declaration. If a type name
8528 was the result of a function, then it is possible to have a symbol
8529 already to be known as a derived type yet have no components. */
8532 gfc_match_derived_decl (void)
8534 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8535 char parent
[GFC_MAX_SYMBOL_LEN
+ 1];
8536 symbol_attribute attr
;
8537 gfc_symbol
*sym
, *gensym
;
8538 gfc_symbol
*extended
;
8540 match is_type_attr_spec
= MATCH_NO
;
8541 bool seen_attr
= false;
8542 gfc_interface
*intr
= NULL
, *head
;
8544 if (gfc_comp_struct (gfc_current_state ()))
8549 gfc_clear_attr (&attr
);
8554 is_type_attr_spec
= gfc_get_type_attr_spec (&attr
, parent
);
8555 if (is_type_attr_spec
== MATCH_ERROR
)
8557 if (is_type_attr_spec
== MATCH_YES
)
8559 } while (is_type_attr_spec
== MATCH_YES
);
8561 /* Deal with derived type extensions. The extension attribute has
8562 been added to 'attr' but now the parent type must be found and
8565 extended
= check_extended_derived_type (parent
);
8567 if (parent
[0] && !extended
)
8570 if (gfc_match (" ::") != MATCH_YES
&& seen_attr
)
8572 gfc_error ("Expected :: in TYPE definition at %C");
8576 m
= gfc_match (" %n%t", name
);
8580 /* Make sure the name is not the name of an intrinsic type. */
8581 if (gfc_is_intrinsic_typename (name
))
8583 gfc_error ("Type name %qs at %C cannot be the same as an intrinsic "
8588 if (gfc_get_symbol (name
, NULL
, &gensym
))
8591 if (!gensym
->attr
.generic
&& gensym
->ts
.type
!= BT_UNKNOWN
)
8593 gfc_error ("Derived type name %qs at %C already has a basic type "
8594 "of %s", gensym
->name
, gfc_typename (&gensym
->ts
));
8598 if (!gensym
->attr
.generic
8599 && !gfc_add_generic (&gensym
->attr
, gensym
->name
, NULL
))
8602 if (!gensym
->attr
.function
8603 && !gfc_add_function (&gensym
->attr
, gensym
->name
, NULL
))
8606 sym
= gfc_find_dt_in_generic (gensym
);
8608 if (sym
&& (sym
->components
!= NULL
|| sym
->attr
.zero_comp
))
8610 gfc_error ("Derived type definition of %qs at %C has already been "
8611 "defined", sym
->name
);
8617 /* Use upper case to save the actual derived-type symbol. */
8618 gfc_get_symbol (gfc_dt_upper_string (gensym
->name
), NULL
, &sym
);
8619 sym
->name
= gfc_get_string (gensym
->name
);
8620 head
= gensym
->generic
;
8621 intr
= gfc_get_interface ();
8623 intr
->where
= gfc_current_locus
;
8624 intr
->sym
->declared_at
= gfc_current_locus
;
8626 gensym
->generic
= intr
;
8627 gensym
->attr
.if_source
= IFSRC_DECL
;
8630 /* The symbol may already have the derived attribute without the
8631 components. The ways this can happen is via a function
8632 definition, an INTRINSIC statement or a subtype in another
8633 derived type that is a pointer. The first part of the AND clause
8634 is true if the symbol is not the return value of a function. */
8635 if (sym
->attr
.flavor
!= FL_DERIVED
8636 && !gfc_add_flavor (&sym
->attr
, FL_DERIVED
, sym
->name
, NULL
))
8639 if (attr
.access
!= ACCESS_UNKNOWN
8640 && !gfc_add_access (&sym
->attr
, attr
.access
, sym
->name
, NULL
))
8642 else if (sym
->attr
.access
== ACCESS_UNKNOWN
8643 && gensym
->attr
.access
!= ACCESS_UNKNOWN
8644 && !gfc_add_access (&sym
->attr
, gensym
->attr
.access
,
8648 if (sym
->attr
.access
!= ACCESS_UNKNOWN
8649 && gensym
->attr
.access
== ACCESS_UNKNOWN
)
8650 gensym
->attr
.access
= sym
->attr
.access
;
8652 /* See if the derived type was labeled as bind(c). */
8653 if (attr
.is_bind_c
!= 0)
8654 sym
->attr
.is_bind_c
= attr
.is_bind_c
;
8656 /* Construct the f2k_derived namespace if it is not yet there. */
8657 if (!sym
->f2k_derived
)
8658 sym
->f2k_derived
= gfc_get_namespace (NULL
, 0);
8660 if (extended
&& !sym
->components
)
8664 /* Add the extended derived type as the first component. */
8665 gfc_add_component (sym
, parent
, &p
);
8667 gfc_set_sym_referenced (extended
);
8669 p
->ts
.type
= BT_DERIVED
;
8670 p
->ts
.u
.derived
= extended
;
8671 p
->initializer
= gfc_default_initializer (&p
->ts
);
8673 /* Set extension level. */
8674 if (extended
->attr
.extension
== 255)
8676 /* Since the extension field is 8 bit wide, we can only have
8677 up to 255 extension levels. */
8678 gfc_error ("Maximum extension level reached with type %qs at %L",
8679 extended
->name
, &extended
->declared_at
);
8682 sym
->attr
.extension
= extended
->attr
.extension
+ 1;
8684 /* Provide the links between the extended type and its extension. */
8685 if (!extended
->f2k_derived
)
8686 extended
->f2k_derived
= gfc_get_namespace (NULL
, 0);
8689 if (!sym
->hash_value
)
8690 /* Set the hash for the compound name for this type. */
8691 sym
->hash_value
= gfc_hash_value (sym
);
8693 /* Take over the ABSTRACT attribute. */
8694 sym
->attr
.abstract
= attr
.abstract
;
8696 gfc_new_block
= sym
;
8702 /* Cray Pointees can be declared as:
8703 pointer (ipt, a (n,m,...,*)) */
8706 gfc_mod_pointee_as (gfc_array_spec
*as
)
8708 as
->cray_pointee
= true; /* This will be useful to know later. */
8709 if (as
->type
== AS_ASSUMED_SIZE
)
8710 as
->cp_was_assumed
= true;
8711 else if (as
->type
== AS_ASSUMED_SHAPE
)
8713 gfc_error ("Cray Pointee at %C cannot be assumed shape array");
8720 /* Match the enum definition statement, here we are trying to match
8721 the first line of enum definition statement.
8722 Returns MATCH_YES if match is found. */
8725 gfc_match_enum (void)
8729 m
= gfc_match_eos ();
8733 if (!gfc_notify_std (GFC_STD_F2003
, "ENUM and ENUMERATOR at %C"))
8740 /* Returns an initializer whose value is one higher than the value of the
8741 LAST_INITIALIZER argument. If the argument is NULL, the
8742 initializers value will be set to zero. The initializer's kind
8743 will be set to gfc_c_int_kind.
8745 If -fshort-enums is given, the appropriate kind will be selected
8746 later after all enumerators have been parsed. A warning is issued
8747 here if an initializer exceeds gfc_c_int_kind. */
8750 enum_initializer (gfc_expr
*last_initializer
, locus where
)
8753 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_c_int_kind
, &where
);
8755 mpz_init (result
->value
.integer
);
8757 if (last_initializer
!= NULL
)
8759 mpz_add_ui (result
->value
.integer
, last_initializer
->value
.integer
, 1);
8760 result
->where
= last_initializer
->where
;
8762 if (gfc_check_integer_range (result
->value
.integer
,
8763 gfc_c_int_kind
) != ARITH_OK
)
8765 gfc_error ("Enumerator exceeds the C integer type at %C");
8771 /* Control comes here, if it's the very first enumerator and no
8772 initializer has been given. It will be initialized to zero. */
8773 mpz_set_si (result
->value
.integer
, 0);
8780 /* Match a variable name with an optional initializer. When this
8781 subroutine is called, a variable is expected to be parsed next.
8782 Depending on what is happening at the moment, updates either the
8783 symbol table or the current interface. */
8786 enumerator_decl (void)
8788 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8789 gfc_expr
*initializer
;
8790 gfc_array_spec
*as
= NULL
;
8798 old_locus
= gfc_current_locus
;
8800 /* When we get here, we've just matched a list of attributes and
8801 maybe a type and a double colon. The next thing we expect to see
8802 is the name of the symbol. */
8803 m
= gfc_match_name (name
);
8807 var_locus
= gfc_current_locus
;
8809 /* OK, we've successfully matched the declaration. Now put the
8810 symbol in the current namespace. If we fail to create the symbol,
8812 if (!build_sym (name
, NULL
, false, &as
, &var_locus
))
8818 /* The double colon must be present in order to have initializers.
8819 Otherwise the statement is ambiguous with an assignment statement. */
8822 if (gfc_match_char ('=') == MATCH_YES
)
8824 m
= gfc_match_init_expr (&initializer
);
8827 gfc_error ("Expected an initialization expression at %C");
8836 /* If we do not have an initializer, the initialization value of the
8837 previous enumerator (stored in last_initializer) is incremented
8838 by 1 and is used to initialize the current enumerator. */
8839 if (initializer
== NULL
)
8840 initializer
= enum_initializer (last_initializer
, old_locus
);
8842 if (initializer
== NULL
|| initializer
->ts
.type
!= BT_INTEGER
)
8844 gfc_error ("ENUMERATOR %L not initialized with integer expression",
8850 /* Store this current initializer, for the next enumerator variable
8851 to be parsed. add_init_expr_to_sym() zeros initializer, so we
8852 use last_initializer below. */
8853 last_initializer
= initializer
;
8854 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
8856 /* Maintain enumerator history. */
8857 gfc_find_symbol (name
, NULL
, 0, &sym
);
8858 create_enum_history (sym
, last_initializer
);
8860 return (t
) ? MATCH_YES
: MATCH_ERROR
;
8863 /* Free stuff up and return. */
8864 gfc_free_expr (initializer
);
8870 /* Match the enumerator definition statement. */
8873 gfc_match_enumerator_def (void)
8878 gfc_clear_ts (¤t_ts
);
8880 m
= gfc_match (" enumerator");
8884 m
= gfc_match (" :: ");
8885 if (m
== MATCH_ERROR
)
8888 colon_seen
= (m
== MATCH_YES
);
8890 if (gfc_current_state () != COMP_ENUM
)
8892 gfc_error ("ENUM definition statement expected before %C");
8893 gfc_free_enum_history ();
8897 (¤t_ts
)->type
= BT_INTEGER
;
8898 (¤t_ts
)->kind
= gfc_c_int_kind
;
8900 gfc_clear_attr (¤t_attr
);
8901 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, NULL
);
8910 m
= enumerator_decl ();
8911 if (m
== MATCH_ERROR
)
8913 gfc_free_enum_history ();
8919 if (gfc_match_eos () == MATCH_YES
)
8921 if (gfc_match_char (',') != MATCH_YES
)
8925 if (gfc_current_state () == COMP_ENUM
)
8927 gfc_free_enum_history ();
8928 gfc_error ("Syntax error in ENUMERATOR definition at %C");
8933 gfc_free_array_spec (current_as
);
8940 /* Match binding attributes. */
8943 match_binding_attributes (gfc_typebound_proc
* ba
, bool generic
, bool ppc
)
8945 bool found_passing
= false;
8946 bool seen_ptr
= false;
8947 match m
= MATCH_YES
;
8949 /* Initialize to defaults. Do so even before the MATCH_NO check so that in
8950 this case the defaults are in there. */
8951 ba
->access
= ACCESS_UNKNOWN
;
8952 ba
->pass_arg
= NULL
;
8953 ba
->pass_arg_num
= 0;
8955 ba
->non_overridable
= 0;
8959 /* If we find a comma, we believe there are binding attributes. */
8960 m
= gfc_match_char (',');
8966 /* Access specifier. */
8968 m
= gfc_match (" public");
8969 if (m
== MATCH_ERROR
)
8973 if (ba
->access
!= ACCESS_UNKNOWN
)
8975 gfc_error ("Duplicate access-specifier at %C");
8979 ba
->access
= ACCESS_PUBLIC
;
8983 m
= gfc_match (" private");
8984 if (m
== MATCH_ERROR
)
8988 if (ba
->access
!= ACCESS_UNKNOWN
)
8990 gfc_error ("Duplicate access-specifier at %C");
8994 ba
->access
= ACCESS_PRIVATE
;
8998 /* If inside GENERIC, the following is not allowed. */
9003 m
= gfc_match (" nopass");
9004 if (m
== MATCH_ERROR
)
9010 gfc_error ("Binding attributes already specify passing,"
9011 " illegal NOPASS at %C");
9015 found_passing
= true;
9020 /* PASS possibly including argument. */
9021 m
= gfc_match (" pass");
9022 if (m
== MATCH_ERROR
)
9026 char arg
[GFC_MAX_SYMBOL_LEN
+ 1];
9030 gfc_error ("Binding attributes already specify passing,"
9031 " illegal PASS at %C");
9035 m
= gfc_match (" ( %n )", arg
);
9036 if (m
== MATCH_ERROR
)
9039 ba
->pass_arg
= gfc_get_string (arg
);
9040 gcc_assert ((m
== MATCH_YES
) == (ba
->pass_arg
!= NULL
));
9042 found_passing
= true;
9050 m
= gfc_match (" pointer");
9051 if (m
== MATCH_ERROR
)
9057 gfc_error ("Duplicate POINTER attribute at %C");
9067 /* NON_OVERRIDABLE flag. */
9068 m
= gfc_match (" non_overridable");
9069 if (m
== MATCH_ERROR
)
9073 if (ba
->non_overridable
)
9075 gfc_error ("Duplicate NON_OVERRIDABLE at %C");
9079 ba
->non_overridable
= 1;
9083 /* DEFERRED flag. */
9084 m
= gfc_match (" deferred");
9085 if (m
== MATCH_ERROR
)
9091 gfc_error ("Duplicate DEFERRED at %C");
9102 /* Nothing matching found. */
9104 gfc_error ("Expected access-specifier at %C");
9106 gfc_error ("Expected binding attribute at %C");
9109 while (gfc_match_char (',') == MATCH_YES
);
9111 /* NON_OVERRIDABLE and DEFERRED exclude themselves. */
9112 if (ba
->non_overridable
&& ba
->deferred
)
9114 gfc_error ("NON_OVERRIDABLE and DEFERRED can't both appear at %C");
9121 if (ba
->access
== ACCESS_UNKNOWN
)
9122 ba
->access
= gfc_typebound_default_access
;
9124 if (ppc
&& !seen_ptr
)
9126 gfc_error ("POINTER attribute is required for procedure pointer component"
9138 /* Match a PROCEDURE specific binding inside a derived type. */
9141 match_procedure_in_type (void)
9143 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9144 char target_buf
[GFC_MAX_SYMBOL_LEN
+ 1];
9145 char* target
= NULL
, *ifc
= NULL
;
9146 gfc_typebound_proc tb
;
9155 /* Check current state. */
9156 gcc_assert (gfc_state_stack
->state
== COMP_DERIVED_CONTAINS
);
9157 block
= gfc_state_stack
->previous
->sym
;
9160 /* Try to match PROCEDURE(interface). */
9161 if (gfc_match (" (") == MATCH_YES
)
9163 m
= gfc_match_name (target_buf
);
9164 if (m
== MATCH_ERROR
)
9168 gfc_error ("Interface-name expected after %<(%> at %C");
9172 if (gfc_match (" )") != MATCH_YES
)
9174 gfc_error ("%<)%> expected at %C");
9181 /* Construct the data structure. */
9182 memset (&tb
, 0, sizeof (tb
));
9183 tb
.where
= gfc_current_locus
;
9185 /* Match binding attributes. */
9186 m
= match_binding_attributes (&tb
, false, false);
9187 if (m
== MATCH_ERROR
)
9189 seen_attrs
= (m
== MATCH_YES
);
9191 /* Check that attribute DEFERRED is given if an interface is specified. */
9192 if (tb
.deferred
&& !ifc
)
9194 gfc_error ("Interface must be specified for DEFERRED binding at %C");
9197 if (ifc
&& !tb
.deferred
)
9199 gfc_error ("PROCEDURE(interface) at %C should be declared DEFERRED");
9203 /* Match the colons. */
9204 m
= gfc_match (" ::");
9205 if (m
== MATCH_ERROR
)
9207 seen_colons
= (m
== MATCH_YES
);
9208 if (seen_attrs
&& !seen_colons
)
9210 gfc_error ("Expected %<::%> after binding-attributes at %C");
9214 /* Match the binding names. */
9217 m
= gfc_match_name (name
);
9218 if (m
== MATCH_ERROR
)
9222 gfc_error ("Expected binding name at %C");
9226 if (num
>1 && !gfc_notify_std (GFC_STD_F2008
, "PROCEDURE list at %C"))
9229 /* Try to match the '=> target', if it's there. */
9231 m
= gfc_match (" =>");
9232 if (m
== MATCH_ERROR
)
9238 gfc_error ("%<=> target%> is invalid for DEFERRED binding at %C");
9244 gfc_error ("%<::%> needed in PROCEDURE binding with explicit target"
9249 m
= gfc_match_name (target_buf
);
9250 if (m
== MATCH_ERROR
)
9254 gfc_error ("Expected binding target after %<=>%> at %C");
9257 target
= target_buf
;
9260 /* If no target was found, it has the same name as the binding. */
9264 /* Get the namespace to insert the symbols into. */
9265 ns
= block
->f2k_derived
;
9268 /* If the binding is DEFERRED, check that the containing type is ABSTRACT. */
9269 if (tb
.deferred
&& !block
->attr
.abstract
)
9271 gfc_error ("Type %qs containing DEFERRED binding at %C "
9272 "is not ABSTRACT", block
->name
);
9276 /* See if we already have a binding with this name in the symtree which
9277 would be an error. If a GENERIC already targeted this binding, it may
9278 be already there but then typebound is still NULL. */
9279 stree
= gfc_find_symtree (ns
->tb_sym_root
, name
);
9280 if (stree
&& stree
->n
.tb
)
9282 gfc_error ("There is already a procedure with binding name %qs for "
9283 "the derived type %qs at %C", name
, block
->name
);
9287 /* Insert it and set attributes. */
9291 stree
= gfc_new_symtree (&ns
->tb_sym_root
, name
);
9294 stree
->n
.tb
= gfc_get_typebound_proc (&tb
);
9296 if (gfc_get_sym_tree (target
, gfc_current_ns
, &stree
->n
.tb
->u
.specific
,
9299 gfc_set_sym_referenced (stree
->n
.tb
->u
.specific
->n
.sym
);
9301 if (gfc_match_eos () == MATCH_YES
)
9303 if (gfc_match_char (',') != MATCH_YES
)
9308 gfc_error ("Syntax error in PROCEDURE statement at %C");
9313 /* Match a GENERIC procedure binding inside a derived type. */
9316 gfc_match_generic (void)
9318 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9319 char bind_name
[GFC_MAX_SYMBOL_LEN
+ 16]; /* Allow space for OPERATOR(...). */
9321 gfc_typebound_proc tbattr
; /* Used for match_binding_attributes. */
9322 gfc_typebound_proc
* tb
;
9324 interface_type op_type
;
9325 gfc_intrinsic_op op
;
9328 /* Check current state. */
9329 if (gfc_current_state () == COMP_DERIVED
)
9331 gfc_error ("GENERIC at %C must be inside a derived-type CONTAINS");
9334 if (gfc_current_state () != COMP_DERIVED_CONTAINS
)
9336 block
= gfc_state_stack
->previous
->sym
;
9337 ns
= block
->f2k_derived
;
9338 gcc_assert (block
&& ns
);
9340 memset (&tbattr
, 0, sizeof (tbattr
));
9341 tbattr
.where
= gfc_current_locus
;
9343 /* See if we get an access-specifier. */
9344 m
= match_binding_attributes (&tbattr
, true, false);
9345 if (m
== MATCH_ERROR
)
9348 /* Now the colons, those are required. */
9349 if (gfc_match (" ::") != MATCH_YES
)
9351 gfc_error ("Expected %<::%> at %C");
9355 /* Match the binding name; depending on type (operator / generic) format
9356 it for future error messages into bind_name. */
9358 m
= gfc_match_generic_spec (&op_type
, name
, &op
);
9359 if (m
== MATCH_ERROR
)
9363 gfc_error ("Expected generic name or operator descriptor at %C");
9369 case INTERFACE_GENERIC
:
9370 snprintf (bind_name
, sizeof (bind_name
), "%s", name
);
9373 case INTERFACE_USER_OP
:
9374 snprintf (bind_name
, sizeof (bind_name
), "OPERATOR(.%s.)", name
);
9377 case INTERFACE_INTRINSIC_OP
:
9378 snprintf (bind_name
, sizeof (bind_name
), "OPERATOR(%s)",
9379 gfc_op2string (op
));
9382 case INTERFACE_NAMELESS
:
9383 gfc_error ("Malformed GENERIC statement at %C");
9391 /* Match the required =>. */
9392 if (gfc_match (" =>") != MATCH_YES
)
9394 gfc_error ("Expected %<=>%> at %C");
9398 /* Try to find existing GENERIC binding with this name / for this operator;
9399 if there is something, check that it is another GENERIC and then extend
9400 it rather than building a new node. Otherwise, create it and put it
9401 at the right position. */
9405 case INTERFACE_USER_OP
:
9406 case INTERFACE_GENERIC
:
9408 const bool is_op
= (op_type
== INTERFACE_USER_OP
);
9411 st
= gfc_find_symtree (is_op
? ns
->tb_uop_root
: ns
->tb_sym_root
, name
);
9423 case INTERFACE_INTRINSIC_OP
:
9433 if (!tb
->is_generic
)
9435 gcc_assert (op_type
== INTERFACE_GENERIC
);
9436 gfc_error ("There's already a non-generic procedure with binding name"
9437 " %qs for the derived type %qs at %C",
9438 bind_name
, block
->name
);
9442 if (tb
->access
!= tbattr
.access
)
9444 gfc_error ("Binding at %C must have the same access as already"
9445 " defined binding %qs", bind_name
);
9451 tb
= gfc_get_typebound_proc (NULL
);
9452 tb
->where
= gfc_current_locus
;
9453 tb
->access
= tbattr
.access
;
9455 tb
->u
.generic
= NULL
;
9459 case INTERFACE_GENERIC
:
9460 case INTERFACE_USER_OP
:
9462 const bool is_op
= (op_type
== INTERFACE_USER_OP
);
9465 st
= gfc_new_symtree (is_op
? &ns
->tb_uop_root
: &ns
->tb_sym_root
,
9473 case INTERFACE_INTRINSIC_OP
:
9482 /* Now, match all following names as specific targets. */
9485 gfc_symtree
* target_st
;
9486 gfc_tbp_generic
* target
;
9488 m
= gfc_match_name (name
);
9489 if (m
== MATCH_ERROR
)
9493 gfc_error ("Expected specific binding name at %C");
9497 target_st
= gfc_get_tbp_symtree (&ns
->tb_sym_root
, name
);
9499 /* See if this is a duplicate specification. */
9500 for (target
= tb
->u
.generic
; target
; target
= target
->next
)
9501 if (target_st
== target
->specific_st
)
9503 gfc_error ("%qs already defined as specific binding for the"
9504 " generic %qs at %C", name
, bind_name
);
9508 target
= gfc_get_tbp_generic ();
9509 target
->specific_st
= target_st
;
9510 target
->specific
= NULL
;
9511 target
->next
= tb
->u
.generic
;
9512 target
->is_operator
= ((op_type
== INTERFACE_USER_OP
)
9513 || (op_type
== INTERFACE_INTRINSIC_OP
));
9514 tb
->u
.generic
= target
;
9516 while (gfc_match (" ,") == MATCH_YES
);
9518 /* Here should be the end. */
9519 if (gfc_match_eos () != MATCH_YES
)
9521 gfc_error ("Junk after GENERIC binding at %C");
9532 /* Match a FINAL declaration inside a derived type. */
9535 gfc_match_final_decl (void)
9537 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9540 gfc_namespace
* module_ns
;
9544 if (gfc_current_form
== FORM_FREE
)
9546 char c
= gfc_peek_ascii_char ();
9547 if (!gfc_is_whitespace (c
) && c
!= ':')
9551 if (gfc_state_stack
->state
!= COMP_DERIVED_CONTAINS
)
9553 if (gfc_current_form
== FORM_FIXED
)
9556 gfc_error ("FINAL declaration at %C must be inside a derived type "
9557 "CONTAINS section");
9561 block
= gfc_state_stack
->previous
->sym
;
9564 if (!gfc_state_stack
->previous
|| !gfc_state_stack
->previous
->previous
9565 || gfc_state_stack
->previous
->previous
->state
!= COMP_MODULE
)
9567 gfc_error ("Derived type declaration with FINAL at %C must be in the"
9568 " specification part of a MODULE");
9572 module_ns
= gfc_current_ns
;
9573 gcc_assert (module_ns
);
9574 gcc_assert (module_ns
->proc_name
->attr
.flavor
== FL_MODULE
);
9576 /* Match optional ::, don't care about MATCH_YES or MATCH_NO. */
9577 if (gfc_match (" ::") == MATCH_ERROR
)
9580 /* Match the sequence of procedure names. */
9587 if (first
&& gfc_match_eos () == MATCH_YES
)
9589 gfc_error ("Empty FINAL at %C");
9593 m
= gfc_match_name (name
);
9596 gfc_error ("Expected module procedure name at %C");
9599 else if (m
!= MATCH_YES
)
9602 if (gfc_match_eos () == MATCH_YES
)
9604 if (!last
&& gfc_match_char (',') != MATCH_YES
)
9606 gfc_error ("Expected %<,%> at %C");
9610 if (gfc_get_symbol (name
, module_ns
, &sym
))
9612 gfc_error ("Unknown procedure name %qs at %C", name
);
9616 /* Mark the symbol as module procedure. */
9617 if (sym
->attr
.proc
!= PROC_MODULE
9618 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
9621 /* Check if we already have this symbol in the list, this is an error. */
9622 for (f
= block
->f2k_derived
->finalizers
; f
; f
= f
->next
)
9623 if (f
->proc_sym
== sym
)
9625 gfc_error ("%qs at %C is already defined as FINAL procedure!",
9630 /* Add this symbol to the list of finalizers. */
9631 gcc_assert (block
->f2k_derived
);
9633 f
= XCNEW (gfc_finalizer
);
9635 f
->proc_tree
= NULL
;
9636 f
->where
= gfc_current_locus
;
9637 f
->next
= block
->f2k_derived
->finalizers
;
9638 block
->f2k_derived
->finalizers
= f
;
9648 const ext_attr_t ext_attr_list
[] = {
9649 { "dllimport", EXT_ATTR_DLLIMPORT
, "dllimport" },
9650 { "dllexport", EXT_ATTR_DLLEXPORT
, "dllexport" },
9651 { "cdecl", EXT_ATTR_CDECL
, "cdecl" },
9652 { "stdcall", EXT_ATTR_STDCALL
, "stdcall" },
9653 { "fastcall", EXT_ATTR_FASTCALL
, "fastcall" },
9654 { "no_arg_check", EXT_ATTR_NO_ARG_CHECK
, NULL
},
9655 { NULL
, EXT_ATTR_LAST
, NULL
}
9658 /* Match a !GCC$ ATTRIBUTES statement of the form:
9659 !GCC$ ATTRIBUTES attribute-list :: var-name [, var-name] ...
9660 When we come here, we have already matched the !GCC$ ATTRIBUTES string.
9662 TODO: We should support all GCC attributes using the same syntax for
9663 the attribute list, i.e. the list in C
9664 __attributes(( attribute-list ))
9666 !GCC$ ATTRIBUTES attribute-list ::
9667 Cf. c-parser.c's c_parser_attributes; the data can then directly be
9670 As there is absolutely no risk of confusion, we should never return
9673 gfc_match_gcc_attributes (void)
9675 symbol_attribute attr
;
9676 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9681 gfc_clear_attr (&attr
);
9686 if (gfc_match_name (name
) != MATCH_YES
)
9689 for (id
= 0; id
< EXT_ATTR_LAST
; id
++)
9690 if (strcmp (name
, ext_attr_list
[id
].name
) == 0)
9693 if (id
== EXT_ATTR_LAST
)
9695 gfc_error ("Unknown attribute in !GCC$ ATTRIBUTES statement at %C");
9699 if (!gfc_add_ext_attribute (&attr
, (ext_attr_id_t
)id
, &gfc_current_locus
))
9702 gfc_gobble_whitespace ();
9703 ch
= gfc_next_ascii_char ();
9706 /* This is the successful exit condition for the loop. */
9707 if (gfc_next_ascii_char () == ':')
9717 if (gfc_match_eos () == MATCH_YES
)
9722 m
= gfc_match_name (name
);
9726 if (find_special (name
, &sym
, true))
9729 sym
->attr
.ext_attr
|= attr
.ext_attr
;
9731 if (gfc_match_eos () == MATCH_YES
)
9734 if (gfc_match_char (',') != MATCH_YES
)
9741 gfc_error ("Syntax error in !GCC$ ATTRIBUTES statement at %C");