1 /* Declaration statement matcher
2 Copyright (C) 2002-2017 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
23 #include "coretypes.h"
27 #include "stringpool.h"
30 #include "constructor.h"
32 /* Macros to access allocate memory for gfc_data_variable,
33 gfc_data_value and gfc_data. */
34 #define gfc_get_data_variable() XCNEW (gfc_data_variable)
35 #define gfc_get_data_value() XCNEW (gfc_data_value)
36 #define gfc_get_data() XCNEW (gfc_data)
39 static bool set_binding_label (const char **, const char *, int);
42 /* This flag is set if an old-style length selector is matched
43 during a type-declaration statement. */
45 static int old_char_selector
;
47 /* When variables acquire types and attributes from a declaration
48 statement, they get them from the following static variables. The
49 first part of a declaration sets these variables and the second
50 part copies these into symbol structures. */
52 static gfc_typespec current_ts
;
54 static symbol_attribute current_attr
;
55 static gfc_array_spec
*current_as
;
56 static int colon_seen
;
59 /* The current binding label (if any). */
60 static const char* curr_binding_label
;
61 /* Need to know how many identifiers are on the current data declaration
62 line in case we're given the BIND(C) attribute with a NAME= specifier. */
63 static int num_idents_on_line
;
64 /* Need to know if a NAME= specifier was found during gfc_match_bind_c so we
65 can supply a name if the curr_binding_label is nil and NAME= was not. */
66 static int has_name_equals
= 0;
68 /* Initializer of the previous enumerator. */
70 static gfc_expr
*last_initializer
;
72 /* History of all the enumerators is maintained, so that
73 kind values of all the enumerators could be updated depending
74 upon the maximum initialized value. */
76 typedef struct enumerator_history
79 gfc_expr
*initializer
;
80 struct enumerator_history
*next
;
84 /* Header of enum history chain. */
86 static enumerator_history
*enum_history
= NULL
;
88 /* Pointer of enum history node containing largest initializer. */
90 static enumerator_history
*max_enum
= NULL
;
92 /* gfc_new_block points to the symbol of a newly matched block. */
94 gfc_symbol
*gfc_new_block
;
96 bool gfc_matching_function
;
98 /* If a kind expression of a component of a parameterized derived type is
99 parameterized, temporarily store the expression here. */
100 static gfc_expr
*saved_kind_expr
= NULL
;
102 /* Used to store the parameter list arising in a PDT declaration and
103 in the typespec of a PDT variable or component. */
104 static gfc_actual_arglist
*decl_type_param_list
;
105 static gfc_actual_arglist
*type_param_spec_list
;
108 /********************* DATA statement subroutines *********************/
110 static bool in_match_data
= false;
113 gfc_in_match_data (void)
115 return in_match_data
;
119 set_in_match_data (bool set_value
)
121 in_match_data
= set_value
;
124 /* Free a gfc_data_variable structure and everything beneath it. */
127 free_variable (gfc_data_variable
*p
)
129 gfc_data_variable
*q
;
134 gfc_free_expr (p
->expr
);
135 gfc_free_iterator (&p
->iter
, 0);
136 free_variable (p
->list
);
142 /* Free a gfc_data_value structure and everything beneath it. */
145 free_value (gfc_data_value
*p
)
152 mpz_clear (p
->repeat
);
153 gfc_free_expr (p
->expr
);
159 /* Free a list of gfc_data structures. */
162 gfc_free_data (gfc_data
*p
)
169 free_variable (p
->var
);
170 free_value (p
->value
);
176 /* Free all data in a namespace. */
179 gfc_free_data_all (gfc_namespace
*ns
)
191 /* Reject data parsed since the last restore point was marked. */
194 gfc_reject_data (gfc_namespace
*ns
)
198 while (ns
->data
&& ns
->data
!= ns
->old_data
)
206 static match
var_element (gfc_data_variable
*);
208 /* Match a list of variables terminated by an iterator and a right
212 var_list (gfc_data_variable
*parent
)
214 gfc_data_variable
*tail
, var
;
217 m
= var_element (&var
);
218 if (m
== MATCH_ERROR
)
223 tail
= gfc_get_data_variable ();
230 if (gfc_match_char (',') != MATCH_YES
)
233 m
= gfc_match_iterator (&parent
->iter
, 1);
236 if (m
== MATCH_ERROR
)
239 m
= var_element (&var
);
240 if (m
== MATCH_ERROR
)
245 tail
->next
= gfc_get_data_variable ();
251 if (gfc_match_char (')') != MATCH_YES
)
256 gfc_syntax_error (ST_DATA
);
261 /* Match a single element in a data variable list, which can be a
262 variable-iterator list. */
265 var_element (gfc_data_variable
*new_var
)
270 memset (new_var
, 0, sizeof (gfc_data_variable
));
272 if (gfc_match_char ('(') == MATCH_YES
)
273 return var_list (new_var
);
275 m
= gfc_match_variable (&new_var
->expr
, 0);
279 sym
= new_var
->expr
->symtree
->n
.sym
;
281 /* Symbol should already have an associated type. */
282 if (!gfc_check_symbol_typed (sym
, gfc_current_ns
, false, gfc_current_locus
))
285 if (!sym
->attr
.function
&& gfc_current_ns
->parent
286 && gfc_current_ns
->parent
== sym
->ns
)
288 gfc_error ("Host associated variable %qs may not be in the DATA "
289 "statement at %C", sym
->name
);
293 if (gfc_current_state () != COMP_BLOCK_DATA
294 && sym
->attr
.in_common
295 && !gfc_notify_std (GFC_STD_GNU
, "initialization of "
296 "common block variable %qs in DATA statement at %C",
300 if (!gfc_add_data (&sym
->attr
, sym
->name
, &new_var
->expr
->where
))
307 /* Match the top-level list of data variables. */
310 top_var_list (gfc_data
*d
)
312 gfc_data_variable var
, *tail
, *new_var
;
319 m
= var_element (&var
);
322 if (m
== MATCH_ERROR
)
325 new_var
= gfc_get_data_variable ();
331 tail
->next
= new_var
;
335 if (gfc_match_char ('/') == MATCH_YES
)
337 if (gfc_match_char (',') != MATCH_YES
)
344 gfc_syntax_error (ST_DATA
);
345 gfc_free_data_all (gfc_current_ns
);
351 match_data_constant (gfc_expr
**result
)
353 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
354 gfc_symbol
*sym
, *dt_sym
= NULL
;
359 m
= gfc_match_literal_constant (&expr
, 1);
366 if (m
== MATCH_ERROR
)
369 m
= gfc_match_null (result
);
373 old_loc
= gfc_current_locus
;
375 /* Should this be a structure component, try to match it
376 before matching a name. */
377 m
= gfc_match_rvalue (result
);
378 if (m
== MATCH_ERROR
)
381 if (m
== MATCH_YES
&& (*result
)->expr_type
== EXPR_STRUCTURE
)
383 if (!gfc_simplify_expr (*result
, 0))
387 else if (m
== MATCH_YES
)
388 gfc_free_expr (*result
);
390 gfc_current_locus
= old_loc
;
392 m
= gfc_match_name (name
);
396 if (gfc_find_symbol (name
, NULL
, 1, &sym
))
399 if (sym
&& sym
->attr
.generic
)
400 dt_sym
= gfc_find_dt_in_generic (sym
);
403 || (sym
->attr
.flavor
!= FL_PARAMETER
404 && (!dt_sym
|| !gfc_fl_struct (dt_sym
->attr
.flavor
))))
406 gfc_error ("Symbol %qs must be a PARAMETER in DATA statement at %C",
411 else if (dt_sym
&& gfc_fl_struct (dt_sym
->attr
.flavor
))
412 return gfc_match_structure_constructor (dt_sym
, result
);
414 /* Check to see if the value is an initialization array expression. */
415 if (sym
->value
->expr_type
== EXPR_ARRAY
)
417 gfc_current_locus
= old_loc
;
419 m
= gfc_match_init_expr (result
);
420 if (m
== MATCH_ERROR
)
425 if (!gfc_simplify_expr (*result
, 0))
428 if ((*result
)->expr_type
== EXPR_CONSTANT
)
432 gfc_error ("Invalid initializer %s in Data statement at %C", name
);
438 *result
= gfc_copy_expr (sym
->value
);
443 /* Match a list of values in a DATA statement. The leading '/' has
444 already been seen at this point. */
447 top_val_list (gfc_data
*data
)
449 gfc_data_value
*new_val
, *tail
;
457 m
= match_data_constant (&expr
);
460 if (m
== MATCH_ERROR
)
463 new_val
= gfc_get_data_value ();
464 mpz_init (new_val
->repeat
);
467 data
->value
= new_val
;
469 tail
->next
= new_val
;
473 if (expr
->ts
.type
!= BT_INTEGER
|| gfc_match_char ('*') != MATCH_YES
)
476 mpz_set_ui (tail
->repeat
, 1);
480 mpz_set (tail
->repeat
, expr
->value
.integer
);
481 gfc_free_expr (expr
);
483 m
= match_data_constant (&tail
->expr
);
486 if (m
== MATCH_ERROR
)
490 if (gfc_match_char ('/') == MATCH_YES
)
492 if (gfc_match_char (',') == MATCH_NO
)
499 gfc_syntax_error (ST_DATA
);
500 gfc_free_data_all (gfc_current_ns
);
505 /* Matches an old style initialization. */
508 match_old_style_init (const char *name
)
515 /* Set up data structure to hold initializers. */
516 gfc_find_sym_tree (name
, NULL
, 0, &st
);
519 newdata
= gfc_get_data ();
520 newdata
->var
= gfc_get_data_variable ();
521 newdata
->var
->expr
= gfc_get_variable_expr (st
);
522 newdata
->where
= gfc_current_locus
;
524 /* Match initial value list. This also eats the terminal '/'. */
525 m
= top_val_list (newdata
);
534 gfc_error ("Initialization at %C is not allowed in a PURE procedure");
538 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
540 /* Mark the variable as having appeared in a data statement. */
541 if (!gfc_add_data (&sym
->attr
, sym
->name
, &sym
->declared_at
))
547 /* Chain in namespace list of DATA initializers. */
548 newdata
->next
= gfc_current_ns
->data
;
549 gfc_current_ns
->data
= newdata
;
555 /* Match the stuff following a DATA statement. If ERROR_FLAG is set,
556 we are matching a DATA statement and are therefore issuing an error
557 if we encounter something unexpected, if not, we're trying to match
558 an old-style initialization expression of the form INTEGER I /2/. */
561 gfc_match_data (void)
566 /* Before parsing the rest of a DATA statement, check F2008:c1206. */
567 if ((gfc_current_state () == COMP_FUNCTION
568 || gfc_current_state () == COMP_SUBROUTINE
)
569 && gfc_state_stack
->previous
->state
== COMP_INTERFACE
)
571 gfc_error ("DATA statement at %C cannot appear within an INTERFACE");
575 set_in_match_data (true);
579 new_data
= gfc_get_data ();
580 new_data
->where
= gfc_current_locus
;
582 m
= top_var_list (new_data
);
586 m
= top_val_list (new_data
);
590 new_data
->next
= gfc_current_ns
->data
;
591 gfc_current_ns
->data
= new_data
;
593 if (gfc_match_eos () == MATCH_YES
)
596 gfc_match_char (','); /* Optional comma */
599 set_in_match_data (false);
603 gfc_error ("DATA statement at %C is not allowed in a PURE procedure");
606 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
611 set_in_match_data (false);
612 gfc_free_data (new_data
);
617 /************************ Declaration statements *********************/
620 /* Like gfc_match_init_expr, but matches a 'clist' (old-style initialization
621 list). The difference here is the expression is a list of constants
622 and is surrounded by '/'.
623 The typespec ts must match the typespec of the variable which the
624 clist is initializing.
625 The arrayspec tells whether this should match a list of constants
626 corresponding to array elements or a scalar (as == NULL). */
629 match_clist_expr (gfc_expr
**result
, gfc_typespec
*ts
, gfc_array_spec
*as
)
631 gfc_constructor_base array_head
= NULL
;
632 gfc_expr
*expr
= NULL
;
635 mpz_t repeat
, cons_size
, as_size
;
641 mpz_init_set_ui (repeat
, 0);
642 scalar
= !as
|| !as
->rank
;
644 /* We have already matched '/' - now look for a constant list, as with
645 top_val_list from decl.c, but append the result to an array. */
646 if (gfc_match ("/") == MATCH_YES
)
648 gfc_error ("Empty old style initializer list at %C");
652 where
= gfc_current_locus
;
655 m
= match_data_constant (&expr
);
657 expr
= NULL
; /* match_data_constant may set expr to garbage */
660 if (m
== MATCH_ERROR
)
663 /* Found r in repeat spec r*c; look for the constant to repeat. */
664 if ( gfc_match_char ('*') == MATCH_YES
)
668 gfc_error ("Repeat spec invalid in scalar initializer at %C");
671 if (expr
->ts
.type
!= BT_INTEGER
)
673 gfc_error ("Repeat spec must be an integer at %C");
676 mpz_set (repeat
, expr
->value
.integer
);
677 gfc_free_expr (expr
);
680 m
= match_data_constant (&expr
);
682 gfc_error ("Expected data constant after repeat spec at %C");
686 /* No repeat spec, we matched the data constant itself. */
688 mpz_set_ui (repeat
, 1);
692 /* Add the constant initializer as many times as repeated. */
693 for (; mpz_cmp_ui (repeat
, 0) > 0; mpz_sub_ui (repeat
, repeat
, 1))
695 /* Make sure types of elements match */
696 if(ts
&& !gfc_compare_types (&expr
->ts
, ts
)
697 && !gfc_convert_type (expr
, ts
, 1))
700 gfc_constructor_append_expr (&array_head
,
701 gfc_copy_expr (expr
), &gfc_current_locus
);
704 gfc_free_expr (expr
);
708 /* For scalar initializers quit after one element. */
711 if(gfc_match_char ('/') != MATCH_YES
)
713 gfc_error ("End of scalar initializer expected at %C");
719 if (gfc_match_char ('/') == MATCH_YES
)
721 if (gfc_match_char (',') == MATCH_NO
)
725 /* Set up expr as an array constructor. */
728 expr
= gfc_get_array_expr (ts
->type
, ts
->kind
, &where
);
730 expr
->value
.constructor
= array_head
;
732 expr
->rank
= as
->rank
;
733 expr
->shape
= gfc_get_shape (expr
->rank
);
735 /* Validate sizes. We built expr ourselves, so cons_size will be
736 constant (we fail above for non-constant expressions).
737 We still need to verify that the array-spec has constant size. */
739 gcc_assert (gfc_array_size (expr
, &cons_size
));
740 if (!spec_size (as
, &as_size
))
742 gfc_error ("Expected constant array-spec in initializer list at %L",
743 as
->type
== AS_EXPLICIT
? &as
->upper
[0]->where
: &where
);
748 /* Make sure the specs are of the same size. */
749 cmp
= mpz_cmp (cons_size
, as_size
);
751 gfc_error ("Not enough elements in array initializer at %C");
753 gfc_error ("Too many elements in array initializer at %C");
756 mpz_clear (cons_size
);
761 /* Make sure scalar types match. */
762 else if (!gfc_compare_types (&expr
->ts
, ts
)
763 && !gfc_convert_type (expr
, ts
, 1))
767 expr
->ts
.u
.cl
->length_from_typespec
= 1;
774 gfc_error ("Syntax error in old style initializer list at %C");
778 expr
->value
.constructor
= NULL
;
779 gfc_free_expr (expr
);
780 gfc_constructor_free (array_head
);
786 /* Auxiliary function to merge DIMENSION and CODIMENSION array specs. */
789 merge_array_spec (gfc_array_spec
*from
, gfc_array_spec
*to
, bool copy
)
793 if ((from
->type
== AS_ASSUMED_RANK
&& to
->corank
)
794 || (to
->type
== AS_ASSUMED_RANK
&& from
->corank
))
796 gfc_error ("The assumed-rank array at %C shall not have a codimension");
800 if (to
->rank
== 0 && from
->rank
> 0)
802 to
->rank
= from
->rank
;
803 to
->type
= from
->type
;
804 to
->cray_pointee
= from
->cray_pointee
;
805 to
->cp_was_assumed
= from
->cp_was_assumed
;
807 for (i
= 0; i
< to
->corank
; i
++)
809 to
->lower
[from
->rank
+ i
] = to
->lower
[i
];
810 to
->upper
[from
->rank
+ i
] = to
->upper
[i
];
812 for (i
= 0; i
< from
->rank
; i
++)
816 to
->lower
[i
] = gfc_copy_expr (from
->lower
[i
]);
817 to
->upper
[i
] = gfc_copy_expr (from
->upper
[i
]);
821 to
->lower
[i
] = from
->lower
[i
];
822 to
->upper
[i
] = from
->upper
[i
];
826 else if (to
->corank
== 0 && from
->corank
> 0)
828 to
->corank
= from
->corank
;
829 to
->cotype
= from
->cotype
;
831 for (i
= 0; i
< from
->corank
; i
++)
835 to
->lower
[to
->rank
+ i
] = gfc_copy_expr (from
->lower
[i
]);
836 to
->upper
[to
->rank
+ i
] = gfc_copy_expr (from
->upper
[i
]);
840 to
->lower
[to
->rank
+ i
] = from
->lower
[i
];
841 to
->upper
[to
->rank
+ i
] = from
->upper
[i
];
850 /* Match an intent specification. Since this can only happen after an
851 INTENT word, a legal intent-spec must follow. */
854 match_intent_spec (void)
857 if (gfc_match (" ( in out )") == MATCH_YES
)
859 if (gfc_match (" ( in )") == MATCH_YES
)
861 if (gfc_match (" ( out )") == MATCH_YES
)
864 gfc_error ("Bad INTENT specification at %C");
865 return INTENT_UNKNOWN
;
869 /* Matches a character length specification, which is either a
870 specification expression, '*', or ':'. */
873 char_len_param_value (gfc_expr
**expr
, bool *deferred
)
880 if (gfc_match_char ('*') == MATCH_YES
)
883 if (gfc_match_char (':') == MATCH_YES
)
885 if (!gfc_notify_std (GFC_STD_F2003
, "deferred type parameter at %C"))
893 m
= gfc_match_expr (expr
);
895 if (m
== MATCH_NO
|| m
== MATCH_ERROR
)
898 if (!gfc_expr_check_typed (*expr
, gfc_current_ns
, false))
901 if ((*expr
)->expr_type
== EXPR_FUNCTION
)
903 if ((*expr
)->ts
.type
== BT_INTEGER
904 || ((*expr
)->ts
.type
== BT_UNKNOWN
905 && strcmp((*expr
)->symtree
->name
, "null") != 0))
910 else if ((*expr
)->expr_type
== EXPR_CONSTANT
)
912 /* F2008, 4.4.3.1: The length is a type parameter; its kind is
913 processor dependent and its value is greater than or equal to zero.
914 F2008, 4.4.3.2: If the character length parameter value evaluates
915 to a negative value, the length of character entities declared
918 if ((*expr
)->ts
.type
== BT_INTEGER
)
920 if (mpz_cmp_si ((*expr
)->value
.integer
, 0) < 0)
921 mpz_set_si ((*expr
)->value
.integer
, 0);
926 else if ((*expr
)->expr_type
== EXPR_ARRAY
)
928 else if ((*expr
)->expr_type
== EXPR_VARIABLE
)
933 e
= gfc_copy_expr (*expr
);
935 /* This catches the invalid code "[character(m(2:3)) :: 'x', 'y']",
936 which causes an ICE if gfc_reduce_init_expr() is called. */
937 if (e
->ref
&& e
->ref
->type
== REF_ARRAY
938 && e
->ref
->u
.ar
.type
== AR_UNKNOWN
939 && e
->ref
->u
.ar
.dimen_type
[0] == DIMEN_RANGE
)
942 t
= gfc_reduce_init_expr (e
);
944 if (!t
&& e
->ts
.type
== BT_UNKNOWN
945 && e
->symtree
->n
.sym
->attr
.untyped
== 1
946 && (flag_implicit_none
947 || e
->symtree
->n
.sym
->ns
->seen_implicit_none
== 1
948 || e
->symtree
->n
.sym
->ns
->parent
->seen_implicit_none
== 1))
954 if ((e
->ref
&& e
->ref
->type
== REF_ARRAY
955 && e
->ref
->u
.ar
.type
!= AR_ELEMENT
)
956 || (!e
->ref
&& e
->expr_type
== EXPR_ARRAY
))
968 gfc_error ("Scalar INTEGER expression expected at %L", &(*expr
)->where
);
973 /* A character length is a '*' followed by a literal integer or a
974 char_len_param_value in parenthesis. */
977 match_char_length (gfc_expr
**expr
, bool *deferred
, bool obsolescent_check
)
983 m
= gfc_match_char ('*');
987 m
= gfc_match_small_literal_int (&length
, NULL
);
988 if (m
== MATCH_ERROR
)
993 if (obsolescent_check
994 && !gfc_notify_std (GFC_STD_F95_OBS
, "Old-style character length at %C"))
996 *expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, length
);
1000 if (gfc_match_char ('(') == MATCH_NO
)
1003 m
= char_len_param_value (expr
, deferred
);
1004 if (m
!= MATCH_YES
&& gfc_matching_function
)
1006 gfc_undo_symbols ();
1010 if (m
== MATCH_ERROR
)
1015 if (gfc_match_char (')') == MATCH_NO
)
1017 gfc_free_expr (*expr
);
1025 gfc_error ("Syntax error in character length specification at %C");
1030 /* Special subroutine for finding a symbol. Check if the name is found
1031 in the current name space. If not, and we're compiling a function or
1032 subroutine and the parent compilation unit is an interface, then check
1033 to see if the name we've been given is the name of the interface
1034 (located in another namespace). */
1037 find_special (const char *name
, gfc_symbol
**result
, bool allow_subroutine
)
1043 i
= gfc_get_sym_tree (name
, NULL
, &st
, allow_subroutine
);
1046 *result
= st
? st
->n
.sym
: NULL
;
1050 if (gfc_current_state () != COMP_SUBROUTINE
1051 && gfc_current_state () != COMP_FUNCTION
)
1054 s
= gfc_state_stack
->previous
;
1058 if (s
->state
!= COMP_INTERFACE
)
1061 goto end
; /* Nameless interface. */
1063 if (strcmp (name
, s
->sym
->name
) == 0)
1074 /* Special subroutine for getting a symbol node associated with a
1075 procedure name, used in SUBROUTINE and FUNCTION statements. The
1076 symbol is created in the parent using with symtree node in the
1077 child unit pointing to the symbol. If the current namespace has no
1078 parent, then the symbol is just created in the current unit. */
1081 get_proc_name (const char *name
, gfc_symbol
**result
, bool module_fcn_entry
)
1087 /* Module functions have to be left in their own namespace because
1088 they have potentially (almost certainly!) already been referenced.
1089 In this sense, they are rather like external functions. This is
1090 fixed up in resolve.c(resolve_entries), where the symbol name-
1091 space is set to point to the master function, so that the fake
1092 result mechanism can work. */
1093 if (module_fcn_entry
)
1095 /* Present if entry is declared to be a module procedure. */
1096 rc
= gfc_find_symbol (name
, gfc_current_ns
->parent
, 0, result
);
1098 if (*result
== NULL
)
1099 rc
= gfc_get_symbol (name
, NULL
, result
);
1100 else if (!gfc_get_symbol (name
, NULL
, &sym
) && sym
1101 && (*result
)->ts
.type
== BT_UNKNOWN
1102 && sym
->attr
.flavor
== FL_UNKNOWN
)
1103 /* Pick up the typespec for the entry, if declared in the function
1104 body. Note that this symbol is FL_UNKNOWN because it will
1105 only have appeared in a type declaration. The local symtree
1106 is set to point to the module symbol and a unique symtree
1107 to the local version. This latter ensures a correct clearing
1110 /* If the ENTRY proceeds its specification, we need to ensure
1111 that this does not raise a "has no IMPLICIT type" error. */
1112 if (sym
->ts
.type
== BT_UNKNOWN
)
1113 sym
->attr
.untyped
= 1;
1115 (*result
)->ts
= sym
->ts
;
1117 /* Put the symbol in the procedure namespace so that, should
1118 the ENTRY precede its specification, the specification
1120 (*result
)->ns
= gfc_current_ns
;
1122 gfc_find_sym_tree (name
, gfc_current_ns
, 0, &st
);
1123 st
->n
.sym
= *result
;
1124 st
= gfc_get_unique_symtree (gfc_current_ns
);
1130 rc
= gfc_get_symbol (name
, gfc_current_ns
->parent
, result
);
1136 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
1139 if (sym
->attr
.module_procedure
1140 && sym
->attr
.if_source
== IFSRC_IFBODY
)
1142 /* Create a partially populated interface symbol to carry the
1143 characteristics of the procedure and the result. */
1144 sym
->tlink
= gfc_new_symbol (name
, sym
->ns
);
1145 gfc_add_type (sym
->tlink
, &(sym
->ts
),
1146 &gfc_current_locus
);
1147 gfc_copy_attr (&sym
->tlink
->attr
, &sym
->attr
, NULL
);
1148 if (sym
->attr
.dimension
)
1149 sym
->tlink
->as
= gfc_copy_array_spec (sym
->as
);
1151 /* Ideally, at this point, a copy would be made of the formal
1152 arguments and their namespace. However, this does not appear
1153 to be necessary, albeit at the expense of not being able to
1154 use gfc_compare_interfaces directly. */
1156 if (sym
->result
&& sym
->result
!= sym
)
1158 sym
->tlink
->result
= sym
->result
;
1161 else if (sym
->result
)
1163 sym
->tlink
->result
= sym
->tlink
;
1166 else if (sym
&& !sym
->gfc_new
1167 && gfc_current_state () != COMP_INTERFACE
)
1169 /* Trap another encompassed procedure with the same name. All
1170 these conditions are necessary to avoid picking up an entry
1171 whose name clashes with that of the encompassing procedure;
1172 this is handled using gsymbols to register unique, globally
1173 accessible names. */
1174 if (sym
->attr
.flavor
!= 0
1175 && sym
->attr
.proc
!= 0
1176 && (sym
->attr
.subroutine
|| sym
->attr
.function
)
1177 && sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
1178 gfc_error_now ("Procedure %qs at %C is already defined at %L",
1179 name
, &sym
->declared_at
);
1181 /* Trap a procedure with a name the same as interface in the
1182 encompassing scope. */
1183 if (sym
->attr
.generic
!= 0
1184 && (sym
->attr
.subroutine
|| sym
->attr
.function
)
1185 && !sym
->attr
.mod_proc
)
1186 gfc_error_now ("Name %qs at %C is already defined"
1187 " as a generic interface at %L",
1188 name
, &sym
->declared_at
);
1190 /* Trap declarations of attributes in encompassing scope. The
1191 signature for this is that ts.kind is set. Legitimate
1192 references only set ts.type. */
1193 if (sym
->ts
.kind
!= 0
1194 && !sym
->attr
.implicit_type
1195 && sym
->attr
.proc
== 0
1196 && gfc_current_ns
->parent
!= NULL
1197 && sym
->attr
.access
== 0
1198 && !module_fcn_entry
)
1199 gfc_error_now ("Procedure %qs at %C has an explicit interface "
1200 "and must not have attributes declared at %L",
1201 name
, &sym
->declared_at
);
1204 if (gfc_current_ns
->parent
== NULL
|| *result
== NULL
)
1207 /* Module function entries will already have a symtree in
1208 the current namespace but will need one at module level. */
1209 if (module_fcn_entry
)
1211 /* Present if entry is declared to be a module procedure. */
1212 rc
= gfc_find_sym_tree (name
, gfc_current_ns
->parent
, 0, &st
);
1214 st
= gfc_new_symtree (&gfc_current_ns
->parent
->sym_root
, name
);
1217 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, name
);
1222 /* See if the procedure should be a module procedure. */
1224 if (((sym
->ns
->proc_name
!= NULL
1225 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
1226 && sym
->attr
.proc
!= PROC_MODULE
)
1227 || (module_fcn_entry
&& sym
->attr
.proc
!= PROC_MODULE
))
1228 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
1235 /* Verify that the given symbol representing a parameter is C
1236 interoperable, by checking to see if it was marked as such after
1237 its declaration. If the given symbol is not interoperable, a
1238 warning is reported, thus removing the need to return the status to
1239 the calling function. The standard does not require the user use
1240 one of the iso_c_binding named constants to declare an
1241 interoperable parameter, but we can't be sure if the param is C
1242 interop or not if the user doesn't. For example, integer(4) may be
1243 legal Fortran, but doesn't have meaning in C. It may interop with
1244 a number of the C types, which causes a problem because the
1245 compiler can't know which one. This code is almost certainly not
1246 portable, and the user will get what they deserve if the C type
1247 across platforms isn't always interoperable with integer(4). If
1248 the user had used something like integer(c_int) or integer(c_long),
1249 the compiler could have automatically handled the varying sizes
1250 across platforms. */
1253 gfc_verify_c_interop_param (gfc_symbol
*sym
)
1255 int is_c_interop
= 0;
1258 /* We check implicitly typed variables in symbol.c:gfc_set_default_type().
1259 Don't repeat the checks here. */
1260 if (sym
->attr
.implicit_type
)
1263 /* For subroutines or functions that are passed to a BIND(C) procedure,
1264 they're interoperable if they're BIND(C) and their params are all
1266 if (sym
->attr
.flavor
== FL_PROCEDURE
)
1268 if (sym
->attr
.is_bind_c
== 0)
1270 gfc_error_now ("Procedure %qs at %L must have the BIND(C) "
1271 "attribute to be C interoperable", sym
->name
,
1272 &(sym
->declared_at
));
1277 if (sym
->attr
.is_c_interop
== 1)
1278 /* We've already checked this procedure; don't check it again. */
1281 return verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
1286 /* See if we've stored a reference to a procedure that owns sym. */
1287 if (sym
->ns
!= NULL
&& sym
->ns
->proc_name
!= NULL
)
1289 if (sym
->ns
->proc_name
->attr
.is_bind_c
== 1)
1291 is_c_interop
= (gfc_verify_c_interop(&(sym
->ts
)) ? 1 : 0);
1293 if (is_c_interop
!= 1)
1295 /* Make personalized messages to give better feedback. */
1296 if (sym
->ts
.type
== BT_DERIVED
)
1297 gfc_error ("Variable %qs at %L is a dummy argument to the "
1298 "BIND(C) procedure %qs but is not C interoperable "
1299 "because derived type %qs is not C interoperable",
1300 sym
->name
, &(sym
->declared_at
),
1301 sym
->ns
->proc_name
->name
,
1302 sym
->ts
.u
.derived
->name
);
1303 else if (sym
->ts
.type
== BT_CLASS
)
1304 gfc_error ("Variable %qs at %L is a dummy argument to the "
1305 "BIND(C) procedure %qs but is not C interoperable "
1306 "because it is polymorphic",
1307 sym
->name
, &(sym
->declared_at
),
1308 sym
->ns
->proc_name
->name
);
1309 else if (warn_c_binding_type
)
1310 gfc_warning (OPT_Wc_binding_type
,
1311 "Variable %qs at %L is a dummy argument of the "
1312 "BIND(C) procedure %qs but may not be C "
1314 sym
->name
, &(sym
->declared_at
),
1315 sym
->ns
->proc_name
->name
);
1318 /* Character strings are only C interoperable if they have a
1320 if (sym
->ts
.type
== BT_CHARACTER
)
1322 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
1323 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
1324 || mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
1326 gfc_error ("Character argument %qs at %L "
1327 "must be length 1 because "
1328 "procedure %qs is BIND(C)",
1329 sym
->name
, &sym
->declared_at
,
1330 sym
->ns
->proc_name
->name
);
1335 /* We have to make sure that any param to a bind(c) routine does
1336 not have the allocatable, pointer, or optional attributes,
1337 according to J3/04-007, section 5.1. */
1338 if (sym
->attr
.allocatable
== 1
1339 && !gfc_notify_std (GFC_STD_F2008_TS
, "Variable %qs at %L with "
1340 "ALLOCATABLE attribute in procedure %qs "
1341 "with BIND(C)", sym
->name
,
1342 &(sym
->declared_at
),
1343 sym
->ns
->proc_name
->name
))
1346 if (sym
->attr
.pointer
== 1
1347 && !gfc_notify_std (GFC_STD_F2008_TS
, "Variable %qs at %L with "
1348 "POINTER attribute in procedure %qs "
1349 "with BIND(C)", sym
->name
,
1350 &(sym
->declared_at
),
1351 sym
->ns
->proc_name
->name
))
1354 if ((sym
->attr
.allocatable
|| sym
->attr
.pointer
) && !sym
->as
)
1356 gfc_error ("Scalar variable %qs at %L with POINTER or "
1357 "ALLOCATABLE in procedure %qs with BIND(C) is not yet"
1358 " supported", sym
->name
, &(sym
->declared_at
),
1359 sym
->ns
->proc_name
->name
);
1363 if (sym
->attr
.optional
== 1 && sym
->attr
.value
)
1365 gfc_error ("Variable %qs at %L cannot have both the OPTIONAL "
1366 "and the VALUE attribute because procedure %qs "
1367 "is BIND(C)", sym
->name
, &(sym
->declared_at
),
1368 sym
->ns
->proc_name
->name
);
1371 else if (sym
->attr
.optional
== 1
1372 && !gfc_notify_std (GFC_STD_F2008_TS
, "Variable %qs "
1373 "at %L with OPTIONAL attribute in "
1374 "procedure %qs which is BIND(C)",
1375 sym
->name
, &(sym
->declared_at
),
1376 sym
->ns
->proc_name
->name
))
1379 /* Make sure that if it has the dimension attribute, that it is
1380 either assumed size or explicit shape. Deferred shape is already
1381 covered by the pointer/allocatable attribute. */
1382 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SHAPE
1383 && !gfc_notify_std (GFC_STD_F2008_TS
, "Assumed-shape array %qs "
1384 "at %L as dummy argument to the BIND(C) "
1385 "procedure %qs at %L", sym
->name
,
1386 &(sym
->declared_at
),
1387 sym
->ns
->proc_name
->name
,
1388 &(sym
->ns
->proc_name
->declared_at
)))
1398 /* Function called by variable_decl() that adds a name to the symbol table. */
1401 build_sym (const char *name
, gfc_charlen
*cl
, bool cl_deferred
,
1402 gfc_array_spec
**as
, locus
*var_locus
)
1404 symbol_attribute attr
;
1409 /* Symbols in a submodule are host associated from the parent module or
1410 submodules. Therefore, they can be overridden by declarations in the
1411 submodule scope. Deal with this by attaching the existing symbol to
1412 a new symtree and recycling the old symtree with a new symbol... */
1413 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
1414 if (st
!= NULL
&& gfc_state_stack
->state
== COMP_SUBMODULE
1415 && st
->n
.sym
!= NULL
1416 && st
->n
.sym
->attr
.host_assoc
&& st
->n
.sym
->attr
.used_in_submodule
)
1418 gfc_symtree
*s
= gfc_get_unique_symtree (gfc_current_ns
);
1419 s
->n
.sym
= st
->n
.sym
;
1420 sym
= gfc_new_symbol (name
, gfc_current_ns
);
1425 gfc_set_sym_referenced (sym
);
1427 /* ...Otherwise generate a new symtree and new symbol. */
1428 else if (gfc_get_symbol (name
, NULL
, &sym
))
1431 /* Check if the name has already been defined as a type. The
1432 first letter of the symtree will be in upper case then. Of
1433 course, this is only necessary if the upper case letter is
1434 actually different. */
1436 upper
= TOUPPER(name
[0]);
1437 if (upper
!= name
[0])
1439 char u_name
[GFC_MAX_SYMBOL_LEN
+ 1];
1442 gcc_assert (strlen(name
) <= GFC_MAX_SYMBOL_LEN
);
1443 strcpy (u_name
, name
);
1446 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, u_name
);
1448 /* STRUCTURE types can alias symbol names */
1449 if (st
!= 0 && st
->n
.sym
->attr
.flavor
!= FL_STRUCT
)
1451 gfc_error ("Symbol %qs at %C also declared as a type at %L", name
,
1452 &st
->n
.sym
->declared_at
);
1457 /* Start updating the symbol table. Add basic type attribute if present. */
1458 if (current_ts
.type
!= BT_UNKNOWN
1459 && (sym
->attr
.implicit_type
== 0
1460 || !gfc_compare_types (&sym
->ts
, ¤t_ts
))
1461 && !gfc_add_type (sym
, ¤t_ts
, var_locus
))
1464 if (sym
->ts
.type
== BT_CHARACTER
)
1467 sym
->ts
.deferred
= cl_deferred
;
1470 /* Add dimension attribute if present. */
1471 if (!gfc_set_array_spec (sym
, *as
, var_locus
))
1475 /* Add attribute to symbol. The copy is so that we can reset the
1476 dimension attribute. */
1477 attr
= current_attr
;
1479 attr
.codimension
= 0;
1481 if (!gfc_copy_attr (&sym
->attr
, &attr
, var_locus
))
1484 /* Finish any work that may need to be done for the binding label,
1485 if it's a bind(c). The bind(c) attr is found before the symbol
1486 is made, and before the symbol name (for data decls), so the
1487 current_ts is holding the binding label, or nothing if the
1488 name= attr wasn't given. Therefore, test here if we're dealing
1489 with a bind(c) and make sure the binding label is set correctly. */
1490 if (sym
->attr
.is_bind_c
== 1)
1492 if (!sym
->binding_label
)
1494 /* Set the binding label and verify that if a NAME= was specified
1495 then only one identifier was in the entity-decl-list. */
1496 if (!set_binding_label (&sym
->binding_label
, sym
->name
,
1497 num_idents_on_line
))
1502 /* See if we know we're in a common block, and if it's a bind(c)
1503 common then we need to make sure we're an interoperable type. */
1504 if (sym
->attr
.in_common
== 1)
1506 /* Test the common block object. */
1507 if (sym
->common_block
!= NULL
&& sym
->common_block
->is_bind_c
== 1
1508 && sym
->ts
.is_c_interop
!= 1)
1510 gfc_error_now ("Variable %qs in common block %qs at %C "
1511 "must be declared with a C interoperable "
1512 "kind since common block %qs is BIND(C)",
1513 sym
->name
, sym
->common_block
->name
,
1514 sym
->common_block
->name
);
1519 sym
->attr
.implied_index
= 0;
1521 /* Use the parameter expressions for a parameterized derived type. */
1522 if ((sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
1523 && sym
->ts
.u
.derived
->attr
.pdt_type
&& type_param_spec_list
)
1524 sym
->param_list
= gfc_copy_actual_arglist (type_param_spec_list
);
1526 if (sym
->ts
.type
== BT_CLASS
)
1527 return gfc_build_class_symbol (&sym
->ts
, &sym
->attr
, &sym
->as
);
1533 /* Set character constant to the given length. The constant will be padded or
1534 truncated. If we're inside an array constructor without a typespec, we
1535 additionally check that all elements have the same length; check_len -1
1536 means no checking. */
1539 gfc_set_constant_character_len (int len
, gfc_expr
*expr
, int check_len
)
1544 if (expr
->ts
.type
!= BT_CHARACTER
)
1547 if (expr
->expr_type
!= EXPR_CONSTANT
)
1549 gfc_error_now ("CHARACTER length must be a constant at %L", &expr
->where
);
1553 slen
= expr
->value
.character
.length
;
1556 s
= gfc_get_wide_string (len
+ 1);
1557 memcpy (s
, expr
->value
.character
.string
,
1558 MIN (len
, slen
) * sizeof (gfc_char_t
));
1560 gfc_wide_memset (&s
[slen
], ' ', len
- slen
);
1562 if (warn_character_truncation
&& slen
> len
)
1563 gfc_warning_now (OPT_Wcharacter_truncation
,
1564 "CHARACTER expression at %L is being truncated "
1565 "(%d/%d)", &expr
->where
, slen
, len
);
1567 /* Apply the standard by 'hand' otherwise it gets cleared for
1569 if (check_len
!= -1 && slen
!= check_len
1570 && !(gfc_option
.allow_std
& GFC_STD_GNU
))
1571 gfc_error_now ("The CHARACTER elements of the array constructor "
1572 "at %L must have the same length (%d/%d)",
1573 &expr
->where
, slen
, check_len
);
1576 free (expr
->value
.character
.string
);
1577 expr
->value
.character
.string
= s
;
1578 expr
->value
.character
.length
= len
;
1583 /* Function to create and update the enumerator history
1584 using the information passed as arguments.
1585 Pointer "max_enum" is also updated, to point to
1586 enum history node containing largest initializer.
1588 SYM points to the symbol node of enumerator.
1589 INIT points to its enumerator value. */
1592 create_enum_history (gfc_symbol
*sym
, gfc_expr
*init
)
1594 enumerator_history
*new_enum_history
;
1595 gcc_assert (sym
!= NULL
&& init
!= NULL
);
1597 new_enum_history
= XCNEW (enumerator_history
);
1599 new_enum_history
->sym
= sym
;
1600 new_enum_history
->initializer
= init
;
1601 new_enum_history
->next
= NULL
;
1603 if (enum_history
== NULL
)
1605 enum_history
= new_enum_history
;
1606 max_enum
= enum_history
;
1610 new_enum_history
->next
= enum_history
;
1611 enum_history
= new_enum_history
;
1613 if (mpz_cmp (max_enum
->initializer
->value
.integer
,
1614 new_enum_history
->initializer
->value
.integer
) < 0)
1615 max_enum
= new_enum_history
;
1620 /* Function to free enum kind history. */
1623 gfc_free_enum_history (void)
1625 enumerator_history
*current
= enum_history
;
1626 enumerator_history
*next
;
1628 while (current
!= NULL
)
1630 next
= current
->next
;
1635 enum_history
= NULL
;
1639 /* Function called by variable_decl() that adds an initialization
1640 expression to a symbol. */
1643 add_init_expr_to_sym (const char *name
, gfc_expr
**initp
, locus
*var_locus
)
1645 symbol_attribute attr
;
1650 if (find_special (name
, &sym
, false))
1655 /* If this symbol is confirming an implicit parameter type,
1656 then an initialization expression is not allowed. */
1657 if (attr
.flavor
== FL_PARAMETER
1658 && sym
->value
!= NULL
1661 gfc_error ("Initializer not allowed for PARAMETER %qs at %C",
1668 /* An initializer is required for PARAMETER declarations. */
1669 if (attr
.flavor
== FL_PARAMETER
)
1671 gfc_error ("PARAMETER at %L is missing an initializer", var_locus
);
1677 /* If a variable appears in a DATA block, it cannot have an
1681 gfc_error ("Variable %qs at %C with an initializer already "
1682 "appears in a DATA statement", sym
->name
);
1686 /* Check if the assignment can happen. This has to be put off
1687 until later for derived type variables and procedure pointers. */
1688 if (!gfc_bt_struct (sym
->ts
.type
) && !gfc_bt_struct (init
->ts
.type
)
1689 && sym
->ts
.type
!= BT_CLASS
&& init
->ts
.type
!= BT_CLASS
1690 && !sym
->attr
.proc_pointer
1691 && !gfc_check_assign_symbol (sym
, NULL
, init
))
1694 if (sym
->ts
.type
== BT_CHARACTER
&& sym
->ts
.u
.cl
1695 && init
->ts
.type
== BT_CHARACTER
)
1697 /* Update symbol character length according initializer. */
1698 if (!gfc_check_assign_symbol (sym
, NULL
, init
))
1701 if (sym
->ts
.u
.cl
->length
== NULL
)
1704 /* If there are multiple CHARACTER variables declared on the
1705 same line, we don't want them to share the same length. */
1706 sym
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1708 if (sym
->attr
.flavor
== FL_PARAMETER
)
1710 if (init
->expr_type
== EXPR_CONSTANT
)
1712 clen
= init
->value
.character
.length
;
1713 sym
->ts
.u
.cl
->length
1714 = gfc_get_int_expr (gfc_default_integer_kind
,
1717 else if (init
->expr_type
== EXPR_ARRAY
)
1721 const gfc_expr
*length
= init
->ts
.u
.cl
->length
;
1722 if (length
->expr_type
!= EXPR_CONSTANT
)
1724 gfc_error ("Cannot initialize parameter array "
1726 "with variable length elements",
1730 clen
= mpz_get_si (length
->value
.integer
);
1732 else if (init
->value
.constructor
)
1735 c
= gfc_constructor_first (init
->value
.constructor
);
1736 clen
= c
->expr
->value
.character
.length
;
1740 sym
->ts
.u
.cl
->length
1741 = gfc_get_int_expr (gfc_default_integer_kind
,
1744 else if (init
->ts
.u
.cl
&& init
->ts
.u
.cl
->length
)
1745 sym
->ts
.u
.cl
->length
=
1746 gfc_copy_expr (sym
->value
->ts
.u
.cl
->length
);
1749 /* Update initializer character length according symbol. */
1750 else if (sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1754 if (!gfc_specification_expr (sym
->ts
.u
.cl
->length
))
1757 len
= mpz_get_si (sym
->ts
.u
.cl
->length
->value
.integer
);
1759 if (init
->expr_type
== EXPR_CONSTANT
)
1760 gfc_set_constant_character_len (len
, init
, -1);
1761 else if (init
->expr_type
== EXPR_ARRAY
)
1765 /* Build a new charlen to prevent simplification from
1766 deleting the length before it is resolved. */
1767 init
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1768 init
->ts
.u
.cl
->length
= gfc_copy_expr (sym
->ts
.u
.cl
->length
);
1770 for (c
= gfc_constructor_first (init
->value
.constructor
);
1771 c
; c
= gfc_constructor_next (c
))
1772 gfc_set_constant_character_len (len
, c
->expr
, -1);
1777 /* If sym is implied-shape, set its upper bounds from init. */
1778 if (sym
->attr
.flavor
== FL_PARAMETER
&& sym
->attr
.dimension
1779 && sym
->as
->type
== AS_IMPLIED_SHAPE
)
1783 if (init
->rank
== 0)
1785 gfc_error ("Can't initialize implied-shape array at %L"
1786 " with scalar", &sym
->declared_at
);
1790 /* Shape should be present, we get an initialization expression. */
1791 gcc_assert (init
->shape
);
1793 for (dim
= 0; dim
< sym
->as
->rank
; ++dim
)
1796 gfc_expr
*e
, *lower
;
1798 lower
= sym
->as
->lower
[dim
];
1800 /* If the lower bound is an array element from another
1801 parameterized array, then it is marked with EXPR_VARIABLE and
1802 is an initialization expression. Try to reduce it. */
1803 if (lower
->expr_type
== EXPR_VARIABLE
)
1804 gfc_reduce_init_expr (lower
);
1806 if (lower
->expr_type
== EXPR_CONSTANT
)
1808 /* All dimensions must be without upper bound. */
1809 gcc_assert (!sym
->as
->upper
[dim
]);
1812 e
= gfc_get_constant_expr (BT_INTEGER
, k
, &sym
->declared_at
);
1813 mpz_add (e
->value
.integer
, lower
->value
.integer
,
1815 mpz_sub_ui (e
->value
.integer
, e
->value
.integer
, 1);
1816 sym
->as
->upper
[dim
] = e
;
1820 gfc_error ("Non-constant lower bound in implied-shape"
1821 " declaration at %L", &lower
->where
);
1826 sym
->as
->type
= AS_EXPLICIT
;
1829 /* Need to check if the expression we initialized this
1830 to was one of the iso_c_binding named constants. If so,
1831 and we're a parameter (constant), let it be iso_c.
1833 integer(c_int), parameter :: my_int = c_int
1834 integer(my_int) :: my_int_2
1835 If we mark my_int as iso_c (since we can see it's value
1836 is equal to one of the named constants), then my_int_2
1837 will be considered C interoperable. */
1838 if (sym
->ts
.type
!= BT_CHARACTER
&& !gfc_bt_struct (sym
->ts
.type
))
1840 sym
->ts
.is_iso_c
|= init
->ts
.is_iso_c
;
1841 sym
->ts
.is_c_interop
|= init
->ts
.is_c_interop
;
1842 /* attr bits needed for module files. */
1843 sym
->attr
.is_iso_c
|= init
->ts
.is_iso_c
;
1844 sym
->attr
.is_c_interop
|= init
->ts
.is_c_interop
;
1845 if (init
->ts
.is_iso_c
)
1846 sym
->ts
.f90_type
= init
->ts
.f90_type
;
1849 /* Add initializer. Make sure we keep the ranks sane. */
1850 if (sym
->attr
.dimension
&& init
->rank
== 0)
1855 if (sym
->attr
.flavor
== FL_PARAMETER
1856 && init
->expr_type
== EXPR_CONSTANT
1857 && spec_size (sym
->as
, &size
)
1858 && mpz_cmp_si (size
, 0) > 0)
1860 array
= gfc_get_array_expr (init
->ts
.type
, init
->ts
.kind
,
1862 for (n
= 0; n
< (int)mpz_get_si (size
); n
++)
1863 gfc_constructor_append_expr (&array
->value
.constructor
,
1866 : gfc_copy_expr (init
),
1869 array
->shape
= gfc_get_shape (sym
->as
->rank
);
1870 for (n
= 0; n
< sym
->as
->rank
; n
++)
1871 spec_dimen_size (sym
->as
, n
, &array
->shape
[n
]);
1876 init
->rank
= sym
->as
->rank
;
1880 if (sym
->attr
.save
== SAVE_NONE
)
1881 sym
->attr
.save
= SAVE_IMPLICIT
;
1889 /* Function called by variable_decl() that adds a name to a structure
1893 build_struct (const char *name
, gfc_charlen
*cl
, gfc_expr
**init
,
1894 gfc_array_spec
**as
)
1899 /* F03:C438/C439. If the current symbol is of the same derived type that we're
1900 constructing, it must have the pointer attribute. */
1901 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
1902 && current_ts
.u
.derived
== gfc_current_block ()
1903 && current_attr
.pointer
== 0)
1905 if (current_attr
.allocatable
1906 && !gfc_notify_std(GFC_STD_F2008
, "Component at %C "
1907 "must have the POINTER attribute"))
1911 else if (current_attr
.allocatable
== 0)
1913 gfc_error ("Component at %C must have the POINTER attribute");
1919 if (current_ts
.type
== BT_CLASS
1920 && !(current_attr
.pointer
|| current_attr
.allocatable
))
1922 gfc_error ("Component %qs with CLASS at %C must be allocatable "
1923 "or pointer", name
);
1927 if (gfc_current_block ()->attr
.pointer
&& (*as
)->rank
!= 0)
1929 if ((*as
)->type
!= AS_DEFERRED
&& (*as
)->type
!= AS_EXPLICIT
)
1931 gfc_error ("Array component of structure at %C must have explicit "
1932 "or deferred shape");
1937 /* If we are in a nested union/map definition, gfc_add_component will not
1938 properly find repeated components because:
1939 (i) gfc_add_component does a flat search, where components of unions
1940 and maps are implicity chained so nested components may conflict.
1941 (ii) Unions and maps are not linked as components of their parent
1942 structures until after they are parsed.
1943 For (i) we use gfc_find_component which searches recursively, and for (ii)
1944 we search each block directly from the parse stack until we find the top
1947 s
= gfc_state_stack
;
1948 if (s
->state
== COMP_UNION
|| s
->state
== COMP_MAP
)
1950 while (s
->state
== COMP_UNION
|| gfc_comp_struct (s
->state
))
1952 c
= gfc_find_component (s
->sym
, name
, true, true, NULL
);
1955 gfc_error_now ("Component %qs at %C already declared at %L",
1959 /* Break after we've searched the entire chain. */
1960 if (s
->state
== COMP_DERIVED
|| s
->state
== COMP_STRUCTURE
)
1966 if (!gfc_add_component (gfc_current_block(), name
, &c
))
1970 if (c
->ts
.type
== BT_CHARACTER
)
1973 if (c
->ts
.type
!= BT_CLASS
&& c
->ts
.type
!= BT_DERIVED
1974 && c
->ts
.kind
== 0 && saved_kind_expr
!= NULL
)
1975 c
->kind_expr
= gfc_copy_expr (saved_kind_expr
);
1977 c
->attr
= current_attr
;
1979 c
->initializer
= *init
;
1986 c
->attr
.codimension
= 1;
1988 c
->attr
.dimension
= 1;
1992 gfc_apply_init (&c
->ts
, &c
->attr
, c
->initializer
);
1994 /* Check array components. */
1995 if (!c
->attr
.dimension
)
1998 if (c
->attr
.pointer
)
2000 if (c
->as
->type
!= AS_DEFERRED
)
2002 gfc_error ("Pointer array component of structure at %C must have a "
2007 else if (c
->attr
.allocatable
)
2009 if (c
->as
->type
!= AS_DEFERRED
)
2011 gfc_error ("Allocatable component of structure at %C must have a "
2018 if (c
->as
->type
!= AS_EXPLICIT
)
2020 gfc_error ("Array component of structure at %C must have an "
2027 if (c
->ts
.type
== BT_CLASS
)
2028 return gfc_build_class_symbol (&c
->ts
, &c
->attr
, &c
->as
);
2030 if (c
->attr
.pdt_kind
|| c
->attr
.pdt_len
)
2033 gfc_find_symbol (c
->name
, gfc_current_block ()->f2k_derived
,
2037 gfc_error ("Type parameter %qs at %C has no corresponding entry "
2038 "in the type parameter name list at %L",
2039 c
->name
, &gfc_current_block ()->declared_at
);
2043 sym
->attr
.pdt_kind
= c
->attr
.pdt_kind
;
2044 sym
->attr
.pdt_len
= c
->attr
.pdt_len
;
2046 sym
->value
= gfc_copy_expr (c
->initializer
);
2047 sym
->attr
.flavor
= FL_VARIABLE
;
2050 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
2051 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_template
2052 && decl_type_param_list
)
2053 c
->param_list
= gfc_copy_actual_arglist (decl_type_param_list
);
2059 /* Match a 'NULL()', and possibly take care of some side effects. */
2062 gfc_match_null (gfc_expr
**result
)
2065 match m
, m2
= MATCH_NO
;
2067 if ((m
= gfc_match (" null ( )")) == MATCH_ERROR
)
2073 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2075 if ((m2
= gfc_match (" null (")) != MATCH_YES
)
2078 old_loc
= gfc_current_locus
;
2079 if ((m2
= gfc_match (" %n ) ", name
)) == MATCH_ERROR
)
2082 && ((m2
= gfc_match (" mold = %n )", name
)) == MATCH_ERROR
))
2086 gfc_current_locus
= old_loc
;
2091 /* The NULL symbol now has to be/become an intrinsic function. */
2092 if (gfc_get_symbol ("null", NULL
, &sym
))
2094 gfc_error ("NULL() initialization at %C is ambiguous");
2098 gfc_intrinsic_symbol (sym
);
2100 if (sym
->attr
.proc
!= PROC_INTRINSIC
2101 && !(sym
->attr
.use_assoc
&& sym
->attr
.intrinsic
)
2102 && (!gfc_add_procedure(&sym
->attr
, PROC_INTRINSIC
, sym
->name
, NULL
)
2103 || !gfc_add_function (&sym
->attr
, sym
->name
, NULL
)))
2106 *result
= gfc_get_null_expr (&gfc_current_locus
);
2108 /* Invalid per F2008, C512. */
2109 if (m2
== MATCH_YES
)
2111 gfc_error ("NULL() initialization at %C may not have MOLD");
2119 /* Match the initialization expr for a data pointer or procedure pointer. */
2122 match_pointer_init (gfc_expr
**init
, int procptr
)
2126 if (gfc_pure (NULL
) && !gfc_comp_struct (gfc_state_stack
->state
))
2128 gfc_error ("Initialization of pointer at %C is not allowed in "
2129 "a PURE procedure");
2132 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
2134 /* Match NULL() initialization. */
2135 m
= gfc_match_null (init
);
2139 /* Match non-NULL initialization. */
2140 gfc_matching_ptr_assignment
= !procptr
;
2141 gfc_matching_procptr_assignment
= procptr
;
2142 m
= gfc_match_rvalue (init
);
2143 gfc_matching_ptr_assignment
= 0;
2144 gfc_matching_procptr_assignment
= 0;
2145 if (m
== MATCH_ERROR
)
2147 else if (m
== MATCH_NO
)
2149 gfc_error ("Error in pointer initialization at %C");
2153 if (!procptr
&& !gfc_resolve_expr (*init
))
2156 if (!gfc_notify_std (GFC_STD_F2008
, "non-NULL pointer "
2157 "initialization at %C"))
2165 check_function_name (char *name
)
2167 /* In functions that have a RESULT variable defined, the function name always
2168 refers to function calls. Therefore, the name is not allowed to appear in
2169 specification statements. When checking this, be careful about
2170 'hidden' procedure pointer results ('ppr@'). */
2172 if (gfc_current_state () == COMP_FUNCTION
)
2174 gfc_symbol
*block
= gfc_current_block ();
2175 if (block
&& block
->result
&& block
->result
!= block
2176 && strcmp (block
->result
->name
, "ppr@") != 0
2177 && strcmp (block
->name
, name
) == 0)
2179 gfc_error ("Function name %qs not allowed at %C", name
);
2188 /* Match a variable name with an optional initializer. When this
2189 subroutine is called, a variable is expected to be parsed next.
2190 Depending on what is happening at the moment, updates either the
2191 symbol table or the current interface. */
2194 variable_decl (int elem
)
2196 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2197 static unsigned int fill_id
= 0;
2198 gfc_expr
*initializer
, *char_len
;
2200 gfc_array_spec
*cp_as
; /* Extra copy for Cray Pointees. */
2212 /* When we get here, we've just matched a list of attributes and
2213 maybe a type and a double colon. The next thing we expect to see
2214 is the name of the symbol. */
2216 /* If we are parsing a structure with legacy support, we allow the symbol
2217 name to be '%FILL' which gives it an anonymous (inaccessible) name. */
2219 gfc_gobble_whitespace ();
2220 if (gfc_peek_ascii_char () == '%')
2222 gfc_next_ascii_char ();
2223 m
= gfc_match ("fill");
2228 m
= gfc_match_name (name
);
2236 if (gfc_current_state () != COMP_STRUCTURE
)
2238 if (flag_dec_structure
)
2239 gfc_error ("%qs not allowed outside STRUCTURE at %C", "%FILL");
2241 gfc_error ("%qs at %C is a DEC extension, enable with "
2242 "%<-fdec-structure%>", "%FILL");
2248 gfc_error ("%qs entity cannot have attributes at %C", "%FILL");
2252 /* %FILL components are given invalid fortran names. */
2253 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "%%FILL%u", fill_id
++);
2257 var_locus
= gfc_current_locus
;
2259 /* Now we could see the optional array spec. or character length. */
2260 m
= gfc_match_array_spec (&as
, true, true);
2261 if (m
== MATCH_ERROR
)
2265 as
= gfc_copy_array_spec (current_as
);
2267 && !merge_array_spec (current_as
, as
, true))
2273 if (flag_cray_pointer
)
2274 cp_as
= gfc_copy_array_spec (as
);
2276 /* At this point, we know for sure if the symbol is PARAMETER and can thus
2277 determine (and check) whether it can be implied-shape. If it
2278 was parsed as assumed-size, change it because PARAMETERs can not
2282 if (as
->type
== AS_IMPLIED_SHAPE
&& current_attr
.flavor
!= FL_PARAMETER
)
2285 gfc_error ("Non-PARAMETER symbol %qs at %L can't be implied-shape",
2290 if (as
->type
== AS_ASSUMED_SIZE
&& as
->rank
== 1
2291 && current_attr
.flavor
== FL_PARAMETER
)
2292 as
->type
= AS_IMPLIED_SHAPE
;
2294 if (as
->type
== AS_IMPLIED_SHAPE
2295 && !gfc_notify_std (GFC_STD_F2008
, "Implied-shape array at %L",
2305 cl_deferred
= false;
2307 if (current_ts
.type
== BT_CHARACTER
)
2309 switch (match_char_length (&char_len
, &cl_deferred
, false))
2312 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2314 cl
->length
= char_len
;
2317 /* Non-constant lengths need to be copied after the first
2318 element. Also copy assumed lengths. */
2321 && (current_ts
.u
.cl
->length
== NULL
2322 || current_ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
2324 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2325 cl
->length
= gfc_copy_expr (current_ts
.u
.cl
->length
);
2328 cl
= current_ts
.u
.cl
;
2330 cl_deferred
= current_ts
.deferred
;
2339 /* The dummy arguments and result of the abreviated form of MODULE
2340 PROCEDUREs, used in SUBMODULES should not be redefined. */
2341 if (gfc_current_ns
->proc_name
2342 && gfc_current_ns
->proc_name
->abr_modproc_decl
)
2344 gfc_find_symbol (name
, gfc_current_ns
, 1, &sym
);
2345 if (sym
!= NULL
&& (sym
->attr
.dummy
|| sym
->attr
.result
))
2348 gfc_error ("%qs at %C is a redefinition of the declaration "
2349 "in the corresponding interface for MODULE "
2350 "PROCEDURE %qs", sym
->name
,
2351 gfc_current_ns
->proc_name
->name
);
2356 /* %FILL components may not have initializers. */
2357 if (strncmp (name
, "%FILL", 5) == 0 && gfc_match_eos () != MATCH_YES
)
2359 gfc_error ("%qs entity cannot have an initializer at %C", "%FILL");
2364 /* If this symbol has already shown up in a Cray Pointer declaration,
2365 and this is not a component declaration,
2366 then we want to set the type & bail out. */
2367 if (flag_cray_pointer
&& !gfc_comp_struct (gfc_current_state ()))
2369 gfc_find_symbol (name
, gfc_current_ns
, 1, &sym
);
2370 if (sym
!= NULL
&& sym
->attr
.cray_pointee
)
2372 sym
->ts
.type
= current_ts
.type
;
2373 sym
->ts
.kind
= current_ts
.kind
;
2375 sym
->ts
.u
.derived
= current_ts
.u
.derived
;
2376 sym
->ts
.is_c_interop
= current_ts
.is_c_interop
;
2377 sym
->ts
.is_iso_c
= current_ts
.is_iso_c
;
2380 /* Check to see if we have an array specification. */
2383 if (sym
->as
!= NULL
)
2385 gfc_error ("Duplicate array spec for Cray pointee at %C");
2386 gfc_free_array_spec (cp_as
);
2392 if (!gfc_set_array_spec (sym
, cp_as
, &var_locus
))
2393 gfc_internal_error ("Couldn't set pointee array spec.");
2395 /* Fix the array spec. */
2396 m
= gfc_mod_pointee_as (sym
->as
);
2397 if (m
== MATCH_ERROR
)
2405 gfc_free_array_spec (cp_as
);
2409 /* Procedure pointer as function result. */
2410 if (gfc_current_state () == COMP_FUNCTION
2411 && strcmp ("ppr@", gfc_current_block ()->name
) == 0
2412 && strcmp (name
, gfc_current_block ()->ns
->proc_name
->name
) == 0)
2413 strcpy (name
, "ppr@");
2415 if (gfc_current_state () == COMP_FUNCTION
2416 && strcmp (name
, gfc_current_block ()->name
) == 0
2417 && gfc_current_block ()->result
2418 && strcmp ("ppr@", gfc_current_block ()->result
->name
) == 0)
2419 strcpy (name
, "ppr@");
2421 /* OK, we've successfully matched the declaration. Now put the
2422 symbol in the current namespace, because it might be used in the
2423 optional initialization expression for this symbol, e.g. this is
2426 integer, parameter :: i = huge(i)
2428 This is only true for parameters or variables of a basic type.
2429 For components of derived types, it is not true, so we don't
2430 create a symbol for those yet. If we fail to create the symbol,
2432 if (!gfc_comp_struct (gfc_current_state ())
2433 && !build_sym (name
, cl
, cl_deferred
, &as
, &var_locus
))
2439 if (!check_function_name (name
))
2445 /* We allow old-style initializations of the form
2446 integer i /2/, j(4) /3*3, 1/
2447 (if no colon has been seen). These are different from data
2448 statements in that initializers are only allowed to apply to the
2449 variable immediately preceding, i.e.
2451 is not allowed. Therefore we have to do some work manually, that
2452 could otherwise be left to the matchers for DATA statements. */
2454 if (!colon_seen
&& gfc_match (" /") == MATCH_YES
)
2456 if (!gfc_notify_std (GFC_STD_GNU
, "Old-style "
2457 "initialization at %C"))
2460 /* Allow old style initializations for components of STRUCTUREs and MAPs
2461 but not components of derived types. */
2462 else if (gfc_current_state () == COMP_DERIVED
)
2464 gfc_error ("Invalid old style initialization for derived type "
2470 /* For structure components, read the initializer as a special
2471 expression and let the rest of this function apply the initializer
2473 else if (gfc_comp_struct (gfc_current_state ()))
2475 m
= match_clist_expr (&initializer
, ¤t_ts
, as
);
2477 gfc_error ("Syntax error in old style initialization of %s at %C",
2483 /* Otherwise we treat the old style initialization just like a
2484 DATA declaration for the current variable. */
2486 return match_old_style_init (name
);
2489 /* The double colon must be present in order to have initializers.
2490 Otherwise the statement is ambiguous with an assignment statement. */
2493 if (gfc_match (" =>") == MATCH_YES
)
2495 if (!current_attr
.pointer
)
2497 gfc_error ("Initialization at %C isn't for a pointer variable");
2502 m
= match_pointer_init (&initializer
, 0);
2506 else if (gfc_match_char ('=') == MATCH_YES
)
2508 if (current_attr
.pointer
)
2510 gfc_error ("Pointer initialization at %C requires %<=>%>, "
2516 m
= gfc_match_init_expr (&initializer
);
2519 gfc_error ("Expected an initialization expression at %C");
2523 if (current_attr
.flavor
!= FL_PARAMETER
&& gfc_pure (NULL
)
2524 && !gfc_comp_struct (gfc_state_stack
->state
))
2526 gfc_error ("Initialization of variable at %C is not allowed in "
2527 "a PURE procedure");
2531 if (current_attr
.flavor
!= FL_PARAMETER
2532 && !gfc_comp_struct (gfc_state_stack
->state
))
2533 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
2540 if (initializer
!= NULL
&& current_attr
.allocatable
2541 && gfc_comp_struct (gfc_current_state ()))
2543 gfc_error ("Initialization of allocatable component at %C is not "
2549 if (gfc_current_state () == COMP_DERIVED
2550 && gfc_current_block ()->attr
.pdt_template
)
2553 gfc_find_symbol (name
, gfc_current_block ()->f2k_derived
,
2555 if (!param
&& (current_attr
.pdt_kind
|| current_attr
.pdt_len
))
2557 gfc_error ("The component with KIND or LEN attribute at %C does not "
2558 "not appear in the type parameter list at %L",
2559 &gfc_current_block ()->declared_at
);
2563 else if (param
&& !(current_attr
.pdt_kind
|| current_attr
.pdt_len
))
2565 gfc_error ("The component at %C that appears in the type parameter "
2566 "list at %L has neither the KIND nor LEN attribute",
2567 &gfc_current_block ()->declared_at
);
2571 else if (as
&& (current_attr
.pdt_kind
|| current_attr
.pdt_len
))
2573 gfc_error ("The component at %C which is a type parameter must be "
2578 else if (param
&& initializer
)
2579 param
->value
= gfc_copy_expr (initializer
);
2582 /* Add the initializer. Note that it is fine if initializer is
2583 NULL here, because we sometimes also need to check if a
2584 declaration *must* have an initialization expression. */
2585 if (!gfc_comp_struct (gfc_current_state ()))
2586 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
2589 if (current_ts
.type
== BT_DERIVED
2590 && !current_attr
.pointer
&& !initializer
)
2591 initializer
= gfc_default_initializer (¤t_ts
);
2592 t
= build_struct (name
, cl
, &initializer
, &as
);
2594 /* If we match a nested structure definition we expect to see the
2595 * body even if the variable declarations blow up, so we need to keep
2596 * the structure declaration around. */
2597 if (gfc_new_block
&& gfc_new_block
->attr
.flavor
== FL_STRUCT
)
2598 gfc_commit_symbol (gfc_new_block
);
2601 m
= (t
) ? MATCH_YES
: MATCH_ERROR
;
2604 /* Free stuff up and return. */
2605 gfc_free_expr (initializer
);
2606 gfc_free_array_spec (as
);
2612 /* Match an extended-f77 "TYPESPEC*bytesize"-style kind specification.
2613 This assumes that the byte size is equal to the kind number for
2614 non-COMPLEX types, and equal to twice the kind number for COMPLEX. */
2617 gfc_match_old_kind_spec (gfc_typespec
*ts
)
2622 if (gfc_match_char ('*') != MATCH_YES
)
2625 m
= gfc_match_small_literal_int (&ts
->kind
, NULL
);
2629 original_kind
= ts
->kind
;
2631 /* Massage the kind numbers for complex types. */
2632 if (ts
->type
== BT_COMPLEX
)
2636 gfc_error ("Old-style type declaration %s*%d not supported at %C",
2637 gfc_basic_typename (ts
->type
), original_kind
);
2644 if (ts
->type
== BT_INTEGER
&& ts
->kind
== 4 && flag_integer4_kind
== 8)
2647 if (ts
->type
== BT_REAL
|| ts
->type
== BT_COMPLEX
)
2651 if (flag_real4_kind
== 8)
2653 if (flag_real4_kind
== 10)
2655 if (flag_real4_kind
== 16)
2661 if (flag_real8_kind
== 4)
2663 if (flag_real8_kind
== 10)
2665 if (flag_real8_kind
== 16)
2670 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
2672 gfc_error ("Old-style type declaration %s*%d not supported at %C",
2673 gfc_basic_typename (ts
->type
), original_kind
);
2677 if (!gfc_notify_std (GFC_STD_GNU
,
2678 "Nonstandard type declaration %s*%d at %C",
2679 gfc_basic_typename(ts
->type
), original_kind
))
2686 /* Match a kind specification. Since kinds are generally optional, we
2687 usually return MATCH_NO if something goes wrong. If a "kind="
2688 string is found, then we know we have an error. */
2691 gfc_match_kind_spec (gfc_typespec
*ts
, bool kind_expr_only
)
2701 saved_kind_expr
= NULL
;
2703 where
= loc
= gfc_current_locus
;
2708 if (gfc_match_char ('(') == MATCH_NO
)
2711 /* Also gobbles optional text. */
2712 if (gfc_match (" kind = ") == MATCH_YES
)
2715 loc
= gfc_current_locus
;
2719 n
= gfc_match_init_expr (&e
);
2721 if (gfc_derived_parameter_expr (e
))
2724 saved_kind_expr
= gfc_copy_expr (e
);
2725 goto close_brackets
;
2730 if (gfc_matching_function
)
2732 /* The function kind expression might include use associated or
2733 imported parameters and try again after the specification
2735 if (gfc_match_char (')') != MATCH_YES
)
2737 gfc_error ("Missing right parenthesis at %C");
2743 gfc_undo_symbols ();
2748 /* ....or else, the match is real. */
2750 gfc_error ("Expected initialization expression at %C");
2758 gfc_error ("Expected scalar initialization expression at %C");
2763 if (gfc_extract_int (e
, &ts
->kind
, 1))
2769 /* Before throwing away the expression, let's see if we had a
2770 C interoperable kind (and store the fact). */
2771 if (e
->ts
.is_c_interop
== 1)
2773 /* Mark this as C interoperable if being declared with one
2774 of the named constants from iso_c_binding. */
2775 ts
->is_c_interop
= e
->ts
.is_iso_c
;
2776 ts
->f90_type
= e
->ts
.f90_type
;
2778 ts
->interop_kind
= e
->symtree
->n
.sym
;
2784 /* Ignore errors to this point, if we've gotten here. This means
2785 we ignore the m=MATCH_ERROR from above. */
2786 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
2788 gfc_error ("Kind %d not supported for type %s at %C", ts
->kind
,
2789 gfc_basic_typename (ts
->type
));
2790 gfc_current_locus
= where
;
2794 /* Warn if, e.g., c_int is used for a REAL variable, but not
2795 if, e.g., c_double is used for COMPLEX as the standard
2796 explicitly says that the kind type parameter for complex and real
2797 variable is the same, i.e. c_float == c_float_complex. */
2798 if (ts
->f90_type
!= BT_UNKNOWN
&& ts
->f90_type
!= ts
->type
2799 && !((ts
->f90_type
== BT_REAL
&& ts
->type
== BT_COMPLEX
)
2800 || (ts
->f90_type
== BT_COMPLEX
&& ts
->type
== BT_REAL
)))
2801 gfc_warning_now (0, "C kind type parameter is for type %s but type at %L "
2802 "is %s", gfc_basic_typename (ts
->f90_type
), &where
,
2803 gfc_basic_typename (ts
->type
));
2807 gfc_gobble_whitespace ();
2808 if ((c
= gfc_next_ascii_char ()) != ')'
2809 && (ts
->type
!= BT_CHARACTER
|| c
!= ','))
2811 if (ts
->type
== BT_CHARACTER
)
2812 gfc_error ("Missing right parenthesis or comma at %C");
2814 gfc_error ("Missing right parenthesis at %C");
2818 /* All tests passed. */
2821 if(m
== MATCH_ERROR
)
2822 gfc_current_locus
= where
;
2824 if (ts
->type
== BT_INTEGER
&& ts
->kind
== 4 && flag_integer4_kind
== 8)
2827 if (ts
->type
== BT_REAL
|| ts
->type
== BT_COMPLEX
)
2831 if (flag_real4_kind
== 8)
2833 if (flag_real4_kind
== 10)
2835 if (flag_real4_kind
== 16)
2841 if (flag_real8_kind
== 4)
2843 if (flag_real8_kind
== 10)
2845 if (flag_real8_kind
== 16)
2850 /* Return what we know from the test(s). */
2855 gfc_current_locus
= where
;
2861 match_char_kind (int * kind
, int * is_iso_c
)
2870 where
= gfc_current_locus
;
2872 n
= gfc_match_init_expr (&e
);
2874 if (n
!= MATCH_YES
&& gfc_matching_function
)
2876 /* The expression might include use-associated or imported
2877 parameters and try again after the specification
2880 gfc_undo_symbols ();
2885 gfc_error ("Expected initialization expression at %C");
2891 gfc_error ("Expected scalar initialization expression at %C");
2896 if (gfc_derived_parameter_expr (e
))
2898 saved_kind_expr
= e
;
2903 fail
= gfc_extract_int (e
, kind
, 1);
2904 *is_iso_c
= e
->ts
.is_iso_c
;
2913 /* Ignore errors to this point, if we've gotten here. This means
2914 we ignore the m=MATCH_ERROR from above. */
2915 if (gfc_validate_kind (BT_CHARACTER
, *kind
, true) < 0)
2917 gfc_error ("Kind %d is not supported for CHARACTER at %C", *kind
);
2921 /* All tests passed. */
2924 if (m
== MATCH_ERROR
)
2925 gfc_current_locus
= where
;
2927 /* Return what we know from the test(s). */
2932 gfc_current_locus
= where
;
2937 /* Match the various kind/length specifications in a CHARACTER
2938 declaration. We don't return MATCH_NO. */
2941 gfc_match_char_spec (gfc_typespec
*ts
)
2943 int kind
, seen_length
, is_iso_c
;
2955 /* Try the old-style specification first. */
2956 old_char_selector
= 0;
2958 m
= match_char_length (&len
, &deferred
, true);
2962 old_char_selector
= 1;
2967 m
= gfc_match_char ('(');
2970 m
= MATCH_YES
; /* Character without length is a single char. */
2974 /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ). */
2975 if (gfc_match (" kind =") == MATCH_YES
)
2977 m
= match_char_kind (&kind
, &is_iso_c
);
2979 if (m
== MATCH_ERROR
)
2984 if (gfc_match (" , len =") == MATCH_NO
)
2987 m
= char_len_param_value (&len
, &deferred
);
2990 if (m
== MATCH_ERROR
)
2997 /* Try to match "LEN = <len-param>" or "LEN = <len-param>, KIND = <int>". */
2998 if (gfc_match (" len =") == MATCH_YES
)
3000 m
= char_len_param_value (&len
, &deferred
);
3003 if (m
== MATCH_ERROR
)
3007 if (gfc_match_char (')') == MATCH_YES
)
3010 if (gfc_match (" , kind =") != MATCH_YES
)
3013 if (match_char_kind (&kind
, &is_iso_c
) == MATCH_ERROR
)
3019 /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ). */
3020 m
= char_len_param_value (&len
, &deferred
);
3023 if (m
== MATCH_ERROR
)
3027 m
= gfc_match_char (')');
3031 if (gfc_match_char (',') != MATCH_YES
)
3034 gfc_match (" kind ="); /* Gobble optional text. */
3036 m
= match_char_kind (&kind
, &is_iso_c
);
3037 if (m
== MATCH_ERROR
)
3043 /* Require a right-paren at this point. */
3044 m
= gfc_match_char (')');
3049 gfc_error ("Syntax error in CHARACTER declaration at %C");
3051 gfc_free_expr (len
);
3055 /* Deal with character functions after USE and IMPORT statements. */
3056 if (gfc_matching_function
)
3058 gfc_free_expr (len
);
3059 gfc_undo_symbols ();
3065 gfc_free_expr (len
);
3069 /* Do some final massaging of the length values. */
3070 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
3072 if (seen_length
== 0)
3073 cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
3078 ts
->kind
= kind
== 0 ? gfc_default_character_kind
: kind
;
3079 ts
->deferred
= deferred
;
3081 /* We have to know if it was a C interoperable kind so we can
3082 do accurate type checking of bind(c) procs, etc. */
3084 /* Mark this as C interoperable if being declared with one
3085 of the named constants from iso_c_binding. */
3086 ts
->is_c_interop
= is_iso_c
;
3087 else if (len
!= NULL
)
3088 /* Here, we might have parsed something such as: character(c_char)
3089 In this case, the parsing code above grabs the c_char when
3090 looking for the length (line 1690, roughly). it's the last
3091 testcase for parsing the kind params of a character variable.
3092 However, it's not actually the length. this seems like it
3094 To see if the user used a C interop kind, test the expr
3095 of the so called length, and see if it's C interoperable. */
3096 ts
->is_c_interop
= len
->ts
.is_iso_c
;
3102 /* Matches a RECORD declaration. */
3105 match_record_decl (char *name
)
3108 old_loc
= gfc_current_locus
;
3111 m
= gfc_match (" record /");
3114 if (!flag_dec_structure
)
3116 gfc_current_locus
= old_loc
;
3117 gfc_error ("RECORD at %C is an extension, enable it with "
3121 m
= gfc_match (" %n/", name
);
3126 gfc_current_locus
= old_loc
;
3127 if (flag_dec_structure
3128 && (gfc_match (" record% ") == MATCH_YES
3129 || gfc_match (" record%t") == MATCH_YES
))
3130 gfc_error ("Structure name expected after RECORD at %C");
3138 /* This function uses the gfc_actual_arglist 'type_param_spec_list' as a source
3139 of expressions to substitute into the possibly parameterized expression
3140 'e'. Using a list is inefficient but should not be too bad since the
3141 number of type parameters is not likely to be large. */
3143 insert_parameter_exprs (gfc_expr
* e
, gfc_symbol
* sym ATTRIBUTE_UNUSED
,
3146 gfc_actual_arglist
*param
;
3149 if (e
->expr_type
!= EXPR_VARIABLE
)
3152 gcc_assert (e
->symtree
);
3153 if (e
->symtree
->n
.sym
->attr
.pdt_kind
3154 || (*f
!= 0 && e
->symtree
->n
.sym
->attr
.pdt_len
))
3156 for (param
= type_param_spec_list
; param
; param
= param
->next
)
3157 if (strcmp (e
->symtree
->n
.sym
->name
, param
->name
) == 0)
3162 copy
= gfc_copy_expr (param
->expr
);
3173 gfc_insert_kind_parameter_exprs (gfc_expr
*e
)
3175 return gfc_traverse_expr (e
, NULL
, &insert_parameter_exprs
, 0);
3180 gfc_insert_parameter_exprs (gfc_expr
*e
, gfc_actual_arglist
*param_list
)
3182 gfc_actual_arglist
*old_param_spec_list
= type_param_spec_list
;
3183 type_param_spec_list
= param_list
;
3184 return gfc_traverse_expr (e
, NULL
, &insert_parameter_exprs
, 1);
3185 type_param_spec_list
= NULL
;
3186 type_param_spec_list
= old_param_spec_list
;
3189 /* Determines the instance of a parameterized derived type to be used by
3190 matching determining the values of the kind parameters and using them
3191 in the name of the instance. If the instance exists, it is used, otherwise
3192 a new derived type is created. */
3194 gfc_get_pdt_instance (gfc_actual_arglist
*param_list
, gfc_symbol
**sym
,
3195 gfc_actual_arglist
**ext_param_list
)
3197 /* The PDT template symbol. */
3198 gfc_symbol
*pdt
= *sym
;
3199 /* The symbol for the parameter in the template f2k_namespace. */
3201 /* The hoped for instance of the PDT. */
3202 gfc_symbol
*instance
;
3203 /* The list of parameters appearing in the PDT declaration. */
3204 gfc_formal_arglist
*type_param_name_list
;
3205 /* Used to store the parameter specification list during recursive calls. */
3206 gfc_actual_arglist
*old_param_spec_list
;
3207 /* Pointers to the parameter specification being used. */
3208 gfc_actual_arglist
*actual_param
;
3209 gfc_actual_arglist
*tail
= NULL
;
3210 /* Used to build up the name of the PDT instance. The prefix uses 4
3211 characters and each KIND parameter 2 more. Allow 8 of the latter. */
3212 char name
[GFC_MAX_SYMBOL_LEN
+ 21];
3214 bool name_seen
= (param_list
== NULL
);
3215 bool assumed_seen
= false;
3216 bool deferred_seen
= false;
3217 bool spec_error
= false;
3219 gfc_expr
*kind_expr
;
3220 gfc_component
*c1
, *c2
;
3223 type_param_spec_list
= NULL
;
3225 type_param_name_list
= pdt
->formal
;
3226 actual_param
= param_list
;
3227 sprintf (name
, "Pdt%s", pdt
->name
);
3229 /* Run through the parameter name list and pick up the actual
3230 parameter values or use the default values in the PDT declaration. */
3231 for (; type_param_name_list
;
3232 type_param_name_list
= type_param_name_list
->next
)
3234 if (actual_param
&& actual_param
->spec_type
!= SPEC_EXPLICIT
)
3236 if (actual_param
->spec_type
== SPEC_ASSUMED
)
3237 spec_error
= deferred_seen
;
3239 spec_error
= assumed_seen
;
3243 gfc_error ("The type parameter spec list at %C cannot contain "
3244 "both ASSUMED and DEFERRED parameters");
3249 if (actual_param
&& actual_param
->name
)
3251 param
= type_param_name_list
->sym
;
3253 c1
= gfc_find_component (pdt
, param
->name
, false, true, NULL
);
3254 /* An error should already have been thrown in resolve.c
3255 (resolve_fl_derived0). */
3256 if (!pdt
->attr
.use_assoc
&& !c1
)
3262 if (!actual_param
&& !(c1
&& c1
->initializer
))
3264 gfc_error ("The type parameter spec list at %C does not contain "
3265 "enough parameter expressions");
3268 else if (!actual_param
&& c1
&& c1
->initializer
)
3269 kind_expr
= gfc_copy_expr (c1
->initializer
);
3270 else if (actual_param
&& actual_param
->spec_type
== SPEC_EXPLICIT
)
3271 kind_expr
= gfc_copy_expr (actual_param
->expr
);
3275 actual_param
= param_list
;
3276 for (;actual_param
; actual_param
= actual_param
->next
)
3277 if (actual_param
->name
3278 && strcmp (actual_param
->name
, param
->name
) == 0)
3280 if (actual_param
&& actual_param
->spec_type
== SPEC_EXPLICIT
)
3281 kind_expr
= gfc_copy_expr (actual_param
->expr
);
3284 if (c1
->initializer
)
3285 kind_expr
= gfc_copy_expr (c1
->initializer
);
3286 else if (!(actual_param
&& param
->attr
.pdt_len
))
3288 gfc_error ("The derived parameter '%qs' at %C does not "
3289 "have a default value", param
->name
);
3295 /* Store the current parameter expressions in a temporary actual
3296 arglist 'list' so that they can be substituted in the corresponding
3297 expressions in the PDT instance. */
3298 if (type_param_spec_list
== NULL
)
3300 type_param_spec_list
= gfc_get_actual_arglist ();
3301 tail
= type_param_spec_list
;
3305 tail
->next
= gfc_get_actual_arglist ();
3308 tail
->name
= param
->name
;
3312 /* Try simplification even for LEN expressions. */
3313 gfc_resolve_expr (kind_expr
);
3314 gfc_simplify_expr (kind_expr
, 1);
3315 /* Variable expressions seem to default to BT_PROCEDURE.
3316 TODO find out why this is and fix it. */
3317 if (kind_expr
->ts
.type
!= BT_INTEGER
3318 && kind_expr
->ts
.type
!= BT_PROCEDURE
)
3320 gfc_error ("The parameter expression at %C must be of "
3321 "INTEGER type and not %s type",
3322 gfc_basic_typename (kind_expr
->ts
.type
));
3326 tail
->expr
= gfc_copy_expr (kind_expr
);
3330 tail
->spec_type
= actual_param
->spec_type
;
3332 if (!param
->attr
.pdt_kind
)
3334 if (!name_seen
&& actual_param
)
3335 actual_param
= actual_param
->next
;
3338 gfc_free_expr (kind_expr
);
3345 && (actual_param
->spec_type
== SPEC_ASSUMED
3346 || actual_param
->spec_type
== SPEC_DEFERRED
))
3348 gfc_error ("The KIND parameter '%qs' at %C cannot either be "
3349 "ASSUMED or DEFERRED", param
->name
);
3353 if (!kind_expr
|| !gfc_is_constant_expr (kind_expr
))
3355 gfc_error ("The value for the KIND parameter '%qs' at %C does not "
3356 "reduce to a constant expression", param
->name
);
3360 gfc_extract_int (kind_expr
, &kind_value
);
3361 sprintf (name
, "%s_%d", name
, kind_value
);
3363 if (!name_seen
&& actual_param
)
3364 actual_param
= actual_param
->next
;
3365 gfc_free_expr (kind_expr
);
3368 if (!name_seen
&& actual_param
)
3370 gfc_error ("The type parameter spec list at %C contains too many "
3371 "parameter expressions");
3375 /* Now we search for the PDT instance 'name'. If it doesn't exist, we
3376 build it, using 'pdt' as a template. */
3377 if (gfc_get_symbol (name
, pdt
->ns
, &instance
))
3379 gfc_error ("Parameterized derived type at %C is ambiguous");
3385 if (instance
->attr
.flavor
== FL_DERIVED
3386 && instance
->attr
.pdt_type
)
3390 *ext_param_list
= type_param_spec_list
;
3392 gfc_commit_symbols ();
3396 /* Start building the new instance of the parameterized type. */
3397 gfc_copy_attr (&instance
->attr
, &pdt
->attr
, &pdt
->declared_at
);
3398 instance
->attr
.pdt_template
= 0;
3399 instance
->attr
.pdt_type
= 1;
3400 instance
->declared_at
= gfc_current_locus
;
3402 /* Add the components, replacing the parameters in all expressions
3403 with the expressions for their values in 'type_param_spec_list'. */
3404 c1
= pdt
->components
;
3405 tail
= type_param_spec_list
;
3406 for (; c1
; c1
= c1
->next
)
3408 gfc_add_component (instance
, c1
->name
, &c2
);
3410 c2
->attr
= c1
->attr
;
3412 /* Deal with type extension by recursively calling this function
3413 to obtain the instance of the extended type. */
3414 if (gfc_current_state () != COMP_DERIVED
3415 && c1
== pdt
->components
3416 && (c1
->ts
.type
== BT_DERIVED
|| c1
->ts
.type
== BT_CLASS
)
3417 && c1
->ts
.u
.derived
&& c1
->ts
.u
.derived
->attr
.pdt_template
3418 && gfc_get_derived_super_type (*sym
) == c2
->ts
.u
.derived
)
3420 gfc_formal_arglist
*f
;
3422 old_param_spec_list
= type_param_spec_list
;
3424 /* Obtain a spec list appropriate to the extended type..*/
3425 actual_param
= gfc_copy_actual_arglist (type_param_spec_list
);
3426 type_param_spec_list
= actual_param
;
3427 for (f
= c1
->ts
.u
.derived
->formal
; f
&& f
->next
; f
= f
->next
)
3428 actual_param
= actual_param
->next
;
3431 gfc_free_actual_arglist (actual_param
->next
);
3432 actual_param
->next
= NULL
;
3435 /* Now obtain the PDT instance for the extended type. */
3436 c2
->param_list
= type_param_spec_list
;
3437 m
= gfc_get_pdt_instance (type_param_spec_list
, &c2
->ts
.u
.derived
,
3439 type_param_spec_list
= old_param_spec_list
;
3441 c2
->ts
.u
.derived
->refs
++;
3442 gfc_set_sym_referenced (c2
->ts
.u
.derived
);
3444 /* Set extension level. */
3445 if (c2
->ts
.u
.derived
->attr
.extension
== 255)
3447 /* Since the extension field is 8 bit wide, we can only have
3448 up to 255 extension levels. */
3449 gfc_error ("Maximum extension level reached with type %qs at %L",
3450 c2
->ts
.u
.derived
->name
,
3451 &c2
->ts
.u
.derived
->declared_at
);
3454 instance
->attr
.extension
= c2
->ts
.u
.derived
->attr
.extension
+ 1;
3456 /* Advance the position in the spec list by the number of
3457 parameters in the extended type. */
3458 tail
= type_param_spec_list
;
3459 for (f
= c1
->ts
.u
.derived
->formal
; f
&& f
->next
; f
= f
->next
)
3465 /* Set the component kind using the parameterized expression. */
3466 if (c1
->ts
.kind
== 0 && c1
->kind_expr
!= NULL
)
3468 gfc_expr
*e
= gfc_copy_expr (c1
->kind_expr
);
3469 gfc_insert_kind_parameter_exprs (e
);
3470 gfc_simplify_expr (e
, 1);
3471 gfc_extract_int (e
, &c2
->ts
.kind
);
3473 if (gfc_validate_kind (c2
->ts
.type
, c2
->ts
.kind
, true) < 0)
3475 gfc_error ("Kind %d not supported for type %s at %C",
3476 c2
->ts
.kind
, gfc_basic_typename (c2
->ts
.type
));
3481 /* Similarly, set the string length if parameterized. */
3482 if (c1
->ts
.type
== BT_CHARACTER
3483 && c1
->ts
.u
.cl
->length
3484 && gfc_derived_parameter_expr (c1
->ts
.u
.cl
->length
))
3487 e
= gfc_copy_expr (c1
->ts
.u
.cl
->length
);
3488 gfc_insert_kind_parameter_exprs (e
);
3489 gfc_simplify_expr (e
, 1);
3490 c2
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
3491 c2
->ts
.u
.cl
->length
= e
;
3492 c2
->attr
.pdt_string
= 1;
3495 /* Set up either the KIND/LEN initializer, if constant,
3496 or the parameterized expression. Use the template
3497 initializer if one is not already set in this instance. */
3498 if (c2
->attr
.pdt_kind
|| c2
->attr
.pdt_len
)
3500 if (tail
&& tail
->expr
&& gfc_is_constant_expr (tail
->expr
))
3501 c2
->initializer
= gfc_copy_expr (tail
->expr
);
3502 else if (tail
&& tail
->expr
)
3504 c2
->param_list
= gfc_get_actual_arglist ();
3505 c2
->param_list
->name
= tail
->name
;
3506 c2
->param_list
->expr
= gfc_copy_expr (tail
->expr
);
3507 c2
->param_list
->next
= NULL
;
3510 if (!c2
->initializer
&& c1
->initializer
)
3511 c2
->initializer
= gfc_copy_expr (c1
->initializer
);
3516 /* Copy the array spec. */
3517 c2
->as
= gfc_copy_array_spec (c1
->as
);
3518 if (c1
->ts
.type
== BT_CLASS
)
3519 CLASS_DATA (c2
)->as
= gfc_copy_array_spec (CLASS_DATA (c1
)->as
);
3521 /* Determine if an array spec is parameterized. If so, substitute
3522 in the parameter expressions for the bounds and set the pdt_array
3523 attribute. Notice that this attribute must be unconditionally set
3524 if this is an array of parameterized character length. */
3525 if (c1
->as
&& c1
->as
->type
== AS_EXPLICIT
)
3527 bool pdt_array
= false;
3529 /* Are the bounds of the array parameterized? */
3530 for (i
= 0; i
< c1
->as
->rank
; i
++)
3532 if (gfc_derived_parameter_expr (c1
->as
->lower
[i
]))
3534 if (gfc_derived_parameter_expr (c1
->as
->upper
[i
]))
3538 /* If they are, free the expressions for the bounds and
3539 replace them with the template expressions with substitute
3541 for (i
= 0; pdt_array
&& i
< c1
->as
->rank
; i
++)
3544 e
= gfc_copy_expr (c1
->as
->lower
[i
]);
3545 gfc_insert_kind_parameter_exprs (e
);
3546 gfc_simplify_expr (e
, 1);
3547 gfc_free_expr (c2
->as
->lower
[i
]);
3548 c2
->as
->lower
[i
] = e
;
3549 e
= gfc_copy_expr (c1
->as
->upper
[i
]);
3550 gfc_insert_kind_parameter_exprs (e
);
3551 gfc_simplify_expr (e
, 1);
3552 gfc_free_expr (c2
->as
->upper
[i
]);
3553 c2
->as
->upper
[i
] = e
;
3555 c2
->attr
.pdt_array
= pdt_array
? 1 : c2
->attr
.pdt_string
;
3558 /* Recurse into this function for PDT components. */
3559 if ((c1
->ts
.type
== BT_DERIVED
|| c1
->ts
.type
== BT_CLASS
)
3560 && c1
->ts
.u
.derived
&& c1
->ts
.u
.derived
->attr
.pdt_template
)
3562 gfc_actual_arglist
*params
;
3563 /* The component in the template has a list of specification
3564 expressions derived from its declaration. */
3565 params
= gfc_copy_actual_arglist (c1
->param_list
);
3566 actual_param
= params
;
3567 /* Substitute the template parameters with the expressions
3568 from the specification list. */
3569 for (;actual_param
; actual_param
= actual_param
->next
)
3570 gfc_insert_parameter_exprs (actual_param
->expr
,
3571 type_param_spec_list
);
3573 /* Now obtain the PDT instance for the component. */
3574 old_param_spec_list
= type_param_spec_list
;
3575 m
= gfc_get_pdt_instance (params
, &c2
->ts
.u
.derived
, NULL
);
3576 type_param_spec_list
= old_param_spec_list
;
3578 c2
->param_list
= params
;
3579 if (!(c2
->attr
.pointer
|| c2
->attr
.allocatable
))
3580 c2
->initializer
= gfc_default_initializer (&c2
->ts
);
3582 if (c2
->attr
.allocatable
)
3583 instance
->attr
.alloc_comp
= 1;
3587 gfc_commit_symbol (instance
);
3589 *ext_param_list
= type_param_spec_list
;
3594 gfc_free_actual_arglist (type_param_spec_list
);
3599 /* Matches a declaration-type-spec (F03:R502). If successful, sets the ts
3600 structure to the matched specification. This is necessary for FUNCTION and
3601 IMPLICIT statements.
3603 If implicit_flag is nonzero, then we don't check for the optional
3604 kind specification. Not doing so is needed for matching an IMPLICIT
3605 statement correctly. */
3608 gfc_match_decl_type_spec (gfc_typespec
*ts
, int implicit_flag
)
3610 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3611 gfc_symbol
*sym
, *dt_sym
;
3614 bool seen_deferred_kind
, matched_type
;
3615 const char *dt_name
;
3617 decl_type_param_list
= NULL
;
3619 /* A belt and braces check that the typespec is correctly being treated
3620 as a deferred characteristic association. */
3621 seen_deferred_kind
= (gfc_current_state () == COMP_FUNCTION
)
3622 && (gfc_current_block ()->result
->ts
.kind
== -1)
3623 && (ts
->kind
== -1);
3625 if (seen_deferred_kind
)
3628 /* Clear the current binding label, in case one is given. */
3629 curr_binding_label
= NULL
;
3631 if (gfc_match (" byte") == MATCH_YES
)
3633 if (!gfc_notify_std (GFC_STD_GNU
, "BYTE type at %C"))
3636 if (gfc_validate_kind (BT_INTEGER
, 1, true) < 0)
3638 gfc_error ("BYTE type used at %C "
3639 "is not available on the target machine");
3643 ts
->type
= BT_INTEGER
;
3649 m
= gfc_match (" type (");
3650 matched_type
= (m
== MATCH_YES
);
3653 gfc_gobble_whitespace ();
3654 if (gfc_peek_ascii_char () == '*')
3656 if ((m
= gfc_match ("*)")) != MATCH_YES
)
3658 if (gfc_comp_struct (gfc_current_state ()))
3660 gfc_error ("Assumed type at %C is not allowed for components");
3663 if (!gfc_notify_std (GFC_STD_F2008_TS
, "Assumed type "
3666 ts
->type
= BT_ASSUMED
;
3670 m
= gfc_match ("%n", name
);
3671 matched_type
= (m
== MATCH_YES
);
3674 if ((matched_type
&& strcmp ("integer", name
) == 0)
3675 || (!matched_type
&& gfc_match (" integer") == MATCH_YES
))
3677 ts
->type
= BT_INTEGER
;
3678 ts
->kind
= gfc_default_integer_kind
;
3682 if ((matched_type
&& strcmp ("character", name
) == 0)
3683 || (!matched_type
&& gfc_match (" character") == MATCH_YES
))
3686 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
3687 "intrinsic-type-spec at %C"))
3690 ts
->type
= BT_CHARACTER
;
3691 if (implicit_flag
== 0)
3692 m
= gfc_match_char_spec (ts
);
3696 if (matched_type
&& m
== MATCH_YES
&& gfc_match_char (')') != MATCH_YES
)
3702 if ((matched_type
&& strcmp ("real", name
) == 0)
3703 || (!matched_type
&& gfc_match (" real") == MATCH_YES
))
3706 ts
->kind
= gfc_default_real_kind
;
3711 && (strcmp ("doubleprecision", name
) == 0
3712 || (strcmp ("double", name
) == 0
3713 && gfc_match (" precision") == MATCH_YES
)))
3714 || (!matched_type
&& gfc_match (" double precision") == MATCH_YES
))
3717 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
3718 "intrinsic-type-spec at %C"))
3720 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
3724 ts
->kind
= gfc_default_double_kind
;
3728 if ((matched_type
&& strcmp ("complex", name
) == 0)
3729 || (!matched_type
&& gfc_match (" complex") == MATCH_YES
))
3731 ts
->type
= BT_COMPLEX
;
3732 ts
->kind
= gfc_default_complex_kind
;
3737 && (strcmp ("doublecomplex", name
) == 0
3738 || (strcmp ("double", name
) == 0
3739 && gfc_match (" complex") == MATCH_YES
)))
3740 || (!matched_type
&& gfc_match (" double complex") == MATCH_YES
))
3742 if (!gfc_notify_std (GFC_STD_GNU
, "DOUBLE COMPLEX at %C"))
3746 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
3747 "intrinsic-type-spec at %C"))
3750 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
3753 ts
->type
= BT_COMPLEX
;
3754 ts
->kind
= gfc_default_double_kind
;
3758 if ((matched_type
&& strcmp ("logical", name
) == 0)
3759 || (!matched_type
&& gfc_match (" logical") == MATCH_YES
))
3761 ts
->type
= BT_LOGICAL
;
3762 ts
->kind
= gfc_default_logical_kind
;
3768 m
= gfc_match_actual_arglist (1, &decl_type_param_list
, true);
3769 if (m
== MATCH_ERROR
)
3772 m
= gfc_match_char (')');
3776 m
= match_record_decl (name
);
3778 if (matched_type
|| m
== MATCH_YES
)
3780 ts
->type
= BT_DERIVED
;
3781 /* We accept record/s/ or type(s) where s is a structure, but we
3782 * don't need all the extra derived-type stuff for structures. */
3783 if (gfc_find_symbol (gfc_dt_upper_string (name
), NULL
, 1, &sym
))
3785 gfc_error ("Type name %qs at %C is ambiguous", name
);
3789 if (sym
&& sym
->attr
.flavor
== FL_DERIVED
3790 && sym
->attr
.pdt_template
3791 && gfc_current_state () != COMP_DERIVED
)
3793 m
= gfc_get_pdt_instance (decl_type_param_list
, &sym
, NULL
);
3796 gcc_assert (!sym
->attr
.pdt_template
&& sym
->attr
.pdt_type
);
3797 ts
->u
.derived
= sym
;
3798 strcpy (name
, gfc_dt_lower_string (sym
->name
));
3801 if (sym
&& sym
->attr
.flavor
== FL_STRUCT
)
3803 ts
->u
.derived
= sym
;
3806 /* Actually a derived type. */
3811 /* Match nested STRUCTURE declarations; only valid within another
3812 structure declaration. */
3813 if (flag_dec_structure
3814 && (gfc_current_state () == COMP_STRUCTURE
3815 || gfc_current_state () == COMP_MAP
))
3817 m
= gfc_match (" structure");
3820 m
= gfc_match_structure_decl ();
3823 /* gfc_new_block is updated by match_structure_decl. */
3824 ts
->type
= BT_DERIVED
;
3825 ts
->u
.derived
= gfc_new_block
;
3829 if (m
== MATCH_ERROR
)
3833 /* Match CLASS declarations. */
3834 m
= gfc_match (" class ( * )");
3835 if (m
== MATCH_ERROR
)
3837 else if (m
== MATCH_YES
)
3841 ts
->type
= BT_CLASS
;
3842 gfc_find_symbol ("STAR", gfc_current_ns
, 1, &upe
);
3845 upe
= gfc_new_symbol ("STAR", gfc_current_ns
);
3846 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "STAR");
3848 gfc_set_sym_referenced (upe
);
3850 upe
->ts
.type
= BT_VOID
;
3851 upe
->attr
.unlimited_polymorphic
= 1;
3852 /* This is essential to force the construction of
3853 unlimited polymorphic component class containers. */
3854 upe
->attr
.zero_comp
= 1;
3855 if (!gfc_add_flavor (&upe
->attr
, FL_DERIVED
, NULL
,
3856 &gfc_current_locus
))
3861 st
= gfc_get_tbp_symtree (&gfc_current_ns
->sym_root
, "STAR");
3865 ts
->u
.derived
= upe
;
3869 m
= gfc_match (" class (");
3872 m
= gfc_match ("%n", name
);
3878 ts
->type
= BT_CLASS
;
3880 if (!gfc_notify_std (GFC_STD_F2003
, "CLASS statement at %C"))
3883 m
= gfc_match_actual_arglist (1, &decl_type_param_list
, true);
3884 if (m
== MATCH_ERROR
)
3887 m
= gfc_match_char (')');
3892 /* Defer association of the derived type until the end of the
3893 specification block. However, if the derived type can be
3894 found, add it to the typespec. */
3895 if (gfc_matching_function
)
3897 ts
->u
.derived
= NULL
;
3898 if (gfc_current_state () != COMP_INTERFACE
3899 && !gfc_find_symbol (name
, NULL
, 1, &sym
) && sym
)
3901 sym
= gfc_find_dt_in_generic (sym
);
3902 ts
->u
.derived
= sym
;
3907 /* Search for the name but allow the components to be defined later. If
3908 type = -1, this typespec has been seen in a function declaration but
3909 the type could not be accessed at that point. The actual derived type is
3910 stored in a symtree with the first letter of the name capitalized; the
3911 symtree with the all lower-case name contains the associated
3912 generic function. */
3913 dt_name
= gfc_dt_upper_string (name
);
3918 gfc_get_ha_symbol (name
, &sym
);
3919 if (sym
->generic
&& gfc_find_symbol (dt_name
, NULL
, 0, &dt_sym
))
3921 gfc_error ("Type name %qs at %C is ambiguous", name
);
3924 if (sym
->generic
&& !dt_sym
)
3925 dt_sym
= gfc_find_dt_in_generic (sym
);
3927 /* Host associated PDTs can get confused with their constructors
3928 because they ar instantiated in the template's namespace. */
3931 if (gfc_find_symbol (dt_name
, NULL
, 1, &dt_sym
))
3933 gfc_error ("Type name %qs at %C is ambiguous", name
);
3936 if (dt_sym
&& !dt_sym
->attr
.pdt_type
)
3940 else if (ts
->kind
== -1)
3942 int iface
= gfc_state_stack
->previous
->state
!= COMP_INTERFACE
3943 || gfc_current_ns
->has_import_set
;
3944 gfc_find_symbol (name
, NULL
, iface
, &sym
);
3945 if (sym
&& sym
->generic
&& gfc_find_symbol (dt_name
, NULL
, 1, &dt_sym
))
3947 gfc_error ("Type name %qs at %C is ambiguous", name
);
3950 if (sym
&& sym
->generic
&& !dt_sym
)
3951 dt_sym
= gfc_find_dt_in_generic (sym
);
3958 if ((sym
->attr
.flavor
!= FL_UNKNOWN
&& sym
->attr
.flavor
!= FL_STRUCT
3959 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.generic
))
3960 || sym
->attr
.subroutine
)
3962 gfc_error ("Type name %qs at %C conflicts with previously declared "
3963 "entity at %L, which has the same name", name
,
3968 if (sym
&& sym
->attr
.flavor
== FL_DERIVED
3969 && sym
->attr
.pdt_template
3970 && gfc_current_state () != COMP_DERIVED
)
3972 m
= gfc_get_pdt_instance (decl_type_param_list
, &sym
, NULL
);
3975 gcc_assert (!sym
->attr
.pdt_template
&& sym
->attr
.pdt_type
);
3976 ts
->u
.derived
= sym
;
3977 strcpy (name
, gfc_dt_lower_string (sym
->name
));
3980 gfc_save_symbol_data (sym
);
3981 gfc_set_sym_referenced (sym
);
3982 if (!sym
->attr
.generic
3983 && !gfc_add_generic (&sym
->attr
, sym
->name
, NULL
))
3986 if (!sym
->attr
.function
3987 && !gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
3990 if (dt_sym
&& dt_sym
->attr
.flavor
== FL_DERIVED
3991 && dt_sym
->attr
.pdt_template
3992 && gfc_current_state () != COMP_DERIVED
)
3994 m
= gfc_get_pdt_instance (decl_type_param_list
, &dt_sym
, NULL
);
3997 gcc_assert (!dt_sym
->attr
.pdt_template
&& dt_sym
->attr
.pdt_type
);
4002 gfc_interface
*intr
, *head
;
4004 /* Use upper case to save the actual derived-type symbol. */
4005 gfc_get_symbol (dt_name
, NULL
, &dt_sym
);
4006 dt_sym
->name
= gfc_get_string ("%s", sym
->name
);
4007 head
= sym
->generic
;
4008 intr
= gfc_get_interface ();
4010 intr
->where
= gfc_current_locus
;
4012 sym
->generic
= intr
;
4013 sym
->attr
.if_source
= IFSRC_DECL
;
4016 gfc_save_symbol_data (dt_sym
);
4018 gfc_set_sym_referenced (dt_sym
);
4020 if (dt_sym
->attr
.flavor
!= FL_DERIVED
&& dt_sym
->attr
.flavor
!= FL_STRUCT
4021 && !gfc_add_flavor (&dt_sym
->attr
, FL_DERIVED
, sym
->name
, NULL
))
4024 ts
->u
.derived
= dt_sym
;
4030 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
4031 "intrinsic-type-spec at %C"))
4034 /* For all types except double, derived and character, look for an
4035 optional kind specifier. MATCH_NO is actually OK at this point. */
4036 if (implicit_flag
== 1)
4038 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
4044 if (gfc_current_form
== FORM_FREE
)
4046 c
= gfc_peek_ascii_char ();
4047 if (!gfc_is_whitespace (c
) && c
!= '*' && c
!= '('
4048 && c
!= ':' && c
!= ',')
4050 if (matched_type
&& c
== ')')
4052 gfc_next_ascii_char ();
4059 m
= gfc_match_kind_spec (ts
, false);
4060 if (m
== MATCH_NO
&& ts
->type
!= BT_CHARACTER
)
4062 m
= gfc_match_old_kind_spec (ts
);
4063 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) == -1)
4067 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
4070 /* Defer association of the KIND expression of function results
4071 until after USE and IMPORT statements. */
4072 if ((gfc_current_state () == COMP_NONE
&& gfc_error_flag_test ())
4073 || gfc_matching_function
)
4077 m
= MATCH_YES
; /* No kind specifier found. */
4083 /* Match an IMPLICIT NONE statement. Actually, this statement is
4084 already matched in parse.c, or we would not end up here in the
4085 first place. So the only thing we need to check, is if there is
4086 trailing garbage. If not, the match is successful. */
4089 gfc_match_implicit_none (void)
4093 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4095 bool external
= false;
4096 locus cur_loc
= gfc_current_locus
;
4098 if (gfc_current_ns
->seen_implicit_none
4099 || gfc_current_ns
->has_implicit_none_export
)
4101 gfc_error ("Duplicate IMPLICIT NONE statement at %C");
4105 gfc_gobble_whitespace ();
4106 c
= gfc_peek_ascii_char ();
4109 (void) gfc_next_ascii_char ();
4110 if (!gfc_notify_std (GFC_STD_F2015
, "IMPORT NONE with spec list at %C"))
4113 gfc_gobble_whitespace ();
4114 if (gfc_peek_ascii_char () == ')')
4116 (void) gfc_next_ascii_char ();
4122 m
= gfc_match (" %n", name
);
4126 if (strcmp (name
, "type") == 0)
4128 else if (strcmp (name
, "external") == 0)
4133 gfc_gobble_whitespace ();
4134 c
= gfc_next_ascii_char ();
4145 if (gfc_match_eos () != MATCH_YES
)
4148 gfc_set_implicit_none (type
, external
, &cur_loc
);
4154 /* Match the letter range(s) of an IMPLICIT statement. */
4157 match_implicit_range (void)
4163 cur_loc
= gfc_current_locus
;
4165 gfc_gobble_whitespace ();
4166 c
= gfc_next_ascii_char ();
4169 gfc_error ("Missing character range in IMPLICIT at %C");
4176 gfc_gobble_whitespace ();
4177 c1
= gfc_next_ascii_char ();
4181 gfc_gobble_whitespace ();
4182 c
= gfc_next_ascii_char ();
4187 inner
= 0; /* Fall through. */
4194 gfc_gobble_whitespace ();
4195 c2
= gfc_next_ascii_char ();
4199 gfc_gobble_whitespace ();
4200 c
= gfc_next_ascii_char ();
4202 if ((c
!= ',') && (c
!= ')'))
4215 gfc_error ("Letters must be in alphabetic order in "
4216 "IMPLICIT statement at %C");
4220 /* See if we can add the newly matched range to the pending
4221 implicits from this IMPLICIT statement. We do not check for
4222 conflicts with whatever earlier IMPLICIT statements may have
4223 set. This is done when we've successfully finished matching
4225 if (!gfc_add_new_implicit_range (c1
, c2
))
4232 gfc_syntax_error (ST_IMPLICIT
);
4234 gfc_current_locus
= cur_loc
;
4239 /* Match an IMPLICIT statement, storing the types for
4240 gfc_set_implicit() if the statement is accepted by the parser.
4241 There is a strange looking, but legal syntactic construction
4242 possible. It looks like:
4244 IMPLICIT INTEGER (a-b) (c-d)
4246 This is legal if "a-b" is a constant expression that happens to
4247 equal one of the legal kinds for integers. The real problem
4248 happens with an implicit specification that looks like:
4250 IMPLICIT INTEGER (a-b)
4252 In this case, a typespec matcher that is "greedy" (as most of the
4253 matchers are) gobbles the character range as a kindspec, leaving
4254 nothing left. We therefore have to go a bit more slowly in the
4255 matching process by inhibiting the kindspec checking during
4256 typespec matching and checking for a kind later. */
4259 gfc_match_implicit (void)
4266 if (gfc_current_ns
->seen_implicit_none
)
4268 gfc_error ("IMPLICIT statement at %C following an IMPLICIT NONE (type) "
4275 /* We don't allow empty implicit statements. */
4276 if (gfc_match_eos () == MATCH_YES
)
4278 gfc_error ("Empty IMPLICIT statement at %C");
4284 /* First cleanup. */
4285 gfc_clear_new_implicit ();
4287 /* A basic type is mandatory here. */
4288 m
= gfc_match_decl_type_spec (&ts
, 1);
4289 if (m
== MATCH_ERROR
)
4294 cur_loc
= gfc_current_locus
;
4295 m
= match_implicit_range ();
4299 /* We may have <TYPE> (<RANGE>). */
4300 gfc_gobble_whitespace ();
4301 c
= gfc_peek_ascii_char ();
4302 if (c
== ',' || c
== '\n' || c
== ';' || c
== '!')
4304 /* Check for CHARACTER with no length parameter. */
4305 if (ts
.type
== BT_CHARACTER
&& !ts
.u
.cl
)
4307 ts
.kind
= gfc_default_character_kind
;
4308 ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4309 ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
,
4313 /* Record the Successful match. */
4314 if (!gfc_merge_new_implicit (&ts
))
4317 c
= gfc_next_ascii_char ();
4318 else if (gfc_match_eos () == MATCH_ERROR
)
4323 gfc_current_locus
= cur_loc
;
4326 /* Discard the (incorrectly) matched range. */
4327 gfc_clear_new_implicit ();
4329 /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
4330 if (ts
.type
== BT_CHARACTER
)
4331 m
= gfc_match_char_spec (&ts
);
4334 m
= gfc_match_kind_spec (&ts
, false);
4337 m
= gfc_match_old_kind_spec (&ts
);
4338 if (m
== MATCH_ERROR
)
4344 if (m
== MATCH_ERROR
)
4347 m
= match_implicit_range ();
4348 if (m
== MATCH_ERROR
)
4353 gfc_gobble_whitespace ();
4354 c
= gfc_next_ascii_char ();
4355 if (c
!= ',' && gfc_match_eos () != MATCH_YES
)
4358 if (!gfc_merge_new_implicit (&ts
))
4366 gfc_syntax_error (ST_IMPLICIT
);
4374 gfc_match_import (void)
4376 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4381 if (gfc_current_ns
->proc_name
== NULL
4382 || gfc_current_ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
4384 gfc_error ("IMPORT statement at %C only permitted in "
4385 "an INTERFACE body");
4389 if (gfc_current_ns
->proc_name
->attr
.module_procedure
)
4391 gfc_error ("F2008: C1210 IMPORT statement at %C is not permitted "
4392 "in a module procedure interface body");
4396 if (!gfc_notify_std (GFC_STD_F2003
, "IMPORT statement at %C"))
4399 if (gfc_match_eos () == MATCH_YES
)
4401 /* All host variables should be imported. */
4402 gfc_current_ns
->has_import_set
= 1;
4406 if (gfc_match (" ::") == MATCH_YES
)
4408 if (gfc_match_eos () == MATCH_YES
)
4410 gfc_error ("Expecting list of named entities at %C");
4418 m
= gfc_match (" %n", name
);
4422 if (gfc_current_ns
->parent
!= NULL
4423 && gfc_find_symbol (name
, gfc_current_ns
->parent
, 1, &sym
))
4425 gfc_error ("Type name %qs at %C is ambiguous", name
);
4428 else if (!sym
&& gfc_current_ns
->proc_name
->ns
->parent
!= NULL
4429 && gfc_find_symbol (name
,
4430 gfc_current_ns
->proc_name
->ns
->parent
,
4433 gfc_error ("Type name %qs at %C is ambiguous", name
);
4439 gfc_error ("Cannot IMPORT %qs from host scoping unit "
4440 "at %C - does not exist.", name
);
4444 if (gfc_find_symtree (gfc_current_ns
->sym_root
, name
))
4446 gfc_warning (0, "%qs is already IMPORTed from host scoping unit "
4451 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, name
);
4454 sym
->attr
.imported
= 1;
4456 if (sym
->attr
.generic
&& (sym
= gfc_find_dt_in_generic (sym
)))
4458 /* The actual derived type is stored in a symtree with the first
4459 letter of the name capitalized; the symtree with the all
4460 lower-case name contains the associated generic function. */
4461 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
,
4462 gfc_dt_upper_string (name
));
4465 sym
->attr
.imported
= 1;
4478 if (gfc_match_eos () == MATCH_YES
)
4480 if (gfc_match_char (',') != MATCH_YES
)
4487 gfc_error ("Syntax error in IMPORT statement at %C");
4492 /* A minimal implementation of gfc_match without whitespace, escape
4493 characters or variable arguments. Returns true if the next
4494 characters match the TARGET template exactly. */
4497 match_string_p (const char *target
)
4501 for (p
= target
; *p
; p
++)
4502 if ((char) gfc_next_ascii_char () != *p
)
4507 /* Matches an attribute specification including array specs. If
4508 successful, leaves the variables current_attr and current_as
4509 holding the specification. Also sets the colon_seen variable for
4510 later use by matchers associated with initializations.
4512 This subroutine is a little tricky in the sense that we don't know
4513 if we really have an attr-spec until we hit the double colon.
4514 Until that time, we can only return MATCH_NO. This forces us to
4515 check for duplicate specification at this level. */
4518 match_attr_spec (void)
4520 /* Modifiers that can exist in a type statement. */
4522 { GFC_DECL_BEGIN
= 0,
4523 DECL_ALLOCATABLE
= GFC_DECL_BEGIN
, DECL_DIMENSION
, DECL_EXTERNAL
,
4524 DECL_IN
, DECL_OUT
, DECL_INOUT
, DECL_INTRINSIC
, DECL_OPTIONAL
,
4525 DECL_PARAMETER
, DECL_POINTER
, DECL_PROTECTED
, DECL_PRIVATE
,
4526 DECL_STATIC
, DECL_AUTOMATIC
,
4527 DECL_PUBLIC
, DECL_SAVE
, DECL_TARGET
, DECL_VALUE
, DECL_VOLATILE
,
4528 DECL_IS_BIND_C
, DECL_CODIMENSION
, DECL_ASYNCHRONOUS
, DECL_CONTIGUOUS
,
4529 DECL_LEN
, DECL_KIND
, DECL_NONE
, GFC_DECL_END
/* Sentinel */
4532 /* GFC_DECL_END is the sentinel, index starts at 0. */
4533 #define NUM_DECL GFC_DECL_END
4535 locus start
, seen_at
[NUM_DECL
];
4542 gfc_clear_attr (¤t_attr
);
4543 start
= gfc_current_locus
;
4549 /* See if we get all of the keywords up to the final double colon. */
4550 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
4558 gfc_gobble_whitespace ();
4560 ch
= gfc_next_ascii_char ();
4563 /* This is the successful exit condition for the loop. */
4564 if (gfc_next_ascii_char () == ':')
4569 gfc_gobble_whitespace ();
4570 switch (gfc_peek_ascii_char ())
4573 gfc_next_ascii_char ();
4574 switch (gfc_next_ascii_char ())
4577 if (match_string_p ("locatable"))
4579 /* Matched "allocatable". */
4580 d
= DECL_ALLOCATABLE
;
4585 if (match_string_p ("ynchronous"))
4587 /* Matched "asynchronous". */
4588 d
= DECL_ASYNCHRONOUS
;
4593 if (match_string_p ("tomatic"))
4595 /* Matched "automatic". */
4603 /* Try and match the bind(c). */
4604 m
= gfc_match_bind_c (NULL
, true);
4607 else if (m
== MATCH_ERROR
)
4612 gfc_next_ascii_char ();
4613 if ('o' != gfc_next_ascii_char ())
4615 switch (gfc_next_ascii_char ())
4618 if (match_string_p ("imension"))
4620 d
= DECL_CODIMENSION
;
4625 if (match_string_p ("tiguous"))
4627 d
= DECL_CONTIGUOUS
;
4634 if (match_string_p ("dimension"))
4639 if (match_string_p ("external"))
4644 if (match_string_p ("int"))
4646 ch
= gfc_next_ascii_char ();
4649 if (match_string_p ("nt"))
4651 /* Matched "intent". */
4652 /* TODO: Call match_intent_spec from here. */
4653 if (gfc_match (" ( in out )") == MATCH_YES
)
4655 else if (gfc_match (" ( in )") == MATCH_YES
)
4657 else if (gfc_match (" ( out )") == MATCH_YES
)
4663 if (match_string_p ("insic"))
4665 /* Matched "intrinsic". */
4673 if (match_string_p ("kind"))
4678 if (match_string_p ("len"))
4683 if (match_string_p ("optional"))
4688 gfc_next_ascii_char ();
4689 switch (gfc_next_ascii_char ())
4692 if (match_string_p ("rameter"))
4694 /* Matched "parameter". */
4700 if (match_string_p ("inter"))
4702 /* Matched "pointer". */
4708 ch
= gfc_next_ascii_char ();
4711 if (match_string_p ("vate"))
4713 /* Matched "private". */
4719 if (match_string_p ("tected"))
4721 /* Matched "protected". */
4728 if (match_string_p ("blic"))
4730 /* Matched "public". */
4738 gfc_next_ascii_char ();
4739 switch (gfc_next_ascii_char ())
4742 if (match_string_p ("ve"))
4744 /* Matched "save". */
4750 if (match_string_p ("atic"))
4752 /* Matched "static". */
4760 if (match_string_p ("target"))
4765 gfc_next_ascii_char ();
4766 ch
= gfc_next_ascii_char ();
4769 if (match_string_p ("lue"))
4771 /* Matched "value". */
4777 if (match_string_p ("latile"))
4779 /* Matched "volatile". */
4787 /* No double colon and no recognizable decl_type, so assume that
4788 we've been looking at something else the whole time. */
4795 /* Check to make sure any parens are paired up correctly. */
4796 if (gfc_match_parens () == MATCH_ERROR
)
4803 seen_at
[d
] = gfc_current_locus
;
4805 if (d
== DECL_DIMENSION
|| d
== DECL_CODIMENSION
)
4807 gfc_array_spec
*as
= NULL
;
4809 m
= gfc_match_array_spec (&as
, d
== DECL_DIMENSION
,
4810 d
== DECL_CODIMENSION
);
4812 if (current_as
== NULL
)
4814 else if (m
== MATCH_YES
)
4816 if (!merge_array_spec (as
, current_as
, false))
4823 if (d
== DECL_CODIMENSION
)
4824 gfc_error ("Missing codimension specification at %C");
4826 gfc_error ("Missing dimension specification at %C");
4830 if (m
== MATCH_ERROR
)
4835 /* Since we've seen a double colon, we have to be looking at an
4836 attr-spec. This means that we can now issue errors. */
4837 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
4842 case DECL_ALLOCATABLE
:
4843 attr
= "ALLOCATABLE";
4845 case DECL_ASYNCHRONOUS
:
4846 attr
= "ASYNCHRONOUS";
4848 case DECL_CODIMENSION
:
4849 attr
= "CODIMENSION";
4851 case DECL_CONTIGUOUS
:
4852 attr
= "CONTIGUOUS";
4854 case DECL_DIMENSION
:
4861 attr
= "INTENT (IN)";
4864 attr
= "INTENT (OUT)";
4867 attr
= "INTENT (IN OUT)";
4869 case DECL_INTRINSIC
:
4881 case DECL_PARAMETER
:
4887 case DECL_PROTECTED
:
4902 case DECL_AUTOMATIC
:
4908 case DECL_IS_BIND_C
:
4918 attr
= NULL
; /* This shouldn't happen. */
4921 gfc_error ("Duplicate %s attribute at %L", attr
, &seen_at
[d
]);
4926 /* Now that we've dealt with duplicate attributes, add the attributes
4927 to the current attribute. */
4928 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
4935 if ((d
== DECL_STATIC
|| d
== DECL_AUTOMATIC
)
4936 && !flag_dec_static
)
4938 gfc_error ("%s at %L is a DEC extension, enable with "
4940 d
== DECL_STATIC
? "STATIC" : "AUTOMATIC", &seen_at
[d
]);
4944 /* Allow SAVE with STATIC, but don't complain. */
4945 if (d
== DECL_STATIC
&& seen
[DECL_SAVE
])
4948 if (gfc_current_state () == COMP_DERIVED
4949 && d
!= DECL_DIMENSION
&& d
!= DECL_CODIMENSION
4950 && d
!= DECL_POINTER
&& d
!= DECL_PRIVATE
4951 && d
!= DECL_PUBLIC
&& d
!= DECL_CONTIGUOUS
&& d
!= DECL_NONE
)
4953 if (d
== DECL_ALLOCATABLE
)
4955 if (!gfc_notify_std (GFC_STD_F2003
, "ALLOCATABLE "
4956 "attribute at %C in a TYPE definition"))
4962 else if (d
== DECL_KIND
)
4964 if (!gfc_notify_std (GFC_STD_F2003
, "KIND "
4965 "attribute at %C in a TYPE definition"))
4970 if (current_ts
.type
!= BT_INTEGER
)
4972 gfc_error ("Component with KIND attribute at %C must be "
4977 if (current_ts
.kind
!= gfc_default_integer_kind
)
4979 gfc_error ("Component with KIND attribute at %C must be "
4980 "default integer kind (%d)",
4981 gfc_default_integer_kind
);
4986 else if (d
== DECL_LEN
)
4988 if (!gfc_notify_std (GFC_STD_F2003
, "LEN "
4989 "attribute at %C in a TYPE definition"))
4994 if (current_ts
.type
!= BT_INTEGER
)
4996 gfc_error ("Component with LEN attribute at %C must be "
5001 if (current_ts
.kind
!= gfc_default_integer_kind
)
5003 gfc_error ("Component with LEN attribute at %C must be "
5004 "default integer kind (%d)",
5005 gfc_default_integer_kind
);
5012 gfc_error ("Attribute at %L is not allowed in a TYPE definition",
5019 if ((d
== DECL_PRIVATE
|| d
== DECL_PUBLIC
)
5020 && gfc_current_state () != COMP_MODULE
)
5022 if (d
== DECL_PRIVATE
)
5026 if (gfc_current_state () == COMP_DERIVED
5027 && gfc_state_stack
->previous
5028 && gfc_state_stack
->previous
->state
== COMP_MODULE
)
5030 if (!gfc_notify_std (GFC_STD_F2003
, "Attribute %s "
5031 "at %L in a TYPE definition", attr
,
5040 gfc_error ("%s attribute at %L is not allowed outside of the "
5041 "specification part of a module", attr
, &seen_at
[d
]);
5047 if (gfc_current_state () != COMP_DERIVED
5048 && (d
== DECL_KIND
|| d
== DECL_LEN
))
5050 gfc_error ("Attribute at %L is not allowed outside a TYPE "
5051 "definition", &seen_at
[d
]);
5058 case DECL_ALLOCATABLE
:
5059 t
= gfc_add_allocatable (¤t_attr
, &seen_at
[d
]);
5062 case DECL_ASYNCHRONOUS
:
5063 if (!gfc_notify_std (GFC_STD_F2003
, "ASYNCHRONOUS attribute at %C"))
5066 t
= gfc_add_asynchronous (¤t_attr
, NULL
, &seen_at
[d
]);
5069 case DECL_CODIMENSION
:
5070 t
= gfc_add_codimension (¤t_attr
, NULL
, &seen_at
[d
]);
5073 case DECL_CONTIGUOUS
:
5074 if (!gfc_notify_std (GFC_STD_F2008
, "CONTIGUOUS attribute at %C"))
5077 t
= gfc_add_contiguous (¤t_attr
, NULL
, &seen_at
[d
]);
5080 case DECL_DIMENSION
:
5081 t
= gfc_add_dimension (¤t_attr
, NULL
, &seen_at
[d
]);
5085 t
= gfc_add_external (¤t_attr
, &seen_at
[d
]);
5089 t
= gfc_add_intent (¤t_attr
, INTENT_IN
, &seen_at
[d
]);
5093 t
= gfc_add_intent (¤t_attr
, INTENT_OUT
, &seen_at
[d
]);
5097 t
= gfc_add_intent (¤t_attr
, INTENT_INOUT
, &seen_at
[d
]);
5100 case DECL_INTRINSIC
:
5101 t
= gfc_add_intrinsic (¤t_attr
, &seen_at
[d
]);
5105 t
= gfc_add_optional (¤t_attr
, &seen_at
[d
]);
5109 t
= gfc_add_kind (¤t_attr
, &seen_at
[d
]);
5113 t
= gfc_add_len (¤t_attr
, &seen_at
[d
]);
5116 case DECL_PARAMETER
:
5117 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, &seen_at
[d
]);
5121 t
= gfc_add_pointer (¤t_attr
, &seen_at
[d
]);
5124 case DECL_PROTECTED
:
5125 if (gfc_current_state () != COMP_MODULE
5126 || (gfc_current_ns
->proc_name
5127 && gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
))
5129 gfc_error ("PROTECTED at %C only allowed in specification "
5130 "part of a module");
5135 if (!gfc_notify_std (GFC_STD_F2003
, "PROTECTED attribute at %C"))
5138 t
= gfc_add_protected (¤t_attr
, NULL
, &seen_at
[d
]);
5142 t
= gfc_add_access (¤t_attr
, ACCESS_PRIVATE
, NULL
,
5147 t
= gfc_add_access (¤t_attr
, ACCESS_PUBLIC
, NULL
,
5153 t
= gfc_add_save (¤t_attr
, SAVE_EXPLICIT
, NULL
, &seen_at
[d
]);
5156 case DECL_AUTOMATIC
:
5157 t
= gfc_add_automatic (¤t_attr
, NULL
, &seen_at
[d
]);
5161 t
= gfc_add_target (¤t_attr
, &seen_at
[d
]);
5164 case DECL_IS_BIND_C
:
5165 t
= gfc_add_is_bind_c(¤t_attr
, NULL
, &seen_at
[d
], 0);
5169 if (!gfc_notify_std (GFC_STD_F2003
, "VALUE attribute at %C"))
5172 t
= gfc_add_value (¤t_attr
, NULL
, &seen_at
[d
]);
5176 if (!gfc_notify_std (GFC_STD_F2003
, "VOLATILE attribute at %C"))
5179 t
= gfc_add_volatile (¤t_attr
, NULL
, &seen_at
[d
]);
5183 gfc_internal_error ("match_attr_spec(): Bad attribute");
5193 /* Since Fortran 2008 module variables implicitly have the SAVE attribute. */
5194 if ((gfc_current_state () == COMP_MODULE
5195 || gfc_current_state () == COMP_SUBMODULE
)
5196 && !current_attr
.save
5197 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
5198 current_attr
.save
= SAVE_IMPLICIT
;
5204 gfc_current_locus
= start
;
5205 gfc_free_array_spec (current_as
);
5212 /* Set the binding label, dest_label, either with the binding label
5213 stored in the given gfc_typespec, ts, or if none was provided, it
5214 will be the symbol name in all lower case, as required by the draft
5215 (J3/04-007, section 15.4.1). If a binding label was given and
5216 there is more than one argument (num_idents), it is an error. */
5219 set_binding_label (const char **dest_label
, const char *sym_name
,
5222 if (num_idents
> 1 && has_name_equals
)
5224 gfc_error ("Multiple identifiers provided with "
5225 "single NAME= specifier at %C");
5229 if (curr_binding_label
)
5230 /* Binding label given; store in temp holder till have sym. */
5231 *dest_label
= curr_binding_label
;
5234 /* No binding label given, and the NAME= specifier did not exist,
5235 which means there was no NAME="". */
5236 if (sym_name
!= NULL
&& has_name_equals
== 0)
5237 *dest_label
= IDENTIFIER_POINTER (get_identifier (sym_name
));
5244 /* Set the status of the given common block as being BIND(C) or not,
5245 depending on the given parameter, is_bind_c. */
5248 set_com_block_bind_c (gfc_common_head
*com_block
, int is_bind_c
)
5250 com_block
->is_bind_c
= is_bind_c
;
5255 /* Verify that the given gfc_typespec is for a C interoperable type. */
5258 gfc_verify_c_interop (gfc_typespec
*ts
)
5260 if (ts
->type
== BT_DERIVED
&& ts
->u
.derived
!= NULL
)
5261 return (ts
->u
.derived
->ts
.is_c_interop
|| ts
->u
.derived
->attr
.is_bind_c
)
5263 else if (ts
->type
== BT_CLASS
)
5265 else if (ts
->is_c_interop
!= 1 && ts
->type
!= BT_ASSUMED
)
5272 /* Verify that the variables of a given common block, which has been
5273 defined with the attribute specifier bind(c), to be of a C
5274 interoperable type. Errors will be reported here, if
5278 verify_com_block_vars_c_interop (gfc_common_head
*com_block
)
5280 gfc_symbol
*curr_sym
= NULL
;
5283 curr_sym
= com_block
->head
;
5285 /* Make sure we have at least one symbol. */
5286 if (curr_sym
== NULL
)
5289 /* Here we know we have a symbol, so we'll execute this loop
5293 /* The second to last param, 1, says this is in a common block. */
5294 retval
= verify_bind_c_sym (curr_sym
, &(curr_sym
->ts
), 1, com_block
);
5295 curr_sym
= curr_sym
->common_next
;
5296 } while (curr_sym
!= NULL
);
5302 /* Verify that a given BIND(C) symbol is C interoperable. If it is not,
5303 an appropriate error message is reported. */
5306 verify_bind_c_sym (gfc_symbol
*tmp_sym
, gfc_typespec
*ts
,
5307 int is_in_common
, gfc_common_head
*com_block
)
5309 bool bind_c_function
= false;
5312 if (tmp_sym
->attr
.function
&& tmp_sym
->attr
.is_bind_c
)
5313 bind_c_function
= true;
5315 if (tmp_sym
->attr
.function
&& tmp_sym
->result
!= NULL
)
5317 tmp_sym
= tmp_sym
->result
;
5318 /* Make sure it wasn't an implicitly typed result. */
5319 if (tmp_sym
->attr
.implicit_type
&& warn_c_binding_type
)
5321 gfc_warning (OPT_Wc_binding_type
,
5322 "Implicitly declared BIND(C) function %qs at "
5323 "%L may not be C interoperable", tmp_sym
->name
,
5324 &tmp_sym
->declared_at
);
5325 tmp_sym
->ts
.f90_type
= tmp_sym
->ts
.type
;
5326 /* Mark it as C interoperable to prevent duplicate warnings. */
5327 tmp_sym
->ts
.is_c_interop
= 1;
5328 tmp_sym
->attr
.is_c_interop
= 1;
5332 /* Here, we know we have the bind(c) attribute, so if we have
5333 enough type info, then verify that it's a C interop kind.
5334 The info could be in the symbol already, or possibly still in
5335 the given ts (current_ts), so look in both. */
5336 if (tmp_sym
->ts
.type
!= BT_UNKNOWN
|| ts
->type
!= BT_UNKNOWN
)
5338 if (!gfc_verify_c_interop (&(tmp_sym
->ts
)))
5340 /* See if we're dealing with a sym in a common block or not. */
5341 if (is_in_common
== 1 && warn_c_binding_type
)
5343 gfc_warning (OPT_Wc_binding_type
,
5344 "Variable %qs in common block %qs at %L "
5345 "may not be a C interoperable "
5346 "kind though common block %qs is BIND(C)",
5347 tmp_sym
->name
, com_block
->name
,
5348 &(tmp_sym
->declared_at
), com_block
->name
);
5352 if (tmp_sym
->ts
.type
== BT_DERIVED
|| ts
->type
== BT_DERIVED
)
5353 gfc_error ("Type declaration %qs at %L is not C "
5354 "interoperable but it is BIND(C)",
5355 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5356 else if (warn_c_binding_type
)
5357 gfc_warning (OPT_Wc_binding_type
, "Variable %qs at %L "
5358 "may not be a C interoperable "
5359 "kind but it is BIND(C)",
5360 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5364 /* Variables declared w/in a common block can't be bind(c)
5365 since there's no way for C to see these variables, so there's
5366 semantically no reason for the attribute. */
5367 if (is_in_common
== 1 && tmp_sym
->attr
.is_bind_c
== 1)
5369 gfc_error ("Variable %qs in common block %qs at "
5370 "%L cannot be declared with BIND(C) "
5371 "since it is not a global",
5372 tmp_sym
->name
, com_block
->name
,
5373 &(tmp_sym
->declared_at
));
5377 /* Scalar variables that are bind(c) can not have the pointer
5378 or allocatable attributes. */
5379 if (tmp_sym
->attr
.is_bind_c
== 1)
5381 if (tmp_sym
->attr
.pointer
== 1)
5383 gfc_error ("Variable %qs at %L cannot have both the "
5384 "POINTER and BIND(C) attributes",
5385 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5389 if (tmp_sym
->attr
.allocatable
== 1)
5391 gfc_error ("Variable %qs at %L cannot have both the "
5392 "ALLOCATABLE and BIND(C) attributes",
5393 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5399 /* If it is a BIND(C) function, make sure the return value is a
5400 scalar value. The previous tests in this function made sure
5401 the type is interoperable. */
5402 if (bind_c_function
&& tmp_sym
->as
!= NULL
)
5403 gfc_error ("Return type of BIND(C) function %qs at %L cannot "
5404 "be an array", tmp_sym
->name
, &(tmp_sym
->declared_at
));
5406 /* BIND(C) functions can not return a character string. */
5407 if (bind_c_function
&& tmp_sym
->ts
.type
== BT_CHARACTER
)
5408 if (tmp_sym
->ts
.u
.cl
== NULL
|| tmp_sym
->ts
.u
.cl
->length
== NULL
5409 || tmp_sym
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
5410 || mpz_cmp_si (tmp_sym
->ts
.u
.cl
->length
->value
.integer
, 1) != 0)
5411 gfc_error ("Return type of BIND(C) function %qs at %L cannot "
5412 "be a character string", tmp_sym
->name
,
5413 &(tmp_sym
->declared_at
));
5416 /* See if the symbol has been marked as private. If it has, make sure
5417 there is no binding label and warn the user if there is one. */
5418 if (tmp_sym
->attr
.access
== ACCESS_PRIVATE
5419 && tmp_sym
->binding_label
)
5420 /* Use gfc_warning_now because we won't say that the symbol fails
5421 just because of this. */
5422 gfc_warning_now (0, "Symbol %qs at %L is marked PRIVATE but has been "
5423 "given the binding label %qs", tmp_sym
->name
,
5424 &(tmp_sym
->declared_at
), tmp_sym
->binding_label
);
5430 /* Set the appropriate fields for a symbol that's been declared as
5431 BIND(C) (the is_bind_c flag and the binding label), and verify that
5432 the type is C interoperable. Errors are reported by the functions
5433 used to set/test these fields. */
5436 set_verify_bind_c_sym (gfc_symbol
*tmp_sym
, int num_idents
)
5440 /* TODO: Do we need to make sure the vars aren't marked private? */
5442 /* Set the is_bind_c bit in symbol_attribute. */
5443 gfc_add_is_bind_c (&(tmp_sym
->attr
), tmp_sym
->name
, &gfc_current_locus
, 0);
5445 if (!set_binding_label (&tmp_sym
->binding_label
, tmp_sym
->name
, num_idents
))
5452 /* Set the fields marking the given common block as BIND(C), including
5453 a binding label, and report any errors encountered. */
5456 set_verify_bind_c_com_block (gfc_common_head
*com_block
, int num_idents
)
5460 /* destLabel, common name, typespec (which may have binding label). */
5461 if (!set_binding_label (&com_block
->binding_label
, com_block
->name
,
5465 /* Set the given common block (com_block) to being bind(c) (1). */
5466 set_com_block_bind_c (com_block
, 1);
5472 /* Retrieve the list of one or more identifiers that the given bind(c)
5473 attribute applies to. */
5476 get_bind_c_idents (void)
5478 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5480 gfc_symbol
*tmp_sym
= NULL
;
5482 gfc_common_head
*com_block
= NULL
;
5484 if (gfc_match_name (name
) == MATCH_YES
)
5486 found_id
= MATCH_YES
;
5487 gfc_get_ha_symbol (name
, &tmp_sym
);
5489 else if (match_common_name (name
) == MATCH_YES
)
5491 found_id
= MATCH_YES
;
5492 com_block
= gfc_get_common (name
, 0);
5496 gfc_error ("Need either entity or common block name for "
5497 "attribute specification statement at %C");
5501 /* Save the current identifier and look for more. */
5504 /* Increment the number of identifiers found for this spec stmt. */
5507 /* Make sure we have a sym or com block, and verify that it can
5508 be bind(c). Set the appropriate field(s) and look for more
5510 if (tmp_sym
!= NULL
|| com_block
!= NULL
)
5512 if (tmp_sym
!= NULL
)
5514 if (!set_verify_bind_c_sym (tmp_sym
, num_idents
))
5519 if (!set_verify_bind_c_com_block (com_block
, num_idents
))
5523 /* Look to see if we have another identifier. */
5525 if (gfc_match_eos () == MATCH_YES
)
5526 found_id
= MATCH_NO
;
5527 else if (gfc_match_char (',') != MATCH_YES
)
5528 found_id
= MATCH_NO
;
5529 else if (gfc_match_name (name
) == MATCH_YES
)
5531 found_id
= MATCH_YES
;
5532 gfc_get_ha_symbol (name
, &tmp_sym
);
5534 else if (match_common_name (name
) == MATCH_YES
)
5536 found_id
= MATCH_YES
;
5537 com_block
= gfc_get_common (name
, 0);
5541 gfc_error ("Missing entity or common block name for "
5542 "attribute specification statement at %C");
5548 gfc_internal_error ("Missing symbol");
5550 } while (found_id
== MATCH_YES
);
5552 /* if we get here we were successful */
5557 /* Try and match a BIND(C) attribute specification statement. */
5560 gfc_match_bind_c_stmt (void)
5562 match found_match
= MATCH_NO
;
5567 /* This may not be necessary. */
5569 /* Clear the temporary binding label holder. */
5570 curr_binding_label
= NULL
;
5572 /* Look for the bind(c). */
5573 found_match
= gfc_match_bind_c (NULL
, true);
5575 if (found_match
== MATCH_YES
)
5577 if (!gfc_notify_std (GFC_STD_F2003
, "BIND(C) statement at %C"))
5580 /* Look for the :: now, but it is not required. */
5583 /* Get the identifier(s) that needs to be updated. This may need to
5584 change to hand the flag(s) for the attr specified so all identifiers
5585 found can have all appropriate parts updated (assuming that the same
5586 spec stmt can have multiple attrs, such as both bind(c) and
5588 if (!get_bind_c_idents ())
5589 /* Error message should have printed already. */
5597 /* Match a data declaration statement. */
5600 gfc_match_data_decl (void)
5606 type_param_spec_list
= NULL
;
5607 decl_type_param_list
= NULL
;
5609 num_idents_on_line
= 0;
5611 m
= gfc_match_decl_type_spec (¤t_ts
, 0);
5615 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
5616 && !gfc_comp_struct (gfc_current_state ()))
5618 sym
= gfc_use_derived (current_ts
.u
.derived
);
5626 current_ts
.u
.derived
= sym
;
5629 m
= match_attr_spec ();
5630 if (m
== MATCH_ERROR
)
5636 if (current_ts
.type
== BT_CLASS
5637 && current_ts
.u
.derived
->attr
.unlimited_polymorphic
)
5640 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
5641 && current_ts
.u
.derived
->components
== NULL
5642 && !current_ts
.u
.derived
->attr
.zero_comp
)
5645 if (current_attr
.pointer
&& gfc_comp_struct (gfc_current_state ()))
5648 if (current_attr
.allocatable
&& gfc_current_state () == COMP_DERIVED
5649 && current_ts
.u
.derived
== gfc_current_block ())
5652 gfc_find_symbol (current_ts
.u
.derived
->name
,
5653 current_ts
.u
.derived
->ns
, 1, &sym
);
5655 /* Any symbol that we find had better be a type definition
5656 which has its components defined, or be a structure definition
5657 actively being parsed. */
5658 if (sym
!= NULL
&& gfc_fl_struct (sym
->attr
.flavor
)
5659 && (current_ts
.u
.derived
->components
!= NULL
5660 || current_ts
.u
.derived
->attr
.zero_comp
5661 || current_ts
.u
.derived
== gfc_new_block
))
5664 gfc_error ("Derived type at %C has not been previously defined "
5665 "and so cannot appear in a derived type definition");
5671 /* If we have an old-style character declaration, and no new-style
5672 attribute specifications, then there a comma is optional between
5673 the type specification and the variable list. */
5674 if (m
== MATCH_NO
&& current_ts
.type
== BT_CHARACTER
&& old_char_selector
)
5675 gfc_match_char (',');
5677 /* Give the types/attributes to symbols that follow. Give the element
5678 a number so that repeat character length expressions can be copied. */
5682 num_idents_on_line
++;
5683 m
= variable_decl (elem
++);
5684 if (m
== MATCH_ERROR
)
5689 if (gfc_match_eos () == MATCH_YES
)
5691 if (gfc_match_char (',') != MATCH_YES
)
5695 if (!gfc_error_flag_test ())
5697 /* An anonymous structure declaration is unambiguous; if we matched one
5698 according to gfc_match_structure_decl, we need to return MATCH_YES
5699 here to avoid confusing the remaining matchers, even if there was an
5700 error during variable_decl. We must flush any such errors. Note this
5701 causes the parser to gracefully continue parsing the remaining input
5702 as a structure body, which likely follows. */
5703 if (current_ts
.type
== BT_DERIVED
&& current_ts
.u
.derived
5704 && gfc_fl_struct (current_ts
.u
.derived
->attr
.flavor
))
5706 gfc_error_now ("Syntax error in anonymous structure declaration"
5708 /* Skip the bad variable_decl and line up for the start of the
5710 gfc_error_recovery ();
5715 gfc_error ("Syntax error in data declaration at %C");
5720 gfc_free_data_all (gfc_current_ns
);
5723 if (saved_kind_expr
)
5724 gfc_free_expr (saved_kind_expr
);
5725 if (type_param_spec_list
)
5726 gfc_free_actual_arglist (type_param_spec_list
);
5727 if (decl_type_param_list
)
5728 gfc_free_actual_arglist (decl_type_param_list
);
5729 saved_kind_expr
= NULL
;
5730 gfc_free_array_spec (current_as
);
5736 /* Match a prefix associated with a function or subroutine
5737 declaration. If the typespec pointer is nonnull, then a typespec
5738 can be matched. Note that if nothing matches, MATCH_YES is
5739 returned (the null string was matched). */
5742 gfc_match_prefix (gfc_typespec
*ts
)
5748 gfc_clear_attr (¤t_attr
);
5750 seen_impure
= false;
5752 gcc_assert (!gfc_matching_prefix
);
5753 gfc_matching_prefix
= true;
5757 found_prefix
= false;
5759 /* MODULE is a prefix like PURE, ELEMENTAL, etc., having a
5760 corresponding attribute seems natural and distinguishes these
5761 procedures from procedure types of PROC_MODULE, which these are
5763 if (gfc_match ("module% ") == MATCH_YES
)
5765 if (!gfc_notify_std (GFC_STD_F2008
, "MODULE prefix at %C"))
5768 current_attr
.module_procedure
= 1;
5769 found_prefix
= true;
5772 if (!seen_type
&& ts
!= NULL
5773 && gfc_match_decl_type_spec (ts
, 0) == MATCH_YES
5774 && gfc_match_space () == MATCH_YES
)
5778 found_prefix
= true;
5781 if (gfc_match ("elemental% ") == MATCH_YES
)
5783 if (!gfc_add_elemental (¤t_attr
, NULL
))
5786 found_prefix
= true;
5789 if (gfc_match ("pure% ") == MATCH_YES
)
5791 if (!gfc_add_pure (¤t_attr
, NULL
))
5794 found_prefix
= true;
5797 if (gfc_match ("recursive% ") == MATCH_YES
)
5799 if (!gfc_add_recursive (¤t_attr
, NULL
))
5802 found_prefix
= true;
5805 /* IMPURE is a somewhat special case, as it needs not set an actual
5806 attribute but rather only prevents ELEMENTAL routines from being
5807 automatically PURE. */
5808 if (gfc_match ("impure% ") == MATCH_YES
)
5810 if (!gfc_notify_std (GFC_STD_F2008
, "IMPURE procedure at %C"))
5814 found_prefix
= true;
5817 while (found_prefix
);
5819 /* IMPURE and PURE must not both appear, of course. */
5820 if (seen_impure
&& current_attr
.pure
)
5822 gfc_error ("PURE and IMPURE must not appear both at %C");
5826 /* If IMPURE it not seen but the procedure is ELEMENTAL, mark it as PURE. */
5827 if (!seen_impure
&& current_attr
.elemental
&& !current_attr
.pure
)
5829 if (!gfc_add_pure (¤t_attr
, NULL
))
5833 /* At this point, the next item is not a prefix. */
5834 gcc_assert (gfc_matching_prefix
);
5836 gfc_matching_prefix
= false;
5840 gcc_assert (gfc_matching_prefix
);
5841 gfc_matching_prefix
= false;
5846 /* Copy attributes matched by gfc_match_prefix() to attributes on a symbol. */
5849 copy_prefix (symbol_attribute
*dest
, locus
*where
)
5851 if (dest
->module_procedure
)
5853 if (current_attr
.elemental
)
5854 dest
->elemental
= 1;
5856 if (current_attr
.pure
)
5859 if (current_attr
.recursive
)
5860 dest
->recursive
= 1;
5862 /* Module procedures are unusual in that the 'dest' is copied from
5863 the interface declaration. However, this is an oportunity to
5864 check that the submodule declaration is compliant with the
5866 if (dest
->elemental
&& !current_attr
.elemental
)
5868 gfc_error ("ELEMENTAL prefix in MODULE PROCEDURE interface is "
5869 "missing at %L", where
);
5873 if (dest
->pure
&& !current_attr
.pure
)
5875 gfc_error ("PURE prefix in MODULE PROCEDURE interface is "
5876 "missing at %L", where
);
5880 if (dest
->recursive
&& !current_attr
.recursive
)
5882 gfc_error ("RECURSIVE prefix in MODULE PROCEDURE interface is "
5883 "missing at %L", where
);
5890 if (current_attr
.elemental
&& !gfc_add_elemental (dest
, where
))
5893 if (current_attr
.pure
&& !gfc_add_pure (dest
, where
))
5896 if (current_attr
.recursive
&& !gfc_add_recursive (dest
, where
))
5903 /* Match a formal argument list or, if typeparam is true, a
5904 type_param_name_list. */
5907 gfc_match_formal_arglist (gfc_symbol
*progname
, int st_flag
,
5908 int null_flag
, bool typeparam
)
5910 gfc_formal_arglist
*head
, *tail
, *p
, *q
;
5911 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5914 gfc_formal_arglist
*formal
= NULL
;
5918 /* Keep the interface formal argument list and null it so that the
5919 matching for the new declaration can be done. The numbers and
5920 names of the arguments are checked here. The interface formal
5921 arguments are retained in formal_arglist and the characteristics
5922 are compared in resolve.c(resolve_fl_procedure). See the remark
5923 in get_proc_name about the eventual need to copy the formal_arglist
5924 and populate the formal namespace of the interface symbol. */
5925 if (progname
->attr
.module_procedure
5926 && progname
->attr
.host_assoc
)
5928 formal
= progname
->formal
;
5929 progname
->formal
= NULL
;
5932 if (gfc_match_char ('(') != MATCH_YES
)
5939 if (gfc_match_char (')') == MATCH_YES
)
5944 if (gfc_match_char ('*') == MATCH_YES
)
5947 if (!gfc_notify_std (GFC_STD_F95_OBS
, "Alternate-return argument "
5956 m
= gfc_match_name (name
);
5960 if (!typeparam
&& gfc_get_symbol (name
, NULL
, &sym
))
5963 && gfc_get_symbol (name
, progname
->f2k_derived
, &sym
))
5967 p
= gfc_get_formal_arglist ();
5979 /* We don't add the VARIABLE flavor because the name could be a
5980 dummy procedure. We don't apply these attributes to formal
5981 arguments of statement functions. */
5982 if (sym
!= NULL
&& !st_flag
5983 && (!gfc_add_dummy(&sym
->attr
, sym
->name
, NULL
)
5984 || !gfc_missing_attr (&sym
->attr
, NULL
)))
5990 /* The name of a program unit can be in a different namespace,
5991 so check for it explicitly. After the statement is accepted,
5992 the name is checked for especially in gfc_get_symbol(). */
5993 if (gfc_new_block
!= NULL
&& sym
!= NULL
&& !typeparam
5994 && strcmp (sym
->name
, gfc_new_block
->name
) == 0)
5996 gfc_error ("Name %qs at %C is the name of the procedure",
6002 if (gfc_match_char (')') == MATCH_YES
)
6005 m
= gfc_match_char (',');
6009 gfc_error_now ("Expected parameter list in type declaration "
6012 gfc_error ("Unexpected junk in formal argument list at %C");
6018 /* Check for duplicate symbols in the formal argument list. */
6021 for (p
= head
; p
->next
; p
= p
->next
)
6026 for (q
= p
->next
; q
; q
= q
->next
)
6027 if (p
->sym
== q
->sym
)
6030 gfc_error_now ("Duplicate name %qs in parameter "
6031 "list at %C", p
->sym
->name
);
6033 gfc_error ("Duplicate symbol %qs in formal argument "
6034 "list at %C", p
->sym
->name
);
6042 if (!gfc_add_explicit_interface (progname
, IFSRC_DECL
, head
, NULL
))
6048 /* gfc_error_now used in following and return with MATCH_YES because
6049 doing otherwise results in a cascade of extraneous errors and in
6050 some cases an ICE in symbol.c(gfc_release_symbol). */
6051 if (progname
->attr
.module_procedure
&& progname
->attr
.host_assoc
)
6053 bool arg_count_mismatch
= false;
6055 if (!formal
&& head
)
6056 arg_count_mismatch
= true;
6058 /* Abbreviated module procedure declaration is not meant to have any
6059 formal arguments! */
6060 if (!progname
->abr_modproc_decl
&& formal
&& !head
)
6061 arg_count_mismatch
= true;
6063 for (p
= formal
, q
= head
; p
&& q
; p
= p
->next
, q
= q
->next
)
6065 if ((p
->next
!= NULL
&& q
->next
== NULL
)
6066 || (p
->next
== NULL
&& q
->next
!= NULL
))
6067 arg_count_mismatch
= true;
6068 else if ((p
->sym
== NULL
&& q
->sym
== NULL
)
6069 || strcmp (p
->sym
->name
, q
->sym
->name
) == 0)
6072 gfc_error_now ("Mismatch in MODULE PROCEDURE formal "
6073 "argument names (%s/%s) at %C",
6074 p
->sym
->name
, q
->sym
->name
);
6077 if (arg_count_mismatch
)
6078 gfc_error_now ("Mismatch in number of MODULE PROCEDURE "
6079 "formal arguments at %C");
6085 gfc_free_formal_arglist (head
);
6090 /* Match a RESULT specification following a function declaration or
6091 ENTRY statement. Also matches the end-of-statement. */
6094 match_result (gfc_symbol
*function
, gfc_symbol
**result
)
6096 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6100 if (gfc_match (" result (") != MATCH_YES
)
6103 m
= gfc_match_name (name
);
6107 /* Get the right paren, and that's it because there could be the
6108 bind(c) attribute after the result clause. */
6109 if (gfc_match_char (')') != MATCH_YES
)
6111 /* TODO: should report the missing right paren here. */
6115 if (strcmp (function
->name
, name
) == 0)
6117 gfc_error ("RESULT variable at %C must be different than function name");
6121 if (gfc_get_symbol (name
, NULL
, &r
))
6124 if (!gfc_add_result (&r
->attr
, r
->name
, NULL
))
6133 /* Match a function suffix, which could be a combination of a result
6134 clause and BIND(C), either one, or neither. The draft does not
6135 require them to come in a specific order. */
6138 gfc_match_suffix (gfc_symbol
*sym
, gfc_symbol
**result
)
6140 match is_bind_c
; /* Found bind(c). */
6141 match is_result
; /* Found result clause. */
6142 match found_match
; /* Status of whether we've found a good match. */
6143 char peek_char
; /* Character we're going to peek at. */
6144 bool allow_binding_name
;
6146 /* Initialize to having found nothing. */
6147 found_match
= MATCH_NO
;
6148 is_bind_c
= MATCH_NO
;
6149 is_result
= MATCH_NO
;
6151 /* Get the next char to narrow between result and bind(c). */
6152 gfc_gobble_whitespace ();
6153 peek_char
= gfc_peek_ascii_char ();
6155 /* C binding names are not allowed for internal procedures. */
6156 if (gfc_current_state () == COMP_CONTAINS
6157 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
6158 allow_binding_name
= false;
6160 allow_binding_name
= true;
6165 /* Look for result clause. */
6166 is_result
= match_result (sym
, result
);
6167 if (is_result
== MATCH_YES
)
6169 /* Now see if there is a bind(c) after it. */
6170 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
6171 /* We've found the result clause and possibly bind(c). */
6172 found_match
= MATCH_YES
;
6175 /* This should only be MATCH_ERROR. */
6176 found_match
= is_result
;
6179 /* Look for bind(c) first. */
6180 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
6181 if (is_bind_c
== MATCH_YES
)
6183 /* Now see if a result clause followed it. */
6184 is_result
= match_result (sym
, result
);
6185 found_match
= MATCH_YES
;
6189 /* Should only be a MATCH_ERROR if we get here after seeing 'b'. */
6190 found_match
= MATCH_ERROR
;
6194 gfc_error ("Unexpected junk after function declaration at %C");
6195 found_match
= MATCH_ERROR
;
6199 if (is_bind_c
== MATCH_YES
)
6201 /* Fortran 2008 draft allows BIND(C) for internal procedures. */
6202 if (gfc_current_state () == COMP_CONTAINS
6203 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
6204 && !gfc_notify_std (GFC_STD_F2008
, "BIND(C) attribute "
6205 "at %L may not be specified for an internal "
6206 "procedure", &gfc_current_locus
))
6209 if (!gfc_add_is_bind_c (&(sym
->attr
), sym
->name
, &gfc_current_locus
, 1))
6217 /* Procedure pointer return value without RESULT statement:
6218 Add "hidden" result variable named "ppr@". */
6221 add_hidden_procptr_result (gfc_symbol
*sym
)
6225 if (gfc_notification_std (GFC_STD_F2003
) == ERROR
)
6228 /* First usage case: PROCEDURE and EXTERNAL statements. */
6229 case1
= gfc_current_state () == COMP_FUNCTION
&& gfc_current_block ()
6230 && strcmp (gfc_current_block ()->name
, sym
->name
) == 0
6231 && sym
->attr
.external
;
6232 /* Second usage case: INTERFACE statements. */
6233 case2
= gfc_current_state () == COMP_INTERFACE
&& gfc_state_stack
->previous
6234 && gfc_state_stack
->previous
->state
== COMP_FUNCTION
6235 && strcmp (gfc_state_stack
->previous
->sym
->name
, sym
->name
) == 0;
6241 gfc_get_sym_tree ("ppr@", gfc_current_ns
, &stree
, false);
6245 gfc_get_sym_tree ("ppr@", gfc_current_ns
->parent
, &stree
, false);
6246 st2
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "ppr@");
6247 st2
->n
.sym
= stree
->n
.sym
;
6248 stree
->n
.sym
->refs
++;
6250 sym
->result
= stree
->n
.sym
;
6252 sym
->result
->attr
.proc_pointer
= sym
->attr
.proc_pointer
;
6253 sym
->result
->attr
.pointer
= sym
->attr
.pointer
;
6254 sym
->result
->attr
.external
= sym
->attr
.external
;
6255 sym
->result
->attr
.referenced
= sym
->attr
.referenced
;
6256 sym
->result
->ts
= sym
->ts
;
6257 sym
->attr
.proc_pointer
= 0;
6258 sym
->attr
.pointer
= 0;
6259 sym
->attr
.external
= 0;
6260 if (sym
->result
->attr
.external
&& sym
->result
->attr
.pointer
)
6262 sym
->result
->attr
.pointer
= 0;
6263 sym
->result
->attr
.proc_pointer
= 1;
6266 return gfc_add_result (&sym
->result
->attr
, sym
->result
->name
, NULL
);
6268 /* POINTER after PROCEDURE/EXTERNAL/INTERFACE statement. */
6269 else if (sym
->attr
.function
&& !sym
->attr
.external
&& sym
->attr
.pointer
6270 && sym
->result
&& sym
->result
!= sym
&& sym
->result
->attr
.external
6271 && sym
== gfc_current_ns
->proc_name
6272 && sym
== sym
->result
->ns
->proc_name
6273 && strcmp ("ppr@", sym
->result
->name
) == 0)
6275 sym
->result
->attr
.proc_pointer
= 1;
6276 sym
->attr
.pointer
= 0;
6284 /* Match the interface for a PROCEDURE declaration,
6285 including brackets (R1212). */
6288 match_procedure_interface (gfc_symbol
**proc_if
)
6292 locus old_loc
, entry_loc
;
6293 gfc_namespace
*old_ns
= gfc_current_ns
;
6294 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6296 old_loc
= entry_loc
= gfc_current_locus
;
6297 gfc_clear_ts (¤t_ts
);
6299 if (gfc_match (" (") != MATCH_YES
)
6301 gfc_current_locus
= entry_loc
;
6305 /* Get the type spec. for the procedure interface. */
6306 old_loc
= gfc_current_locus
;
6307 m
= gfc_match_decl_type_spec (¤t_ts
, 0);
6308 gfc_gobble_whitespace ();
6309 if (m
== MATCH_YES
|| (m
== MATCH_NO
&& gfc_peek_ascii_char () == ')'))
6312 if (m
== MATCH_ERROR
)
6315 /* Procedure interface is itself a procedure. */
6316 gfc_current_locus
= old_loc
;
6317 m
= gfc_match_name (name
);
6319 /* First look to see if it is already accessible in the current
6320 namespace because it is use associated or contained. */
6322 if (gfc_find_sym_tree (name
, NULL
, 0, &st
))
6325 /* If it is still not found, then try the parent namespace, if it
6326 exists and create the symbol there if it is still not found. */
6327 if (gfc_current_ns
->parent
)
6328 gfc_current_ns
= gfc_current_ns
->parent
;
6329 if (st
== NULL
&& gfc_get_ha_sym_tree (name
, &st
))
6332 gfc_current_ns
= old_ns
;
6333 *proc_if
= st
->n
.sym
;
6338 /* Resolve interface if possible. That way, attr.procedure is only set
6339 if it is declared by a later procedure-declaration-stmt, which is
6340 invalid per F08:C1216 (cf. resolve_procedure_interface). */
6341 while ((*proc_if
)->ts
.interface
6342 && *proc_if
!= (*proc_if
)->ts
.interface
)
6343 *proc_if
= (*proc_if
)->ts
.interface
;
6345 if ((*proc_if
)->attr
.flavor
== FL_UNKNOWN
6346 && (*proc_if
)->ts
.type
== BT_UNKNOWN
6347 && !gfc_add_flavor (&(*proc_if
)->attr
, FL_PROCEDURE
,
6348 (*proc_if
)->name
, NULL
))
6353 if (gfc_match (" )") != MATCH_YES
)
6355 gfc_current_locus
= entry_loc
;
6363 /* Match a PROCEDURE declaration (R1211). */
6366 match_procedure_decl (void)
6369 gfc_symbol
*sym
, *proc_if
= NULL
;
6371 gfc_expr
*initializer
= NULL
;
6373 /* Parse interface (with brackets). */
6374 m
= match_procedure_interface (&proc_if
);
6378 /* Parse attributes (with colons). */
6379 m
= match_attr_spec();
6380 if (m
== MATCH_ERROR
)
6383 if (proc_if
&& proc_if
->attr
.is_bind_c
&& !current_attr
.is_bind_c
)
6385 current_attr
.is_bind_c
= 1;
6386 has_name_equals
= 0;
6387 curr_binding_label
= NULL
;
6390 /* Get procedure symbols. */
6393 m
= gfc_match_symbol (&sym
, 0);
6396 else if (m
== MATCH_ERROR
)
6399 /* Add current_attr to the symbol attributes. */
6400 if (!gfc_copy_attr (&sym
->attr
, ¤t_attr
, NULL
))
6403 if (sym
->attr
.is_bind_c
)
6405 /* Check for C1218. */
6406 if (!proc_if
|| !proc_if
->attr
.is_bind_c
)
6408 gfc_error ("BIND(C) attribute at %C requires "
6409 "an interface with BIND(C)");
6412 /* Check for C1217. */
6413 if (has_name_equals
&& sym
->attr
.pointer
)
6415 gfc_error ("BIND(C) procedure with NAME may not have "
6416 "POINTER attribute at %C");
6419 if (has_name_equals
&& sym
->attr
.dummy
)
6421 gfc_error ("Dummy procedure at %C may not have "
6422 "BIND(C) attribute with NAME");
6425 /* Set binding label for BIND(C). */
6426 if (!set_binding_label (&sym
->binding_label
, sym
->name
, num
))
6430 if (!gfc_add_external (&sym
->attr
, NULL
))
6433 if (add_hidden_procptr_result (sym
))
6436 if (!gfc_add_proc (&sym
->attr
, sym
->name
, NULL
))
6439 /* Set interface. */
6440 if (proc_if
!= NULL
)
6442 if (sym
->ts
.type
!= BT_UNKNOWN
)
6444 gfc_error ("Procedure %qs at %L already has basic type of %s",
6445 sym
->name
, &gfc_current_locus
,
6446 gfc_basic_typename (sym
->ts
.type
));
6449 sym
->ts
.interface
= proc_if
;
6450 sym
->attr
.untyped
= 1;
6451 sym
->attr
.if_source
= IFSRC_IFBODY
;
6453 else if (current_ts
.type
!= BT_UNKNOWN
)
6455 if (!gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
6457 sym
->ts
.interface
= gfc_new_symbol ("", gfc_current_ns
);
6458 sym
->ts
.interface
->ts
= current_ts
;
6459 sym
->ts
.interface
->attr
.flavor
= FL_PROCEDURE
;
6460 sym
->ts
.interface
->attr
.function
= 1;
6461 sym
->attr
.function
= 1;
6462 sym
->attr
.if_source
= IFSRC_UNKNOWN
;
6465 if (gfc_match (" =>") == MATCH_YES
)
6467 if (!current_attr
.pointer
)
6469 gfc_error ("Initialization at %C isn't for a pointer variable");
6474 m
= match_pointer_init (&initializer
, 1);
6478 if (!add_init_expr_to_sym (sym
->name
, &initializer
, &gfc_current_locus
))
6483 if (gfc_match_eos () == MATCH_YES
)
6485 if (gfc_match_char (',') != MATCH_YES
)
6490 gfc_error ("Syntax error in PROCEDURE statement at %C");
6494 /* Free stuff up and return. */
6495 gfc_free_expr (initializer
);
6501 match_binding_attributes (gfc_typebound_proc
* ba
, bool generic
, bool ppc
);
6504 /* Match a procedure pointer component declaration (R445). */
6507 match_ppc_decl (void)
6510 gfc_symbol
*proc_if
= NULL
;
6514 gfc_expr
*initializer
= NULL
;
6515 gfc_typebound_proc
* tb
;
6516 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6518 /* Parse interface (with brackets). */
6519 m
= match_procedure_interface (&proc_if
);
6523 /* Parse attributes. */
6524 tb
= XCNEW (gfc_typebound_proc
);
6525 tb
->where
= gfc_current_locus
;
6526 m
= match_binding_attributes (tb
, false, true);
6527 if (m
== MATCH_ERROR
)
6530 gfc_clear_attr (¤t_attr
);
6531 current_attr
.procedure
= 1;
6532 current_attr
.proc_pointer
= 1;
6533 current_attr
.access
= tb
->access
;
6534 current_attr
.flavor
= FL_PROCEDURE
;
6536 /* Match the colons (required). */
6537 if (gfc_match (" ::") != MATCH_YES
)
6539 gfc_error ("Expected %<::%> after binding-attributes at %C");
6543 /* Check for C450. */
6544 if (!tb
->nopass
&& proc_if
== NULL
)
6546 gfc_error("NOPASS or explicit interface required at %C");
6550 if (!gfc_notify_std (GFC_STD_F2003
, "Procedure pointer component at %C"))
6553 /* Match PPC names. */
6557 m
= gfc_match_name (name
);
6560 else if (m
== MATCH_ERROR
)
6563 if (!gfc_add_component (gfc_current_block(), name
, &c
))
6566 /* Add current_attr to the symbol attributes. */
6567 if (!gfc_copy_attr (&c
->attr
, ¤t_attr
, NULL
))
6570 if (!gfc_add_external (&c
->attr
, NULL
))
6573 if (!gfc_add_proc (&c
->attr
, name
, NULL
))
6580 c
->tb
= XCNEW (gfc_typebound_proc
);
6581 c
->tb
->where
= gfc_current_locus
;
6585 /* Set interface. */
6586 if (proc_if
!= NULL
)
6588 c
->ts
.interface
= proc_if
;
6589 c
->attr
.untyped
= 1;
6590 c
->attr
.if_source
= IFSRC_IFBODY
;
6592 else if (ts
.type
!= BT_UNKNOWN
)
6595 c
->ts
.interface
= gfc_new_symbol ("", gfc_current_ns
);
6596 c
->ts
.interface
->result
= c
->ts
.interface
;
6597 c
->ts
.interface
->ts
= ts
;
6598 c
->ts
.interface
->attr
.flavor
= FL_PROCEDURE
;
6599 c
->ts
.interface
->attr
.function
= 1;
6600 c
->attr
.function
= 1;
6601 c
->attr
.if_source
= IFSRC_UNKNOWN
;
6604 if (gfc_match (" =>") == MATCH_YES
)
6606 m
= match_pointer_init (&initializer
, 1);
6609 gfc_free_expr (initializer
);
6612 c
->initializer
= initializer
;
6615 if (gfc_match_eos () == MATCH_YES
)
6617 if (gfc_match_char (',') != MATCH_YES
)
6622 gfc_error ("Syntax error in procedure pointer component at %C");
6627 /* Match a PROCEDURE declaration inside an interface (R1206). */
6630 match_procedure_in_interface (void)
6634 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6637 if (current_interface
.type
== INTERFACE_NAMELESS
6638 || current_interface
.type
== INTERFACE_ABSTRACT
)
6640 gfc_error ("PROCEDURE at %C must be in a generic interface");
6644 /* Check if the F2008 optional double colon appears. */
6645 gfc_gobble_whitespace ();
6646 old_locus
= gfc_current_locus
;
6647 if (gfc_match ("::") == MATCH_YES
)
6649 if (!gfc_notify_std (GFC_STD_F2008
, "double colon in "
6650 "MODULE PROCEDURE statement at %L", &old_locus
))
6654 gfc_current_locus
= old_locus
;
6658 m
= gfc_match_name (name
);
6661 else if (m
== MATCH_ERROR
)
6663 if (gfc_get_symbol (name
, gfc_current_ns
->parent
, &sym
))
6666 if (!gfc_add_interface (sym
))
6669 if (gfc_match_eos () == MATCH_YES
)
6671 if (gfc_match_char (',') != MATCH_YES
)
6678 gfc_error ("Syntax error in PROCEDURE statement at %C");
6683 /* General matcher for PROCEDURE declarations. */
6685 static match
match_procedure_in_type (void);
6688 gfc_match_procedure (void)
6692 switch (gfc_current_state ())
6697 case COMP_SUBMODULE
:
6698 case COMP_SUBROUTINE
:
6701 m
= match_procedure_decl ();
6703 case COMP_INTERFACE
:
6704 m
= match_procedure_in_interface ();
6707 m
= match_ppc_decl ();
6709 case COMP_DERIVED_CONTAINS
:
6710 m
= match_procedure_in_type ();
6719 if (!gfc_notify_std (GFC_STD_F2003
, "PROCEDURE statement at %C"))
6726 /* Warn if a matched procedure has the same name as an intrinsic; this is
6727 simply a wrapper around gfc_warn_intrinsic_shadow that interprets the current
6728 parser-state-stack to find out whether we're in a module. */
6731 do_warn_intrinsic_shadow (const gfc_symbol
* sym
, bool func
)
6735 in_module
= (gfc_state_stack
->previous
6736 && (gfc_state_stack
->previous
->state
== COMP_MODULE
6737 || gfc_state_stack
->previous
->state
== COMP_SUBMODULE
));
6739 gfc_warn_intrinsic_shadow (sym
, in_module
, func
);
6743 /* Match a function declaration. */
6746 gfc_match_function_decl (void)
6748 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6749 gfc_symbol
*sym
, *result
;
6753 match found_match
; /* Status returned by match func. */
6755 if (gfc_current_state () != COMP_NONE
6756 && gfc_current_state () != COMP_INTERFACE
6757 && gfc_current_state () != COMP_CONTAINS
)
6760 gfc_clear_ts (¤t_ts
);
6762 old_loc
= gfc_current_locus
;
6764 m
= gfc_match_prefix (¤t_ts
);
6767 gfc_current_locus
= old_loc
;
6771 if (gfc_match ("function% %n", name
) != MATCH_YES
)
6773 gfc_current_locus
= old_loc
;
6777 if (get_proc_name (name
, &sym
, false))
6780 if (add_hidden_procptr_result (sym
))
6783 if (current_attr
.module_procedure
)
6784 sym
->attr
.module_procedure
= 1;
6786 gfc_new_block
= sym
;
6788 m
= gfc_match_formal_arglist (sym
, 0, 0);
6791 gfc_error ("Expected formal argument list in function "
6792 "definition at %C");
6796 else if (m
== MATCH_ERROR
)
6801 /* According to the draft, the bind(c) and result clause can
6802 come in either order after the formal_arg_list (i.e., either
6803 can be first, both can exist together or by themselves or neither
6804 one). Therefore, the match_result can't match the end of the
6805 string, and check for the bind(c) or result clause in either order. */
6806 found_match
= gfc_match_eos ();
6808 /* Make sure that it isn't already declared as BIND(C). If it is, it
6809 must have been marked BIND(C) with a BIND(C) attribute and that is
6810 not allowed for procedures. */
6811 if (sym
->attr
.is_bind_c
== 1)
6813 sym
->attr
.is_bind_c
= 0;
6814 if (sym
->old_symbol
!= NULL
)
6815 gfc_error_now ("BIND(C) attribute at %L can only be used for "
6816 "variables or common blocks",
6817 &(sym
->old_symbol
->declared_at
));
6819 gfc_error_now ("BIND(C) attribute at %L can only be used for "
6820 "variables or common blocks", &gfc_current_locus
);
6823 if (found_match
!= MATCH_YES
)
6825 /* If we haven't found the end-of-statement, look for a suffix. */
6826 suffix_match
= gfc_match_suffix (sym
, &result
);
6827 if (suffix_match
== MATCH_YES
)
6828 /* Need to get the eos now. */
6829 found_match
= gfc_match_eos ();
6831 found_match
= suffix_match
;
6834 if(found_match
!= MATCH_YES
)
6838 /* Make changes to the symbol. */
6841 if (!gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
6844 if (!gfc_missing_attr (&sym
->attr
, NULL
))
6847 if (!copy_prefix (&sym
->attr
, &sym
->declared_at
))
6849 if(!sym
->attr
.module_procedure
)
6855 /* Delay matching the function characteristics until after the
6856 specification block by signalling kind=-1. */
6857 sym
->declared_at
= old_loc
;
6858 if (current_ts
.type
!= BT_UNKNOWN
)
6859 current_ts
.kind
= -1;
6861 current_ts
.kind
= 0;
6865 if (current_ts
.type
!= BT_UNKNOWN
6866 && !gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
6872 if (current_ts
.type
!= BT_UNKNOWN
6873 && !gfc_add_type (result
, ¤t_ts
, &gfc_current_locus
))
6875 sym
->result
= result
;
6878 /* Warn if this procedure has the same name as an intrinsic. */
6879 do_warn_intrinsic_shadow (sym
, true);
6885 gfc_current_locus
= old_loc
;
6890 /* This is mostly a copy of parse.c(add_global_procedure) but modified to
6891 pass the name of the entry, rather than the gfc_current_block name, and
6892 to return false upon finding an existing global entry. */
6895 add_global_entry (const char *name
, const char *binding_label
, bool sub
,
6899 enum gfc_symbol_type type
;
6901 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
6903 /* Only in Fortran 2003: For procedures with a binding label also the Fortran
6904 name is a global identifier. */
6905 if (!binding_label
|| gfc_notification_std (GFC_STD_F2008
))
6907 s
= gfc_get_gsymbol (name
);
6909 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= type
))
6911 gfc_global_used (s
, where
);
6920 s
->ns
= gfc_current_ns
;
6924 /* Don't add the symbol multiple times. */
6926 && (!gfc_notification_std (GFC_STD_F2008
)
6927 || strcmp (name
, binding_label
) != 0))
6929 s
= gfc_get_gsymbol (binding_label
);
6931 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= type
))
6933 gfc_global_used (s
, where
);
6940 s
->binding_label
= binding_label
;
6943 s
->ns
= gfc_current_ns
;
6951 /* Match an ENTRY statement. */
6954 gfc_match_entry (void)
6959 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6960 gfc_compile_state state
;
6964 bool module_procedure
;
6968 m
= gfc_match_name (name
);
6972 if (!gfc_notify_std (GFC_STD_F2008_OBS
, "ENTRY statement at %C"))
6975 state
= gfc_current_state ();
6976 if (state
!= COMP_SUBROUTINE
&& state
!= COMP_FUNCTION
)
6981 gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
6984 gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
6986 case COMP_SUBMODULE
:
6987 gfc_error ("ENTRY statement at %C cannot appear within a SUBMODULE");
6989 case COMP_BLOCK_DATA
:
6990 gfc_error ("ENTRY statement at %C cannot appear within "
6993 case COMP_INTERFACE
:
6994 gfc_error ("ENTRY statement at %C cannot appear within "
6997 case COMP_STRUCTURE
:
6998 gfc_error ("ENTRY statement at %C cannot appear within "
6999 "a STRUCTURE block");
7002 gfc_error ("ENTRY statement at %C cannot appear within "
7003 "a DERIVED TYPE block");
7006 gfc_error ("ENTRY statement at %C cannot appear within "
7007 "an IF-THEN block");
7010 case COMP_DO_CONCURRENT
:
7011 gfc_error ("ENTRY statement at %C cannot appear within "
7015 gfc_error ("ENTRY statement at %C cannot appear within "
7019 gfc_error ("ENTRY statement at %C cannot appear within "
7023 gfc_error ("ENTRY statement at %C cannot appear within "
7027 gfc_error ("ENTRY statement at %C cannot appear within "
7028 "a contained subprogram");
7031 gfc_error ("Unexpected ENTRY statement at %C");
7036 if ((state
== COMP_SUBROUTINE
|| state
== COMP_FUNCTION
)
7037 && gfc_state_stack
->previous
->state
== COMP_INTERFACE
)
7039 gfc_error ("ENTRY statement at %C cannot appear within an INTERFACE");
7043 module_procedure
= gfc_current_ns
->parent
!= NULL
7044 && gfc_current_ns
->parent
->proc_name
7045 && gfc_current_ns
->parent
->proc_name
->attr
.flavor
7048 if (gfc_current_ns
->parent
!= NULL
7049 && gfc_current_ns
->parent
->proc_name
7050 && !module_procedure
)
7052 gfc_error("ENTRY statement at %C cannot appear in a "
7053 "contained procedure");
7057 /* Module function entries need special care in get_proc_name
7058 because previous references within the function will have
7059 created symbols attached to the current namespace. */
7060 if (get_proc_name (name
, &entry
,
7061 gfc_current_ns
->parent
!= NULL
7062 && module_procedure
))
7065 proc
= gfc_current_block ();
7067 /* Make sure that it isn't already declared as BIND(C). If it is, it
7068 must have been marked BIND(C) with a BIND(C) attribute and that is
7069 not allowed for procedures. */
7070 if (entry
->attr
.is_bind_c
== 1)
7072 entry
->attr
.is_bind_c
= 0;
7073 if (entry
->old_symbol
!= NULL
)
7074 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7075 "variables or common blocks",
7076 &(entry
->old_symbol
->declared_at
));
7078 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7079 "variables or common blocks", &gfc_current_locus
);
7082 /* Check what next non-whitespace character is so we can tell if there
7083 is the required parens if we have a BIND(C). */
7084 old_loc
= gfc_current_locus
;
7085 gfc_gobble_whitespace ();
7086 peek_char
= gfc_peek_ascii_char ();
7088 if (state
== COMP_SUBROUTINE
)
7090 m
= gfc_match_formal_arglist (entry
, 0, 1);
7094 /* Call gfc_match_bind_c with allow_binding_name = true as ENTRY can
7095 never be an internal procedure. */
7096 is_bind_c
= gfc_match_bind_c (entry
, true);
7097 if (is_bind_c
== MATCH_ERROR
)
7099 if (is_bind_c
== MATCH_YES
)
7101 if (peek_char
!= '(')
7103 gfc_error ("Missing required parentheses before BIND(C) at %C");
7106 if (!gfc_add_is_bind_c (&(entry
->attr
), entry
->name
,
7107 &(entry
->declared_at
), 1))
7111 if (!gfc_current_ns
->parent
7112 && !add_global_entry (name
, entry
->binding_label
, true,
7116 /* An entry in a subroutine. */
7117 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
7118 || !gfc_add_subroutine (&entry
->attr
, entry
->name
, NULL
))
7123 /* An entry in a function.
7124 We need to take special care because writing
7129 ENTRY f() RESULT (r)
7131 ENTRY f RESULT (r). */
7132 if (gfc_match_eos () == MATCH_YES
)
7134 gfc_current_locus
= old_loc
;
7135 /* Match the empty argument list, and add the interface to
7137 m
= gfc_match_formal_arglist (entry
, 0, 1);
7140 m
= gfc_match_formal_arglist (entry
, 0, 0);
7147 if (gfc_match_eos () == MATCH_YES
)
7149 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
7150 || !gfc_add_function (&entry
->attr
, entry
->name
, NULL
))
7153 entry
->result
= entry
;
7157 m
= gfc_match_suffix (entry
, &result
);
7159 gfc_syntax_error (ST_ENTRY
);
7165 if (!gfc_add_result (&result
->attr
, result
->name
, NULL
)
7166 || !gfc_add_entry (&entry
->attr
, result
->name
, NULL
)
7167 || !gfc_add_function (&entry
->attr
, result
->name
, NULL
))
7169 entry
->result
= result
;
7173 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
7174 || !gfc_add_function (&entry
->attr
, entry
->name
, NULL
))
7176 entry
->result
= entry
;
7180 if (!gfc_current_ns
->parent
7181 && !add_global_entry (name
, entry
->binding_label
, false,
7186 if (gfc_match_eos () != MATCH_YES
)
7188 gfc_syntax_error (ST_ENTRY
);
7192 entry
->attr
.recursive
= proc
->attr
.recursive
;
7193 entry
->attr
.elemental
= proc
->attr
.elemental
;
7194 entry
->attr
.pure
= proc
->attr
.pure
;
7196 el
= gfc_get_entry_list ();
7198 el
->next
= gfc_current_ns
->entries
;
7199 gfc_current_ns
->entries
= el
;
7201 el
->id
= el
->next
->id
+ 1;
7205 new_st
.op
= EXEC_ENTRY
;
7206 new_st
.ext
.entry
= el
;
7212 /* Match a subroutine statement, including optional prefixes. */
7215 gfc_match_subroutine (void)
7217 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7222 bool allow_binding_name
;
7224 if (gfc_current_state () != COMP_NONE
7225 && gfc_current_state () != COMP_INTERFACE
7226 && gfc_current_state () != COMP_CONTAINS
)
7229 m
= gfc_match_prefix (NULL
);
7233 m
= gfc_match ("subroutine% %n", name
);
7237 if (get_proc_name (name
, &sym
, false))
7240 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
7241 the symbol existed before. */
7242 sym
->declared_at
= gfc_current_locus
;
7244 if (current_attr
.module_procedure
)
7245 sym
->attr
.module_procedure
= 1;
7247 if (add_hidden_procptr_result (sym
))
7250 gfc_new_block
= sym
;
7252 /* Check what next non-whitespace character is so we can tell if there
7253 is the required parens if we have a BIND(C). */
7254 gfc_gobble_whitespace ();
7255 peek_char
= gfc_peek_ascii_char ();
7257 if (!gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
))
7260 if (gfc_match_formal_arglist (sym
, 0, 1) != MATCH_YES
)
7263 /* Make sure that it isn't already declared as BIND(C). If it is, it
7264 must have been marked BIND(C) with a BIND(C) attribute and that is
7265 not allowed for procedures. */
7266 if (sym
->attr
.is_bind_c
== 1)
7268 sym
->attr
.is_bind_c
= 0;
7269 if (sym
->old_symbol
!= NULL
)
7270 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7271 "variables or common blocks",
7272 &(sym
->old_symbol
->declared_at
));
7274 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7275 "variables or common blocks", &gfc_current_locus
);
7278 /* C binding names are not allowed for internal procedures. */
7279 if (gfc_current_state () == COMP_CONTAINS
7280 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
7281 allow_binding_name
= false;
7283 allow_binding_name
= true;
7285 /* Here, we are just checking if it has the bind(c) attribute, and if
7286 so, then we need to make sure it's all correct. If it doesn't,
7287 we still need to continue matching the rest of the subroutine line. */
7288 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
7289 if (is_bind_c
== MATCH_ERROR
)
7291 /* There was an attempt at the bind(c), but it was wrong. An
7292 error message should have been printed w/in the gfc_match_bind_c
7293 so here we'll just return the MATCH_ERROR. */
7297 if (is_bind_c
== MATCH_YES
)
7299 /* The following is allowed in the Fortran 2008 draft. */
7300 if (gfc_current_state () == COMP_CONTAINS
7301 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
7302 && !gfc_notify_std (GFC_STD_F2008
, "BIND(C) attribute "
7303 "at %L may not be specified for an internal "
7304 "procedure", &gfc_current_locus
))
7307 if (peek_char
!= '(')
7309 gfc_error ("Missing required parentheses before BIND(C) at %C");
7312 if (!gfc_add_is_bind_c (&(sym
->attr
), sym
->name
,
7313 &(sym
->declared_at
), 1))
7317 if (gfc_match_eos () != MATCH_YES
)
7319 gfc_syntax_error (ST_SUBROUTINE
);
7323 if (!copy_prefix (&sym
->attr
, &sym
->declared_at
))
7325 if(!sym
->attr
.module_procedure
)
7331 /* Warn if it has the same name as an intrinsic. */
7332 do_warn_intrinsic_shadow (sym
, false);
7338 /* Check that the NAME identifier in a BIND attribute or statement
7339 is conform to C identifier rules. */
7342 check_bind_name_identifier (char **name
)
7344 char *n
= *name
, *p
;
7346 /* Remove leading spaces. */
7350 /* On an empty string, free memory and set name to NULL. */
7358 /* Remove trailing spaces. */
7359 p
= n
+ strlen(n
) - 1;
7363 /* Insert the identifier into the symbol table. */
7368 /* Now check that identifier is valid under C rules. */
7371 gfc_error ("Invalid C identifier in NAME= specifier at %C");
7376 if (!(ISALNUM (*p
) || *p
== '_' || *p
== '$'))
7378 gfc_error ("Invalid C identifier in NAME= specifier at %C");
7386 /* Match a BIND(C) specifier, with the optional 'name=' specifier if
7387 given, and set the binding label in either the given symbol (if not
7388 NULL), or in the current_ts. The symbol may be NULL because we may
7389 encounter the BIND(C) before the declaration itself. Return
7390 MATCH_NO if what we're looking at isn't a BIND(C) specifier,
7391 MATCH_ERROR if it is a BIND(C) clause but an error was encountered,
7392 or MATCH_YES if the specifier was correct and the binding label and
7393 bind(c) fields were set correctly for the given symbol or the
7394 current_ts. If allow_binding_name is false, no binding name may be
7398 gfc_match_bind_c (gfc_symbol
*sym
, bool allow_binding_name
)
7400 char *binding_label
= NULL
;
7403 /* Initialize the flag that specifies whether we encountered a NAME=
7404 specifier or not. */
7405 has_name_equals
= 0;
7407 /* This much we have to be able to match, in this order, if
7408 there is a bind(c) label. */
7409 if (gfc_match (" bind ( c ") != MATCH_YES
)
7412 /* Now see if there is a binding label, or if we've reached the
7413 end of the bind(c) attribute without one. */
7414 if (gfc_match_char (',') == MATCH_YES
)
7416 if (gfc_match (" name = ") != MATCH_YES
)
7418 gfc_error ("Syntax error in NAME= specifier for binding label "
7420 /* should give an error message here */
7424 has_name_equals
= 1;
7426 if (gfc_match_init_expr (&e
) != MATCH_YES
)
7432 if (!gfc_simplify_expr(e
, 0))
7434 gfc_error ("NAME= specifier at %C should be a constant expression");
7439 if (e
->expr_type
!= EXPR_CONSTANT
|| e
->ts
.type
!= BT_CHARACTER
7440 || e
->ts
.kind
!= gfc_default_character_kind
|| e
->rank
!= 0)
7442 gfc_error ("NAME= specifier at %C should be a scalar of "
7443 "default character kind");
7448 // Get a C string from the Fortran string constant
7449 binding_label
= gfc_widechar_to_char (e
->value
.character
.string
,
7450 e
->value
.character
.length
);
7453 // Check that it is valid (old gfc_match_name_C)
7454 if (check_bind_name_identifier (&binding_label
) != MATCH_YES
)
7458 /* Get the required right paren. */
7459 if (gfc_match_char (')') != MATCH_YES
)
7461 gfc_error ("Missing closing paren for binding label at %C");
7465 if (has_name_equals
&& !allow_binding_name
)
7467 gfc_error ("No binding name is allowed in BIND(C) at %C");
7471 if (has_name_equals
&& sym
!= NULL
&& sym
->attr
.dummy
)
7473 gfc_error ("For dummy procedure %s, no binding name is "
7474 "allowed in BIND(C) at %C", sym
->name
);
7479 /* Save the binding label to the symbol. If sym is null, we're
7480 probably matching the typespec attributes of a declaration and
7481 haven't gotten the name yet, and therefore, no symbol yet. */
7485 sym
->binding_label
= binding_label
;
7487 curr_binding_label
= binding_label
;
7489 else if (allow_binding_name
)
7491 /* No binding label, but if symbol isn't null, we
7492 can set the label for it here.
7493 If name="" or allow_binding_name is false, no C binding name is
7495 if (sym
!= NULL
&& sym
->name
!= NULL
&& has_name_equals
== 0)
7496 sym
->binding_label
= IDENTIFIER_POINTER (get_identifier (sym
->name
));
7499 if (has_name_equals
&& gfc_current_state () == COMP_INTERFACE
7500 && current_interface
.type
== INTERFACE_ABSTRACT
)
7502 gfc_error ("NAME not allowed on BIND(C) for ABSTRACT INTERFACE at %C");
7510 /* Return nonzero if we're currently compiling a contained procedure. */
7513 contained_procedure (void)
7515 gfc_state_data
*s
= gfc_state_stack
;
7517 if ((s
->state
== COMP_SUBROUTINE
|| s
->state
== COMP_FUNCTION
)
7518 && s
->previous
!= NULL
&& s
->previous
->state
== COMP_CONTAINS
)
7524 /* Set the kind of each enumerator. The kind is selected such that it is
7525 interoperable with the corresponding C enumeration type, making
7526 sure that -fshort-enums is honored. */
7531 enumerator_history
*current_history
= NULL
;
7535 if (max_enum
== NULL
|| enum_history
== NULL
)
7538 if (!flag_short_enums
)
7544 kind
= gfc_integer_kinds
[i
++].kind
;
7546 while (kind
< gfc_c_int_kind
7547 && gfc_check_integer_range (max_enum
->initializer
->value
.integer
,
7550 current_history
= enum_history
;
7551 while (current_history
!= NULL
)
7553 current_history
->sym
->ts
.kind
= kind
;
7554 current_history
= current_history
->next
;
7559 /* Match any of the various end-block statements. Returns the type of
7560 END to the caller. The END INTERFACE, END IF, END DO, END SELECT
7561 and END BLOCK statements cannot be replaced by a single END statement. */
7564 gfc_match_end (gfc_statement
*st
)
7566 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7567 gfc_compile_state state
;
7569 const char *block_name
;
7573 gfc_namespace
*parent_ns
, *ns
, *prev_ns
;
7574 gfc_namespace
**nsp
;
7575 bool abreviated_modproc_decl
= false;
7576 bool got_matching_end
= false;
7578 old_loc
= gfc_current_locus
;
7579 if (gfc_match ("end") != MATCH_YES
)
7582 state
= gfc_current_state ();
7583 block_name
= gfc_current_block () == NULL
7584 ? NULL
: gfc_current_block ()->name
;
7588 case COMP_ASSOCIATE
:
7590 if (!strncmp (block_name
, "block@", strlen("block@")))
7595 case COMP_DERIVED_CONTAINS
:
7596 state
= gfc_state_stack
->previous
->state
;
7597 block_name
= gfc_state_stack
->previous
->sym
== NULL
7598 ? NULL
: gfc_state_stack
->previous
->sym
->name
;
7599 abreviated_modproc_decl
= gfc_state_stack
->previous
->sym
7600 && gfc_state_stack
->previous
->sym
->abr_modproc_decl
;
7607 if (!abreviated_modproc_decl
)
7608 abreviated_modproc_decl
= gfc_current_block ()
7609 && gfc_current_block ()->abr_modproc_decl
;
7615 *st
= ST_END_PROGRAM
;
7616 target
= " program";
7620 case COMP_SUBROUTINE
:
7621 *st
= ST_END_SUBROUTINE
;
7622 if (!abreviated_modproc_decl
)
7623 target
= " subroutine";
7625 target
= " procedure";
7626 eos_ok
= !contained_procedure ();
7630 *st
= ST_END_FUNCTION
;
7631 if (!abreviated_modproc_decl
)
7632 target
= " function";
7634 target
= " procedure";
7635 eos_ok
= !contained_procedure ();
7638 case COMP_BLOCK_DATA
:
7639 *st
= ST_END_BLOCK_DATA
;
7640 target
= " block data";
7645 *st
= ST_END_MODULE
;
7650 case COMP_SUBMODULE
:
7651 *st
= ST_END_SUBMODULE
;
7652 target
= " submodule";
7656 case COMP_INTERFACE
:
7657 *st
= ST_END_INTERFACE
;
7658 target
= " interface";
7674 case COMP_STRUCTURE
:
7675 *st
= ST_END_STRUCTURE
;
7676 target
= " structure";
7681 case COMP_DERIVED_CONTAINS
:
7687 case COMP_ASSOCIATE
:
7688 *st
= ST_END_ASSOCIATE
;
7689 target
= " associate";
7706 case COMP_DO_CONCURRENT
:
7713 *st
= ST_END_CRITICAL
;
7714 target
= " critical";
7719 case COMP_SELECT_TYPE
:
7720 *st
= ST_END_SELECT
;
7726 *st
= ST_END_FORALL
;
7741 last_initializer
= NULL
;
7743 gfc_free_enum_history ();
7747 gfc_error ("Unexpected END statement at %C");
7751 old_loc
= gfc_current_locus
;
7752 if (gfc_match_eos () == MATCH_YES
)
7754 if (!eos_ok
&& (*st
== ST_END_SUBROUTINE
|| *st
== ST_END_FUNCTION
))
7756 if (!gfc_notify_std (GFC_STD_F2008
, "END statement "
7757 "instead of %s statement at %L",
7758 abreviated_modproc_decl
? "END PROCEDURE"
7759 : gfc_ascii_statement(*st
), &old_loc
))
7764 /* We would have required END [something]. */
7765 gfc_error ("%s statement expected at %L",
7766 gfc_ascii_statement (*st
), &old_loc
);
7773 /* Verify that we've got the sort of end-block that we're expecting. */
7774 if (gfc_match (target
) != MATCH_YES
)
7776 gfc_error ("Expecting %s statement at %L", abreviated_modproc_decl
7777 ? "END PROCEDURE" : gfc_ascii_statement(*st
), &old_loc
);
7781 got_matching_end
= true;
7783 old_loc
= gfc_current_locus
;
7784 /* If we're at the end, make sure a block name wasn't required. */
7785 if (gfc_match_eos () == MATCH_YES
)
7788 if (*st
!= ST_ENDDO
&& *st
!= ST_ENDIF
&& *st
!= ST_END_SELECT
7789 && *st
!= ST_END_FORALL
&& *st
!= ST_END_WHERE
&& *st
!= ST_END_BLOCK
7790 && *st
!= ST_END_ASSOCIATE
&& *st
!= ST_END_CRITICAL
)
7796 gfc_error ("Expected block name of %qs in %s statement at %L",
7797 block_name
, gfc_ascii_statement (*st
), &old_loc
);
7802 /* END INTERFACE has a special handler for its several possible endings. */
7803 if (*st
== ST_END_INTERFACE
)
7804 return gfc_match_end_interface ();
7806 /* We haven't hit the end of statement, so what is left must be an
7808 m
= gfc_match_space ();
7810 m
= gfc_match_name (name
);
7813 gfc_error ("Expected terminating name at %C");
7817 if (block_name
== NULL
)
7820 /* We have to pick out the declared submodule name from the composite
7821 required by F2008:11.2.3 para 2, which ends in the declared name. */
7822 if (state
== COMP_SUBMODULE
)
7823 block_name
= strchr (block_name
, '.') + 1;
7825 if (strcmp (name
, block_name
) != 0 && strcmp (block_name
, "ppr@") != 0)
7827 gfc_error ("Expected label %qs for %s statement at %C", block_name
,
7828 gfc_ascii_statement (*st
));
7831 /* Procedure pointer as function result. */
7832 else if (strcmp (block_name
, "ppr@") == 0
7833 && strcmp (name
, gfc_current_block ()->ns
->proc_name
->name
) != 0)
7835 gfc_error ("Expected label %qs for %s statement at %C",
7836 gfc_current_block ()->ns
->proc_name
->name
,
7837 gfc_ascii_statement (*st
));
7841 if (gfc_match_eos () == MATCH_YES
)
7845 gfc_syntax_error (*st
);
7848 gfc_current_locus
= old_loc
;
7850 /* If we are missing an END BLOCK, we created a half-ready namespace.
7851 Remove it from the parent namespace's sibling list. */
7853 while (state
== COMP_BLOCK
&& !got_matching_end
)
7855 parent_ns
= gfc_current_ns
->parent
;
7857 nsp
= &(gfc_state_stack
->previous
->tail
->ext
.block
.ns
);
7863 if (ns
== gfc_current_ns
)
7865 if (prev_ns
== NULL
)
7868 prev_ns
->sibling
= ns
->sibling
;
7874 gfc_free_namespace (gfc_current_ns
);
7875 gfc_current_ns
= parent_ns
;
7876 gfc_state_stack
= gfc_state_stack
->previous
;
7877 state
= gfc_current_state ();
7885 /***************** Attribute declaration statements ****************/
7887 /* Set the attribute of a single variable. */
7892 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7895 /* Workaround -Wmaybe-uninitialized false positive during
7896 profiledbootstrap by initializing them. */
7897 gfc_symbol
*sym
= NULL
;
7903 m
= gfc_match_name (name
);
7907 if (find_special (name
, &sym
, false))
7910 if (!check_function_name (name
))
7916 var_locus
= gfc_current_locus
;
7918 /* Deal with possible array specification for certain attributes. */
7919 if (current_attr
.dimension
7920 || current_attr
.codimension
7921 || current_attr
.allocatable
7922 || current_attr
.pointer
7923 || current_attr
.target
)
7925 m
= gfc_match_array_spec (&as
, !current_attr
.codimension
,
7926 !current_attr
.dimension
7927 && !current_attr
.pointer
7928 && !current_attr
.target
);
7929 if (m
== MATCH_ERROR
)
7932 if (current_attr
.dimension
&& m
== MATCH_NO
)
7934 gfc_error ("Missing array specification at %L in DIMENSION "
7935 "statement", &var_locus
);
7940 if (current_attr
.dimension
&& sym
->value
)
7942 gfc_error ("Dimensions specified for %s at %L after its "
7943 "initialization", sym
->name
, &var_locus
);
7948 if (current_attr
.codimension
&& m
== MATCH_NO
)
7950 gfc_error ("Missing array specification at %L in CODIMENSION "
7951 "statement", &var_locus
);
7956 if ((current_attr
.allocatable
|| current_attr
.pointer
)
7957 && (m
== MATCH_YES
) && (as
->type
!= AS_DEFERRED
))
7959 gfc_error ("Array specification must be deferred at %L", &var_locus
);
7965 /* Update symbol table. DIMENSION attribute is set in
7966 gfc_set_array_spec(). For CLASS variables, this must be applied
7967 to the first component, or '_data' field. */
7968 if (sym
->ts
.type
== BT_CLASS
&& sym
->ts
.u
.derived
->attr
.is_class
)
7970 if (!gfc_copy_attr (&CLASS_DATA(sym
)->attr
, ¤t_attr
, &var_locus
))
7978 if (current_attr
.dimension
== 0 && current_attr
.codimension
== 0
7979 && !gfc_copy_attr (&sym
->attr
, ¤t_attr
, &var_locus
))
7986 if (sym
->ts
.type
== BT_CLASS
7987 && !gfc_build_class_symbol (&sym
->ts
, &sym
->attr
, &sym
->as
))
7993 if (!gfc_set_array_spec (sym
, as
, &var_locus
))
7999 if (sym
->attr
.cray_pointee
&& sym
->as
!= NULL
)
8001 /* Fix the array spec. */
8002 m
= gfc_mod_pointee_as (sym
->as
);
8003 if (m
== MATCH_ERROR
)
8007 if (!gfc_add_attribute (&sym
->attr
, &var_locus
))
8013 if ((current_attr
.external
|| current_attr
.intrinsic
)
8014 && sym
->attr
.flavor
!= FL_PROCEDURE
8015 && !gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, NULL
))
8021 add_hidden_procptr_result (sym
);
8026 gfc_free_array_spec (as
);
8031 /* Generic attribute declaration subroutine. Used for attributes that
8032 just have a list of names. */
8039 /* Gobble the optional double colon, by simply ignoring the result
8049 if (gfc_match_eos () == MATCH_YES
)
8055 if (gfc_match_char (',') != MATCH_YES
)
8057 gfc_error ("Unexpected character in variable list at %C");
8067 /* This routine matches Cray Pointer declarations of the form:
8068 pointer ( <pointer>, <pointee> )
8070 pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...
8071 The pointer, if already declared, should be an integer. Otherwise, we
8072 set it as BT_INTEGER with kind gfc_index_integer_kind. The pointee may
8073 be either a scalar, or an array declaration. No space is allocated for
8074 the pointee. For the statement
8075 pointer (ipt, ar(10))
8076 any subsequent uses of ar will be translated (in C-notation) as
8077 ar(i) => ((<type> *) ipt)(i)
8078 After gimplification, pointee variable will disappear in the code. */
8081 cray_pointer_decl (void)
8084 gfc_array_spec
*as
= NULL
;
8085 gfc_symbol
*cptr
; /* Pointer symbol. */
8086 gfc_symbol
*cpte
; /* Pointee symbol. */
8092 if (gfc_match_char ('(') != MATCH_YES
)
8094 gfc_error ("Expected %<(%> at %C");
8098 /* Match pointer. */
8099 var_locus
= gfc_current_locus
;
8100 gfc_clear_attr (¤t_attr
);
8101 gfc_add_cray_pointer (¤t_attr
, &var_locus
);
8102 current_ts
.type
= BT_INTEGER
;
8103 current_ts
.kind
= gfc_index_integer_kind
;
8105 m
= gfc_match_symbol (&cptr
, 0);
8108 gfc_error ("Expected variable name at %C");
8112 if (!gfc_add_cray_pointer (&cptr
->attr
, &var_locus
))
8115 gfc_set_sym_referenced (cptr
);
8117 if (cptr
->ts
.type
== BT_UNKNOWN
) /* Override the type, if necessary. */
8119 cptr
->ts
.type
= BT_INTEGER
;
8120 cptr
->ts
.kind
= gfc_index_integer_kind
;
8122 else if (cptr
->ts
.type
!= BT_INTEGER
)
8124 gfc_error ("Cray pointer at %C must be an integer");
8127 else if (cptr
->ts
.kind
< gfc_index_integer_kind
)
8128 gfc_warning (0, "Cray pointer at %C has %d bytes of precision;"
8129 " memory addresses require %d bytes",
8130 cptr
->ts
.kind
, gfc_index_integer_kind
);
8132 if (gfc_match_char (',') != MATCH_YES
)
8134 gfc_error ("Expected \",\" at %C");
8138 /* Match Pointee. */
8139 var_locus
= gfc_current_locus
;
8140 gfc_clear_attr (¤t_attr
);
8141 gfc_add_cray_pointee (¤t_attr
, &var_locus
);
8142 current_ts
.type
= BT_UNKNOWN
;
8143 current_ts
.kind
= 0;
8145 m
= gfc_match_symbol (&cpte
, 0);
8148 gfc_error ("Expected variable name at %C");
8152 /* Check for an optional array spec. */
8153 m
= gfc_match_array_spec (&as
, true, false);
8154 if (m
== MATCH_ERROR
)
8156 gfc_free_array_spec (as
);
8159 else if (m
== MATCH_NO
)
8161 gfc_free_array_spec (as
);
8165 if (!gfc_add_cray_pointee (&cpte
->attr
, &var_locus
))
8168 gfc_set_sym_referenced (cpte
);
8170 if (cpte
->as
== NULL
)
8172 if (!gfc_set_array_spec (cpte
, as
, &var_locus
))
8173 gfc_internal_error ("Couldn't set Cray pointee array spec.");
8175 else if (as
!= NULL
)
8177 gfc_error ("Duplicate array spec for Cray pointee at %C");
8178 gfc_free_array_spec (as
);
8184 if (cpte
->as
!= NULL
)
8186 /* Fix array spec. */
8187 m
= gfc_mod_pointee_as (cpte
->as
);
8188 if (m
== MATCH_ERROR
)
8192 /* Point the Pointee at the Pointer. */
8193 cpte
->cp_pointer
= cptr
;
8195 if (gfc_match_char (')') != MATCH_YES
)
8197 gfc_error ("Expected \")\" at %C");
8200 m
= gfc_match_char (',');
8202 done
= true; /* Stop searching for more declarations. */
8206 if (m
== MATCH_ERROR
/* Failed when trying to find ',' above. */
8207 || gfc_match_eos () != MATCH_YES
)
8209 gfc_error ("Expected %<,%> or end of statement at %C");
8217 gfc_match_external (void)
8220 gfc_clear_attr (¤t_attr
);
8221 current_attr
.external
= 1;
8223 return attr_decl ();
8228 gfc_match_intent (void)
8232 /* This is not allowed within a BLOCK construct! */
8233 if (gfc_current_state () == COMP_BLOCK
)
8235 gfc_error ("INTENT is not allowed inside of BLOCK at %C");
8239 intent
= match_intent_spec ();
8240 if (intent
== INTENT_UNKNOWN
)
8243 gfc_clear_attr (¤t_attr
);
8244 current_attr
.intent
= intent
;
8246 return attr_decl ();
8251 gfc_match_intrinsic (void)
8254 gfc_clear_attr (¤t_attr
);
8255 current_attr
.intrinsic
= 1;
8257 return attr_decl ();
8262 gfc_match_optional (void)
8264 /* This is not allowed within a BLOCK construct! */
8265 if (gfc_current_state () == COMP_BLOCK
)
8267 gfc_error ("OPTIONAL is not allowed inside of BLOCK at %C");
8271 gfc_clear_attr (¤t_attr
);
8272 current_attr
.optional
= 1;
8274 return attr_decl ();
8279 gfc_match_pointer (void)
8281 gfc_gobble_whitespace ();
8282 if (gfc_peek_ascii_char () == '(')
8284 if (!flag_cray_pointer
)
8286 gfc_error ("Cray pointer declaration at %C requires -fcray-pointer "
8290 return cray_pointer_decl ();
8294 gfc_clear_attr (¤t_attr
);
8295 current_attr
.pointer
= 1;
8297 return attr_decl ();
8303 gfc_match_allocatable (void)
8305 gfc_clear_attr (¤t_attr
);
8306 current_attr
.allocatable
= 1;
8308 return attr_decl ();
8313 gfc_match_codimension (void)
8315 gfc_clear_attr (¤t_attr
);
8316 current_attr
.codimension
= 1;
8318 return attr_decl ();
8323 gfc_match_contiguous (void)
8325 if (!gfc_notify_std (GFC_STD_F2008
, "CONTIGUOUS statement at %C"))
8328 gfc_clear_attr (¤t_attr
);
8329 current_attr
.contiguous
= 1;
8331 return attr_decl ();
8336 gfc_match_dimension (void)
8338 gfc_clear_attr (¤t_attr
);
8339 current_attr
.dimension
= 1;
8341 return attr_decl ();
8346 gfc_match_target (void)
8348 gfc_clear_attr (¤t_attr
);
8349 current_attr
.target
= 1;
8351 return attr_decl ();
8355 /* Match the list of entities being specified in a PUBLIC or PRIVATE
8359 access_attr_decl (gfc_statement st
)
8361 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8362 interface_type type
;
8364 gfc_symbol
*sym
, *dt_sym
;
8365 gfc_intrinsic_op op
;
8368 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
8373 m
= gfc_match_generic_spec (&type
, name
, &op
);
8376 if (m
== MATCH_ERROR
)
8381 case INTERFACE_NAMELESS
:
8382 case INTERFACE_ABSTRACT
:
8385 case INTERFACE_GENERIC
:
8386 case INTERFACE_DTIO
:
8388 if (gfc_get_symbol (name
, NULL
, &sym
))
8391 if (type
== INTERFACE_DTIO
8392 && gfc_current_ns
->proc_name
8393 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
8394 && sym
->attr
.flavor
== FL_UNKNOWN
)
8395 sym
->attr
.flavor
= FL_PROCEDURE
;
8397 if (!gfc_add_access (&sym
->attr
,
8399 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
,
8403 if (sym
->attr
.generic
&& (dt_sym
= gfc_find_dt_in_generic (sym
))
8404 && !gfc_add_access (&dt_sym
->attr
,
8406 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
,
8412 case INTERFACE_INTRINSIC_OP
:
8413 if (gfc_current_ns
->operator_access
[op
] == ACCESS_UNKNOWN
)
8415 gfc_intrinsic_op other_op
;
8417 gfc_current_ns
->operator_access
[op
] =
8418 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
8420 /* Handle the case if there is another op with the same
8421 function, for INTRINSIC_EQ vs. INTRINSIC_EQ_OS and so on. */
8422 other_op
= gfc_equivalent_op (op
);
8424 if (other_op
!= INTRINSIC_NONE
)
8425 gfc_current_ns
->operator_access
[other_op
] =
8426 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
8431 gfc_error ("Access specification of the %s operator at %C has "
8432 "already been specified", gfc_op2string (op
));
8438 case INTERFACE_USER_OP
:
8439 uop
= gfc_get_uop (name
);
8441 if (uop
->access
== ACCESS_UNKNOWN
)
8443 uop
->access
= (st
== ST_PUBLIC
)
8444 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
8448 gfc_error ("Access specification of the .%s. operator at %C "
8449 "has already been specified", sym
->name
);
8456 if (gfc_match_char (',') == MATCH_NO
)
8460 if (gfc_match_eos () != MATCH_YES
)
8465 gfc_syntax_error (st
);
8473 gfc_match_protected (void)
8478 if (!gfc_current_ns
->proc_name
8479 || gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
8481 gfc_error ("PROTECTED at %C only allowed in specification "
8482 "part of a module");
8487 if (!gfc_notify_std (GFC_STD_F2003
, "PROTECTED statement at %C"))
8490 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
8495 if (gfc_match_eos () == MATCH_YES
)
8500 m
= gfc_match_symbol (&sym
, 0);
8504 if (!gfc_add_protected (&sym
->attr
, sym
->name
, &gfc_current_locus
))
8516 if (gfc_match_eos () == MATCH_YES
)
8518 if (gfc_match_char (',') != MATCH_YES
)
8525 gfc_error ("Syntax error in PROTECTED statement at %C");
8530 /* The PRIVATE statement is a bit weird in that it can be an attribute
8531 declaration, but also works as a standalone statement inside of a
8532 type declaration or a module. */
8535 gfc_match_private (gfc_statement
*st
)
8538 if (gfc_match ("private") != MATCH_YES
)
8541 if (gfc_current_state () != COMP_MODULE
8542 && !(gfc_current_state () == COMP_DERIVED
8543 && gfc_state_stack
->previous
8544 && gfc_state_stack
->previous
->state
== COMP_MODULE
)
8545 && !(gfc_current_state () == COMP_DERIVED_CONTAINS
8546 && gfc_state_stack
->previous
&& gfc_state_stack
->previous
->previous
8547 && gfc_state_stack
->previous
->previous
->state
== COMP_MODULE
))
8549 gfc_error ("PRIVATE statement at %C is only allowed in the "
8550 "specification part of a module");
8554 if (gfc_current_state () == COMP_DERIVED
)
8556 if (gfc_match_eos () == MATCH_YES
)
8562 gfc_syntax_error (ST_PRIVATE
);
8566 if (gfc_match_eos () == MATCH_YES
)
8573 return access_attr_decl (ST_PRIVATE
);
8578 gfc_match_public (gfc_statement
*st
)
8581 if (gfc_match ("public") != MATCH_YES
)
8584 if (gfc_current_state () != COMP_MODULE
)
8586 gfc_error ("PUBLIC statement at %C is only allowed in the "
8587 "specification part of a module");
8591 if (gfc_match_eos () == MATCH_YES
)
8598 return access_attr_decl (ST_PUBLIC
);
8602 /* Workhorse for gfc_match_parameter. */
8612 m
= gfc_match_symbol (&sym
, 0);
8614 gfc_error ("Expected variable name at %C in PARAMETER statement");
8619 if (gfc_match_char ('=') == MATCH_NO
)
8621 gfc_error ("Expected = sign in PARAMETER statement at %C");
8625 m
= gfc_match_init_expr (&init
);
8627 gfc_error ("Expected expression at %C in PARAMETER statement");
8631 if (sym
->ts
.type
== BT_UNKNOWN
8632 && !gfc_set_default_type (sym
, 1, NULL
))
8638 if (!gfc_check_assign_symbol (sym
, NULL
, init
)
8639 || !gfc_add_flavor (&sym
->attr
, FL_PARAMETER
, sym
->name
, NULL
))
8647 gfc_error ("Initializing already initialized variable at %C");
8652 t
= add_init_expr_to_sym (sym
->name
, &init
, &gfc_current_locus
);
8653 return (t
) ? MATCH_YES
: MATCH_ERROR
;
8656 gfc_free_expr (init
);
8661 /* Match a parameter statement, with the weird syntax that these have. */
8664 gfc_match_parameter (void)
8666 const char *term
= " )%t";
8669 if (gfc_match_char ('(') == MATCH_NO
)
8671 /* With legacy PARAMETER statements, don't expect a terminating ')'. */
8672 if (!gfc_notify_std (GFC_STD_LEGACY
, "PARAMETER without '()' at %C"))
8683 if (gfc_match (term
) == MATCH_YES
)
8686 if (gfc_match_char (',') != MATCH_YES
)
8688 gfc_error ("Unexpected characters in PARAMETER statement at %C");
8699 gfc_match_automatic (void)
8703 bool seen_symbol
= false;
8705 if (!flag_dec_static
)
8707 gfc_error ("%s at %C is a DEC extension, enable with "
8718 m
= gfc_match_symbol (&sym
, 0);
8728 if (!gfc_add_automatic (&sym
->attr
, sym
->name
, &gfc_current_locus
))
8734 if (gfc_match_eos () == MATCH_YES
)
8736 if (gfc_match_char (',') != MATCH_YES
)
8742 gfc_error ("Expected entity-list in AUTOMATIC statement at %C");
8749 gfc_error ("Syntax error in AUTOMATIC statement at %C");
8755 gfc_match_static (void)
8759 bool seen_symbol
= false;
8761 if (!flag_dec_static
)
8763 gfc_error ("%s at %C is a DEC extension, enable with "
8773 m
= gfc_match_symbol (&sym
, 0);
8783 if (!gfc_add_save (&sym
->attr
, SAVE_EXPLICIT
, sym
->name
,
8784 &gfc_current_locus
))
8790 if (gfc_match_eos () == MATCH_YES
)
8792 if (gfc_match_char (',') != MATCH_YES
)
8798 gfc_error ("Expected entity-list in STATIC statement at %C");
8805 gfc_error ("Syntax error in STATIC statement at %C");
8810 /* Save statements have a special syntax. */
8813 gfc_match_save (void)
8815 char n
[GFC_MAX_SYMBOL_LEN
+1];
8820 if (gfc_match_eos () == MATCH_YES
)
8822 if (gfc_current_ns
->seen_save
)
8824 if (!gfc_notify_std (GFC_STD_LEGACY
, "Blanket SAVE statement at %C "
8825 "follows previous SAVE statement"))
8829 gfc_current_ns
->save_all
= gfc_current_ns
->seen_save
= 1;
8833 if (gfc_current_ns
->save_all
)
8835 if (!gfc_notify_std (GFC_STD_LEGACY
, "SAVE statement at %C follows "
8836 "blanket SAVE statement"))
8844 m
= gfc_match_symbol (&sym
, 0);
8848 if (!gfc_add_save (&sym
->attr
, SAVE_EXPLICIT
, sym
->name
,
8849 &gfc_current_locus
))
8860 m
= gfc_match (" / %n /", &n
);
8861 if (m
== MATCH_ERROR
)
8866 c
= gfc_get_common (n
, 0);
8869 gfc_current_ns
->seen_save
= 1;
8872 if (gfc_match_eos () == MATCH_YES
)
8874 if (gfc_match_char (',') != MATCH_YES
)
8881 gfc_error ("Syntax error in SAVE statement at %C");
8887 gfc_match_value (void)
8892 /* This is not allowed within a BLOCK construct! */
8893 if (gfc_current_state () == COMP_BLOCK
)
8895 gfc_error ("VALUE is not allowed inside of BLOCK at %C");
8899 if (!gfc_notify_std (GFC_STD_F2003
, "VALUE statement at %C"))
8902 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
8907 if (gfc_match_eos () == MATCH_YES
)
8912 m
= gfc_match_symbol (&sym
, 0);
8916 if (!gfc_add_value (&sym
->attr
, sym
->name
, &gfc_current_locus
))
8928 if (gfc_match_eos () == MATCH_YES
)
8930 if (gfc_match_char (',') != MATCH_YES
)
8937 gfc_error ("Syntax error in VALUE statement at %C");
8943 gfc_match_volatile (void)
8948 if (!gfc_notify_std (GFC_STD_F2003
, "VOLATILE statement at %C"))
8951 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
8956 if (gfc_match_eos () == MATCH_YES
)
8961 /* VOLATILE is special because it can be added to host-associated
8962 symbols locally. Except for coarrays. */
8963 m
= gfc_match_symbol (&sym
, 1);
8967 /* F2008, C560+C561. VOLATILE for host-/use-associated variable or
8968 for variable in a BLOCK which is defined outside of the BLOCK. */
8969 if (sym
->ns
!= gfc_current_ns
&& sym
->attr
.codimension
)
8971 gfc_error ("Specifying VOLATILE for coarray variable %qs at "
8972 "%C, which is use-/host-associated", sym
->name
);
8975 if (!gfc_add_volatile (&sym
->attr
, sym
->name
, &gfc_current_locus
))
8987 if (gfc_match_eos () == MATCH_YES
)
8989 if (gfc_match_char (',') != MATCH_YES
)
8996 gfc_error ("Syntax error in VOLATILE statement at %C");
9002 gfc_match_asynchronous (void)
9007 if (!gfc_notify_std (GFC_STD_F2003
, "ASYNCHRONOUS statement at %C"))
9010 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
9015 if (gfc_match_eos () == MATCH_YES
)
9020 /* ASYNCHRONOUS is special because it can be added to host-associated
9022 m
= gfc_match_symbol (&sym
, 1);
9026 if (!gfc_add_asynchronous (&sym
->attr
, sym
->name
, &gfc_current_locus
))
9038 if (gfc_match_eos () == MATCH_YES
)
9040 if (gfc_match_char (',') != MATCH_YES
)
9047 gfc_error ("Syntax error in ASYNCHRONOUS statement at %C");
9052 /* Match a module procedure statement in a submodule. */
9055 gfc_match_submod_proc (void)
9057 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9058 gfc_symbol
*sym
, *fsym
;
9060 gfc_formal_arglist
*formal
, *head
, *tail
;
9062 if (gfc_current_state () != COMP_CONTAINS
9063 || !(gfc_state_stack
->previous
9064 && (gfc_state_stack
->previous
->state
== COMP_SUBMODULE
9065 || gfc_state_stack
->previous
->state
== COMP_MODULE
)))
9068 m
= gfc_match (" module% procedure% %n", name
);
9072 if (!gfc_notify_std (GFC_STD_F2008
, "MODULE PROCEDURE declaration "
9076 if (get_proc_name (name
, &sym
, false))
9079 /* Make sure that the result field is appropriately filled, even though
9080 the result symbol will be replaced later on. */
9081 if (sym
->tlink
&& sym
->tlink
->attr
.function
)
9083 if (sym
->tlink
->result
9084 && sym
->tlink
->result
!= sym
->tlink
)
9085 sym
->result
= sym
->tlink
->result
;
9090 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
9091 the symbol existed before. */
9092 sym
->declared_at
= gfc_current_locus
;
9094 if (!sym
->attr
.module_procedure
)
9097 /* Signal match_end to expect "end procedure". */
9098 sym
->abr_modproc_decl
= 1;
9100 /* Change from IFSRC_IFBODY coming from the interface declaration. */
9101 sym
->attr
.if_source
= IFSRC_DECL
;
9103 gfc_new_block
= sym
;
9105 /* Make a new formal arglist with the symbols in the procedure
9108 for (formal
= sym
->formal
; formal
&& formal
->sym
; formal
= formal
->next
)
9110 if (formal
== sym
->formal
)
9111 head
= tail
= gfc_get_formal_arglist ();
9114 tail
->next
= gfc_get_formal_arglist ();
9118 if (gfc_copy_dummy_sym (&fsym
, formal
->sym
, 0))
9122 gfc_set_sym_referenced (fsym
);
9125 /* The dummy symbols get cleaned up, when the formal_namespace of the
9126 interface declaration is cleared. This allows us to add the
9127 explicit interface as is done for other type of procedure. */
9128 if (!gfc_add_explicit_interface (sym
, IFSRC_DECL
, head
,
9129 &gfc_current_locus
))
9132 if (gfc_match_eos () != MATCH_YES
)
9134 gfc_syntax_error (ST_MODULE_PROC
);
9141 gfc_free_formal_arglist (head
);
9146 /* Match a module procedure statement. Note that we have to modify
9147 symbols in the parent's namespace because the current one was there
9148 to receive symbols that are in an interface's formal argument list. */
9151 gfc_match_modproc (void)
9153 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9157 gfc_namespace
*module_ns
;
9158 gfc_interface
*old_interface_head
, *interface
;
9160 if (gfc_state_stack
->state
!= COMP_INTERFACE
9161 || gfc_state_stack
->previous
== NULL
9162 || current_interface
.type
== INTERFACE_NAMELESS
9163 || current_interface
.type
== INTERFACE_ABSTRACT
)
9165 gfc_error ("MODULE PROCEDURE at %C must be in a generic module "
9170 module_ns
= gfc_current_ns
->parent
;
9171 for (; module_ns
; module_ns
= module_ns
->parent
)
9172 if (module_ns
->proc_name
->attr
.flavor
== FL_MODULE
9173 || module_ns
->proc_name
->attr
.flavor
== FL_PROGRAM
9174 || (module_ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
9175 && !module_ns
->proc_name
->attr
.contained
))
9178 if (module_ns
== NULL
)
9181 /* Store the current state of the interface. We will need it if we
9182 end up with a syntax error and need to recover. */
9183 old_interface_head
= gfc_current_interface_head ();
9185 /* Check if the F2008 optional double colon appears. */
9186 gfc_gobble_whitespace ();
9187 old_locus
= gfc_current_locus
;
9188 if (gfc_match ("::") == MATCH_YES
)
9190 if (!gfc_notify_std (GFC_STD_F2008
, "double colon in "
9191 "MODULE PROCEDURE statement at %L", &old_locus
))
9195 gfc_current_locus
= old_locus
;
9200 old_locus
= gfc_current_locus
;
9202 m
= gfc_match_name (name
);
9208 /* Check for syntax error before starting to add symbols to the
9209 current namespace. */
9210 if (gfc_match_eos () == MATCH_YES
)
9213 if (!last
&& gfc_match_char (',') != MATCH_YES
)
9216 /* Now we're sure the syntax is valid, we process this item
9218 if (gfc_get_symbol (name
, module_ns
, &sym
))
9221 if (sym
->attr
.intrinsic
)
9223 gfc_error ("Intrinsic procedure at %L cannot be a MODULE "
9224 "PROCEDURE", &old_locus
);
9228 if (sym
->attr
.proc
!= PROC_MODULE
9229 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
9232 if (!gfc_add_interface (sym
))
9235 sym
->attr
.mod_proc
= 1;
9236 sym
->declared_at
= old_locus
;
9245 /* Restore the previous state of the interface. */
9246 interface
= gfc_current_interface_head ();
9247 gfc_set_current_interface_head (old_interface_head
);
9249 /* Free the new interfaces. */
9250 while (interface
!= old_interface_head
)
9252 gfc_interface
*i
= interface
->next
;
9257 /* And issue a syntax error. */
9258 gfc_syntax_error (ST_MODULE_PROC
);
9263 /* Check a derived type that is being extended. */
9266 check_extended_derived_type (char *name
)
9268 gfc_symbol
*extended
;
9270 if (gfc_find_symbol (name
, gfc_current_ns
, 1, &extended
))
9272 gfc_error ("Ambiguous symbol in TYPE definition at %C");
9276 extended
= gfc_find_dt_in_generic (extended
);
9281 gfc_error ("Symbol %qs at %C has not been previously defined", name
);
9285 if (extended
->attr
.flavor
!= FL_DERIVED
)
9287 gfc_error ("%qs in EXTENDS expression at %C is not a "
9288 "derived type", name
);
9292 if (extended
->attr
.is_bind_c
)
9294 gfc_error ("%qs cannot be extended at %C because it "
9295 "is BIND(C)", extended
->name
);
9299 if (extended
->attr
.sequence
)
9301 gfc_error ("%qs cannot be extended at %C because it "
9302 "is a SEQUENCE type", extended
->name
);
9310 /* Match the optional attribute specifiers for a type declaration.
9311 Return MATCH_ERROR if an error is encountered in one of the handled
9312 attributes (public, private, bind(c)), MATCH_NO if what's found is
9313 not a handled attribute, and MATCH_YES otherwise. TODO: More error
9314 checking on attribute conflicts needs to be done. */
9317 gfc_get_type_attr_spec (symbol_attribute
*attr
, char *name
)
9319 /* See if the derived type is marked as private. */
9320 if (gfc_match (" , private") == MATCH_YES
)
9322 if (gfc_current_state () != COMP_MODULE
)
9324 gfc_error ("Derived type at %C can only be PRIVATE in the "
9325 "specification part of a module");
9329 if (!gfc_add_access (attr
, ACCESS_PRIVATE
, NULL
, NULL
))
9332 else if (gfc_match (" , public") == MATCH_YES
)
9334 if (gfc_current_state () != COMP_MODULE
)
9336 gfc_error ("Derived type at %C can only be PUBLIC in the "
9337 "specification part of a module");
9341 if (!gfc_add_access (attr
, ACCESS_PUBLIC
, NULL
, NULL
))
9344 else if (gfc_match (" , bind ( c )") == MATCH_YES
)
9346 /* If the type is defined to be bind(c) it then needs to make
9347 sure that all fields are interoperable. This will
9348 need to be a semantic check on the finished derived type.
9349 See 15.2.3 (lines 9-12) of F2003 draft. */
9350 if (!gfc_add_is_bind_c (attr
, NULL
, &gfc_current_locus
, 0))
9353 /* TODO: attr conflicts need to be checked, probably in symbol.c. */
9355 else if (gfc_match (" , abstract") == MATCH_YES
)
9357 if (!gfc_notify_std (GFC_STD_F2003
, "ABSTRACT type at %C"))
9360 if (!gfc_add_abstract (attr
, &gfc_current_locus
))
9363 else if (name
&& gfc_match (" , extends ( %n )", name
) == MATCH_YES
)
9365 if (!gfc_add_extension (attr
, &gfc_current_locus
))
9371 /* If we get here, something matched. */
9376 /* Common function for type declaration blocks similar to derived types, such
9377 as STRUCTURES and MAPs. Unlike derived types, a structure type
9378 does NOT have a generic symbol matching the name given by the user.
9379 STRUCTUREs can share names with variables and PARAMETERs so we must allow
9380 for the creation of an independent symbol.
9381 Other parameters are a message to prefix errors with, the name of the new
9382 type to be created, and the flavor to add to the resulting symbol. */
9385 get_struct_decl (const char *name
, sym_flavor fl
, locus
*decl
,
9386 gfc_symbol
**result
)
9391 gcc_assert (name
[0] == (char) TOUPPER (name
[0]));
9396 where
= gfc_current_locus
;
9398 if (gfc_get_symbol (name
, NULL
, &sym
))
9403 gfc_internal_error ("Failed to create structure type '%s' at %C", name
);
9407 if (sym
->components
!= NULL
|| sym
->attr
.zero_comp
)
9409 gfc_error ("Type definition of %qs at %C was already defined at %L",
9410 sym
->name
, &sym
->declared_at
);
9414 sym
->declared_at
= where
;
9416 if (sym
->attr
.flavor
!= fl
9417 && !gfc_add_flavor (&sym
->attr
, fl
, sym
->name
, NULL
))
9420 if (!sym
->hash_value
)
9421 /* Set the hash for the compound name for this type. */
9422 sym
->hash_value
= gfc_hash_value (sym
);
9424 /* Normally the type is expected to have been completely parsed by the time
9425 a field declaration with this type is seen. For unions, maps, and nested
9426 structure declarations, we need to indicate that it is okay that we
9427 haven't seen any components yet. This will be updated after the structure
9429 sym
->attr
.zero_comp
= 0;
9431 /* Structures always act like derived-types with the SEQUENCE attribute */
9432 gfc_add_sequence (&sym
->attr
, sym
->name
, NULL
);
9434 if (result
) *result
= sym
;
9440 /* Match the opening of a MAP block. Like a struct within a union in C;
9441 behaves identical to STRUCTURE blocks. */
9444 gfc_match_map (void)
9446 /* Counter used to give unique internal names to map structures. */
9447 static unsigned int gfc_map_id
= 0;
9448 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9452 old_loc
= gfc_current_locus
;
9454 if (gfc_match_eos () != MATCH_YES
)
9456 gfc_error ("Junk after MAP statement at %C");
9457 gfc_current_locus
= old_loc
;
9461 /* Map blocks are anonymous so we make up unique names for the symbol table
9462 which are invalid Fortran identifiers. */
9463 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "MM$%u", gfc_map_id
++);
9465 if (!get_struct_decl (name
, FL_STRUCT
, &old_loc
, &sym
))
9468 gfc_new_block
= sym
;
9474 /* Match the opening of a UNION block. */
9477 gfc_match_union (void)
9479 /* Counter used to give unique internal names to union types. */
9480 static unsigned int gfc_union_id
= 0;
9481 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9485 old_loc
= gfc_current_locus
;
9487 if (gfc_match_eos () != MATCH_YES
)
9489 gfc_error ("Junk after UNION statement at %C");
9490 gfc_current_locus
= old_loc
;
9494 /* Unions are anonymous so we make up unique names for the symbol table
9495 which are invalid Fortran identifiers. */
9496 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "UU$%u", gfc_union_id
++);
9498 if (!get_struct_decl (name
, FL_UNION
, &old_loc
, &sym
))
9501 gfc_new_block
= sym
;
9507 /* Match the beginning of a STRUCTURE declaration. This is similar to
9508 matching the beginning of a derived type declaration with a few
9509 twists. The resulting type symbol has no access control or other
9510 interesting attributes. */
9513 gfc_match_structure_decl (void)
9515 /* Counter used to give unique internal names to anonymous structures. */
9516 static unsigned int gfc_structure_id
= 0;
9517 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9522 if (!flag_dec_structure
)
9524 gfc_error ("%s at %C is a DEC extension, enable with "
9525 "%<-fdec-structure%>",
9532 m
= gfc_match (" /%n/", name
);
9535 /* Non-nested structure declarations require a structure name. */
9536 if (!gfc_comp_struct (gfc_current_state ()))
9538 gfc_error ("Structure name expected in non-nested structure "
9539 "declaration at %C");
9542 /* This is an anonymous structure; make up a unique name for it
9543 (upper-case letters never make it to symbol names from the source).
9544 The important thing is initializing the type variable
9545 and setting gfc_new_symbol, which is immediately used by
9546 parse_structure () and variable_decl () to add components of
9548 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "SS$%u", gfc_structure_id
++);
9551 where
= gfc_current_locus
;
9552 /* No field list allowed after non-nested structure declaration. */
9553 if (!gfc_comp_struct (gfc_current_state ())
9554 && gfc_match_eos () != MATCH_YES
)
9556 gfc_error ("Junk after non-nested STRUCTURE statement at %C");
9560 /* Make sure the name is not the name of an intrinsic type. */
9561 if (gfc_is_intrinsic_typename (name
))
9563 gfc_error ("Structure name %qs at %C cannot be the same as an"
9564 " intrinsic type", name
);
9568 /* Store the actual type symbol for the structure with an upper-case first
9569 letter (an invalid Fortran identifier). */
9571 if (!get_struct_decl (gfc_dt_upper_string (name
), FL_STRUCT
, &where
, &sym
))
9574 gfc_new_block
= sym
;
9579 /* This function does some work to determine which matcher should be used to
9580 * match a statement beginning with "TYPE". This is used to disambiguate TYPE
9581 * as an alias for PRINT from derived type declarations, TYPE IS statements,
9582 * and derived type data declarations. */
9585 gfc_match_type (gfc_statement
*st
)
9587 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9591 /* Requires -fdec. */
9595 m
= gfc_match ("type");
9598 /* If we already have an error in the buffer, it is probably from failing to
9599 * match a derived type data declaration. Let it happen. */
9600 else if (gfc_error_flag_test ())
9603 old_loc
= gfc_current_locus
;
9606 /* If we see an attribute list before anything else it's definitely a derived
9607 * type declaration. */
9608 if (gfc_match (" ,") == MATCH_YES
|| gfc_match (" ::") == MATCH_YES
)
9610 gfc_current_locus
= old_loc
;
9611 *st
= ST_DERIVED_DECL
;
9612 return gfc_match_derived_decl ();
9615 /* By now "TYPE" has already been matched. If we do not see a name, this may
9616 * be something like "TYPE *" or "TYPE <fmt>". */
9617 m
= gfc_match_name (name
);
9620 /* Let print match if it can, otherwise throw an error from
9621 * gfc_match_derived_decl. */
9622 gfc_current_locus
= old_loc
;
9623 if (gfc_match_print () == MATCH_YES
)
9628 gfc_current_locus
= old_loc
;
9629 *st
= ST_DERIVED_DECL
;
9630 return gfc_match_derived_decl ();
9633 /* A derived type declaration requires an EOS. Without it, assume print. */
9634 m
= gfc_match_eos ();
9637 /* Check manually for TYPE IS (... - this is invalid print syntax. */
9638 if (strncmp ("is", name
, 3) == 0
9639 && gfc_match (" (", name
) == MATCH_YES
)
9641 gfc_current_locus
= old_loc
;
9642 gcc_assert (gfc_match (" is") == MATCH_YES
);
9644 return gfc_match_type_is ();
9646 gfc_current_locus
= old_loc
;
9648 return gfc_match_print ();
9652 /* By now we have "TYPE <name> <EOS>". Check first if the name is an
9653 * intrinsic typename - if so let gfc_match_derived_decl dump an error.
9654 * Otherwise if gfc_match_derived_decl fails it's probably an existing
9655 * symbol which can be printed. */
9656 gfc_current_locus
= old_loc
;
9657 m
= gfc_match_derived_decl ();
9658 if (gfc_is_intrinsic_typename (name
) || m
== MATCH_YES
)
9660 *st
= ST_DERIVED_DECL
;
9663 gfc_current_locus
= old_loc
;
9665 return gfc_match_print ();
9672 /* Match the beginning of a derived type declaration. If a type name
9673 was the result of a function, then it is possible to have a symbol
9674 already to be known as a derived type yet have no components. */
9677 gfc_match_derived_decl (void)
9679 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9680 char parent
[GFC_MAX_SYMBOL_LEN
+ 1];
9681 symbol_attribute attr
;
9682 gfc_symbol
*sym
, *gensym
;
9683 gfc_symbol
*extended
;
9685 match is_type_attr_spec
= MATCH_NO
;
9686 bool seen_attr
= false;
9687 gfc_interface
*intr
= NULL
, *head
;
9688 bool parameterized_type
= false;
9689 bool seen_colons
= false;
9691 if (gfc_comp_struct (gfc_current_state ()))
9696 gfc_clear_attr (&attr
);
9701 is_type_attr_spec
= gfc_get_type_attr_spec (&attr
, parent
);
9702 if (is_type_attr_spec
== MATCH_ERROR
)
9704 if (is_type_attr_spec
== MATCH_YES
)
9706 } while (is_type_attr_spec
== MATCH_YES
);
9708 /* Deal with derived type extensions. The extension attribute has
9709 been added to 'attr' but now the parent type must be found and
9712 extended
= check_extended_derived_type (parent
);
9714 if (parent
[0] && !extended
)
9717 m
= gfc_match (" ::");
9724 gfc_error ("Expected :: in TYPE definition at %C");
9728 m
= gfc_match (" %n ", name
);
9732 /* Make sure that we don't identify TYPE IS (...) as a parameterized
9733 derived type named 'is'.
9734 TODO Expand the check, when 'name' = "is" by matching " (tname) "
9735 and checking if this is a(n intrinsic) typename. his picks up
9736 misplaced TYPE IS statements such as in select_type_1.f03. */
9737 if (gfc_peek_ascii_char () == '(')
9739 if (gfc_current_state () == COMP_SELECT_TYPE
9740 || (!seen_colons
&& !strcmp (name
, "is")))
9742 parameterized_type
= true;
9745 m
= gfc_match_eos ();
9746 if (m
!= MATCH_YES
&& !parameterized_type
)
9749 /* Make sure the name is not the name of an intrinsic type. */
9750 if (gfc_is_intrinsic_typename (name
))
9752 gfc_error ("Type name %qs at %C cannot be the same as an intrinsic "
9757 if (gfc_get_symbol (name
, NULL
, &gensym
))
9760 if (!gensym
->attr
.generic
&& gensym
->ts
.type
!= BT_UNKNOWN
)
9762 gfc_error ("Derived type name %qs at %C already has a basic type "
9763 "of %s", gensym
->name
, gfc_typename (&gensym
->ts
));
9767 if (!gensym
->attr
.generic
9768 && !gfc_add_generic (&gensym
->attr
, gensym
->name
, NULL
))
9771 if (!gensym
->attr
.function
9772 && !gfc_add_function (&gensym
->attr
, gensym
->name
, NULL
))
9775 sym
= gfc_find_dt_in_generic (gensym
);
9777 if (sym
&& (sym
->components
!= NULL
|| sym
->attr
.zero_comp
))
9779 gfc_error ("Derived type definition of %qs at %C has already been "
9780 "defined", sym
->name
);
9786 /* Use upper case to save the actual derived-type symbol. */
9787 gfc_get_symbol (gfc_dt_upper_string (gensym
->name
), NULL
, &sym
);
9788 sym
->name
= gfc_get_string ("%s", gensym
->name
);
9789 head
= gensym
->generic
;
9790 intr
= gfc_get_interface ();
9792 intr
->where
= gfc_current_locus
;
9793 intr
->sym
->declared_at
= gfc_current_locus
;
9795 gensym
->generic
= intr
;
9796 gensym
->attr
.if_source
= IFSRC_DECL
;
9799 /* The symbol may already have the derived attribute without the
9800 components. The ways this can happen is via a function
9801 definition, an INTRINSIC statement or a subtype in another
9802 derived type that is a pointer. The first part of the AND clause
9803 is true if the symbol is not the return value of a function. */
9804 if (sym
->attr
.flavor
!= FL_DERIVED
9805 && !gfc_add_flavor (&sym
->attr
, FL_DERIVED
, sym
->name
, NULL
))
9808 if (attr
.access
!= ACCESS_UNKNOWN
9809 && !gfc_add_access (&sym
->attr
, attr
.access
, sym
->name
, NULL
))
9811 else if (sym
->attr
.access
== ACCESS_UNKNOWN
9812 && gensym
->attr
.access
!= ACCESS_UNKNOWN
9813 && !gfc_add_access (&sym
->attr
, gensym
->attr
.access
,
9817 if (sym
->attr
.access
!= ACCESS_UNKNOWN
9818 && gensym
->attr
.access
== ACCESS_UNKNOWN
)
9819 gensym
->attr
.access
= sym
->attr
.access
;
9821 /* See if the derived type was labeled as bind(c). */
9822 if (attr
.is_bind_c
!= 0)
9823 sym
->attr
.is_bind_c
= attr
.is_bind_c
;
9825 /* Construct the f2k_derived namespace if it is not yet there. */
9826 if (!sym
->f2k_derived
)
9827 sym
->f2k_derived
= gfc_get_namespace (NULL
, 0);
9829 if (parameterized_type
)
9831 /* Ignore error or mismatches to avoid the component declarations
9832 causing problems later. */
9833 gfc_match_formal_arglist (sym
, 0, 0, true);
9834 m
= gfc_match_eos ();
9837 sym
->attr
.pdt_template
= 1;
9840 if (extended
&& !sym
->components
)
9843 gfc_formal_arglist
*f
, *g
, *h
;
9845 /* Add the extended derived type as the first component. */
9846 gfc_add_component (sym
, parent
, &p
);
9848 gfc_set_sym_referenced (extended
);
9850 p
->ts
.type
= BT_DERIVED
;
9851 p
->ts
.u
.derived
= extended
;
9852 p
->initializer
= gfc_default_initializer (&p
->ts
);
9854 /* Set extension level. */
9855 if (extended
->attr
.extension
== 255)
9857 /* Since the extension field is 8 bit wide, we can only have
9858 up to 255 extension levels. */
9859 gfc_error ("Maximum extension level reached with type %qs at %L",
9860 extended
->name
, &extended
->declared_at
);
9863 sym
->attr
.extension
= extended
->attr
.extension
+ 1;
9865 /* Provide the links between the extended type and its extension. */
9866 if (!extended
->f2k_derived
)
9867 extended
->f2k_derived
= gfc_get_namespace (NULL
, 0);
9869 /* Copy the extended type-param-name-list from the extended type,
9870 append those of the extension and add the whole lot to the
9872 if (extended
->attr
.pdt_template
)
9875 sym
->attr
.pdt_template
= 1;
9876 for (f
= extended
->formal
; f
; f
= f
->next
)
9878 if (f
== extended
->formal
)
9880 g
= gfc_get_formal_arglist ();
9885 g
->next
= gfc_get_formal_arglist ();
9890 g
->next
= sym
->formal
;
9895 if (!sym
->hash_value
)
9896 /* Set the hash for the compound name for this type. */
9897 sym
->hash_value
= gfc_hash_value (sym
);
9899 /* Take over the ABSTRACT attribute. */
9900 sym
->attr
.abstract
= attr
.abstract
;
9902 gfc_new_block
= sym
;
9908 /* Cray Pointees can be declared as:
9909 pointer (ipt, a (n,m,...,*)) */
9912 gfc_mod_pointee_as (gfc_array_spec
*as
)
9914 as
->cray_pointee
= true; /* This will be useful to know later. */
9915 if (as
->type
== AS_ASSUMED_SIZE
)
9916 as
->cp_was_assumed
= true;
9917 else if (as
->type
== AS_ASSUMED_SHAPE
)
9919 gfc_error ("Cray Pointee at %C cannot be assumed shape array");
9926 /* Match the enum definition statement, here we are trying to match
9927 the first line of enum definition statement.
9928 Returns MATCH_YES if match is found. */
9931 gfc_match_enum (void)
9935 m
= gfc_match_eos ();
9939 if (!gfc_notify_std (GFC_STD_F2003
, "ENUM and ENUMERATOR at %C"))
9946 /* Returns an initializer whose value is one higher than the value of the
9947 LAST_INITIALIZER argument. If the argument is NULL, the
9948 initializers value will be set to zero. The initializer's kind
9949 will be set to gfc_c_int_kind.
9951 If -fshort-enums is given, the appropriate kind will be selected
9952 later after all enumerators have been parsed. A warning is issued
9953 here if an initializer exceeds gfc_c_int_kind. */
9956 enum_initializer (gfc_expr
*last_initializer
, locus where
)
9959 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_c_int_kind
, &where
);
9961 mpz_init (result
->value
.integer
);
9963 if (last_initializer
!= NULL
)
9965 mpz_add_ui (result
->value
.integer
, last_initializer
->value
.integer
, 1);
9966 result
->where
= last_initializer
->where
;
9968 if (gfc_check_integer_range (result
->value
.integer
,
9969 gfc_c_int_kind
) != ARITH_OK
)
9971 gfc_error ("Enumerator exceeds the C integer type at %C");
9977 /* Control comes here, if it's the very first enumerator and no
9978 initializer has been given. It will be initialized to zero. */
9979 mpz_set_si (result
->value
.integer
, 0);
9986 /* Match a variable name with an optional initializer. When this
9987 subroutine is called, a variable is expected to be parsed next.
9988 Depending on what is happening at the moment, updates either the
9989 symbol table or the current interface. */
9992 enumerator_decl (void)
9994 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9995 gfc_expr
*initializer
;
9996 gfc_array_spec
*as
= NULL
;
10003 initializer
= NULL
;
10004 old_locus
= gfc_current_locus
;
10006 /* When we get here, we've just matched a list of attributes and
10007 maybe a type and a double colon. The next thing we expect to see
10008 is the name of the symbol. */
10009 m
= gfc_match_name (name
);
10010 if (m
!= MATCH_YES
)
10013 var_locus
= gfc_current_locus
;
10015 /* OK, we've successfully matched the declaration. Now put the
10016 symbol in the current namespace. If we fail to create the symbol,
10018 if (!build_sym (name
, NULL
, false, &as
, &var_locus
))
10024 /* The double colon must be present in order to have initializers.
10025 Otherwise the statement is ambiguous with an assignment statement. */
10028 if (gfc_match_char ('=') == MATCH_YES
)
10030 m
= gfc_match_init_expr (&initializer
);
10033 gfc_error ("Expected an initialization expression at %C");
10037 if (m
!= MATCH_YES
)
10042 /* If we do not have an initializer, the initialization value of the
10043 previous enumerator (stored in last_initializer) is incremented
10044 by 1 and is used to initialize the current enumerator. */
10045 if (initializer
== NULL
)
10046 initializer
= enum_initializer (last_initializer
, old_locus
);
10048 if (initializer
== NULL
|| initializer
->ts
.type
!= BT_INTEGER
)
10050 gfc_error ("ENUMERATOR %L not initialized with integer expression",
10056 /* Store this current initializer, for the next enumerator variable
10057 to be parsed. add_init_expr_to_sym() zeros initializer, so we
10058 use last_initializer below. */
10059 last_initializer
= initializer
;
10060 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
10062 /* Maintain enumerator history. */
10063 gfc_find_symbol (name
, NULL
, 0, &sym
);
10064 create_enum_history (sym
, last_initializer
);
10066 return (t
) ? MATCH_YES
: MATCH_ERROR
;
10069 /* Free stuff up and return. */
10070 gfc_free_expr (initializer
);
10076 /* Match the enumerator definition statement. */
10079 gfc_match_enumerator_def (void)
10084 gfc_clear_ts (¤t_ts
);
10086 m
= gfc_match (" enumerator");
10087 if (m
!= MATCH_YES
)
10090 m
= gfc_match (" :: ");
10091 if (m
== MATCH_ERROR
)
10094 colon_seen
= (m
== MATCH_YES
);
10096 if (gfc_current_state () != COMP_ENUM
)
10098 gfc_error ("ENUM definition statement expected before %C");
10099 gfc_free_enum_history ();
10100 return MATCH_ERROR
;
10103 (¤t_ts
)->type
= BT_INTEGER
;
10104 (¤t_ts
)->kind
= gfc_c_int_kind
;
10106 gfc_clear_attr (¤t_attr
);
10107 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, NULL
);
10116 m
= enumerator_decl ();
10117 if (m
== MATCH_ERROR
)
10119 gfc_free_enum_history ();
10125 if (gfc_match_eos () == MATCH_YES
)
10127 if (gfc_match_char (',') != MATCH_YES
)
10131 if (gfc_current_state () == COMP_ENUM
)
10133 gfc_free_enum_history ();
10134 gfc_error ("Syntax error in ENUMERATOR definition at %C");
10139 gfc_free_array_spec (current_as
);
10146 /* Match binding attributes. */
10149 match_binding_attributes (gfc_typebound_proc
* ba
, bool generic
, bool ppc
)
10151 bool found_passing
= false;
10152 bool seen_ptr
= false;
10153 match m
= MATCH_YES
;
10155 /* Initialize to defaults. Do so even before the MATCH_NO check so that in
10156 this case the defaults are in there. */
10157 ba
->access
= ACCESS_UNKNOWN
;
10158 ba
->pass_arg
= NULL
;
10159 ba
->pass_arg_num
= 0;
10161 ba
->non_overridable
= 0;
10165 /* If we find a comma, we believe there are binding attributes. */
10166 m
= gfc_match_char (',');
10172 /* Access specifier. */
10174 m
= gfc_match (" public");
10175 if (m
== MATCH_ERROR
)
10177 if (m
== MATCH_YES
)
10179 if (ba
->access
!= ACCESS_UNKNOWN
)
10181 gfc_error ("Duplicate access-specifier at %C");
10185 ba
->access
= ACCESS_PUBLIC
;
10189 m
= gfc_match (" private");
10190 if (m
== MATCH_ERROR
)
10192 if (m
== MATCH_YES
)
10194 if (ba
->access
!= ACCESS_UNKNOWN
)
10196 gfc_error ("Duplicate access-specifier at %C");
10200 ba
->access
= ACCESS_PRIVATE
;
10204 /* If inside GENERIC, the following is not allowed. */
10209 m
= gfc_match (" nopass");
10210 if (m
== MATCH_ERROR
)
10212 if (m
== MATCH_YES
)
10216 gfc_error ("Binding attributes already specify passing,"
10217 " illegal NOPASS at %C");
10221 found_passing
= true;
10226 /* PASS possibly including argument. */
10227 m
= gfc_match (" pass");
10228 if (m
== MATCH_ERROR
)
10230 if (m
== MATCH_YES
)
10232 char arg
[GFC_MAX_SYMBOL_LEN
+ 1];
10236 gfc_error ("Binding attributes already specify passing,"
10237 " illegal PASS at %C");
10241 m
= gfc_match (" ( %n )", arg
);
10242 if (m
== MATCH_ERROR
)
10244 if (m
== MATCH_YES
)
10245 ba
->pass_arg
= gfc_get_string ("%s", arg
);
10246 gcc_assert ((m
== MATCH_YES
) == (ba
->pass_arg
!= NULL
));
10248 found_passing
= true;
10255 /* POINTER flag. */
10256 m
= gfc_match (" pointer");
10257 if (m
== MATCH_ERROR
)
10259 if (m
== MATCH_YES
)
10263 gfc_error ("Duplicate POINTER attribute at %C");
10273 /* NON_OVERRIDABLE flag. */
10274 m
= gfc_match (" non_overridable");
10275 if (m
== MATCH_ERROR
)
10277 if (m
== MATCH_YES
)
10279 if (ba
->non_overridable
)
10281 gfc_error ("Duplicate NON_OVERRIDABLE at %C");
10285 ba
->non_overridable
= 1;
10289 /* DEFERRED flag. */
10290 m
= gfc_match (" deferred");
10291 if (m
== MATCH_ERROR
)
10293 if (m
== MATCH_YES
)
10297 gfc_error ("Duplicate DEFERRED at %C");
10308 /* Nothing matching found. */
10310 gfc_error ("Expected access-specifier at %C");
10312 gfc_error ("Expected binding attribute at %C");
10315 while (gfc_match_char (',') == MATCH_YES
);
10317 /* NON_OVERRIDABLE and DEFERRED exclude themselves. */
10318 if (ba
->non_overridable
&& ba
->deferred
)
10320 gfc_error ("NON_OVERRIDABLE and DEFERRED can't both appear at %C");
10327 if (ba
->access
== ACCESS_UNKNOWN
)
10328 ba
->access
= gfc_typebound_default_access
;
10330 if (ppc
&& !seen_ptr
)
10332 gfc_error ("POINTER attribute is required for procedure pointer component"
10340 return MATCH_ERROR
;
10344 /* Match a PROCEDURE specific binding inside a derived type. */
10347 match_procedure_in_type (void)
10349 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10350 char target_buf
[GFC_MAX_SYMBOL_LEN
+ 1];
10351 char* target
= NULL
, *ifc
= NULL
;
10352 gfc_typebound_proc tb
;
10356 gfc_symtree
* stree
;
10361 /* Check current state. */
10362 gcc_assert (gfc_state_stack
->state
== COMP_DERIVED_CONTAINS
);
10363 block
= gfc_state_stack
->previous
->sym
;
10364 gcc_assert (block
);
10366 /* Try to match PROCEDURE(interface). */
10367 if (gfc_match (" (") == MATCH_YES
)
10369 m
= gfc_match_name (target_buf
);
10370 if (m
== MATCH_ERROR
)
10372 if (m
!= MATCH_YES
)
10374 gfc_error ("Interface-name expected after %<(%> at %C");
10375 return MATCH_ERROR
;
10378 if (gfc_match (" )") != MATCH_YES
)
10380 gfc_error ("%<)%> expected at %C");
10381 return MATCH_ERROR
;
10387 /* Construct the data structure. */
10388 memset (&tb
, 0, sizeof (tb
));
10389 tb
.where
= gfc_current_locus
;
10391 /* Match binding attributes. */
10392 m
= match_binding_attributes (&tb
, false, false);
10393 if (m
== MATCH_ERROR
)
10395 seen_attrs
= (m
== MATCH_YES
);
10397 /* Check that attribute DEFERRED is given if an interface is specified. */
10398 if (tb
.deferred
&& !ifc
)
10400 gfc_error ("Interface must be specified for DEFERRED binding at %C");
10401 return MATCH_ERROR
;
10403 if (ifc
&& !tb
.deferred
)
10405 gfc_error ("PROCEDURE(interface) at %C should be declared DEFERRED");
10406 return MATCH_ERROR
;
10409 /* Match the colons. */
10410 m
= gfc_match (" ::");
10411 if (m
== MATCH_ERROR
)
10413 seen_colons
= (m
== MATCH_YES
);
10414 if (seen_attrs
&& !seen_colons
)
10416 gfc_error ("Expected %<::%> after binding-attributes at %C");
10417 return MATCH_ERROR
;
10420 /* Match the binding names. */
10423 m
= gfc_match_name (name
);
10424 if (m
== MATCH_ERROR
)
10428 gfc_error ("Expected binding name at %C");
10429 return MATCH_ERROR
;
10432 if (num
>1 && !gfc_notify_std (GFC_STD_F2008
, "PROCEDURE list at %C"))
10433 return MATCH_ERROR
;
10435 /* Try to match the '=> target', if it's there. */
10437 m
= gfc_match (" =>");
10438 if (m
== MATCH_ERROR
)
10440 if (m
== MATCH_YES
)
10444 gfc_error ("%<=> target%> is invalid for DEFERRED binding at %C");
10445 return MATCH_ERROR
;
10450 gfc_error ("%<::%> needed in PROCEDURE binding with explicit target"
10452 return MATCH_ERROR
;
10455 m
= gfc_match_name (target_buf
);
10456 if (m
== MATCH_ERROR
)
10460 gfc_error ("Expected binding target after %<=>%> at %C");
10461 return MATCH_ERROR
;
10463 target
= target_buf
;
10466 /* If no target was found, it has the same name as the binding. */
10470 /* Get the namespace to insert the symbols into. */
10471 ns
= block
->f2k_derived
;
10474 /* If the binding is DEFERRED, check that the containing type is ABSTRACT. */
10475 if (tb
.deferred
&& !block
->attr
.abstract
)
10477 gfc_error ("Type %qs containing DEFERRED binding at %C "
10478 "is not ABSTRACT", block
->name
);
10479 return MATCH_ERROR
;
10482 /* See if we already have a binding with this name in the symtree which
10483 would be an error. If a GENERIC already targeted this binding, it may
10484 be already there but then typebound is still NULL. */
10485 stree
= gfc_find_symtree (ns
->tb_sym_root
, name
);
10486 if (stree
&& stree
->n
.tb
)
10488 gfc_error ("There is already a procedure with binding name %qs for "
10489 "the derived type %qs at %C", name
, block
->name
);
10490 return MATCH_ERROR
;
10493 /* Insert it and set attributes. */
10497 stree
= gfc_new_symtree (&ns
->tb_sym_root
, name
);
10498 gcc_assert (stree
);
10500 stree
->n
.tb
= gfc_get_typebound_proc (&tb
);
10502 if (gfc_get_sym_tree (target
, gfc_current_ns
, &stree
->n
.tb
->u
.specific
,
10504 return MATCH_ERROR
;
10505 gfc_set_sym_referenced (stree
->n
.tb
->u
.specific
->n
.sym
);
10506 gfc_add_flavor(&stree
->n
.tb
->u
.specific
->n
.sym
->attr
, FL_PROCEDURE
,
10507 target
, &stree
->n
.tb
->u
.specific
->n
.sym
->declared_at
);
10509 if (gfc_match_eos () == MATCH_YES
)
10511 if (gfc_match_char (',') != MATCH_YES
)
10516 gfc_error ("Syntax error in PROCEDURE statement at %C");
10517 return MATCH_ERROR
;
10521 /* Match a GENERIC procedure binding inside a derived type. */
10524 gfc_match_generic (void)
10526 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10527 char bind_name
[GFC_MAX_SYMBOL_LEN
+ 16]; /* Allow space for OPERATOR(...). */
10529 gfc_typebound_proc tbattr
; /* Used for match_binding_attributes. */
10530 gfc_typebound_proc
* tb
;
10532 interface_type op_type
;
10533 gfc_intrinsic_op op
;
10536 /* Check current state. */
10537 if (gfc_current_state () == COMP_DERIVED
)
10539 gfc_error ("GENERIC at %C must be inside a derived-type CONTAINS");
10540 return MATCH_ERROR
;
10542 if (gfc_current_state () != COMP_DERIVED_CONTAINS
)
10544 block
= gfc_state_stack
->previous
->sym
;
10545 ns
= block
->f2k_derived
;
10546 gcc_assert (block
&& ns
);
10548 memset (&tbattr
, 0, sizeof (tbattr
));
10549 tbattr
.where
= gfc_current_locus
;
10551 /* See if we get an access-specifier. */
10552 m
= match_binding_attributes (&tbattr
, true, false);
10553 if (m
== MATCH_ERROR
)
10556 /* Now the colons, those are required. */
10557 if (gfc_match (" ::") != MATCH_YES
)
10559 gfc_error ("Expected %<::%> at %C");
10563 /* Match the binding name; depending on type (operator / generic) format
10564 it for future error messages into bind_name. */
10566 m
= gfc_match_generic_spec (&op_type
, name
, &op
);
10567 if (m
== MATCH_ERROR
)
10568 return MATCH_ERROR
;
10571 gfc_error ("Expected generic name or operator descriptor at %C");
10577 case INTERFACE_GENERIC
:
10578 case INTERFACE_DTIO
:
10579 snprintf (bind_name
, sizeof (bind_name
), "%s", name
);
10582 case INTERFACE_USER_OP
:
10583 snprintf (bind_name
, sizeof (bind_name
), "OPERATOR(.%s.)", name
);
10586 case INTERFACE_INTRINSIC_OP
:
10587 snprintf (bind_name
, sizeof (bind_name
), "OPERATOR(%s)",
10588 gfc_op2string (op
));
10591 case INTERFACE_NAMELESS
:
10592 gfc_error ("Malformed GENERIC statement at %C");
10597 gcc_unreachable ();
10600 /* Match the required =>. */
10601 if (gfc_match (" =>") != MATCH_YES
)
10603 gfc_error ("Expected %<=>%> at %C");
10607 /* Try to find existing GENERIC binding with this name / for this operator;
10608 if there is something, check that it is another GENERIC and then extend
10609 it rather than building a new node. Otherwise, create it and put it
10610 at the right position. */
10614 case INTERFACE_DTIO
:
10615 case INTERFACE_USER_OP
:
10616 case INTERFACE_GENERIC
:
10618 const bool is_op
= (op_type
== INTERFACE_USER_OP
);
10621 st
= gfc_find_symtree (is_op
? ns
->tb_uop_root
: ns
->tb_sym_root
, name
);
10622 tb
= st
? st
->n
.tb
: NULL
;
10626 case INTERFACE_INTRINSIC_OP
:
10627 tb
= ns
->tb_op
[op
];
10631 gcc_unreachable ();
10636 if (!tb
->is_generic
)
10638 gcc_assert (op_type
== INTERFACE_GENERIC
);
10639 gfc_error ("There's already a non-generic procedure with binding name"
10640 " %qs for the derived type %qs at %C",
10641 bind_name
, block
->name
);
10645 if (tb
->access
!= tbattr
.access
)
10647 gfc_error ("Binding at %C must have the same access as already"
10648 " defined binding %qs", bind_name
);
10654 tb
= gfc_get_typebound_proc (NULL
);
10655 tb
->where
= gfc_current_locus
;
10656 tb
->access
= tbattr
.access
;
10657 tb
->is_generic
= 1;
10658 tb
->u
.generic
= NULL
;
10662 case INTERFACE_DTIO
:
10663 case INTERFACE_GENERIC
:
10664 case INTERFACE_USER_OP
:
10666 const bool is_op
= (op_type
== INTERFACE_USER_OP
);
10667 gfc_symtree
* st
= gfc_get_tbp_symtree (is_op
? &ns
->tb_uop_root
:
10668 &ns
->tb_sym_root
, name
);
10675 case INTERFACE_INTRINSIC_OP
:
10676 ns
->tb_op
[op
] = tb
;
10680 gcc_unreachable ();
10684 /* Now, match all following names as specific targets. */
10687 gfc_symtree
* target_st
;
10688 gfc_tbp_generic
* target
;
10690 m
= gfc_match_name (name
);
10691 if (m
== MATCH_ERROR
)
10695 gfc_error ("Expected specific binding name at %C");
10699 target_st
= gfc_get_tbp_symtree (&ns
->tb_sym_root
, name
);
10701 /* See if this is a duplicate specification. */
10702 for (target
= tb
->u
.generic
; target
; target
= target
->next
)
10703 if (target_st
== target
->specific_st
)
10705 gfc_error ("%qs already defined as specific binding for the"
10706 " generic %qs at %C", name
, bind_name
);
10710 target
= gfc_get_tbp_generic ();
10711 target
->specific_st
= target_st
;
10712 target
->specific
= NULL
;
10713 target
->next
= tb
->u
.generic
;
10714 target
->is_operator
= ((op_type
== INTERFACE_USER_OP
)
10715 || (op_type
== INTERFACE_INTRINSIC_OP
));
10716 tb
->u
.generic
= target
;
10718 while (gfc_match (" ,") == MATCH_YES
);
10720 /* Here should be the end. */
10721 if (gfc_match_eos () != MATCH_YES
)
10723 gfc_error ("Junk after GENERIC binding at %C");
10730 return MATCH_ERROR
;
10734 /* Match a FINAL declaration inside a derived type. */
10737 gfc_match_final_decl (void)
10739 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10742 gfc_namespace
* module_ns
;
10746 if (gfc_current_form
== FORM_FREE
)
10748 char c
= gfc_peek_ascii_char ();
10749 if (!gfc_is_whitespace (c
) && c
!= ':')
10753 if (gfc_state_stack
->state
!= COMP_DERIVED_CONTAINS
)
10755 if (gfc_current_form
== FORM_FIXED
)
10758 gfc_error ("FINAL declaration at %C must be inside a derived type "
10759 "CONTAINS section");
10760 return MATCH_ERROR
;
10763 block
= gfc_state_stack
->previous
->sym
;
10764 gcc_assert (block
);
10766 if (!gfc_state_stack
->previous
|| !gfc_state_stack
->previous
->previous
10767 || gfc_state_stack
->previous
->previous
->state
!= COMP_MODULE
)
10769 gfc_error ("Derived type declaration with FINAL at %C must be in the"
10770 " specification part of a MODULE");
10771 return MATCH_ERROR
;
10774 module_ns
= gfc_current_ns
;
10775 gcc_assert (module_ns
);
10776 gcc_assert (module_ns
->proc_name
->attr
.flavor
== FL_MODULE
);
10778 /* Match optional ::, don't care about MATCH_YES or MATCH_NO. */
10779 if (gfc_match (" ::") == MATCH_ERROR
)
10780 return MATCH_ERROR
;
10782 /* Match the sequence of procedure names. */
10789 if (first
&& gfc_match_eos () == MATCH_YES
)
10791 gfc_error ("Empty FINAL at %C");
10792 return MATCH_ERROR
;
10795 m
= gfc_match_name (name
);
10798 gfc_error ("Expected module procedure name at %C");
10799 return MATCH_ERROR
;
10801 else if (m
!= MATCH_YES
)
10802 return MATCH_ERROR
;
10804 if (gfc_match_eos () == MATCH_YES
)
10806 if (!last
&& gfc_match_char (',') != MATCH_YES
)
10808 gfc_error ("Expected %<,%> at %C");
10809 return MATCH_ERROR
;
10812 if (gfc_get_symbol (name
, module_ns
, &sym
))
10814 gfc_error ("Unknown procedure name %qs at %C", name
);
10815 return MATCH_ERROR
;
10818 /* Mark the symbol as module procedure. */
10819 if (sym
->attr
.proc
!= PROC_MODULE
10820 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
10821 return MATCH_ERROR
;
10823 /* Check if we already have this symbol in the list, this is an error. */
10824 for (f
= block
->f2k_derived
->finalizers
; f
; f
= f
->next
)
10825 if (f
->proc_sym
== sym
)
10827 gfc_error ("%qs at %C is already defined as FINAL procedure",
10829 return MATCH_ERROR
;
10832 /* Add this symbol to the list of finalizers. */
10833 gcc_assert (block
->f2k_derived
);
10835 f
= XCNEW (gfc_finalizer
);
10837 f
->proc_tree
= NULL
;
10838 f
->where
= gfc_current_locus
;
10839 f
->next
= block
->f2k_derived
->finalizers
;
10840 block
->f2k_derived
->finalizers
= f
;
10850 const ext_attr_t ext_attr_list
[] = {
10851 { "dllimport", EXT_ATTR_DLLIMPORT
, "dllimport" },
10852 { "dllexport", EXT_ATTR_DLLEXPORT
, "dllexport" },
10853 { "cdecl", EXT_ATTR_CDECL
, "cdecl" },
10854 { "stdcall", EXT_ATTR_STDCALL
, "stdcall" },
10855 { "fastcall", EXT_ATTR_FASTCALL
, "fastcall" },
10856 { "no_arg_check", EXT_ATTR_NO_ARG_CHECK
, NULL
},
10857 { NULL
, EXT_ATTR_LAST
, NULL
}
10860 /* Match a !GCC$ ATTRIBUTES statement of the form:
10861 !GCC$ ATTRIBUTES attribute-list :: var-name [, var-name] ...
10862 When we come here, we have already matched the !GCC$ ATTRIBUTES string.
10864 TODO: We should support all GCC attributes using the same syntax for
10865 the attribute list, i.e. the list in C
10866 __attributes(( attribute-list ))
10868 !GCC$ ATTRIBUTES attribute-list ::
10869 Cf. c-parser.c's c_parser_attributes; the data can then directly be
10872 As there is absolutely no risk of confusion, we should never return
10875 gfc_match_gcc_attributes (void)
10877 symbol_attribute attr
;
10878 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10883 gfc_clear_attr (&attr
);
10888 if (gfc_match_name (name
) != MATCH_YES
)
10889 return MATCH_ERROR
;
10891 for (id
= 0; id
< EXT_ATTR_LAST
; id
++)
10892 if (strcmp (name
, ext_attr_list
[id
].name
) == 0)
10895 if (id
== EXT_ATTR_LAST
)
10897 gfc_error ("Unknown attribute in !GCC$ ATTRIBUTES statement at %C");
10898 return MATCH_ERROR
;
10901 if (!gfc_add_ext_attribute (&attr
, (ext_attr_id_t
)id
, &gfc_current_locus
))
10902 return MATCH_ERROR
;
10904 gfc_gobble_whitespace ();
10905 ch
= gfc_next_ascii_char ();
10908 /* This is the successful exit condition for the loop. */
10909 if (gfc_next_ascii_char () == ':')
10919 if (gfc_match_eos () == MATCH_YES
)
10924 m
= gfc_match_name (name
);
10925 if (m
!= MATCH_YES
)
10928 if (find_special (name
, &sym
, true))
10929 return MATCH_ERROR
;
10931 sym
->attr
.ext_attr
|= attr
.ext_attr
;
10933 if (gfc_match_eos () == MATCH_YES
)
10936 if (gfc_match_char (',') != MATCH_YES
)
10943 gfc_error ("Syntax error in !GCC$ ATTRIBUTES statement at %C");
10944 return MATCH_ERROR
;