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 (dest
->module_procedure
)
4983 if (current_attr
.elemental
)
4984 dest
->elemental
= 1;
4986 if (current_attr
.pure
)
4989 if (current_attr
.recursive
)
4990 dest
->recursive
= 1;
4992 /* Module procedures are unusual in that the 'dest' is copied from
4993 the interface declaration. However, this is an oportunity to
4994 check that the submodule declaration is compliant with the
4996 if (dest
->elemental
&& !current_attr
.elemental
)
4998 gfc_error ("ELEMENTAL prefix in MODULE PROCEDURE interface is "
4999 "missing at %L", where
);
5003 if (dest
->pure
&& !current_attr
.pure
)
5005 gfc_error ("PURE prefix in MODULE PROCEDURE interface is "
5006 "missing at %L", where
);
5010 if (dest
->recursive
&& !current_attr
.recursive
)
5012 gfc_error ("RECURSIVE prefix in MODULE PROCEDURE interface is "
5013 "missing at %L", where
);
5020 if (current_attr
.elemental
&& !gfc_add_elemental (dest
, where
))
5023 if (current_attr
.pure
&& !gfc_add_pure (dest
, where
))
5026 if (current_attr
.recursive
&& !gfc_add_recursive (dest
, where
))
5033 /* Match a formal argument list. */
5036 gfc_match_formal_arglist (gfc_symbol
*progname
, int st_flag
, int null_flag
)
5038 gfc_formal_arglist
*head
, *tail
, *p
, *q
;
5039 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5042 gfc_formal_arglist
*formal
= NULL
;
5046 /* Keep the interface formal argument list and null it so that the
5047 matching for the new declaration can be done. The numbers and
5048 names of the arguments are checked here. The interface formal
5049 arguments are retained in formal_arglist and the characteristics
5050 are compared in resolve.c(resolve_fl_procedure). See the remark
5051 in get_proc_name about the eventual need to copy the formal_arglist
5052 and populate the formal namespace of the interface symbol. */
5053 if (progname
->attr
.module_procedure
5054 && progname
->attr
.host_assoc
)
5056 formal
= progname
->formal
;
5057 progname
->formal
= NULL
;
5060 if (gfc_match_char ('(') != MATCH_YES
)
5067 if (gfc_match_char (')') == MATCH_YES
)
5072 if (gfc_match_char ('*') == MATCH_YES
)
5075 if (!gfc_notify_std (GFC_STD_F95_OBS
, "Alternate-return argument "
5084 m
= gfc_match_name (name
);
5088 if (gfc_get_symbol (name
, NULL
, &sym
))
5092 p
= gfc_get_formal_arglist ();
5104 /* We don't add the VARIABLE flavor because the name could be a
5105 dummy procedure. We don't apply these attributes to formal
5106 arguments of statement functions. */
5107 if (sym
!= NULL
&& !st_flag
5108 && (!gfc_add_dummy(&sym
->attr
, sym
->name
, NULL
)
5109 || !gfc_missing_attr (&sym
->attr
, NULL
)))
5115 /* The name of a program unit can be in a different namespace,
5116 so check for it explicitly. After the statement is accepted,
5117 the name is checked for especially in gfc_get_symbol(). */
5118 if (gfc_new_block
!= NULL
&& sym
!= NULL
5119 && strcmp (sym
->name
, gfc_new_block
->name
) == 0)
5121 gfc_error ("Name %qs at %C is the name of the procedure",
5127 if (gfc_match_char (')') == MATCH_YES
)
5130 m
= gfc_match_char (',');
5133 gfc_error ("Unexpected junk in formal argument list at %C");
5139 /* Check for duplicate symbols in the formal argument list. */
5142 for (p
= head
; p
->next
; p
= p
->next
)
5147 for (q
= p
->next
; q
; q
= q
->next
)
5148 if (p
->sym
== q
->sym
)
5150 gfc_error ("Duplicate symbol %qs in formal argument list "
5151 "at %C", p
->sym
->name
);
5159 if (!gfc_add_explicit_interface (progname
, IFSRC_DECL
, head
, NULL
))
5165 /* gfc_error_now used in following and return with MATCH_YES because
5166 doing otherwise results in a cascade of extraneous errors and in
5167 some cases an ICE in symbol.c(gfc_release_symbol). */
5168 if (progname
->attr
.module_procedure
&& progname
->attr
.host_assoc
)
5170 bool arg_count_mismatch
= false;
5172 if (!formal
&& head
)
5173 arg_count_mismatch
= true;
5175 /* Abbreviated module procedure declaration is not meant to have any
5176 formal arguments! */
5177 if (!progname
->abr_modproc_decl
&& formal
&& !head
)
5178 arg_count_mismatch
= true;
5180 for (p
= formal
, q
= head
; p
&& q
; p
= p
->next
, q
= q
->next
)
5182 if ((p
->next
!= NULL
&& q
->next
== NULL
)
5183 || (p
->next
== NULL
&& q
->next
!= NULL
))
5184 arg_count_mismatch
= true;
5185 else if ((p
->sym
== NULL
&& q
->sym
== NULL
)
5186 || strcmp (p
->sym
->name
, q
->sym
->name
) == 0)
5189 gfc_error_now ("Mismatch in MODULE PROCEDURE formal "
5190 "argument names (%s/%s) at %C",
5191 p
->sym
->name
, q
->sym
->name
);
5194 if (arg_count_mismatch
)
5195 gfc_error_now ("Mismatch in number of MODULE PROCEDURE "
5196 "formal arguments at %C");
5202 gfc_free_formal_arglist (head
);
5207 /* Match a RESULT specification following a function declaration or
5208 ENTRY statement. Also matches the end-of-statement. */
5211 match_result (gfc_symbol
*function
, gfc_symbol
**result
)
5213 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5217 if (gfc_match (" result (") != MATCH_YES
)
5220 m
= gfc_match_name (name
);
5224 /* Get the right paren, and that's it because there could be the
5225 bind(c) attribute after the result clause. */
5226 if (gfc_match_char (')') != MATCH_YES
)
5228 /* TODO: should report the missing right paren here. */
5232 if (strcmp (function
->name
, name
) == 0)
5234 gfc_error ("RESULT variable at %C must be different than function name");
5238 if (gfc_get_symbol (name
, NULL
, &r
))
5241 if (!gfc_add_result (&r
->attr
, r
->name
, NULL
))
5250 /* Match a function suffix, which could be a combination of a result
5251 clause and BIND(C), either one, or neither. The draft does not
5252 require them to come in a specific order. */
5255 gfc_match_suffix (gfc_symbol
*sym
, gfc_symbol
**result
)
5257 match is_bind_c
; /* Found bind(c). */
5258 match is_result
; /* Found result clause. */
5259 match found_match
; /* Status of whether we've found a good match. */
5260 char peek_char
; /* Character we're going to peek at. */
5261 bool allow_binding_name
;
5263 /* Initialize to having found nothing. */
5264 found_match
= MATCH_NO
;
5265 is_bind_c
= MATCH_NO
;
5266 is_result
= MATCH_NO
;
5268 /* Get the next char to narrow between result and bind(c). */
5269 gfc_gobble_whitespace ();
5270 peek_char
= gfc_peek_ascii_char ();
5272 /* C binding names are not allowed for internal procedures. */
5273 if (gfc_current_state () == COMP_CONTAINS
5274 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
5275 allow_binding_name
= false;
5277 allow_binding_name
= true;
5282 /* Look for result clause. */
5283 is_result
= match_result (sym
, result
);
5284 if (is_result
== MATCH_YES
)
5286 /* Now see if there is a bind(c) after it. */
5287 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
5288 /* We've found the result clause and possibly bind(c). */
5289 found_match
= MATCH_YES
;
5292 /* This should only be MATCH_ERROR. */
5293 found_match
= is_result
;
5296 /* Look for bind(c) first. */
5297 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
5298 if (is_bind_c
== MATCH_YES
)
5300 /* Now see if a result clause followed it. */
5301 is_result
= match_result (sym
, result
);
5302 found_match
= MATCH_YES
;
5306 /* Should only be a MATCH_ERROR if we get here after seeing 'b'. */
5307 found_match
= MATCH_ERROR
;
5311 gfc_error ("Unexpected junk after function declaration at %C");
5312 found_match
= MATCH_ERROR
;
5316 if (is_bind_c
== MATCH_YES
)
5318 /* Fortran 2008 draft allows BIND(C) for internal procedures. */
5319 if (gfc_current_state () == COMP_CONTAINS
5320 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
5321 && !gfc_notify_std (GFC_STD_F2008
, "BIND(C) attribute "
5322 "at %L may not be specified for an internal "
5323 "procedure", &gfc_current_locus
))
5326 if (!gfc_add_is_bind_c (&(sym
->attr
), sym
->name
, &gfc_current_locus
, 1))
5334 /* Procedure pointer return value without RESULT statement:
5335 Add "hidden" result variable named "ppr@". */
5338 add_hidden_procptr_result (gfc_symbol
*sym
)
5342 if (gfc_notification_std (GFC_STD_F2003
) == ERROR
)
5345 /* First usage case: PROCEDURE and EXTERNAL statements. */
5346 case1
= gfc_current_state () == COMP_FUNCTION
&& gfc_current_block ()
5347 && strcmp (gfc_current_block ()->name
, sym
->name
) == 0
5348 && sym
->attr
.external
;
5349 /* Second usage case: INTERFACE statements. */
5350 case2
= gfc_current_state () == COMP_INTERFACE
&& gfc_state_stack
->previous
5351 && gfc_state_stack
->previous
->state
== COMP_FUNCTION
5352 && strcmp (gfc_state_stack
->previous
->sym
->name
, sym
->name
) == 0;
5358 gfc_get_sym_tree ("ppr@", gfc_current_ns
, &stree
, false);
5362 gfc_get_sym_tree ("ppr@", gfc_current_ns
->parent
, &stree
, false);
5363 st2
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "ppr@");
5364 st2
->n
.sym
= stree
->n
.sym
;
5366 sym
->result
= stree
->n
.sym
;
5368 sym
->result
->attr
.proc_pointer
= sym
->attr
.proc_pointer
;
5369 sym
->result
->attr
.pointer
= sym
->attr
.pointer
;
5370 sym
->result
->attr
.external
= sym
->attr
.external
;
5371 sym
->result
->attr
.referenced
= sym
->attr
.referenced
;
5372 sym
->result
->ts
= sym
->ts
;
5373 sym
->attr
.proc_pointer
= 0;
5374 sym
->attr
.pointer
= 0;
5375 sym
->attr
.external
= 0;
5376 if (sym
->result
->attr
.external
&& sym
->result
->attr
.pointer
)
5378 sym
->result
->attr
.pointer
= 0;
5379 sym
->result
->attr
.proc_pointer
= 1;
5382 return gfc_add_result (&sym
->result
->attr
, sym
->result
->name
, NULL
);
5384 /* POINTER after PROCEDURE/EXTERNAL/INTERFACE statement. */
5385 else if (sym
->attr
.function
&& !sym
->attr
.external
&& sym
->attr
.pointer
5386 && sym
->result
&& sym
->result
!= sym
&& sym
->result
->attr
.external
5387 && sym
== gfc_current_ns
->proc_name
5388 && sym
== sym
->result
->ns
->proc_name
5389 && strcmp ("ppr@", sym
->result
->name
) == 0)
5391 sym
->result
->attr
.proc_pointer
= 1;
5392 sym
->attr
.pointer
= 0;
5400 /* Match the interface for a PROCEDURE declaration,
5401 including brackets (R1212). */
5404 match_procedure_interface (gfc_symbol
**proc_if
)
5408 locus old_loc
, entry_loc
;
5409 gfc_namespace
*old_ns
= gfc_current_ns
;
5410 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5412 old_loc
= entry_loc
= gfc_current_locus
;
5413 gfc_clear_ts (¤t_ts
);
5415 if (gfc_match (" (") != MATCH_YES
)
5417 gfc_current_locus
= entry_loc
;
5421 /* Get the type spec. for the procedure interface. */
5422 old_loc
= gfc_current_locus
;
5423 m
= gfc_match_decl_type_spec (¤t_ts
, 0);
5424 gfc_gobble_whitespace ();
5425 if (m
== MATCH_YES
|| (m
== MATCH_NO
&& gfc_peek_ascii_char () == ')'))
5428 if (m
== MATCH_ERROR
)
5431 /* Procedure interface is itself a procedure. */
5432 gfc_current_locus
= old_loc
;
5433 m
= gfc_match_name (name
);
5435 /* First look to see if it is already accessible in the current
5436 namespace because it is use associated or contained. */
5438 if (gfc_find_sym_tree (name
, NULL
, 0, &st
))
5441 /* If it is still not found, then try the parent namespace, if it
5442 exists and create the symbol there if it is still not found. */
5443 if (gfc_current_ns
->parent
)
5444 gfc_current_ns
= gfc_current_ns
->parent
;
5445 if (st
== NULL
&& gfc_get_ha_sym_tree (name
, &st
))
5448 gfc_current_ns
= old_ns
;
5449 *proc_if
= st
->n
.sym
;
5454 /* Resolve interface if possible. That way, attr.procedure is only set
5455 if it is declared by a later procedure-declaration-stmt, which is
5456 invalid per F08:C1216 (cf. resolve_procedure_interface). */
5457 while ((*proc_if
)->ts
.interface
)
5458 *proc_if
= (*proc_if
)->ts
.interface
;
5460 if ((*proc_if
)->attr
.flavor
== FL_UNKNOWN
5461 && (*proc_if
)->ts
.type
== BT_UNKNOWN
5462 && !gfc_add_flavor (&(*proc_if
)->attr
, FL_PROCEDURE
,
5463 (*proc_if
)->name
, NULL
))
5468 if (gfc_match (" )") != MATCH_YES
)
5470 gfc_current_locus
= entry_loc
;
5478 /* Match a PROCEDURE declaration (R1211). */
5481 match_procedure_decl (void)
5484 gfc_symbol
*sym
, *proc_if
= NULL
;
5486 gfc_expr
*initializer
= NULL
;
5488 /* Parse interface (with brackets). */
5489 m
= match_procedure_interface (&proc_if
);
5493 /* Parse attributes (with colons). */
5494 m
= match_attr_spec();
5495 if (m
== MATCH_ERROR
)
5498 if (proc_if
&& proc_if
->attr
.is_bind_c
&& !current_attr
.is_bind_c
)
5500 current_attr
.is_bind_c
= 1;
5501 has_name_equals
= 0;
5502 curr_binding_label
= NULL
;
5505 /* Get procedure symbols. */
5508 m
= gfc_match_symbol (&sym
, 0);
5511 else if (m
== MATCH_ERROR
)
5514 /* Add current_attr to the symbol attributes. */
5515 if (!gfc_copy_attr (&sym
->attr
, ¤t_attr
, NULL
))
5518 if (sym
->attr
.is_bind_c
)
5520 /* Check for C1218. */
5521 if (!proc_if
|| !proc_if
->attr
.is_bind_c
)
5523 gfc_error ("BIND(C) attribute at %C requires "
5524 "an interface with BIND(C)");
5527 /* Check for C1217. */
5528 if (has_name_equals
&& sym
->attr
.pointer
)
5530 gfc_error ("BIND(C) procedure with NAME may not have "
5531 "POINTER attribute at %C");
5534 if (has_name_equals
&& sym
->attr
.dummy
)
5536 gfc_error ("Dummy procedure at %C may not have "
5537 "BIND(C) attribute with NAME");
5540 /* Set binding label for BIND(C). */
5541 if (!set_binding_label (&sym
->binding_label
, sym
->name
, num
))
5545 if (!gfc_add_external (&sym
->attr
, NULL
))
5548 if (add_hidden_procptr_result (sym
))
5551 if (!gfc_add_proc (&sym
->attr
, sym
->name
, NULL
))
5554 /* Set interface. */
5555 if (proc_if
!= NULL
)
5557 if (sym
->ts
.type
!= BT_UNKNOWN
)
5559 gfc_error ("Procedure %qs at %L already has basic type of %s",
5560 sym
->name
, &gfc_current_locus
,
5561 gfc_basic_typename (sym
->ts
.type
));
5564 sym
->ts
.interface
= proc_if
;
5565 sym
->attr
.untyped
= 1;
5566 sym
->attr
.if_source
= IFSRC_IFBODY
;
5568 else if (current_ts
.type
!= BT_UNKNOWN
)
5570 if (!gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
5572 sym
->ts
.interface
= gfc_new_symbol ("", gfc_current_ns
);
5573 sym
->ts
.interface
->ts
= current_ts
;
5574 sym
->ts
.interface
->attr
.flavor
= FL_PROCEDURE
;
5575 sym
->ts
.interface
->attr
.function
= 1;
5576 sym
->attr
.function
= 1;
5577 sym
->attr
.if_source
= IFSRC_UNKNOWN
;
5580 if (gfc_match (" =>") == MATCH_YES
)
5582 if (!current_attr
.pointer
)
5584 gfc_error ("Initialization at %C isn't for a pointer variable");
5589 m
= match_pointer_init (&initializer
, 1);
5593 if (!add_init_expr_to_sym (sym
->name
, &initializer
, &gfc_current_locus
))
5598 if (gfc_match_eos () == MATCH_YES
)
5600 if (gfc_match_char (',') != MATCH_YES
)
5605 gfc_error ("Syntax error in PROCEDURE statement at %C");
5609 /* Free stuff up and return. */
5610 gfc_free_expr (initializer
);
5616 match_binding_attributes (gfc_typebound_proc
* ba
, bool generic
, bool ppc
);
5619 /* Match a procedure pointer component declaration (R445). */
5622 match_ppc_decl (void)
5625 gfc_symbol
*proc_if
= NULL
;
5629 gfc_expr
*initializer
= NULL
;
5630 gfc_typebound_proc
* tb
;
5631 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5633 /* Parse interface (with brackets). */
5634 m
= match_procedure_interface (&proc_if
);
5638 /* Parse attributes. */
5639 tb
= XCNEW (gfc_typebound_proc
);
5640 tb
->where
= gfc_current_locus
;
5641 m
= match_binding_attributes (tb
, false, true);
5642 if (m
== MATCH_ERROR
)
5645 gfc_clear_attr (¤t_attr
);
5646 current_attr
.procedure
= 1;
5647 current_attr
.proc_pointer
= 1;
5648 current_attr
.access
= tb
->access
;
5649 current_attr
.flavor
= FL_PROCEDURE
;
5651 /* Match the colons (required). */
5652 if (gfc_match (" ::") != MATCH_YES
)
5654 gfc_error ("Expected %<::%> after binding-attributes at %C");
5658 /* Check for C450. */
5659 if (!tb
->nopass
&& proc_if
== NULL
)
5661 gfc_error("NOPASS or explicit interface required at %C");
5665 if (!gfc_notify_std (GFC_STD_F2003
, "Procedure pointer component at %C"))
5668 /* Match PPC names. */
5672 m
= gfc_match_name (name
);
5675 else if (m
== MATCH_ERROR
)
5678 if (!gfc_add_component (gfc_current_block(), name
, &c
))
5681 /* Add current_attr to the symbol attributes. */
5682 if (!gfc_copy_attr (&c
->attr
, ¤t_attr
, NULL
))
5685 if (!gfc_add_external (&c
->attr
, NULL
))
5688 if (!gfc_add_proc (&c
->attr
, name
, NULL
))
5695 c
->tb
= XCNEW (gfc_typebound_proc
);
5696 c
->tb
->where
= gfc_current_locus
;
5700 /* Set interface. */
5701 if (proc_if
!= NULL
)
5703 c
->ts
.interface
= proc_if
;
5704 c
->attr
.untyped
= 1;
5705 c
->attr
.if_source
= IFSRC_IFBODY
;
5707 else if (ts
.type
!= BT_UNKNOWN
)
5710 c
->ts
.interface
= gfc_new_symbol ("", gfc_current_ns
);
5711 c
->ts
.interface
->result
= c
->ts
.interface
;
5712 c
->ts
.interface
->ts
= ts
;
5713 c
->ts
.interface
->attr
.flavor
= FL_PROCEDURE
;
5714 c
->ts
.interface
->attr
.function
= 1;
5715 c
->attr
.function
= 1;
5716 c
->attr
.if_source
= IFSRC_UNKNOWN
;
5719 if (gfc_match (" =>") == MATCH_YES
)
5721 m
= match_pointer_init (&initializer
, 1);
5724 gfc_free_expr (initializer
);
5727 c
->initializer
= initializer
;
5730 if (gfc_match_eos () == MATCH_YES
)
5732 if (gfc_match_char (',') != MATCH_YES
)
5737 gfc_error ("Syntax error in procedure pointer component at %C");
5742 /* Match a PROCEDURE declaration inside an interface (R1206). */
5745 match_procedure_in_interface (void)
5749 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5752 if (current_interface
.type
== INTERFACE_NAMELESS
5753 || current_interface
.type
== INTERFACE_ABSTRACT
)
5755 gfc_error ("PROCEDURE at %C must be in a generic interface");
5759 /* Check if the F2008 optional double colon appears. */
5760 gfc_gobble_whitespace ();
5761 old_locus
= gfc_current_locus
;
5762 if (gfc_match ("::") == MATCH_YES
)
5764 if (!gfc_notify_std (GFC_STD_F2008
, "double colon in "
5765 "MODULE PROCEDURE statement at %L", &old_locus
))
5769 gfc_current_locus
= old_locus
;
5773 m
= gfc_match_name (name
);
5776 else if (m
== MATCH_ERROR
)
5778 if (gfc_get_symbol (name
, gfc_current_ns
->parent
, &sym
))
5781 if (!gfc_add_interface (sym
))
5784 if (gfc_match_eos () == MATCH_YES
)
5786 if (gfc_match_char (',') != MATCH_YES
)
5793 gfc_error ("Syntax error in PROCEDURE statement at %C");
5798 /* General matcher for PROCEDURE declarations. */
5800 static match
match_procedure_in_type (void);
5803 gfc_match_procedure (void)
5807 switch (gfc_current_state ())
5812 case COMP_SUBMODULE
:
5813 case COMP_SUBROUTINE
:
5816 m
= match_procedure_decl ();
5818 case COMP_INTERFACE
:
5819 m
= match_procedure_in_interface ();
5822 m
= match_ppc_decl ();
5824 case COMP_DERIVED_CONTAINS
:
5825 m
= match_procedure_in_type ();
5834 if (!gfc_notify_std (GFC_STD_F2003
, "PROCEDURE statement at %C"))
5841 /* Warn if a matched procedure has the same name as an intrinsic; this is
5842 simply a wrapper around gfc_warn_intrinsic_shadow that interprets the current
5843 parser-state-stack to find out whether we're in a module. */
5846 do_warn_intrinsic_shadow (const gfc_symbol
* sym
, bool func
)
5850 in_module
= (gfc_state_stack
->previous
5851 && (gfc_state_stack
->previous
->state
== COMP_MODULE
5852 || gfc_state_stack
->previous
->state
== COMP_SUBMODULE
));
5854 gfc_warn_intrinsic_shadow (sym
, in_module
, func
);
5858 /* Match a function declaration. */
5861 gfc_match_function_decl (void)
5863 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5864 gfc_symbol
*sym
, *result
;
5868 match found_match
; /* Status returned by match func. */
5870 if (gfc_current_state () != COMP_NONE
5871 && gfc_current_state () != COMP_INTERFACE
5872 && gfc_current_state () != COMP_CONTAINS
)
5875 gfc_clear_ts (¤t_ts
);
5877 old_loc
= gfc_current_locus
;
5879 m
= gfc_match_prefix (¤t_ts
);
5882 gfc_current_locus
= old_loc
;
5886 if (gfc_match ("function% %n", name
) != MATCH_YES
)
5888 gfc_current_locus
= old_loc
;
5892 if (get_proc_name (name
, &sym
, false))
5895 if (add_hidden_procptr_result (sym
))
5898 if (current_attr
.module_procedure
)
5899 sym
->attr
.module_procedure
= 1;
5901 gfc_new_block
= sym
;
5903 m
= gfc_match_formal_arglist (sym
, 0, 0);
5906 gfc_error ("Expected formal argument list in function "
5907 "definition at %C");
5911 else if (m
== MATCH_ERROR
)
5916 /* According to the draft, the bind(c) and result clause can
5917 come in either order after the formal_arg_list (i.e., either
5918 can be first, both can exist together or by themselves or neither
5919 one). Therefore, the match_result can't match the end of the
5920 string, and check for the bind(c) or result clause in either order. */
5921 found_match
= gfc_match_eos ();
5923 /* Make sure that it isn't already declared as BIND(C). If it is, it
5924 must have been marked BIND(C) with a BIND(C) attribute and that is
5925 not allowed for procedures. */
5926 if (sym
->attr
.is_bind_c
== 1)
5928 sym
->attr
.is_bind_c
= 0;
5929 if (sym
->old_symbol
!= NULL
)
5930 gfc_error_now ("BIND(C) attribute at %L can only be used for "
5931 "variables or common blocks",
5932 &(sym
->old_symbol
->declared_at
));
5934 gfc_error_now ("BIND(C) attribute at %L can only be used for "
5935 "variables or common blocks", &gfc_current_locus
);
5938 if (found_match
!= MATCH_YES
)
5940 /* If we haven't found the end-of-statement, look for a suffix. */
5941 suffix_match
= gfc_match_suffix (sym
, &result
);
5942 if (suffix_match
== MATCH_YES
)
5943 /* Need to get the eos now. */
5944 found_match
= gfc_match_eos ();
5946 found_match
= suffix_match
;
5949 if(found_match
!= MATCH_YES
)
5953 /* Make changes to the symbol. */
5956 if (!gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
5959 if (!gfc_missing_attr (&sym
->attr
, NULL
))
5962 if (!copy_prefix (&sym
->attr
, &sym
->declared_at
))
5964 if(!sym
->attr
.module_procedure
)
5970 /* Delay matching the function characteristics until after the
5971 specification block by signalling kind=-1. */
5972 sym
->declared_at
= old_loc
;
5973 if (current_ts
.type
!= BT_UNKNOWN
)
5974 current_ts
.kind
= -1;
5976 current_ts
.kind
= 0;
5980 if (current_ts
.type
!= BT_UNKNOWN
5981 && !gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
5987 if (current_ts
.type
!= BT_UNKNOWN
5988 && !gfc_add_type (result
, ¤t_ts
, &gfc_current_locus
))
5990 sym
->result
= result
;
5994 /* Warn if this procedure has the same name as an intrinsic. */
5995 do_warn_intrinsic_shadow (sym
, true);
6001 gfc_current_locus
= old_loc
;
6006 /* This is mostly a copy of parse.c(add_global_procedure) but modified to
6007 pass the name of the entry, rather than the gfc_current_block name, and
6008 to return false upon finding an existing global entry. */
6011 add_global_entry (const char *name
, const char *binding_label
, bool sub
,
6015 enum gfc_symbol_type type
;
6017 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
6019 /* Only in Fortran 2003: For procedures with a binding label also the Fortran
6020 name is a global identifier. */
6021 if (!binding_label
|| gfc_notification_std (GFC_STD_F2008
))
6023 s
= gfc_get_gsymbol (name
);
6025 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= type
))
6027 gfc_global_used (s
, where
);
6036 s
->ns
= gfc_current_ns
;
6040 /* Don't add the symbol multiple times. */
6042 && (!gfc_notification_std (GFC_STD_F2008
)
6043 || strcmp (name
, binding_label
) != 0))
6045 s
= gfc_get_gsymbol (binding_label
);
6047 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= type
))
6049 gfc_global_used (s
, where
);
6056 s
->binding_label
= binding_label
;
6059 s
->ns
= gfc_current_ns
;
6067 /* Match an ENTRY statement. */
6070 gfc_match_entry (void)
6075 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6076 gfc_compile_state state
;
6080 bool module_procedure
;
6084 m
= gfc_match_name (name
);
6088 if (!gfc_notify_std (GFC_STD_F2008_OBS
, "ENTRY statement at %C"))
6091 state
= gfc_current_state ();
6092 if (state
!= COMP_SUBROUTINE
&& state
!= COMP_FUNCTION
)
6097 gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
6100 gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
6102 case COMP_SUBMODULE
:
6103 gfc_error ("ENTRY statement at %C cannot appear within a SUBMODULE");
6105 case COMP_BLOCK_DATA
:
6106 gfc_error ("ENTRY statement at %C cannot appear within "
6109 case COMP_INTERFACE
:
6110 gfc_error ("ENTRY statement at %C cannot appear within "
6113 case COMP_STRUCTURE
:
6114 gfc_error ("ENTRY statement at %C cannot appear within "
6115 "a STRUCTURE block");
6118 gfc_error ("ENTRY statement at %C cannot appear within "
6119 "a DERIVED TYPE block");
6122 gfc_error ("ENTRY statement at %C cannot appear within "
6123 "an IF-THEN block");
6126 case COMP_DO_CONCURRENT
:
6127 gfc_error ("ENTRY statement at %C cannot appear within "
6131 gfc_error ("ENTRY statement at %C cannot appear within "
6135 gfc_error ("ENTRY statement at %C cannot appear within "
6139 gfc_error ("ENTRY statement at %C cannot appear within "
6143 gfc_error ("ENTRY statement at %C cannot appear within "
6144 "a contained subprogram");
6147 gfc_error ("Unexpected ENTRY statement at %C");
6152 if ((state
== COMP_SUBROUTINE
|| state
== COMP_FUNCTION
)
6153 && gfc_state_stack
->previous
->state
== COMP_INTERFACE
)
6155 gfc_error ("ENTRY statement at %C cannot appear within an INTERFACE");
6159 module_procedure
= gfc_current_ns
->parent
!= NULL
6160 && gfc_current_ns
->parent
->proc_name
6161 && gfc_current_ns
->parent
->proc_name
->attr
.flavor
6164 if (gfc_current_ns
->parent
!= NULL
6165 && gfc_current_ns
->parent
->proc_name
6166 && !module_procedure
)
6168 gfc_error("ENTRY statement at %C cannot appear in a "
6169 "contained procedure");
6173 /* Module function entries need special care in get_proc_name
6174 because previous references within the function will have
6175 created symbols attached to the current namespace. */
6176 if (get_proc_name (name
, &entry
,
6177 gfc_current_ns
->parent
!= NULL
6178 && module_procedure
))
6181 proc
= gfc_current_block ();
6183 /* Make sure that it isn't already declared as BIND(C). If it is, it
6184 must have been marked BIND(C) with a BIND(C) attribute and that is
6185 not allowed for procedures. */
6186 if (entry
->attr
.is_bind_c
== 1)
6188 entry
->attr
.is_bind_c
= 0;
6189 if (entry
->old_symbol
!= NULL
)
6190 gfc_error_now ("BIND(C) attribute at %L can only be used for "
6191 "variables or common blocks",
6192 &(entry
->old_symbol
->declared_at
));
6194 gfc_error_now ("BIND(C) attribute at %L can only be used for "
6195 "variables or common blocks", &gfc_current_locus
);
6198 /* Check what next non-whitespace character is so we can tell if there
6199 is the required parens if we have a BIND(C). */
6200 old_loc
= gfc_current_locus
;
6201 gfc_gobble_whitespace ();
6202 peek_char
= gfc_peek_ascii_char ();
6204 if (state
== COMP_SUBROUTINE
)
6206 m
= gfc_match_formal_arglist (entry
, 0, 1);
6210 /* Call gfc_match_bind_c with allow_binding_name = true as ENTRY can
6211 never be an internal procedure. */
6212 is_bind_c
= gfc_match_bind_c (entry
, true);
6213 if (is_bind_c
== MATCH_ERROR
)
6215 if (is_bind_c
== MATCH_YES
)
6217 if (peek_char
!= '(')
6219 gfc_error ("Missing required parentheses before BIND(C) at %C");
6222 if (!gfc_add_is_bind_c (&(entry
->attr
), entry
->name
,
6223 &(entry
->declared_at
), 1))
6227 if (!gfc_current_ns
->parent
6228 && !add_global_entry (name
, entry
->binding_label
, true,
6232 /* An entry in a subroutine. */
6233 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
6234 || !gfc_add_subroutine (&entry
->attr
, entry
->name
, NULL
))
6239 /* An entry in a function.
6240 We need to take special care because writing
6245 ENTRY f() RESULT (r)
6247 ENTRY f RESULT (r). */
6248 if (gfc_match_eos () == MATCH_YES
)
6250 gfc_current_locus
= old_loc
;
6251 /* Match the empty argument list, and add the interface to
6253 m
= gfc_match_formal_arglist (entry
, 0, 1);
6256 m
= gfc_match_formal_arglist (entry
, 0, 0);
6263 if (gfc_match_eos () == MATCH_YES
)
6265 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
6266 || !gfc_add_function (&entry
->attr
, entry
->name
, NULL
))
6269 entry
->result
= entry
;
6273 m
= gfc_match_suffix (entry
, &result
);
6275 gfc_syntax_error (ST_ENTRY
);
6281 if (!gfc_add_result (&result
->attr
, result
->name
, NULL
)
6282 || !gfc_add_entry (&entry
->attr
, result
->name
, NULL
)
6283 || !gfc_add_function (&entry
->attr
, result
->name
, NULL
))
6285 entry
->result
= result
;
6289 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
6290 || !gfc_add_function (&entry
->attr
, entry
->name
, NULL
))
6292 entry
->result
= entry
;
6296 if (!gfc_current_ns
->parent
6297 && !add_global_entry (name
, entry
->binding_label
, false,
6302 if (gfc_match_eos () != MATCH_YES
)
6304 gfc_syntax_error (ST_ENTRY
);
6308 entry
->attr
.recursive
= proc
->attr
.recursive
;
6309 entry
->attr
.elemental
= proc
->attr
.elemental
;
6310 entry
->attr
.pure
= proc
->attr
.pure
;
6312 el
= gfc_get_entry_list ();
6314 el
->next
= gfc_current_ns
->entries
;
6315 gfc_current_ns
->entries
= el
;
6317 el
->id
= el
->next
->id
+ 1;
6321 new_st
.op
= EXEC_ENTRY
;
6322 new_st
.ext
.entry
= el
;
6328 /* Match a subroutine statement, including optional prefixes. */
6331 gfc_match_subroutine (void)
6333 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6338 bool allow_binding_name
;
6340 if (gfc_current_state () != COMP_NONE
6341 && gfc_current_state () != COMP_INTERFACE
6342 && gfc_current_state () != COMP_CONTAINS
)
6345 m
= gfc_match_prefix (NULL
);
6349 m
= gfc_match ("subroutine% %n", name
);
6353 if (get_proc_name (name
, &sym
, false))
6356 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
6357 the symbol existed before. */
6358 sym
->declared_at
= gfc_current_locus
;
6360 if (current_attr
.module_procedure
)
6361 sym
->attr
.module_procedure
= 1;
6363 if (add_hidden_procptr_result (sym
))
6366 gfc_new_block
= sym
;
6368 /* Check what next non-whitespace character is so we can tell if there
6369 is the required parens if we have a BIND(C). */
6370 gfc_gobble_whitespace ();
6371 peek_char
= gfc_peek_ascii_char ();
6373 if (!gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
))
6376 if (gfc_match_formal_arglist (sym
, 0, 1) != MATCH_YES
)
6379 /* Make sure that it isn't already declared as BIND(C). If it is, it
6380 must have been marked BIND(C) with a BIND(C) attribute and that is
6381 not allowed for procedures. */
6382 if (sym
->attr
.is_bind_c
== 1)
6384 sym
->attr
.is_bind_c
= 0;
6385 if (sym
->old_symbol
!= NULL
)
6386 gfc_error_now ("BIND(C) attribute at %L can only be used for "
6387 "variables or common blocks",
6388 &(sym
->old_symbol
->declared_at
));
6390 gfc_error_now ("BIND(C) attribute at %L can only be used for "
6391 "variables or common blocks", &gfc_current_locus
);
6394 /* C binding names are not allowed for internal procedures. */
6395 if (gfc_current_state () == COMP_CONTAINS
6396 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
6397 allow_binding_name
= false;
6399 allow_binding_name
= true;
6401 /* Here, we are just checking if it has the bind(c) attribute, and if
6402 so, then we need to make sure it's all correct. If it doesn't,
6403 we still need to continue matching the rest of the subroutine line. */
6404 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
6405 if (is_bind_c
== MATCH_ERROR
)
6407 /* There was an attempt at the bind(c), but it was wrong. An
6408 error message should have been printed w/in the gfc_match_bind_c
6409 so here we'll just return the MATCH_ERROR. */
6413 if (is_bind_c
== MATCH_YES
)
6415 /* The following is allowed in the Fortran 2008 draft. */
6416 if (gfc_current_state () == COMP_CONTAINS
6417 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
6418 && !gfc_notify_std (GFC_STD_F2008
, "BIND(C) attribute "
6419 "at %L may not be specified for an internal "
6420 "procedure", &gfc_current_locus
))
6423 if (peek_char
!= '(')
6425 gfc_error ("Missing required parentheses before BIND(C) at %C");
6428 if (!gfc_add_is_bind_c (&(sym
->attr
), sym
->name
,
6429 &(sym
->declared_at
), 1))
6433 if (gfc_match_eos () != MATCH_YES
)
6435 gfc_syntax_error (ST_SUBROUTINE
);
6439 if (!copy_prefix (&sym
->attr
, &sym
->declared_at
))
6441 if(!sym
->attr
.module_procedure
)
6447 /* Warn if it has the same name as an intrinsic. */
6448 do_warn_intrinsic_shadow (sym
, false);
6454 /* Check that the NAME identifier in a BIND attribute or statement
6455 is conform to C identifier rules. */
6458 check_bind_name_identifier (char **name
)
6460 char *n
= *name
, *p
;
6462 /* Remove leading spaces. */
6466 /* On an empty string, free memory and set name to NULL. */
6474 /* Remove trailing spaces. */
6475 p
= n
+ strlen(n
) - 1;
6479 /* Insert the identifier into the symbol table. */
6484 /* Now check that identifier is valid under C rules. */
6487 gfc_error ("Invalid C identifier in NAME= specifier at %C");
6492 if (!(ISALNUM (*p
) || *p
== '_' || *p
== '$'))
6494 gfc_error ("Invalid C identifier in NAME= specifier at %C");
6502 /* Match a BIND(C) specifier, with the optional 'name=' specifier if
6503 given, and set the binding label in either the given symbol (if not
6504 NULL), or in the current_ts. The symbol may be NULL because we may
6505 encounter the BIND(C) before the declaration itself. Return
6506 MATCH_NO if what we're looking at isn't a BIND(C) specifier,
6507 MATCH_ERROR if it is a BIND(C) clause but an error was encountered,
6508 or MATCH_YES if the specifier was correct and the binding label and
6509 bind(c) fields were set correctly for the given symbol or the
6510 current_ts. If allow_binding_name is false, no binding name may be
6514 gfc_match_bind_c (gfc_symbol
*sym
, bool allow_binding_name
)
6516 char *binding_label
= NULL
;
6519 /* Initialize the flag that specifies whether we encountered a NAME=
6520 specifier or not. */
6521 has_name_equals
= 0;
6523 /* This much we have to be able to match, in this order, if
6524 there is a bind(c) label. */
6525 if (gfc_match (" bind ( c ") != MATCH_YES
)
6528 /* Now see if there is a binding label, or if we've reached the
6529 end of the bind(c) attribute without one. */
6530 if (gfc_match_char (',') == MATCH_YES
)
6532 if (gfc_match (" name = ") != MATCH_YES
)
6534 gfc_error ("Syntax error in NAME= specifier for binding label "
6536 /* should give an error message here */
6540 has_name_equals
= 1;
6542 if (gfc_match_init_expr (&e
) != MATCH_YES
)
6548 if (!gfc_simplify_expr(e
, 0))
6550 gfc_error ("NAME= specifier at %C should be a constant expression");
6555 if (e
->expr_type
!= EXPR_CONSTANT
|| e
->ts
.type
!= BT_CHARACTER
6556 || e
->ts
.kind
!= gfc_default_character_kind
|| e
->rank
!= 0)
6558 gfc_error ("NAME= specifier at %C should be a scalar of "
6559 "default character kind");
6564 // Get a C string from the Fortran string constant
6565 binding_label
= gfc_widechar_to_char (e
->value
.character
.string
,
6566 e
->value
.character
.length
);
6569 // Check that it is valid (old gfc_match_name_C)
6570 if (check_bind_name_identifier (&binding_label
) != MATCH_YES
)
6574 /* Get the required right paren. */
6575 if (gfc_match_char (')') != MATCH_YES
)
6577 gfc_error ("Missing closing paren for binding label at %C");
6581 if (has_name_equals
&& !allow_binding_name
)
6583 gfc_error ("No binding name is allowed in BIND(C) at %C");
6587 if (has_name_equals
&& sym
!= NULL
&& sym
->attr
.dummy
)
6589 gfc_error ("For dummy procedure %s, no binding name is "
6590 "allowed in BIND(C) at %C", sym
->name
);
6595 /* Save the binding label to the symbol. If sym is null, we're
6596 probably matching the typespec attributes of a declaration and
6597 haven't gotten the name yet, and therefore, no symbol yet. */
6601 sym
->binding_label
= binding_label
;
6603 curr_binding_label
= binding_label
;
6605 else if (allow_binding_name
)
6607 /* No binding label, but if symbol isn't null, we
6608 can set the label for it here.
6609 If name="" or allow_binding_name is false, no C binding name is
6611 if (sym
!= NULL
&& sym
->name
!= NULL
&& has_name_equals
== 0)
6612 sym
->binding_label
= IDENTIFIER_POINTER (get_identifier (sym
->name
));
6615 if (has_name_equals
&& gfc_current_state () == COMP_INTERFACE
6616 && current_interface
.type
== INTERFACE_ABSTRACT
)
6618 gfc_error ("NAME not allowed on BIND(C) for ABSTRACT INTERFACE at %C");
6626 /* Return nonzero if we're currently compiling a contained procedure. */
6629 contained_procedure (void)
6631 gfc_state_data
*s
= gfc_state_stack
;
6633 if ((s
->state
== COMP_SUBROUTINE
|| s
->state
== COMP_FUNCTION
)
6634 && s
->previous
!= NULL
&& s
->previous
->state
== COMP_CONTAINS
)
6640 /* Set the kind of each enumerator. The kind is selected such that it is
6641 interoperable with the corresponding C enumeration type, making
6642 sure that -fshort-enums is honored. */
6647 enumerator_history
*current_history
= NULL
;
6651 if (max_enum
== NULL
|| enum_history
== NULL
)
6654 if (!flag_short_enums
)
6660 kind
= gfc_integer_kinds
[i
++].kind
;
6662 while (kind
< gfc_c_int_kind
6663 && gfc_check_integer_range (max_enum
->initializer
->value
.integer
,
6666 current_history
= enum_history
;
6667 while (current_history
!= NULL
)
6669 current_history
->sym
->ts
.kind
= kind
;
6670 current_history
= current_history
->next
;
6675 /* Match any of the various end-block statements. Returns the type of
6676 END to the caller. The END INTERFACE, END IF, END DO, END SELECT
6677 and END BLOCK statements cannot be replaced by a single END statement. */
6680 gfc_match_end (gfc_statement
*st
)
6682 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6683 gfc_compile_state state
;
6685 const char *block_name
;
6689 gfc_namespace
*parent_ns
, *ns
, *prev_ns
;
6690 gfc_namespace
**nsp
;
6691 bool abreviated_modproc_decl
;
6692 bool got_matching_end
= false;
6694 old_loc
= gfc_current_locus
;
6695 if (gfc_match ("end") != MATCH_YES
)
6698 state
= gfc_current_state ();
6699 block_name
= gfc_current_block () == NULL
6700 ? NULL
: gfc_current_block ()->name
;
6704 case COMP_ASSOCIATE
:
6706 if (!strncmp (block_name
, "block@", strlen("block@")))
6711 case COMP_DERIVED_CONTAINS
:
6712 state
= gfc_state_stack
->previous
->state
;
6713 block_name
= gfc_state_stack
->previous
->sym
== NULL
6714 ? NULL
: gfc_state_stack
->previous
->sym
->name
;
6721 abreviated_modproc_decl
6722 = gfc_current_block ()
6723 && gfc_current_block ()->abr_modproc_decl
;
6729 *st
= ST_END_PROGRAM
;
6730 target
= " program";
6734 case COMP_SUBROUTINE
:
6735 *st
= ST_END_SUBROUTINE
;
6736 if (!abreviated_modproc_decl
)
6737 target
= " subroutine";
6739 target
= " procedure";
6740 eos_ok
= !contained_procedure ();
6744 *st
= ST_END_FUNCTION
;
6745 if (!abreviated_modproc_decl
)
6746 target
= " function";
6748 target
= " procedure";
6749 eos_ok
= !contained_procedure ();
6752 case COMP_BLOCK_DATA
:
6753 *st
= ST_END_BLOCK_DATA
;
6754 target
= " block data";
6759 *st
= ST_END_MODULE
;
6764 case COMP_SUBMODULE
:
6765 *st
= ST_END_SUBMODULE
;
6766 target
= " submodule";
6770 case COMP_INTERFACE
:
6771 *st
= ST_END_INTERFACE
;
6772 target
= " interface";
6788 case COMP_STRUCTURE
:
6789 *st
= ST_END_STRUCTURE
;
6790 target
= " structure";
6795 case COMP_DERIVED_CONTAINS
:
6801 case COMP_ASSOCIATE
:
6802 *st
= ST_END_ASSOCIATE
;
6803 target
= " associate";
6820 case COMP_DO_CONCURRENT
:
6827 *st
= ST_END_CRITICAL
;
6828 target
= " critical";
6833 case COMP_SELECT_TYPE
:
6834 *st
= ST_END_SELECT
;
6840 *st
= ST_END_FORALL
;
6855 last_initializer
= NULL
;
6857 gfc_free_enum_history ();
6861 gfc_error ("Unexpected END statement at %C");
6865 old_loc
= gfc_current_locus
;
6866 if (gfc_match_eos () == MATCH_YES
)
6868 if (!eos_ok
&& (*st
== ST_END_SUBROUTINE
|| *st
== ST_END_FUNCTION
))
6870 if (!gfc_notify_std (GFC_STD_F2008
, "END statement "
6871 "instead of %s statement at %L",
6872 abreviated_modproc_decl
? "END PROCEDURE"
6873 : gfc_ascii_statement(*st
), &old_loc
))
6878 /* We would have required END [something]. */
6879 gfc_error ("%s statement expected at %L",
6880 gfc_ascii_statement (*st
), &old_loc
);
6887 /* Verify that we've got the sort of end-block that we're expecting. */
6888 if (gfc_match (target
) != MATCH_YES
)
6890 gfc_error ("Expecting %s statement at %L", abreviated_modproc_decl
6891 ? "END PROCEDURE" : gfc_ascii_statement(*st
), &old_loc
);
6895 got_matching_end
= true;
6897 old_loc
= gfc_current_locus
;
6898 /* If we're at the end, make sure a block name wasn't required. */
6899 if (gfc_match_eos () == MATCH_YES
)
6902 if (*st
!= ST_ENDDO
&& *st
!= ST_ENDIF
&& *st
!= ST_END_SELECT
6903 && *st
!= ST_END_FORALL
&& *st
!= ST_END_WHERE
&& *st
!= ST_END_BLOCK
6904 && *st
!= ST_END_ASSOCIATE
&& *st
!= ST_END_CRITICAL
)
6910 gfc_error ("Expected block name of %qs in %s statement at %L",
6911 block_name
, gfc_ascii_statement (*st
), &old_loc
);
6916 /* END INTERFACE has a special handler for its several possible endings. */
6917 if (*st
== ST_END_INTERFACE
)
6918 return gfc_match_end_interface ();
6920 /* We haven't hit the end of statement, so what is left must be an
6922 m
= gfc_match_space ();
6924 m
= gfc_match_name (name
);
6927 gfc_error ("Expected terminating name at %C");
6931 if (block_name
== NULL
)
6934 /* We have to pick out the declared submodule name from the composite
6935 required by F2008:11.2.3 para 2, which ends in the declared name. */
6936 if (state
== COMP_SUBMODULE
)
6937 block_name
= strchr (block_name
, '.') + 1;
6939 if (strcmp (name
, block_name
) != 0 && strcmp (block_name
, "ppr@") != 0)
6941 gfc_error ("Expected label %qs for %s statement at %C", block_name
,
6942 gfc_ascii_statement (*st
));
6945 /* Procedure pointer as function result. */
6946 else if (strcmp (block_name
, "ppr@") == 0
6947 && strcmp (name
, gfc_current_block ()->ns
->proc_name
->name
) != 0)
6949 gfc_error ("Expected label %qs for %s statement at %C",
6950 gfc_current_block ()->ns
->proc_name
->name
,
6951 gfc_ascii_statement (*st
));
6955 if (gfc_match_eos () == MATCH_YES
)
6959 gfc_syntax_error (*st
);
6962 gfc_current_locus
= old_loc
;
6964 /* If we are missing an END BLOCK, we created a half-ready namespace.
6965 Remove it from the parent namespace's sibling list. */
6967 while (state
== COMP_BLOCK
&& !got_matching_end
)
6969 parent_ns
= gfc_current_ns
->parent
;
6971 nsp
= &(gfc_state_stack
->previous
->tail
->ext
.block
.ns
);
6977 if (ns
== gfc_current_ns
)
6979 if (prev_ns
== NULL
)
6982 prev_ns
->sibling
= ns
->sibling
;
6988 gfc_free_namespace (gfc_current_ns
);
6989 gfc_current_ns
= parent_ns
;
6990 gfc_state_stack
= gfc_state_stack
->previous
;
6991 state
= gfc_current_state ();
6999 /***************** Attribute declaration statements ****************/
7001 /* Set the attribute of a single variable. */
7006 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7009 /* Workaround -Wmaybe-uninitialized false positive during
7010 profiledbootstrap by initializing them. */
7011 gfc_symbol
*sym
= NULL
;
7017 m
= gfc_match_name (name
);
7021 if (find_special (name
, &sym
, false))
7024 if (!check_function_name (name
))
7030 var_locus
= gfc_current_locus
;
7032 /* Deal with possible array specification for certain attributes. */
7033 if (current_attr
.dimension
7034 || current_attr
.codimension
7035 || current_attr
.allocatable
7036 || current_attr
.pointer
7037 || current_attr
.target
)
7039 m
= gfc_match_array_spec (&as
, !current_attr
.codimension
,
7040 !current_attr
.dimension
7041 && !current_attr
.pointer
7042 && !current_attr
.target
);
7043 if (m
== MATCH_ERROR
)
7046 if (current_attr
.dimension
&& m
== MATCH_NO
)
7048 gfc_error ("Missing array specification at %L in DIMENSION "
7049 "statement", &var_locus
);
7054 if (current_attr
.dimension
&& sym
->value
)
7056 gfc_error ("Dimensions specified for %s at %L after its "
7057 "initialisation", sym
->name
, &var_locus
);
7062 if (current_attr
.codimension
&& m
== MATCH_NO
)
7064 gfc_error ("Missing array specification at %L in CODIMENSION "
7065 "statement", &var_locus
);
7070 if ((current_attr
.allocatable
|| current_attr
.pointer
)
7071 && (m
== MATCH_YES
) && (as
->type
!= AS_DEFERRED
))
7073 gfc_error ("Array specification must be deferred at %L", &var_locus
);
7079 /* Update symbol table. DIMENSION attribute is set in
7080 gfc_set_array_spec(). For CLASS variables, this must be applied
7081 to the first component, or '_data' field. */
7082 if (sym
->ts
.type
== BT_CLASS
&& sym
->ts
.u
.derived
->attr
.is_class
)
7084 if (!gfc_copy_attr (&CLASS_DATA(sym
)->attr
, ¤t_attr
, &var_locus
))
7092 if (current_attr
.dimension
== 0 && current_attr
.codimension
== 0
7093 && !gfc_copy_attr (&sym
->attr
, ¤t_attr
, &var_locus
))
7100 if (sym
->ts
.type
== BT_CLASS
7101 && !gfc_build_class_symbol (&sym
->ts
, &sym
->attr
, &sym
->as
))
7107 if (!gfc_set_array_spec (sym
, as
, &var_locus
))
7113 if (sym
->attr
.cray_pointee
&& sym
->as
!= NULL
)
7115 /* Fix the array spec. */
7116 m
= gfc_mod_pointee_as (sym
->as
);
7117 if (m
== MATCH_ERROR
)
7121 if (!gfc_add_attribute (&sym
->attr
, &var_locus
))
7127 if ((current_attr
.external
|| current_attr
.intrinsic
)
7128 && sym
->attr
.flavor
!= FL_PROCEDURE
7129 && !gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, NULL
))
7135 add_hidden_procptr_result (sym
);
7140 gfc_free_array_spec (as
);
7145 /* Generic attribute declaration subroutine. Used for attributes that
7146 just have a list of names. */
7153 /* Gobble the optional double colon, by simply ignoring the result
7163 if (gfc_match_eos () == MATCH_YES
)
7169 if (gfc_match_char (',') != MATCH_YES
)
7171 gfc_error ("Unexpected character in variable list at %C");
7181 /* This routine matches Cray Pointer declarations of the form:
7182 pointer ( <pointer>, <pointee> )
7184 pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...
7185 The pointer, if already declared, should be an integer. Otherwise, we
7186 set it as BT_INTEGER with kind gfc_index_integer_kind. The pointee may
7187 be either a scalar, or an array declaration. No space is allocated for
7188 the pointee. For the statement
7189 pointer (ipt, ar(10))
7190 any subsequent uses of ar will be translated (in C-notation) as
7191 ar(i) => ((<type> *) ipt)(i)
7192 After gimplification, pointee variable will disappear in the code. */
7195 cray_pointer_decl (void)
7198 gfc_array_spec
*as
= NULL
;
7199 gfc_symbol
*cptr
; /* Pointer symbol. */
7200 gfc_symbol
*cpte
; /* Pointee symbol. */
7206 if (gfc_match_char ('(') != MATCH_YES
)
7208 gfc_error ("Expected %<(%> at %C");
7212 /* Match pointer. */
7213 var_locus
= gfc_current_locus
;
7214 gfc_clear_attr (¤t_attr
);
7215 gfc_add_cray_pointer (¤t_attr
, &var_locus
);
7216 current_ts
.type
= BT_INTEGER
;
7217 current_ts
.kind
= gfc_index_integer_kind
;
7219 m
= gfc_match_symbol (&cptr
, 0);
7222 gfc_error ("Expected variable name at %C");
7226 if (!gfc_add_cray_pointer (&cptr
->attr
, &var_locus
))
7229 gfc_set_sym_referenced (cptr
);
7231 if (cptr
->ts
.type
== BT_UNKNOWN
) /* Override the type, if necessary. */
7233 cptr
->ts
.type
= BT_INTEGER
;
7234 cptr
->ts
.kind
= gfc_index_integer_kind
;
7236 else if (cptr
->ts
.type
!= BT_INTEGER
)
7238 gfc_error ("Cray pointer at %C must be an integer");
7241 else if (cptr
->ts
.kind
< gfc_index_integer_kind
)
7242 gfc_warning (0, "Cray pointer at %C has %d bytes of precision;"
7243 " memory addresses require %d bytes",
7244 cptr
->ts
.kind
, gfc_index_integer_kind
);
7246 if (gfc_match_char (',') != MATCH_YES
)
7248 gfc_error ("Expected \",\" at %C");
7252 /* Match Pointee. */
7253 var_locus
= gfc_current_locus
;
7254 gfc_clear_attr (¤t_attr
);
7255 gfc_add_cray_pointee (¤t_attr
, &var_locus
);
7256 current_ts
.type
= BT_UNKNOWN
;
7257 current_ts
.kind
= 0;
7259 m
= gfc_match_symbol (&cpte
, 0);
7262 gfc_error ("Expected variable name at %C");
7266 /* Check for an optional array spec. */
7267 m
= gfc_match_array_spec (&as
, true, false);
7268 if (m
== MATCH_ERROR
)
7270 gfc_free_array_spec (as
);
7273 else if (m
== MATCH_NO
)
7275 gfc_free_array_spec (as
);
7279 if (!gfc_add_cray_pointee (&cpte
->attr
, &var_locus
))
7282 gfc_set_sym_referenced (cpte
);
7284 if (cpte
->as
== NULL
)
7286 if (!gfc_set_array_spec (cpte
, as
, &var_locus
))
7287 gfc_internal_error ("Couldn't set Cray pointee array spec.");
7289 else if (as
!= NULL
)
7291 gfc_error ("Duplicate array spec for Cray pointee at %C");
7292 gfc_free_array_spec (as
);
7298 if (cpte
->as
!= NULL
)
7300 /* Fix array spec. */
7301 m
= gfc_mod_pointee_as (cpte
->as
);
7302 if (m
== MATCH_ERROR
)
7306 /* Point the Pointee at the Pointer. */
7307 cpte
->cp_pointer
= cptr
;
7309 if (gfc_match_char (')') != MATCH_YES
)
7311 gfc_error ("Expected \")\" at %C");
7314 m
= gfc_match_char (',');
7316 done
= true; /* Stop searching for more declarations. */
7320 if (m
== MATCH_ERROR
/* Failed when trying to find ',' above. */
7321 || gfc_match_eos () != MATCH_YES
)
7323 gfc_error ("Expected %<,%> or end of statement at %C");
7331 gfc_match_external (void)
7334 gfc_clear_attr (¤t_attr
);
7335 current_attr
.external
= 1;
7337 return attr_decl ();
7342 gfc_match_intent (void)
7346 /* This is not allowed within a BLOCK construct! */
7347 if (gfc_current_state () == COMP_BLOCK
)
7349 gfc_error ("INTENT is not allowed inside of BLOCK at %C");
7353 intent
= match_intent_spec ();
7354 if (intent
== INTENT_UNKNOWN
)
7357 gfc_clear_attr (¤t_attr
);
7358 current_attr
.intent
= intent
;
7360 return attr_decl ();
7365 gfc_match_intrinsic (void)
7368 gfc_clear_attr (¤t_attr
);
7369 current_attr
.intrinsic
= 1;
7371 return attr_decl ();
7376 gfc_match_optional (void)
7378 /* This is not allowed within a BLOCK construct! */
7379 if (gfc_current_state () == COMP_BLOCK
)
7381 gfc_error ("OPTIONAL is not allowed inside of BLOCK at %C");
7385 gfc_clear_attr (¤t_attr
);
7386 current_attr
.optional
= 1;
7388 return attr_decl ();
7393 gfc_match_pointer (void)
7395 gfc_gobble_whitespace ();
7396 if (gfc_peek_ascii_char () == '(')
7398 if (!flag_cray_pointer
)
7400 gfc_error ("Cray pointer declaration at %C requires -fcray-pointer "
7404 return cray_pointer_decl ();
7408 gfc_clear_attr (¤t_attr
);
7409 current_attr
.pointer
= 1;
7411 return attr_decl ();
7417 gfc_match_allocatable (void)
7419 gfc_clear_attr (¤t_attr
);
7420 current_attr
.allocatable
= 1;
7422 return attr_decl ();
7427 gfc_match_codimension (void)
7429 gfc_clear_attr (¤t_attr
);
7430 current_attr
.codimension
= 1;
7432 return attr_decl ();
7437 gfc_match_contiguous (void)
7439 if (!gfc_notify_std (GFC_STD_F2008
, "CONTIGUOUS statement at %C"))
7442 gfc_clear_attr (¤t_attr
);
7443 current_attr
.contiguous
= 1;
7445 return attr_decl ();
7450 gfc_match_dimension (void)
7452 gfc_clear_attr (¤t_attr
);
7453 current_attr
.dimension
= 1;
7455 return attr_decl ();
7460 gfc_match_target (void)
7462 gfc_clear_attr (¤t_attr
);
7463 current_attr
.target
= 1;
7465 return attr_decl ();
7469 /* Match the list of entities being specified in a PUBLIC or PRIVATE
7473 access_attr_decl (gfc_statement st
)
7475 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7476 interface_type type
;
7478 gfc_symbol
*sym
, *dt_sym
;
7479 gfc_intrinsic_op op
;
7482 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
7487 m
= gfc_match_generic_spec (&type
, name
, &op
);
7490 if (m
== MATCH_ERROR
)
7495 case INTERFACE_NAMELESS
:
7496 case INTERFACE_ABSTRACT
:
7499 case INTERFACE_GENERIC
:
7500 if (gfc_get_symbol (name
, NULL
, &sym
))
7503 if (!gfc_add_access (&sym
->attr
,
7505 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
,
7509 if (sym
->attr
.generic
&& (dt_sym
= gfc_find_dt_in_generic (sym
))
7510 && !gfc_add_access (&dt_sym
->attr
,
7512 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
,
7518 case INTERFACE_INTRINSIC_OP
:
7519 if (gfc_current_ns
->operator_access
[op
] == ACCESS_UNKNOWN
)
7521 gfc_intrinsic_op other_op
;
7523 gfc_current_ns
->operator_access
[op
] =
7524 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
7526 /* Handle the case if there is another op with the same
7527 function, for INTRINSIC_EQ vs. INTRINSIC_EQ_OS and so on. */
7528 other_op
= gfc_equivalent_op (op
);
7530 if (other_op
!= INTRINSIC_NONE
)
7531 gfc_current_ns
->operator_access
[other_op
] =
7532 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
7537 gfc_error ("Access specification of the %s operator at %C has "
7538 "already been specified", gfc_op2string (op
));
7544 case INTERFACE_USER_OP
:
7545 uop
= gfc_get_uop (name
);
7547 if (uop
->access
== ACCESS_UNKNOWN
)
7549 uop
->access
= (st
== ST_PUBLIC
)
7550 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
7554 gfc_error ("Access specification of the .%s. operator at %C "
7555 "has already been specified", sym
->name
);
7562 if (gfc_match_char (',') == MATCH_NO
)
7566 if (gfc_match_eos () != MATCH_YES
)
7571 gfc_syntax_error (st
);
7579 gfc_match_protected (void)
7584 if (!gfc_current_ns
->proc_name
7585 || gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
7587 gfc_error ("PROTECTED at %C only allowed in specification "
7588 "part of a module");
7593 if (!gfc_notify_std (GFC_STD_F2003
, "PROTECTED statement at %C"))
7596 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
7601 if (gfc_match_eos () == MATCH_YES
)
7606 m
= gfc_match_symbol (&sym
, 0);
7610 if (!gfc_add_protected (&sym
->attr
, sym
->name
, &gfc_current_locus
))
7622 if (gfc_match_eos () == MATCH_YES
)
7624 if (gfc_match_char (',') != MATCH_YES
)
7631 gfc_error ("Syntax error in PROTECTED statement at %C");
7636 /* The PRIVATE statement is a bit weird in that it can be an attribute
7637 declaration, but also works as a standalone statement inside of a
7638 type declaration or a module. */
7641 gfc_match_private (gfc_statement
*st
)
7644 if (gfc_match ("private") != MATCH_YES
)
7647 if (gfc_current_state () != COMP_MODULE
7648 && !(gfc_current_state () == COMP_DERIVED
7649 && gfc_state_stack
->previous
7650 && gfc_state_stack
->previous
->state
== COMP_MODULE
)
7651 && !(gfc_current_state () == COMP_DERIVED_CONTAINS
7652 && gfc_state_stack
->previous
&& gfc_state_stack
->previous
->previous
7653 && gfc_state_stack
->previous
->previous
->state
== COMP_MODULE
))
7655 gfc_error ("PRIVATE statement at %C is only allowed in the "
7656 "specification part of a module");
7660 if (gfc_current_state () == COMP_DERIVED
)
7662 if (gfc_match_eos () == MATCH_YES
)
7668 gfc_syntax_error (ST_PRIVATE
);
7672 if (gfc_match_eos () == MATCH_YES
)
7679 return access_attr_decl (ST_PRIVATE
);
7684 gfc_match_public (gfc_statement
*st
)
7687 if (gfc_match ("public") != MATCH_YES
)
7690 if (gfc_current_state () != COMP_MODULE
)
7692 gfc_error ("PUBLIC statement at %C is only allowed in the "
7693 "specification part of a module");
7697 if (gfc_match_eos () == MATCH_YES
)
7704 return access_attr_decl (ST_PUBLIC
);
7708 /* Workhorse for gfc_match_parameter. */
7718 m
= gfc_match_symbol (&sym
, 0);
7720 gfc_error ("Expected variable name at %C in PARAMETER statement");
7725 if (gfc_match_char ('=') == MATCH_NO
)
7727 gfc_error ("Expected = sign in PARAMETER statement at %C");
7731 m
= gfc_match_init_expr (&init
);
7733 gfc_error ("Expected expression at %C in PARAMETER statement");
7737 if (sym
->ts
.type
== BT_UNKNOWN
7738 && !gfc_set_default_type (sym
, 1, NULL
))
7744 if (!gfc_check_assign_symbol (sym
, NULL
, init
)
7745 || !gfc_add_flavor (&sym
->attr
, FL_PARAMETER
, sym
->name
, NULL
))
7753 gfc_error ("Initializing already initialized variable at %C");
7758 t
= add_init_expr_to_sym (sym
->name
, &init
, &gfc_current_locus
);
7759 return (t
) ? MATCH_YES
: MATCH_ERROR
;
7762 gfc_free_expr (init
);
7767 /* Match a parameter statement, with the weird syntax that these have. */
7770 gfc_match_parameter (void)
7774 if (gfc_match_char ('(') == MATCH_NO
)
7783 if (gfc_match (" )%t") == MATCH_YES
)
7786 if (gfc_match_char (',') != MATCH_YES
)
7788 gfc_error ("Unexpected characters in PARAMETER statement at %C");
7798 /* Save statements have a special syntax. */
7801 gfc_match_save (void)
7803 char n
[GFC_MAX_SYMBOL_LEN
+1];
7808 if (gfc_match_eos () == MATCH_YES
)
7810 if (gfc_current_ns
->seen_save
)
7812 if (!gfc_notify_std (GFC_STD_LEGACY
, "Blanket SAVE statement at %C "
7813 "follows previous SAVE statement"))
7817 gfc_current_ns
->save_all
= gfc_current_ns
->seen_save
= 1;
7821 if (gfc_current_ns
->save_all
)
7823 if (!gfc_notify_std (GFC_STD_LEGACY
, "SAVE statement at %C follows "
7824 "blanket SAVE statement"))
7832 m
= gfc_match_symbol (&sym
, 0);
7836 if (!gfc_add_save (&sym
->attr
, SAVE_EXPLICIT
, sym
->name
,
7837 &gfc_current_locus
))
7848 m
= gfc_match (" / %n /", &n
);
7849 if (m
== MATCH_ERROR
)
7854 c
= gfc_get_common (n
, 0);
7857 gfc_current_ns
->seen_save
= 1;
7860 if (gfc_match_eos () == MATCH_YES
)
7862 if (gfc_match_char (',') != MATCH_YES
)
7869 gfc_error ("Syntax error in SAVE statement at %C");
7875 gfc_match_value (void)
7880 /* This is not allowed within a BLOCK construct! */
7881 if (gfc_current_state () == COMP_BLOCK
)
7883 gfc_error ("VALUE is not allowed inside of BLOCK at %C");
7887 if (!gfc_notify_std (GFC_STD_F2003
, "VALUE statement at %C"))
7890 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
7895 if (gfc_match_eos () == MATCH_YES
)
7900 m
= gfc_match_symbol (&sym
, 0);
7904 if (!gfc_add_value (&sym
->attr
, sym
->name
, &gfc_current_locus
))
7916 if (gfc_match_eos () == MATCH_YES
)
7918 if (gfc_match_char (',') != MATCH_YES
)
7925 gfc_error ("Syntax error in VALUE statement at %C");
7931 gfc_match_volatile (void)
7936 if (!gfc_notify_std (GFC_STD_F2003
, "VOLATILE statement at %C"))
7939 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
7944 if (gfc_match_eos () == MATCH_YES
)
7949 /* VOLATILE is special because it can be added to host-associated
7950 symbols locally. Except for coarrays. */
7951 m
= gfc_match_symbol (&sym
, 1);
7955 /* F2008, C560+C561. VOLATILE for host-/use-associated variable or
7956 for variable in a BLOCK which is defined outside of the BLOCK. */
7957 if (sym
->ns
!= gfc_current_ns
&& sym
->attr
.codimension
)
7959 gfc_error ("Specifying VOLATILE for coarray variable %qs at "
7960 "%C, which is use-/host-associated", sym
->name
);
7963 if (!gfc_add_volatile (&sym
->attr
, sym
->name
, &gfc_current_locus
))
7975 if (gfc_match_eos () == MATCH_YES
)
7977 if (gfc_match_char (',') != MATCH_YES
)
7984 gfc_error ("Syntax error in VOLATILE statement at %C");
7990 gfc_match_asynchronous (void)
7995 if (!gfc_notify_std (GFC_STD_F2003
, "ASYNCHRONOUS statement at %C"))
7998 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
8003 if (gfc_match_eos () == MATCH_YES
)
8008 /* ASYNCHRONOUS is special because it can be added to host-associated
8010 m
= gfc_match_symbol (&sym
, 1);
8014 if (!gfc_add_asynchronous (&sym
->attr
, sym
->name
, &gfc_current_locus
))
8026 if (gfc_match_eos () == MATCH_YES
)
8028 if (gfc_match_char (',') != MATCH_YES
)
8035 gfc_error ("Syntax error in ASYNCHRONOUS statement at %C");
8040 /* Match a module procedure statement in a submodule. */
8043 gfc_match_submod_proc (void)
8045 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8046 gfc_symbol
*sym
, *fsym
;
8048 gfc_formal_arglist
*formal
, *head
, *tail
;
8050 if (gfc_current_state () != COMP_CONTAINS
8051 || !(gfc_state_stack
->previous
8052 && (gfc_state_stack
->previous
->state
== COMP_SUBMODULE
8053 || gfc_state_stack
->previous
->state
== COMP_MODULE
)))
8056 m
= gfc_match (" module% procedure% %n", name
);
8060 if (!gfc_notify_std (GFC_STD_F2008
, "MODULE PROCEDURE declaration "
8064 if (get_proc_name (name
, &sym
, false))
8067 /* Make sure that the result field is appropriately filled, even though
8068 the result symbol will be replaced later on. */
8069 if (sym
->ts
.interface
&& sym
->ts
.interface
->attr
.function
)
8071 if (sym
->ts
.interface
->result
8072 && sym
->ts
.interface
->result
!= sym
->ts
.interface
)
8073 sym
->result
= sym
->ts
.interface
->result
;
8078 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
8079 the symbol existed before. */
8080 sym
->declared_at
= gfc_current_locus
;
8082 if (!sym
->attr
.module_procedure
)
8085 /* Signal match_end to expect "end procedure". */
8086 sym
->abr_modproc_decl
= 1;
8088 /* Change from IFSRC_IFBODY coming from the interface declaration. */
8089 sym
->attr
.if_source
= IFSRC_DECL
;
8091 gfc_new_block
= sym
;
8093 /* Make a new formal arglist with the symbols in the procedure
8096 for (formal
= sym
->formal
; formal
&& formal
->sym
; formal
= formal
->next
)
8098 if (formal
== sym
->formal
)
8099 head
= tail
= gfc_get_formal_arglist ();
8102 tail
->next
= gfc_get_formal_arglist ();
8106 if (gfc_copy_dummy_sym (&fsym
, formal
->sym
, 0))
8110 gfc_set_sym_referenced (fsym
);
8113 /* The dummy symbols get cleaned up, when the formal_namespace of the
8114 interface declaration is cleared. This allows us to add the
8115 explicit interface as is done for other type of procedure. */
8116 if (!gfc_add_explicit_interface (sym
, IFSRC_DECL
, head
,
8117 &gfc_current_locus
))
8120 if (gfc_match_eos () != MATCH_YES
)
8122 gfc_syntax_error (ST_MODULE_PROC
);
8129 gfc_free_formal_arglist (head
);
8134 /* Match a module procedure statement. Note that we have to modify
8135 symbols in the parent's namespace because the current one was there
8136 to receive symbols that are in an interface's formal argument list. */
8139 gfc_match_modproc (void)
8141 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8145 gfc_namespace
*module_ns
;
8146 gfc_interface
*old_interface_head
, *interface
;
8148 if (gfc_state_stack
->state
!= COMP_INTERFACE
8149 || gfc_state_stack
->previous
== NULL
8150 || current_interface
.type
== INTERFACE_NAMELESS
8151 || current_interface
.type
== INTERFACE_ABSTRACT
)
8153 gfc_error ("MODULE PROCEDURE at %C must be in a generic module "
8158 module_ns
= gfc_current_ns
->parent
;
8159 for (; module_ns
; module_ns
= module_ns
->parent
)
8160 if (module_ns
->proc_name
->attr
.flavor
== FL_MODULE
8161 || module_ns
->proc_name
->attr
.flavor
== FL_PROGRAM
8162 || (module_ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
8163 && !module_ns
->proc_name
->attr
.contained
))
8166 if (module_ns
== NULL
)
8169 /* Store the current state of the interface. We will need it if we
8170 end up with a syntax error and need to recover. */
8171 old_interface_head
= gfc_current_interface_head ();
8173 /* Check if the F2008 optional double colon appears. */
8174 gfc_gobble_whitespace ();
8175 old_locus
= gfc_current_locus
;
8176 if (gfc_match ("::") == MATCH_YES
)
8178 if (!gfc_notify_std (GFC_STD_F2008
, "double colon in "
8179 "MODULE PROCEDURE statement at %L", &old_locus
))
8183 gfc_current_locus
= old_locus
;
8188 old_locus
= gfc_current_locus
;
8190 m
= gfc_match_name (name
);
8196 /* Check for syntax error before starting to add symbols to the
8197 current namespace. */
8198 if (gfc_match_eos () == MATCH_YES
)
8201 if (!last
&& gfc_match_char (',') != MATCH_YES
)
8204 /* Now we're sure the syntax is valid, we process this item
8206 if (gfc_get_symbol (name
, module_ns
, &sym
))
8209 if (sym
->attr
.intrinsic
)
8211 gfc_error ("Intrinsic procedure at %L cannot be a MODULE "
8212 "PROCEDURE", &old_locus
);
8216 if (sym
->attr
.proc
!= PROC_MODULE
8217 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
8220 if (!gfc_add_interface (sym
))
8223 sym
->attr
.mod_proc
= 1;
8224 sym
->declared_at
= old_locus
;
8233 /* Restore the previous state of the interface. */
8234 interface
= gfc_current_interface_head ();
8235 gfc_set_current_interface_head (old_interface_head
);
8237 /* Free the new interfaces. */
8238 while (interface
!= old_interface_head
)
8240 gfc_interface
*i
= interface
->next
;
8245 /* And issue a syntax error. */
8246 gfc_syntax_error (ST_MODULE_PROC
);
8251 /* Check a derived type that is being extended. */
8254 check_extended_derived_type (char *name
)
8256 gfc_symbol
*extended
;
8258 if (gfc_find_symbol (name
, gfc_current_ns
, 1, &extended
))
8260 gfc_error ("Ambiguous symbol in TYPE definition at %C");
8264 extended
= gfc_find_dt_in_generic (extended
);
8269 gfc_error ("Symbol %qs at %C has not been previously defined", name
);
8273 if (extended
->attr
.flavor
!= FL_DERIVED
)
8275 gfc_error ("%qs in EXTENDS expression at %C is not a "
8276 "derived type", name
);
8280 if (extended
->attr
.is_bind_c
)
8282 gfc_error ("%qs cannot be extended at %C because it "
8283 "is BIND(C)", extended
->name
);
8287 if (extended
->attr
.sequence
)
8289 gfc_error ("%qs cannot be extended at %C because it "
8290 "is a SEQUENCE type", extended
->name
);
8298 /* Match the optional attribute specifiers for a type declaration.
8299 Return MATCH_ERROR if an error is encountered in one of the handled
8300 attributes (public, private, bind(c)), MATCH_NO if what's found is
8301 not a handled attribute, and MATCH_YES otherwise. TODO: More error
8302 checking on attribute conflicts needs to be done. */
8305 gfc_get_type_attr_spec (symbol_attribute
*attr
, char *name
)
8307 /* See if the derived type is marked as private. */
8308 if (gfc_match (" , private") == MATCH_YES
)
8310 if (gfc_current_state () != COMP_MODULE
)
8312 gfc_error ("Derived type at %C can only be PRIVATE in the "
8313 "specification part of a module");
8317 if (!gfc_add_access (attr
, ACCESS_PRIVATE
, NULL
, NULL
))
8320 else if (gfc_match (" , public") == MATCH_YES
)
8322 if (gfc_current_state () != COMP_MODULE
)
8324 gfc_error ("Derived type at %C can only be PUBLIC in the "
8325 "specification part of a module");
8329 if (!gfc_add_access (attr
, ACCESS_PUBLIC
, NULL
, NULL
))
8332 else if (gfc_match (" , bind ( c )") == MATCH_YES
)
8334 /* If the type is defined to be bind(c) it then needs to make
8335 sure that all fields are interoperable. This will
8336 need to be a semantic check on the finished derived type.
8337 See 15.2.3 (lines 9-12) of F2003 draft. */
8338 if (!gfc_add_is_bind_c (attr
, NULL
, &gfc_current_locus
, 0))
8341 /* TODO: attr conflicts need to be checked, probably in symbol.c. */
8343 else if (gfc_match (" , abstract") == MATCH_YES
)
8345 if (!gfc_notify_std (GFC_STD_F2003
, "ABSTRACT type at %C"))
8348 if (!gfc_add_abstract (attr
, &gfc_current_locus
))
8351 else if (name
&& gfc_match (" , extends ( %n )", name
) == MATCH_YES
)
8353 if (!gfc_add_extension (attr
, &gfc_current_locus
))
8359 /* If we get here, something matched. */
8364 /* Common function for type declaration blocks similar to derived types, such
8365 as STRUCTURES and MAPs. Unlike derived types, a structure type
8366 does NOT have a generic symbol matching the name given by the user.
8367 STRUCTUREs can share names with variables and PARAMETERs so we must allow
8368 for the creation of an independent symbol.
8369 Other parameters are a message to prefix errors with, the name of the new
8370 type to be created, and the flavor to add to the resulting symbol. */
8373 get_struct_decl (const char *name
, sym_flavor fl
, locus
*decl
,
8374 gfc_symbol
**result
)
8379 gcc_assert (name
[0] == (char) TOUPPER (name
[0]));
8384 where
= gfc_current_locus
;
8386 if (gfc_get_symbol (name
, NULL
, &sym
))
8391 gfc_internal_error ("Failed to create structure type '%s' at %C", name
);
8395 if (sym
->components
!= NULL
|| sym
->attr
.zero_comp
)
8397 gfc_error ("Type definition of '%s' at %C was already defined at %L",
8398 sym
->name
, &sym
->declared_at
);
8402 sym
->declared_at
= where
;
8404 if (sym
->attr
.flavor
!= fl
8405 && !gfc_add_flavor (&sym
->attr
, fl
, sym
->name
, NULL
))
8408 if (!sym
->hash_value
)
8409 /* Set the hash for the compound name for this type. */
8410 sym
->hash_value
= gfc_hash_value (sym
);
8412 /* Normally the type is expected to have been completely parsed by the time
8413 a field declaration with this type is seen. For unions, maps, and nested
8414 structure declarations, we need to indicate that it is okay that we
8415 haven't seen any components yet. This will be updated after the structure
8417 sym
->attr
.zero_comp
= 0;
8419 /* Structures always act like derived-types with the SEQUENCE attribute */
8420 gfc_add_sequence (&sym
->attr
, sym
->name
, NULL
);
8422 if (result
) *result
= sym
;
8428 /* Match the opening of a MAP block. Like a struct within a union in C;
8429 behaves identical to STRUCTURE blocks. */
8432 gfc_match_map (void)
8434 /* Counter used to give unique internal names to map structures. */
8435 static unsigned int gfc_map_id
= 0;
8436 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8440 old_loc
= gfc_current_locus
;
8442 if (gfc_match_eos () != MATCH_YES
)
8444 gfc_error ("Junk after MAP statement at %C");
8445 gfc_current_locus
= old_loc
;
8449 /* Map blocks are anonymous so we make up unique names for the symbol table
8450 which are invalid Fortran identifiers. */
8451 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "MM$%u", gfc_map_id
++);
8453 if (!get_struct_decl (name
, FL_STRUCT
, &old_loc
, &sym
))
8456 gfc_new_block
= sym
;
8462 /* Match the opening of a UNION block. */
8465 gfc_match_union (void)
8467 /* Counter used to give unique internal names to union types. */
8468 static unsigned int gfc_union_id
= 0;
8469 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8473 old_loc
= gfc_current_locus
;
8475 if (gfc_match_eos () != MATCH_YES
)
8477 gfc_error ("Junk after UNION statement at %C");
8478 gfc_current_locus
= old_loc
;
8482 /* Unions are anonymous so we make up unique names for the symbol table
8483 which are invalid Fortran identifiers. */
8484 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "UU$%u", gfc_union_id
++);
8486 if (!get_struct_decl (name
, FL_UNION
, &old_loc
, &sym
))
8489 gfc_new_block
= sym
;
8495 /* Match the beginning of a STRUCTURE declaration. This is similar to
8496 matching the beginning of a derived type declaration with a few
8497 twists. The resulting type symbol has no access control or other
8498 interesting attributes. */
8501 gfc_match_structure_decl (void)
8503 /* Counter used to give unique internal names to anonymous structures. */
8504 int gfc_structure_id
= 0;
8505 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8510 if(!gfc_option
.flag_dec_structure
)
8512 gfc_error ("STRUCTURE at %C is a DEC extension, enable with "
8519 m
= gfc_match (" /%n/", name
);
8522 /* Non-nested structure declarations require a structure name. */
8523 if (!gfc_comp_struct (gfc_current_state ()))
8525 gfc_error ("Structure name expected in non-nested structure "
8526 "declaration at %C");
8529 /* This is an anonymous structure; make up a unique name for it
8530 (upper-case letters never make it to symbol names from the source).
8531 The important thing is initializing the type variable
8532 and setting gfc_new_symbol, which is immediately used by
8533 parse_structure () and variable_decl () to add components of
8535 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "SS$%u", gfc_structure_id
++);
8538 where
= gfc_current_locus
;
8539 /* No field list allowed after non-nested structure declaration. */
8540 if (!gfc_comp_struct (gfc_current_state ())
8541 && gfc_match_eos () != MATCH_YES
)
8543 gfc_error ("Junk after non-nested STRUCTURE statement at %C");
8547 /* Make sure the name is not the name of an intrinsic type. */
8548 if (gfc_is_intrinsic_typename (name
))
8550 gfc_error ("Structure name '%s' at %C cannot be the same as an"
8551 " intrinsic type", name
);
8555 /* Store the actual type symbol for the structure with an upper-case first
8556 letter (an invalid Fortran identifier). */
8558 sprintf (name
, gfc_dt_upper_string (name
));
8559 if (!get_struct_decl (name
, FL_STRUCT
, &where
, &sym
))
8562 gfc_new_block
= sym
;
8566 /* Match the beginning of a derived type declaration. If a type name
8567 was the result of a function, then it is possible to have a symbol
8568 already to be known as a derived type yet have no components. */
8571 gfc_match_derived_decl (void)
8573 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8574 char parent
[GFC_MAX_SYMBOL_LEN
+ 1];
8575 symbol_attribute attr
;
8576 gfc_symbol
*sym
, *gensym
;
8577 gfc_symbol
*extended
;
8579 match is_type_attr_spec
= MATCH_NO
;
8580 bool seen_attr
= false;
8581 gfc_interface
*intr
= NULL
, *head
;
8583 if (gfc_comp_struct (gfc_current_state ()))
8588 gfc_clear_attr (&attr
);
8593 is_type_attr_spec
= gfc_get_type_attr_spec (&attr
, parent
);
8594 if (is_type_attr_spec
== MATCH_ERROR
)
8596 if (is_type_attr_spec
== MATCH_YES
)
8598 } while (is_type_attr_spec
== MATCH_YES
);
8600 /* Deal with derived type extensions. The extension attribute has
8601 been added to 'attr' but now the parent type must be found and
8604 extended
= check_extended_derived_type (parent
);
8606 if (parent
[0] && !extended
)
8609 if (gfc_match (" ::") != MATCH_YES
&& seen_attr
)
8611 gfc_error ("Expected :: in TYPE definition at %C");
8615 m
= gfc_match (" %n%t", name
);
8619 /* Make sure the name is not the name of an intrinsic type. */
8620 if (gfc_is_intrinsic_typename (name
))
8622 gfc_error ("Type name %qs at %C cannot be the same as an intrinsic "
8627 if (gfc_get_symbol (name
, NULL
, &gensym
))
8630 if (!gensym
->attr
.generic
&& gensym
->ts
.type
!= BT_UNKNOWN
)
8632 gfc_error ("Derived type name %qs at %C already has a basic type "
8633 "of %s", gensym
->name
, gfc_typename (&gensym
->ts
));
8637 if (!gensym
->attr
.generic
8638 && !gfc_add_generic (&gensym
->attr
, gensym
->name
, NULL
))
8641 if (!gensym
->attr
.function
8642 && !gfc_add_function (&gensym
->attr
, gensym
->name
, NULL
))
8645 sym
= gfc_find_dt_in_generic (gensym
);
8647 if (sym
&& (sym
->components
!= NULL
|| sym
->attr
.zero_comp
))
8649 gfc_error ("Derived type definition of %qs at %C has already been "
8650 "defined", sym
->name
);
8656 /* Use upper case to save the actual derived-type symbol. */
8657 gfc_get_symbol (gfc_dt_upper_string (gensym
->name
), NULL
, &sym
);
8658 sym
->name
= gfc_get_string (gensym
->name
);
8659 head
= gensym
->generic
;
8660 intr
= gfc_get_interface ();
8662 intr
->where
= gfc_current_locus
;
8663 intr
->sym
->declared_at
= gfc_current_locus
;
8665 gensym
->generic
= intr
;
8666 gensym
->attr
.if_source
= IFSRC_DECL
;
8669 /* The symbol may already have the derived attribute without the
8670 components. The ways this can happen is via a function
8671 definition, an INTRINSIC statement or a subtype in another
8672 derived type that is a pointer. The first part of the AND clause
8673 is true if the symbol is not the return value of a function. */
8674 if (sym
->attr
.flavor
!= FL_DERIVED
8675 && !gfc_add_flavor (&sym
->attr
, FL_DERIVED
, sym
->name
, NULL
))
8678 if (attr
.access
!= ACCESS_UNKNOWN
8679 && !gfc_add_access (&sym
->attr
, attr
.access
, sym
->name
, NULL
))
8681 else if (sym
->attr
.access
== ACCESS_UNKNOWN
8682 && gensym
->attr
.access
!= ACCESS_UNKNOWN
8683 && !gfc_add_access (&sym
->attr
, gensym
->attr
.access
,
8687 if (sym
->attr
.access
!= ACCESS_UNKNOWN
8688 && gensym
->attr
.access
== ACCESS_UNKNOWN
)
8689 gensym
->attr
.access
= sym
->attr
.access
;
8691 /* See if the derived type was labeled as bind(c). */
8692 if (attr
.is_bind_c
!= 0)
8693 sym
->attr
.is_bind_c
= attr
.is_bind_c
;
8695 /* Construct the f2k_derived namespace if it is not yet there. */
8696 if (!sym
->f2k_derived
)
8697 sym
->f2k_derived
= gfc_get_namespace (NULL
, 0);
8699 if (extended
&& !sym
->components
)
8703 /* Add the extended derived type as the first component. */
8704 gfc_add_component (sym
, parent
, &p
);
8706 gfc_set_sym_referenced (extended
);
8708 p
->ts
.type
= BT_DERIVED
;
8709 p
->ts
.u
.derived
= extended
;
8710 p
->initializer
= gfc_default_initializer (&p
->ts
);
8712 /* Set extension level. */
8713 if (extended
->attr
.extension
== 255)
8715 /* Since the extension field is 8 bit wide, we can only have
8716 up to 255 extension levels. */
8717 gfc_error ("Maximum extension level reached with type %qs at %L",
8718 extended
->name
, &extended
->declared_at
);
8721 sym
->attr
.extension
= extended
->attr
.extension
+ 1;
8723 /* Provide the links between the extended type and its extension. */
8724 if (!extended
->f2k_derived
)
8725 extended
->f2k_derived
= gfc_get_namespace (NULL
, 0);
8728 if (!sym
->hash_value
)
8729 /* Set the hash for the compound name for this type. */
8730 sym
->hash_value
= gfc_hash_value (sym
);
8732 /* Take over the ABSTRACT attribute. */
8733 sym
->attr
.abstract
= attr
.abstract
;
8735 gfc_new_block
= sym
;
8741 /* Cray Pointees can be declared as:
8742 pointer (ipt, a (n,m,...,*)) */
8745 gfc_mod_pointee_as (gfc_array_spec
*as
)
8747 as
->cray_pointee
= true; /* This will be useful to know later. */
8748 if (as
->type
== AS_ASSUMED_SIZE
)
8749 as
->cp_was_assumed
= true;
8750 else if (as
->type
== AS_ASSUMED_SHAPE
)
8752 gfc_error ("Cray Pointee at %C cannot be assumed shape array");
8759 /* Match the enum definition statement, here we are trying to match
8760 the first line of enum definition statement.
8761 Returns MATCH_YES if match is found. */
8764 gfc_match_enum (void)
8768 m
= gfc_match_eos ();
8772 if (!gfc_notify_std (GFC_STD_F2003
, "ENUM and ENUMERATOR at %C"))
8779 /* Returns an initializer whose value is one higher than the value of the
8780 LAST_INITIALIZER argument. If the argument is NULL, the
8781 initializers value will be set to zero. The initializer's kind
8782 will be set to gfc_c_int_kind.
8784 If -fshort-enums is given, the appropriate kind will be selected
8785 later after all enumerators have been parsed. A warning is issued
8786 here if an initializer exceeds gfc_c_int_kind. */
8789 enum_initializer (gfc_expr
*last_initializer
, locus where
)
8792 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_c_int_kind
, &where
);
8794 mpz_init (result
->value
.integer
);
8796 if (last_initializer
!= NULL
)
8798 mpz_add_ui (result
->value
.integer
, last_initializer
->value
.integer
, 1);
8799 result
->where
= last_initializer
->where
;
8801 if (gfc_check_integer_range (result
->value
.integer
,
8802 gfc_c_int_kind
) != ARITH_OK
)
8804 gfc_error ("Enumerator exceeds the C integer type at %C");
8810 /* Control comes here, if it's the very first enumerator and no
8811 initializer has been given. It will be initialized to zero. */
8812 mpz_set_si (result
->value
.integer
, 0);
8819 /* Match a variable name with an optional initializer. When this
8820 subroutine is called, a variable is expected to be parsed next.
8821 Depending on what is happening at the moment, updates either the
8822 symbol table or the current interface. */
8825 enumerator_decl (void)
8827 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8828 gfc_expr
*initializer
;
8829 gfc_array_spec
*as
= NULL
;
8837 old_locus
= gfc_current_locus
;
8839 /* When we get here, we've just matched a list of attributes and
8840 maybe a type and a double colon. The next thing we expect to see
8841 is the name of the symbol. */
8842 m
= gfc_match_name (name
);
8846 var_locus
= gfc_current_locus
;
8848 /* OK, we've successfully matched the declaration. Now put the
8849 symbol in the current namespace. If we fail to create the symbol,
8851 if (!build_sym (name
, NULL
, false, &as
, &var_locus
))
8857 /* The double colon must be present in order to have initializers.
8858 Otherwise the statement is ambiguous with an assignment statement. */
8861 if (gfc_match_char ('=') == MATCH_YES
)
8863 m
= gfc_match_init_expr (&initializer
);
8866 gfc_error ("Expected an initialization expression at %C");
8875 /* If we do not have an initializer, the initialization value of the
8876 previous enumerator (stored in last_initializer) is incremented
8877 by 1 and is used to initialize the current enumerator. */
8878 if (initializer
== NULL
)
8879 initializer
= enum_initializer (last_initializer
, old_locus
);
8881 if (initializer
== NULL
|| initializer
->ts
.type
!= BT_INTEGER
)
8883 gfc_error ("ENUMERATOR %L not initialized with integer expression",
8889 /* Store this current initializer, for the next enumerator variable
8890 to be parsed. add_init_expr_to_sym() zeros initializer, so we
8891 use last_initializer below. */
8892 last_initializer
= initializer
;
8893 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
8895 /* Maintain enumerator history. */
8896 gfc_find_symbol (name
, NULL
, 0, &sym
);
8897 create_enum_history (sym
, last_initializer
);
8899 return (t
) ? MATCH_YES
: MATCH_ERROR
;
8902 /* Free stuff up and return. */
8903 gfc_free_expr (initializer
);
8909 /* Match the enumerator definition statement. */
8912 gfc_match_enumerator_def (void)
8917 gfc_clear_ts (¤t_ts
);
8919 m
= gfc_match (" enumerator");
8923 m
= gfc_match (" :: ");
8924 if (m
== MATCH_ERROR
)
8927 colon_seen
= (m
== MATCH_YES
);
8929 if (gfc_current_state () != COMP_ENUM
)
8931 gfc_error ("ENUM definition statement expected before %C");
8932 gfc_free_enum_history ();
8936 (¤t_ts
)->type
= BT_INTEGER
;
8937 (¤t_ts
)->kind
= gfc_c_int_kind
;
8939 gfc_clear_attr (¤t_attr
);
8940 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, NULL
);
8949 m
= enumerator_decl ();
8950 if (m
== MATCH_ERROR
)
8952 gfc_free_enum_history ();
8958 if (gfc_match_eos () == MATCH_YES
)
8960 if (gfc_match_char (',') != MATCH_YES
)
8964 if (gfc_current_state () == COMP_ENUM
)
8966 gfc_free_enum_history ();
8967 gfc_error ("Syntax error in ENUMERATOR definition at %C");
8972 gfc_free_array_spec (current_as
);
8979 /* Match binding attributes. */
8982 match_binding_attributes (gfc_typebound_proc
* ba
, bool generic
, bool ppc
)
8984 bool found_passing
= false;
8985 bool seen_ptr
= false;
8986 match m
= MATCH_YES
;
8988 /* Initialize to defaults. Do so even before the MATCH_NO check so that in
8989 this case the defaults are in there. */
8990 ba
->access
= ACCESS_UNKNOWN
;
8991 ba
->pass_arg
= NULL
;
8992 ba
->pass_arg_num
= 0;
8994 ba
->non_overridable
= 0;
8998 /* If we find a comma, we believe there are binding attributes. */
8999 m
= gfc_match_char (',');
9005 /* Access specifier. */
9007 m
= gfc_match (" public");
9008 if (m
== MATCH_ERROR
)
9012 if (ba
->access
!= ACCESS_UNKNOWN
)
9014 gfc_error ("Duplicate access-specifier at %C");
9018 ba
->access
= ACCESS_PUBLIC
;
9022 m
= gfc_match (" private");
9023 if (m
== MATCH_ERROR
)
9027 if (ba
->access
!= ACCESS_UNKNOWN
)
9029 gfc_error ("Duplicate access-specifier at %C");
9033 ba
->access
= ACCESS_PRIVATE
;
9037 /* If inside GENERIC, the following is not allowed. */
9042 m
= gfc_match (" nopass");
9043 if (m
== MATCH_ERROR
)
9049 gfc_error ("Binding attributes already specify passing,"
9050 " illegal NOPASS at %C");
9054 found_passing
= true;
9059 /* PASS possibly including argument. */
9060 m
= gfc_match (" pass");
9061 if (m
== MATCH_ERROR
)
9065 char arg
[GFC_MAX_SYMBOL_LEN
+ 1];
9069 gfc_error ("Binding attributes already specify passing,"
9070 " illegal PASS at %C");
9074 m
= gfc_match (" ( %n )", arg
);
9075 if (m
== MATCH_ERROR
)
9078 ba
->pass_arg
= gfc_get_string (arg
);
9079 gcc_assert ((m
== MATCH_YES
) == (ba
->pass_arg
!= NULL
));
9081 found_passing
= true;
9089 m
= gfc_match (" pointer");
9090 if (m
== MATCH_ERROR
)
9096 gfc_error ("Duplicate POINTER attribute at %C");
9106 /* NON_OVERRIDABLE flag. */
9107 m
= gfc_match (" non_overridable");
9108 if (m
== MATCH_ERROR
)
9112 if (ba
->non_overridable
)
9114 gfc_error ("Duplicate NON_OVERRIDABLE at %C");
9118 ba
->non_overridable
= 1;
9122 /* DEFERRED flag. */
9123 m
= gfc_match (" deferred");
9124 if (m
== MATCH_ERROR
)
9130 gfc_error ("Duplicate DEFERRED at %C");
9141 /* Nothing matching found. */
9143 gfc_error ("Expected access-specifier at %C");
9145 gfc_error ("Expected binding attribute at %C");
9148 while (gfc_match_char (',') == MATCH_YES
);
9150 /* NON_OVERRIDABLE and DEFERRED exclude themselves. */
9151 if (ba
->non_overridable
&& ba
->deferred
)
9153 gfc_error ("NON_OVERRIDABLE and DEFERRED can't both appear at %C");
9160 if (ba
->access
== ACCESS_UNKNOWN
)
9161 ba
->access
= gfc_typebound_default_access
;
9163 if (ppc
&& !seen_ptr
)
9165 gfc_error ("POINTER attribute is required for procedure pointer component"
9177 /* Match a PROCEDURE specific binding inside a derived type. */
9180 match_procedure_in_type (void)
9182 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9183 char target_buf
[GFC_MAX_SYMBOL_LEN
+ 1];
9184 char* target
= NULL
, *ifc
= NULL
;
9185 gfc_typebound_proc tb
;
9194 /* Check current state. */
9195 gcc_assert (gfc_state_stack
->state
== COMP_DERIVED_CONTAINS
);
9196 block
= gfc_state_stack
->previous
->sym
;
9199 /* Try to match PROCEDURE(interface). */
9200 if (gfc_match (" (") == MATCH_YES
)
9202 m
= gfc_match_name (target_buf
);
9203 if (m
== MATCH_ERROR
)
9207 gfc_error ("Interface-name expected after %<(%> at %C");
9211 if (gfc_match (" )") != MATCH_YES
)
9213 gfc_error ("%<)%> expected at %C");
9220 /* Construct the data structure. */
9221 memset (&tb
, 0, sizeof (tb
));
9222 tb
.where
= gfc_current_locus
;
9224 /* Match binding attributes. */
9225 m
= match_binding_attributes (&tb
, false, false);
9226 if (m
== MATCH_ERROR
)
9228 seen_attrs
= (m
== MATCH_YES
);
9230 /* Check that attribute DEFERRED is given if an interface is specified. */
9231 if (tb
.deferred
&& !ifc
)
9233 gfc_error ("Interface must be specified for DEFERRED binding at %C");
9236 if (ifc
&& !tb
.deferred
)
9238 gfc_error ("PROCEDURE(interface) at %C should be declared DEFERRED");
9242 /* Match the colons. */
9243 m
= gfc_match (" ::");
9244 if (m
== MATCH_ERROR
)
9246 seen_colons
= (m
== MATCH_YES
);
9247 if (seen_attrs
&& !seen_colons
)
9249 gfc_error ("Expected %<::%> after binding-attributes at %C");
9253 /* Match the binding names. */
9256 m
= gfc_match_name (name
);
9257 if (m
== MATCH_ERROR
)
9261 gfc_error ("Expected binding name at %C");
9265 if (num
>1 && !gfc_notify_std (GFC_STD_F2008
, "PROCEDURE list at %C"))
9268 /* Try to match the '=> target', if it's there. */
9270 m
= gfc_match (" =>");
9271 if (m
== MATCH_ERROR
)
9277 gfc_error ("%<=> target%> is invalid for DEFERRED binding at %C");
9283 gfc_error ("%<::%> needed in PROCEDURE binding with explicit target"
9288 m
= gfc_match_name (target_buf
);
9289 if (m
== MATCH_ERROR
)
9293 gfc_error ("Expected binding target after %<=>%> at %C");
9296 target
= target_buf
;
9299 /* If no target was found, it has the same name as the binding. */
9303 /* Get the namespace to insert the symbols into. */
9304 ns
= block
->f2k_derived
;
9307 /* If the binding is DEFERRED, check that the containing type is ABSTRACT. */
9308 if (tb
.deferred
&& !block
->attr
.abstract
)
9310 gfc_error ("Type %qs containing DEFERRED binding at %C "
9311 "is not ABSTRACT", block
->name
);
9315 /* See if we already have a binding with this name in the symtree which
9316 would be an error. If a GENERIC already targeted this binding, it may
9317 be already there but then typebound is still NULL. */
9318 stree
= gfc_find_symtree (ns
->tb_sym_root
, name
);
9319 if (stree
&& stree
->n
.tb
)
9321 gfc_error ("There is already a procedure with binding name %qs for "
9322 "the derived type %qs at %C", name
, block
->name
);
9326 /* Insert it and set attributes. */
9330 stree
= gfc_new_symtree (&ns
->tb_sym_root
, name
);
9333 stree
->n
.tb
= gfc_get_typebound_proc (&tb
);
9335 if (gfc_get_sym_tree (target
, gfc_current_ns
, &stree
->n
.tb
->u
.specific
,
9338 gfc_set_sym_referenced (stree
->n
.tb
->u
.specific
->n
.sym
);
9340 if (gfc_match_eos () == MATCH_YES
)
9342 if (gfc_match_char (',') != MATCH_YES
)
9347 gfc_error ("Syntax error in PROCEDURE statement at %C");
9352 /* Match a GENERIC procedure binding inside a derived type. */
9355 gfc_match_generic (void)
9357 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9358 char bind_name
[GFC_MAX_SYMBOL_LEN
+ 16]; /* Allow space for OPERATOR(...). */
9360 gfc_typebound_proc tbattr
; /* Used for match_binding_attributes. */
9361 gfc_typebound_proc
* tb
;
9363 interface_type op_type
;
9364 gfc_intrinsic_op op
;
9367 /* Check current state. */
9368 if (gfc_current_state () == COMP_DERIVED
)
9370 gfc_error ("GENERIC at %C must be inside a derived-type CONTAINS");
9373 if (gfc_current_state () != COMP_DERIVED_CONTAINS
)
9375 block
= gfc_state_stack
->previous
->sym
;
9376 ns
= block
->f2k_derived
;
9377 gcc_assert (block
&& ns
);
9379 memset (&tbattr
, 0, sizeof (tbattr
));
9380 tbattr
.where
= gfc_current_locus
;
9382 /* See if we get an access-specifier. */
9383 m
= match_binding_attributes (&tbattr
, true, false);
9384 if (m
== MATCH_ERROR
)
9387 /* Now the colons, those are required. */
9388 if (gfc_match (" ::") != MATCH_YES
)
9390 gfc_error ("Expected %<::%> at %C");
9394 /* Match the binding name; depending on type (operator / generic) format
9395 it for future error messages into bind_name. */
9397 m
= gfc_match_generic_spec (&op_type
, name
, &op
);
9398 if (m
== MATCH_ERROR
)
9402 gfc_error ("Expected generic name or operator descriptor at %C");
9408 case INTERFACE_GENERIC
:
9409 snprintf (bind_name
, sizeof (bind_name
), "%s", name
);
9412 case INTERFACE_USER_OP
:
9413 snprintf (bind_name
, sizeof (bind_name
), "OPERATOR(.%s.)", name
);
9416 case INTERFACE_INTRINSIC_OP
:
9417 snprintf (bind_name
, sizeof (bind_name
), "OPERATOR(%s)",
9418 gfc_op2string (op
));
9421 case INTERFACE_NAMELESS
:
9422 gfc_error ("Malformed GENERIC statement at %C");
9430 /* Match the required =>. */
9431 if (gfc_match (" =>") != MATCH_YES
)
9433 gfc_error ("Expected %<=>%> at %C");
9437 /* Try to find existing GENERIC binding with this name / for this operator;
9438 if there is something, check that it is another GENERIC and then extend
9439 it rather than building a new node. Otherwise, create it and put it
9440 at the right position. */
9444 case INTERFACE_USER_OP
:
9445 case INTERFACE_GENERIC
:
9447 const bool is_op
= (op_type
== INTERFACE_USER_OP
);
9450 st
= gfc_find_symtree (is_op
? ns
->tb_uop_root
: ns
->tb_sym_root
, name
);
9462 case INTERFACE_INTRINSIC_OP
:
9472 if (!tb
->is_generic
)
9474 gcc_assert (op_type
== INTERFACE_GENERIC
);
9475 gfc_error ("There's already a non-generic procedure with binding name"
9476 " %qs for the derived type %qs at %C",
9477 bind_name
, block
->name
);
9481 if (tb
->access
!= tbattr
.access
)
9483 gfc_error ("Binding at %C must have the same access as already"
9484 " defined binding %qs", bind_name
);
9490 tb
= gfc_get_typebound_proc (NULL
);
9491 tb
->where
= gfc_current_locus
;
9492 tb
->access
= tbattr
.access
;
9494 tb
->u
.generic
= NULL
;
9498 case INTERFACE_GENERIC
:
9499 case INTERFACE_USER_OP
:
9501 const bool is_op
= (op_type
== INTERFACE_USER_OP
);
9504 st
= gfc_new_symtree (is_op
? &ns
->tb_uop_root
: &ns
->tb_sym_root
,
9512 case INTERFACE_INTRINSIC_OP
:
9521 /* Now, match all following names as specific targets. */
9524 gfc_symtree
* target_st
;
9525 gfc_tbp_generic
* target
;
9527 m
= gfc_match_name (name
);
9528 if (m
== MATCH_ERROR
)
9532 gfc_error ("Expected specific binding name at %C");
9536 target_st
= gfc_get_tbp_symtree (&ns
->tb_sym_root
, name
);
9538 /* See if this is a duplicate specification. */
9539 for (target
= tb
->u
.generic
; target
; target
= target
->next
)
9540 if (target_st
== target
->specific_st
)
9542 gfc_error ("%qs already defined as specific binding for the"
9543 " generic %qs at %C", name
, bind_name
);
9547 target
= gfc_get_tbp_generic ();
9548 target
->specific_st
= target_st
;
9549 target
->specific
= NULL
;
9550 target
->next
= tb
->u
.generic
;
9551 target
->is_operator
= ((op_type
== INTERFACE_USER_OP
)
9552 || (op_type
== INTERFACE_INTRINSIC_OP
));
9553 tb
->u
.generic
= target
;
9555 while (gfc_match (" ,") == MATCH_YES
);
9557 /* Here should be the end. */
9558 if (gfc_match_eos () != MATCH_YES
)
9560 gfc_error ("Junk after GENERIC binding at %C");
9571 /* Match a FINAL declaration inside a derived type. */
9574 gfc_match_final_decl (void)
9576 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9579 gfc_namespace
* module_ns
;
9583 if (gfc_current_form
== FORM_FREE
)
9585 char c
= gfc_peek_ascii_char ();
9586 if (!gfc_is_whitespace (c
) && c
!= ':')
9590 if (gfc_state_stack
->state
!= COMP_DERIVED_CONTAINS
)
9592 if (gfc_current_form
== FORM_FIXED
)
9595 gfc_error ("FINAL declaration at %C must be inside a derived type "
9596 "CONTAINS section");
9600 block
= gfc_state_stack
->previous
->sym
;
9603 if (!gfc_state_stack
->previous
|| !gfc_state_stack
->previous
->previous
9604 || gfc_state_stack
->previous
->previous
->state
!= COMP_MODULE
)
9606 gfc_error ("Derived type declaration with FINAL at %C must be in the"
9607 " specification part of a MODULE");
9611 module_ns
= gfc_current_ns
;
9612 gcc_assert (module_ns
);
9613 gcc_assert (module_ns
->proc_name
->attr
.flavor
== FL_MODULE
);
9615 /* Match optional ::, don't care about MATCH_YES or MATCH_NO. */
9616 if (gfc_match (" ::") == MATCH_ERROR
)
9619 /* Match the sequence of procedure names. */
9626 if (first
&& gfc_match_eos () == MATCH_YES
)
9628 gfc_error ("Empty FINAL at %C");
9632 m
= gfc_match_name (name
);
9635 gfc_error ("Expected module procedure name at %C");
9638 else if (m
!= MATCH_YES
)
9641 if (gfc_match_eos () == MATCH_YES
)
9643 if (!last
&& gfc_match_char (',') != MATCH_YES
)
9645 gfc_error ("Expected %<,%> at %C");
9649 if (gfc_get_symbol (name
, module_ns
, &sym
))
9651 gfc_error ("Unknown procedure name %qs at %C", name
);
9655 /* Mark the symbol as module procedure. */
9656 if (sym
->attr
.proc
!= PROC_MODULE
9657 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
9660 /* Check if we already have this symbol in the list, this is an error. */
9661 for (f
= block
->f2k_derived
->finalizers
; f
; f
= f
->next
)
9662 if (f
->proc_sym
== sym
)
9664 gfc_error ("%qs at %C is already defined as FINAL procedure!",
9669 /* Add this symbol to the list of finalizers. */
9670 gcc_assert (block
->f2k_derived
);
9672 f
= XCNEW (gfc_finalizer
);
9674 f
->proc_tree
= NULL
;
9675 f
->where
= gfc_current_locus
;
9676 f
->next
= block
->f2k_derived
->finalizers
;
9677 block
->f2k_derived
->finalizers
= f
;
9687 const ext_attr_t ext_attr_list
[] = {
9688 { "dllimport", EXT_ATTR_DLLIMPORT
, "dllimport" },
9689 { "dllexport", EXT_ATTR_DLLEXPORT
, "dllexport" },
9690 { "cdecl", EXT_ATTR_CDECL
, "cdecl" },
9691 { "stdcall", EXT_ATTR_STDCALL
, "stdcall" },
9692 { "fastcall", EXT_ATTR_FASTCALL
, "fastcall" },
9693 { "no_arg_check", EXT_ATTR_NO_ARG_CHECK
, NULL
},
9694 { NULL
, EXT_ATTR_LAST
, NULL
}
9697 /* Match a !GCC$ ATTRIBUTES statement of the form:
9698 !GCC$ ATTRIBUTES attribute-list :: var-name [, var-name] ...
9699 When we come here, we have already matched the !GCC$ ATTRIBUTES string.
9701 TODO: We should support all GCC attributes using the same syntax for
9702 the attribute list, i.e. the list in C
9703 __attributes(( attribute-list ))
9705 !GCC$ ATTRIBUTES attribute-list ::
9706 Cf. c-parser.c's c_parser_attributes; the data can then directly be
9709 As there is absolutely no risk of confusion, we should never return
9712 gfc_match_gcc_attributes (void)
9714 symbol_attribute attr
;
9715 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9720 gfc_clear_attr (&attr
);
9725 if (gfc_match_name (name
) != MATCH_YES
)
9728 for (id
= 0; id
< EXT_ATTR_LAST
; id
++)
9729 if (strcmp (name
, ext_attr_list
[id
].name
) == 0)
9732 if (id
== EXT_ATTR_LAST
)
9734 gfc_error ("Unknown attribute in !GCC$ ATTRIBUTES statement at %C");
9738 if (!gfc_add_ext_attribute (&attr
, (ext_attr_id_t
)id
, &gfc_current_locus
))
9741 gfc_gobble_whitespace ();
9742 ch
= gfc_next_ascii_char ();
9745 /* This is the successful exit condition for the loop. */
9746 if (gfc_next_ascii_char () == ':')
9756 if (gfc_match_eos () == MATCH_YES
)
9761 m
= gfc_match_name (name
);
9765 if (find_special (name
, &sym
, true))
9768 sym
->attr
.ext_attr
|= attr
.ext_attr
;
9770 if (gfc_match_eos () == MATCH_YES
)
9773 if (gfc_match_char (',') != MATCH_YES
)
9780 gfc_error ("Syntax error in !GCC$ ATTRIBUTES statement at %C");