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 || c
->ts
.type
== BT_CHARACTER
)
1975 && saved_kind_expr
!= NULL
)
1976 c
->kind_expr
= gfc_copy_expr (saved_kind_expr
);
1978 c
->attr
= current_attr
;
1980 c
->initializer
= *init
;
1987 c
->attr
.codimension
= 1;
1989 c
->attr
.dimension
= 1;
1993 gfc_apply_init (&c
->ts
, &c
->attr
, c
->initializer
);
1995 /* Check array components. */
1996 if (!c
->attr
.dimension
)
1999 if (c
->attr
.pointer
)
2001 if (c
->as
->type
!= AS_DEFERRED
)
2003 gfc_error ("Pointer array component of structure at %C must have a "
2008 else if (c
->attr
.allocatable
)
2010 if (c
->as
->type
!= AS_DEFERRED
)
2012 gfc_error ("Allocatable component of structure at %C must have a "
2019 if (c
->as
->type
!= AS_EXPLICIT
)
2021 gfc_error ("Array component of structure at %C must have an "
2028 if (c
->ts
.type
== BT_CLASS
)
2029 return gfc_build_class_symbol (&c
->ts
, &c
->attr
, &c
->as
);
2031 if (c
->attr
.pdt_kind
|| c
->attr
.pdt_len
)
2034 gfc_find_symbol (c
->name
, gfc_current_block ()->f2k_derived
,
2038 gfc_error ("Type parameter %qs at %C has no corresponding entry "
2039 "in the type parameter name list at %L",
2040 c
->name
, &gfc_current_block ()->declared_at
);
2044 sym
->attr
.pdt_kind
= c
->attr
.pdt_kind
;
2045 sym
->attr
.pdt_len
= c
->attr
.pdt_len
;
2047 sym
->value
= gfc_copy_expr (c
->initializer
);
2048 sym
->attr
.flavor
= FL_VARIABLE
;
2051 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
2052 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_template
2053 && decl_type_param_list
)
2054 c
->param_list
= gfc_copy_actual_arglist (decl_type_param_list
);
2060 /* Match a 'NULL()', and possibly take care of some side effects. */
2063 gfc_match_null (gfc_expr
**result
)
2066 match m
, m2
= MATCH_NO
;
2068 if ((m
= gfc_match (" null ( )")) == MATCH_ERROR
)
2074 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2076 if ((m2
= gfc_match (" null (")) != MATCH_YES
)
2079 old_loc
= gfc_current_locus
;
2080 if ((m2
= gfc_match (" %n ) ", name
)) == MATCH_ERROR
)
2083 && ((m2
= gfc_match (" mold = %n )", name
)) == MATCH_ERROR
))
2087 gfc_current_locus
= old_loc
;
2092 /* The NULL symbol now has to be/become an intrinsic function. */
2093 if (gfc_get_symbol ("null", NULL
, &sym
))
2095 gfc_error ("NULL() initialization at %C is ambiguous");
2099 gfc_intrinsic_symbol (sym
);
2101 if (sym
->attr
.proc
!= PROC_INTRINSIC
2102 && !(sym
->attr
.use_assoc
&& sym
->attr
.intrinsic
)
2103 && (!gfc_add_procedure(&sym
->attr
, PROC_INTRINSIC
, sym
->name
, NULL
)
2104 || !gfc_add_function (&sym
->attr
, sym
->name
, NULL
)))
2107 *result
= gfc_get_null_expr (&gfc_current_locus
);
2109 /* Invalid per F2008, C512. */
2110 if (m2
== MATCH_YES
)
2112 gfc_error ("NULL() initialization at %C may not have MOLD");
2120 /* Match the initialization expr for a data pointer or procedure pointer. */
2123 match_pointer_init (gfc_expr
**init
, int procptr
)
2127 if (gfc_pure (NULL
) && !gfc_comp_struct (gfc_state_stack
->state
))
2129 gfc_error ("Initialization of pointer at %C is not allowed in "
2130 "a PURE procedure");
2133 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
2135 /* Match NULL() initialization. */
2136 m
= gfc_match_null (init
);
2140 /* Match non-NULL initialization. */
2141 gfc_matching_ptr_assignment
= !procptr
;
2142 gfc_matching_procptr_assignment
= procptr
;
2143 m
= gfc_match_rvalue (init
);
2144 gfc_matching_ptr_assignment
= 0;
2145 gfc_matching_procptr_assignment
= 0;
2146 if (m
== MATCH_ERROR
)
2148 else if (m
== MATCH_NO
)
2150 gfc_error ("Error in pointer initialization at %C");
2154 if (!procptr
&& !gfc_resolve_expr (*init
))
2157 if (!gfc_notify_std (GFC_STD_F2008
, "non-NULL pointer "
2158 "initialization at %C"))
2166 check_function_name (char *name
)
2168 /* In functions that have a RESULT variable defined, the function name always
2169 refers to function calls. Therefore, the name is not allowed to appear in
2170 specification statements. When checking this, be careful about
2171 'hidden' procedure pointer results ('ppr@'). */
2173 if (gfc_current_state () == COMP_FUNCTION
)
2175 gfc_symbol
*block
= gfc_current_block ();
2176 if (block
&& block
->result
&& block
->result
!= block
2177 && strcmp (block
->result
->name
, "ppr@") != 0
2178 && strcmp (block
->name
, name
) == 0)
2180 gfc_error ("Function name %qs not allowed at %C", name
);
2189 /* Match a variable name with an optional initializer. When this
2190 subroutine is called, a variable is expected to be parsed next.
2191 Depending on what is happening at the moment, updates either the
2192 symbol table or the current interface. */
2195 variable_decl (int elem
)
2197 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2198 static unsigned int fill_id
= 0;
2199 gfc_expr
*initializer
, *char_len
;
2201 gfc_array_spec
*cp_as
; /* Extra copy for Cray Pointees. */
2213 /* When we get here, we've just matched a list of attributes and
2214 maybe a type and a double colon. The next thing we expect to see
2215 is the name of the symbol. */
2217 /* If we are parsing a structure with legacy support, we allow the symbol
2218 name to be '%FILL' which gives it an anonymous (inaccessible) name. */
2220 gfc_gobble_whitespace ();
2221 if (gfc_peek_ascii_char () == '%')
2223 gfc_next_ascii_char ();
2224 m
= gfc_match ("fill");
2229 m
= gfc_match_name (name
);
2237 if (gfc_current_state () != COMP_STRUCTURE
)
2239 if (flag_dec_structure
)
2240 gfc_error ("%qs not allowed outside STRUCTURE at %C", "%FILL");
2242 gfc_error ("%qs at %C is a DEC extension, enable with "
2243 "%<-fdec-structure%>", "%FILL");
2249 gfc_error ("%qs entity cannot have attributes at %C", "%FILL");
2253 /* %FILL components are given invalid fortran names. */
2254 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "%%FILL%u", fill_id
++);
2258 var_locus
= gfc_current_locus
;
2260 /* Now we could see the optional array spec. or character length. */
2261 m
= gfc_match_array_spec (&as
, true, true);
2262 if (m
== MATCH_ERROR
)
2266 as
= gfc_copy_array_spec (current_as
);
2268 && !merge_array_spec (current_as
, as
, true))
2274 if (flag_cray_pointer
)
2275 cp_as
= gfc_copy_array_spec (as
);
2277 /* At this point, we know for sure if the symbol is PARAMETER and can thus
2278 determine (and check) whether it can be implied-shape. If it
2279 was parsed as assumed-size, change it because PARAMETERs can not
2283 if (as
->type
== AS_IMPLIED_SHAPE
&& current_attr
.flavor
!= FL_PARAMETER
)
2286 gfc_error ("Non-PARAMETER symbol %qs at %L can't be implied-shape",
2291 if (as
->type
== AS_ASSUMED_SIZE
&& as
->rank
== 1
2292 && current_attr
.flavor
== FL_PARAMETER
)
2293 as
->type
= AS_IMPLIED_SHAPE
;
2295 if (as
->type
== AS_IMPLIED_SHAPE
2296 && !gfc_notify_std (GFC_STD_F2008
, "Implied-shape array at %L",
2306 cl_deferred
= false;
2308 if (current_ts
.type
== BT_CHARACTER
)
2310 switch (match_char_length (&char_len
, &cl_deferred
, false))
2313 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2315 cl
->length
= char_len
;
2318 /* Non-constant lengths need to be copied after the first
2319 element. Also copy assumed lengths. */
2322 && (current_ts
.u
.cl
->length
== NULL
2323 || current_ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
2325 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2326 cl
->length
= gfc_copy_expr (current_ts
.u
.cl
->length
);
2329 cl
= current_ts
.u
.cl
;
2331 cl_deferred
= current_ts
.deferred
;
2340 /* The dummy arguments and result of the abreviated form of MODULE
2341 PROCEDUREs, used in SUBMODULES should not be redefined. */
2342 if (gfc_current_ns
->proc_name
2343 && gfc_current_ns
->proc_name
->abr_modproc_decl
)
2345 gfc_find_symbol (name
, gfc_current_ns
, 1, &sym
);
2346 if (sym
!= NULL
&& (sym
->attr
.dummy
|| sym
->attr
.result
))
2349 gfc_error ("%qs at %C is a redefinition of the declaration "
2350 "in the corresponding interface for MODULE "
2351 "PROCEDURE %qs", sym
->name
,
2352 gfc_current_ns
->proc_name
->name
);
2357 /* %FILL components may not have initializers. */
2358 if (strncmp (name
, "%FILL", 5) == 0 && gfc_match_eos () != MATCH_YES
)
2360 gfc_error ("%qs entity cannot have an initializer at %C", "%FILL");
2365 /* If this symbol has already shown up in a Cray Pointer declaration,
2366 and this is not a component declaration,
2367 then we want to set the type & bail out. */
2368 if (flag_cray_pointer
&& !gfc_comp_struct (gfc_current_state ()))
2370 gfc_find_symbol (name
, gfc_current_ns
, 1, &sym
);
2371 if (sym
!= NULL
&& sym
->attr
.cray_pointee
)
2373 sym
->ts
.type
= current_ts
.type
;
2374 sym
->ts
.kind
= current_ts
.kind
;
2376 sym
->ts
.u
.derived
= current_ts
.u
.derived
;
2377 sym
->ts
.is_c_interop
= current_ts
.is_c_interop
;
2378 sym
->ts
.is_iso_c
= current_ts
.is_iso_c
;
2381 /* Check to see if we have an array specification. */
2384 if (sym
->as
!= NULL
)
2386 gfc_error ("Duplicate array spec for Cray pointee at %C");
2387 gfc_free_array_spec (cp_as
);
2393 if (!gfc_set_array_spec (sym
, cp_as
, &var_locus
))
2394 gfc_internal_error ("Couldn't set pointee array spec.");
2396 /* Fix the array spec. */
2397 m
= gfc_mod_pointee_as (sym
->as
);
2398 if (m
== MATCH_ERROR
)
2406 gfc_free_array_spec (cp_as
);
2410 /* Procedure pointer as function result. */
2411 if (gfc_current_state () == COMP_FUNCTION
2412 && strcmp ("ppr@", gfc_current_block ()->name
) == 0
2413 && strcmp (name
, gfc_current_block ()->ns
->proc_name
->name
) == 0)
2414 strcpy (name
, "ppr@");
2416 if (gfc_current_state () == COMP_FUNCTION
2417 && strcmp (name
, gfc_current_block ()->name
) == 0
2418 && gfc_current_block ()->result
2419 && strcmp ("ppr@", gfc_current_block ()->result
->name
) == 0)
2420 strcpy (name
, "ppr@");
2422 /* OK, we've successfully matched the declaration. Now put the
2423 symbol in the current namespace, because it might be used in the
2424 optional initialization expression for this symbol, e.g. this is
2427 integer, parameter :: i = huge(i)
2429 This is only true for parameters or variables of a basic type.
2430 For components of derived types, it is not true, so we don't
2431 create a symbol for those yet. If we fail to create the symbol,
2433 if (!gfc_comp_struct (gfc_current_state ())
2434 && !build_sym (name
, cl
, cl_deferred
, &as
, &var_locus
))
2440 if (!check_function_name (name
))
2446 /* We allow old-style initializations of the form
2447 integer i /2/, j(4) /3*3, 1/
2448 (if no colon has been seen). These are different from data
2449 statements in that initializers are only allowed to apply to the
2450 variable immediately preceding, i.e.
2452 is not allowed. Therefore we have to do some work manually, that
2453 could otherwise be left to the matchers for DATA statements. */
2455 if (!colon_seen
&& gfc_match (" /") == MATCH_YES
)
2457 if (!gfc_notify_std (GFC_STD_GNU
, "Old-style "
2458 "initialization at %C"))
2461 /* Allow old style initializations for components of STRUCTUREs and MAPs
2462 but not components of derived types. */
2463 else if (gfc_current_state () == COMP_DERIVED
)
2465 gfc_error ("Invalid old style initialization for derived type "
2471 /* For structure components, read the initializer as a special
2472 expression and let the rest of this function apply the initializer
2474 else if (gfc_comp_struct (gfc_current_state ()))
2476 m
= match_clist_expr (&initializer
, ¤t_ts
, as
);
2478 gfc_error ("Syntax error in old style initialization of %s at %C",
2484 /* Otherwise we treat the old style initialization just like a
2485 DATA declaration for the current variable. */
2487 return match_old_style_init (name
);
2490 /* The double colon must be present in order to have initializers.
2491 Otherwise the statement is ambiguous with an assignment statement. */
2494 if (gfc_match (" =>") == MATCH_YES
)
2496 if (!current_attr
.pointer
)
2498 gfc_error ("Initialization at %C isn't for a pointer variable");
2503 m
= match_pointer_init (&initializer
, 0);
2507 else if (gfc_match_char ('=') == MATCH_YES
)
2509 if (current_attr
.pointer
)
2511 gfc_error ("Pointer initialization at %C requires %<=>%>, "
2517 m
= gfc_match_init_expr (&initializer
);
2520 gfc_error ("Expected an initialization expression at %C");
2524 if (current_attr
.flavor
!= FL_PARAMETER
&& gfc_pure (NULL
)
2525 && !gfc_comp_struct (gfc_state_stack
->state
))
2527 gfc_error ("Initialization of variable at %C is not allowed in "
2528 "a PURE procedure");
2532 if (current_attr
.flavor
!= FL_PARAMETER
2533 && !gfc_comp_struct (gfc_state_stack
->state
))
2534 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
2541 if (initializer
!= NULL
&& current_attr
.allocatable
2542 && gfc_comp_struct (gfc_current_state ()))
2544 gfc_error ("Initialization of allocatable component at %C is not "
2550 if (gfc_current_state () == COMP_DERIVED
2551 && gfc_current_block ()->attr
.pdt_template
)
2554 gfc_find_symbol (name
, gfc_current_block ()->f2k_derived
,
2556 if (!param
&& (current_attr
.pdt_kind
|| current_attr
.pdt_len
))
2558 gfc_error ("The component with KIND or LEN attribute at %C does not "
2559 "not appear in the type parameter list at %L",
2560 &gfc_current_block ()->declared_at
);
2564 else if (param
&& !(current_attr
.pdt_kind
|| current_attr
.pdt_len
))
2566 gfc_error ("The component at %C that appears in the type parameter "
2567 "list at %L has neither the KIND nor LEN attribute",
2568 &gfc_current_block ()->declared_at
);
2572 else if (as
&& (current_attr
.pdt_kind
|| current_attr
.pdt_len
))
2574 gfc_error ("The component at %C which is a type parameter must be "
2579 else if (param
&& initializer
)
2580 param
->value
= gfc_copy_expr (initializer
);
2583 /* Add the initializer. Note that it is fine if initializer is
2584 NULL here, because we sometimes also need to check if a
2585 declaration *must* have an initialization expression. */
2586 if (!gfc_comp_struct (gfc_current_state ()))
2587 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
2590 if (current_ts
.type
== BT_DERIVED
2591 && !current_attr
.pointer
&& !initializer
)
2592 initializer
= gfc_default_initializer (¤t_ts
);
2593 t
= build_struct (name
, cl
, &initializer
, &as
);
2595 /* If we match a nested structure definition we expect to see the
2596 * body even if the variable declarations blow up, so we need to keep
2597 * the structure declaration around. */
2598 if (gfc_new_block
&& gfc_new_block
->attr
.flavor
== FL_STRUCT
)
2599 gfc_commit_symbol (gfc_new_block
);
2602 m
= (t
) ? MATCH_YES
: MATCH_ERROR
;
2605 /* Free stuff up and return. */
2606 gfc_free_expr (initializer
);
2607 gfc_free_array_spec (as
);
2613 /* Match an extended-f77 "TYPESPEC*bytesize"-style kind specification.
2614 This assumes that the byte size is equal to the kind number for
2615 non-COMPLEX types, and equal to twice the kind number for COMPLEX. */
2618 gfc_match_old_kind_spec (gfc_typespec
*ts
)
2623 if (gfc_match_char ('*') != MATCH_YES
)
2626 m
= gfc_match_small_literal_int (&ts
->kind
, NULL
);
2630 original_kind
= ts
->kind
;
2632 /* Massage the kind numbers for complex types. */
2633 if (ts
->type
== BT_COMPLEX
)
2637 gfc_error ("Old-style type declaration %s*%d not supported at %C",
2638 gfc_basic_typename (ts
->type
), original_kind
);
2645 if (ts
->type
== BT_INTEGER
&& ts
->kind
== 4 && flag_integer4_kind
== 8)
2648 if (ts
->type
== BT_REAL
|| ts
->type
== BT_COMPLEX
)
2652 if (flag_real4_kind
== 8)
2654 if (flag_real4_kind
== 10)
2656 if (flag_real4_kind
== 16)
2662 if (flag_real8_kind
== 4)
2664 if (flag_real8_kind
== 10)
2666 if (flag_real8_kind
== 16)
2671 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
2673 gfc_error ("Old-style type declaration %s*%d not supported at %C",
2674 gfc_basic_typename (ts
->type
), original_kind
);
2678 if (!gfc_notify_std (GFC_STD_GNU
,
2679 "Nonstandard type declaration %s*%d at %C",
2680 gfc_basic_typename(ts
->type
), original_kind
))
2687 /* Match a kind specification. Since kinds are generally optional, we
2688 usually return MATCH_NO if something goes wrong. If a "kind="
2689 string is found, then we know we have an error. */
2692 gfc_match_kind_spec (gfc_typespec
*ts
, bool kind_expr_only
)
2702 saved_kind_expr
= NULL
;
2704 where
= loc
= gfc_current_locus
;
2709 if (gfc_match_char ('(') == MATCH_NO
)
2712 /* Also gobbles optional text. */
2713 if (gfc_match (" kind = ") == MATCH_YES
)
2716 loc
= gfc_current_locus
;
2720 n
= gfc_match_init_expr (&e
);
2722 if (gfc_derived_parameter_expr (e
))
2725 saved_kind_expr
= gfc_copy_expr (e
);
2726 goto close_brackets
;
2731 if (gfc_matching_function
)
2733 /* The function kind expression might include use associated or
2734 imported parameters and try again after the specification
2736 if (gfc_match_char (')') != MATCH_YES
)
2738 gfc_error ("Missing right parenthesis at %C");
2744 gfc_undo_symbols ();
2749 /* ....or else, the match is real. */
2751 gfc_error ("Expected initialization expression at %C");
2759 gfc_error ("Expected scalar initialization expression at %C");
2764 if (gfc_extract_int (e
, &ts
->kind
, 1))
2770 /* Before throwing away the expression, let's see if we had a
2771 C interoperable kind (and store the fact). */
2772 if (e
->ts
.is_c_interop
== 1)
2774 /* Mark this as C interoperable if being declared with one
2775 of the named constants from iso_c_binding. */
2776 ts
->is_c_interop
= e
->ts
.is_iso_c
;
2777 ts
->f90_type
= e
->ts
.f90_type
;
2779 ts
->interop_kind
= e
->symtree
->n
.sym
;
2785 /* Ignore errors to this point, if we've gotten here. This means
2786 we ignore the m=MATCH_ERROR from above. */
2787 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
2789 gfc_error ("Kind %d not supported for type %s at %C", ts
->kind
,
2790 gfc_basic_typename (ts
->type
));
2791 gfc_current_locus
= where
;
2795 /* Warn if, e.g., c_int is used for a REAL variable, but not
2796 if, e.g., c_double is used for COMPLEX as the standard
2797 explicitly says that the kind type parameter for complex and real
2798 variable is the same, i.e. c_float == c_float_complex. */
2799 if (ts
->f90_type
!= BT_UNKNOWN
&& ts
->f90_type
!= ts
->type
2800 && !((ts
->f90_type
== BT_REAL
&& ts
->type
== BT_COMPLEX
)
2801 || (ts
->f90_type
== BT_COMPLEX
&& ts
->type
== BT_REAL
)))
2802 gfc_warning_now (0, "C kind type parameter is for type %s but type at %L "
2803 "is %s", gfc_basic_typename (ts
->f90_type
), &where
,
2804 gfc_basic_typename (ts
->type
));
2808 gfc_gobble_whitespace ();
2809 if ((c
= gfc_next_ascii_char ()) != ')'
2810 && (ts
->type
!= BT_CHARACTER
|| c
!= ','))
2812 if (ts
->type
== BT_CHARACTER
)
2813 gfc_error ("Missing right parenthesis or comma at %C");
2815 gfc_error ("Missing right parenthesis at %C");
2819 /* All tests passed. */
2822 if(m
== MATCH_ERROR
)
2823 gfc_current_locus
= where
;
2825 if (ts
->type
== BT_INTEGER
&& ts
->kind
== 4 && flag_integer4_kind
== 8)
2828 if (ts
->type
== BT_REAL
|| ts
->type
== BT_COMPLEX
)
2832 if (flag_real4_kind
== 8)
2834 if (flag_real4_kind
== 10)
2836 if (flag_real4_kind
== 16)
2842 if (flag_real8_kind
== 4)
2844 if (flag_real8_kind
== 10)
2846 if (flag_real8_kind
== 16)
2851 /* Return what we know from the test(s). */
2856 gfc_current_locus
= where
;
2862 match_char_kind (int * kind
, int * is_iso_c
)
2871 where
= gfc_current_locus
;
2873 n
= gfc_match_init_expr (&e
);
2875 if (n
!= MATCH_YES
&& gfc_matching_function
)
2877 /* The expression might include use-associated or imported
2878 parameters and try again after the specification
2881 gfc_undo_symbols ();
2886 gfc_error ("Expected initialization expression at %C");
2892 gfc_error ("Expected scalar initialization expression at %C");
2897 if (gfc_derived_parameter_expr (e
))
2899 saved_kind_expr
= e
;
2904 fail
= gfc_extract_int (e
, kind
, 1);
2905 *is_iso_c
= e
->ts
.is_iso_c
;
2914 /* Ignore errors to this point, if we've gotten here. This means
2915 we ignore the m=MATCH_ERROR from above. */
2916 if (gfc_validate_kind (BT_CHARACTER
, *kind
, true) < 0)
2918 gfc_error ("Kind %d is not supported for CHARACTER at %C", *kind
);
2922 /* All tests passed. */
2925 if (m
== MATCH_ERROR
)
2926 gfc_current_locus
= where
;
2928 /* Return what we know from the test(s). */
2933 gfc_current_locus
= where
;
2938 /* Match the various kind/length specifications in a CHARACTER
2939 declaration. We don't return MATCH_NO. */
2942 gfc_match_char_spec (gfc_typespec
*ts
)
2944 int kind
, seen_length
, is_iso_c
;
2956 /* Try the old-style specification first. */
2957 old_char_selector
= 0;
2959 m
= match_char_length (&len
, &deferred
, true);
2963 old_char_selector
= 1;
2968 m
= gfc_match_char ('(');
2971 m
= MATCH_YES
; /* Character without length is a single char. */
2975 /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ). */
2976 if (gfc_match (" kind =") == MATCH_YES
)
2978 m
= match_char_kind (&kind
, &is_iso_c
);
2980 if (m
== MATCH_ERROR
)
2985 if (gfc_match (" , len =") == MATCH_NO
)
2988 m
= char_len_param_value (&len
, &deferred
);
2991 if (m
== MATCH_ERROR
)
2998 /* Try to match "LEN = <len-param>" or "LEN = <len-param>, KIND = <int>". */
2999 if (gfc_match (" len =") == MATCH_YES
)
3001 m
= char_len_param_value (&len
, &deferred
);
3004 if (m
== MATCH_ERROR
)
3008 if (gfc_match_char (')') == MATCH_YES
)
3011 if (gfc_match (" , kind =") != MATCH_YES
)
3014 if (match_char_kind (&kind
, &is_iso_c
) == MATCH_ERROR
)
3020 /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ). */
3021 m
= char_len_param_value (&len
, &deferred
);
3024 if (m
== MATCH_ERROR
)
3028 m
= gfc_match_char (')');
3032 if (gfc_match_char (',') != MATCH_YES
)
3035 gfc_match (" kind ="); /* Gobble optional text. */
3037 m
= match_char_kind (&kind
, &is_iso_c
);
3038 if (m
== MATCH_ERROR
)
3044 /* Require a right-paren at this point. */
3045 m
= gfc_match_char (')');
3050 gfc_error ("Syntax error in CHARACTER declaration at %C");
3052 gfc_free_expr (len
);
3056 /* Deal with character functions after USE and IMPORT statements. */
3057 if (gfc_matching_function
)
3059 gfc_free_expr (len
);
3060 gfc_undo_symbols ();
3066 gfc_free_expr (len
);
3070 /* Do some final massaging of the length values. */
3071 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
3073 if (seen_length
== 0)
3074 cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
3079 ts
->kind
= kind
== 0 ? gfc_default_character_kind
: kind
;
3080 ts
->deferred
= deferred
;
3082 /* We have to know if it was a C interoperable kind so we can
3083 do accurate type checking of bind(c) procs, etc. */
3085 /* Mark this as C interoperable if being declared with one
3086 of the named constants from iso_c_binding. */
3087 ts
->is_c_interop
= is_iso_c
;
3088 else if (len
!= NULL
)
3089 /* Here, we might have parsed something such as: character(c_char)
3090 In this case, the parsing code above grabs the c_char when
3091 looking for the length (line 1690, roughly). it's the last
3092 testcase for parsing the kind params of a character variable.
3093 However, it's not actually the length. this seems like it
3095 To see if the user used a C interop kind, test the expr
3096 of the so called length, and see if it's C interoperable. */
3097 ts
->is_c_interop
= len
->ts
.is_iso_c
;
3103 /* Matches a RECORD declaration. */
3106 match_record_decl (char *name
)
3109 old_loc
= gfc_current_locus
;
3112 m
= gfc_match (" record /");
3115 if (!flag_dec_structure
)
3117 gfc_current_locus
= old_loc
;
3118 gfc_error ("RECORD at %C is an extension, enable it with "
3122 m
= gfc_match (" %n/", name
);
3127 gfc_current_locus
= old_loc
;
3128 if (flag_dec_structure
3129 && (gfc_match (" record% ") == MATCH_YES
3130 || gfc_match (" record%t") == MATCH_YES
))
3131 gfc_error ("Structure name expected after RECORD at %C");
3139 /* This function uses the gfc_actual_arglist 'type_param_spec_list' as a source
3140 of expressions to substitute into the possibly parameterized expression
3141 'e'. Using a list is inefficient but should not be too bad since the
3142 number of type parameters is not likely to be large. */
3144 insert_parameter_exprs (gfc_expr
* e
, gfc_symbol
* sym ATTRIBUTE_UNUSED
,
3147 gfc_actual_arglist
*param
;
3150 if (e
->expr_type
!= EXPR_VARIABLE
)
3153 gcc_assert (e
->symtree
);
3154 if (e
->symtree
->n
.sym
->attr
.pdt_kind
3155 || (*f
!= 0 && e
->symtree
->n
.sym
->attr
.pdt_len
))
3157 for (param
= type_param_spec_list
; param
; param
= param
->next
)
3158 if (strcmp (e
->symtree
->n
.sym
->name
, param
->name
) == 0)
3163 copy
= gfc_copy_expr (param
->expr
);
3174 gfc_insert_kind_parameter_exprs (gfc_expr
*e
)
3176 return gfc_traverse_expr (e
, NULL
, &insert_parameter_exprs
, 0);
3181 gfc_insert_parameter_exprs (gfc_expr
*e
, gfc_actual_arglist
*param_list
)
3183 gfc_actual_arglist
*old_param_spec_list
= type_param_spec_list
;
3184 type_param_spec_list
= param_list
;
3185 return gfc_traverse_expr (e
, NULL
, &insert_parameter_exprs
, 1);
3186 type_param_spec_list
= NULL
;
3187 type_param_spec_list
= old_param_spec_list
;
3190 /* Determines the instance of a parameterized derived type to be used by
3191 matching determining the values of the kind parameters and using them
3192 in the name of the instance. If the instance exists, it is used, otherwise
3193 a new derived type is created. */
3195 gfc_get_pdt_instance (gfc_actual_arglist
*param_list
, gfc_symbol
**sym
,
3196 gfc_actual_arglist
**ext_param_list
)
3198 /* The PDT template symbol. */
3199 gfc_symbol
*pdt
= *sym
;
3200 /* The symbol for the parameter in the template f2k_namespace. */
3202 /* The hoped for instance of the PDT. */
3203 gfc_symbol
*instance
;
3204 /* The list of parameters appearing in the PDT declaration. */
3205 gfc_formal_arglist
*type_param_name_list
;
3206 /* Used to store the parameter specification list during recursive calls. */
3207 gfc_actual_arglist
*old_param_spec_list
;
3208 /* Pointers to the parameter specification being used. */
3209 gfc_actual_arglist
*actual_param
;
3210 gfc_actual_arglist
*tail
= NULL
;
3211 /* Used to build up the name of the PDT instance. The prefix uses 4
3212 characters and each KIND parameter 2 more. Allow 8 of the latter. */
3213 char name
[GFC_MAX_SYMBOL_LEN
+ 21];
3215 bool name_seen
= (param_list
== NULL
);
3216 bool assumed_seen
= false;
3217 bool deferred_seen
= false;
3218 bool spec_error
= false;
3220 gfc_expr
*kind_expr
;
3221 gfc_component
*c1
, *c2
;
3224 type_param_spec_list
= NULL
;
3226 type_param_name_list
= pdt
->formal
;
3227 actual_param
= param_list
;
3228 sprintf (name
, "Pdt%s", pdt
->name
);
3230 /* Run through the parameter name list and pick up the actual
3231 parameter values or use the default values in the PDT declaration. */
3232 for (; type_param_name_list
;
3233 type_param_name_list
= type_param_name_list
->next
)
3235 if (actual_param
&& actual_param
->spec_type
!= SPEC_EXPLICIT
)
3237 if (actual_param
->spec_type
== SPEC_ASSUMED
)
3238 spec_error
= deferred_seen
;
3240 spec_error
= assumed_seen
;
3244 gfc_error ("The type parameter spec list at %C cannot contain "
3245 "both ASSUMED and DEFERRED parameters");
3250 if (actual_param
&& actual_param
->name
)
3252 param
= type_param_name_list
->sym
;
3254 if (!param
|| !param
->name
)
3257 c1
= gfc_find_component (pdt
, param
->name
, false, true, NULL
);
3258 /* An error should already have been thrown in resolve.c
3259 (resolve_fl_derived0). */
3260 if (!pdt
->attr
.use_assoc
&& !c1
)
3266 if (!actual_param
&& !(c1
&& c1
->initializer
))
3268 gfc_error ("The type parameter spec list at %C does not contain "
3269 "enough parameter expressions");
3272 else if (!actual_param
&& c1
&& c1
->initializer
)
3273 kind_expr
= gfc_copy_expr (c1
->initializer
);
3274 else if (actual_param
&& actual_param
->spec_type
== SPEC_EXPLICIT
)
3275 kind_expr
= gfc_copy_expr (actual_param
->expr
);
3279 actual_param
= param_list
;
3280 for (;actual_param
; actual_param
= actual_param
->next
)
3281 if (actual_param
->name
3282 && strcmp (actual_param
->name
, param
->name
) == 0)
3284 if (actual_param
&& actual_param
->spec_type
== SPEC_EXPLICIT
)
3285 kind_expr
= gfc_copy_expr (actual_param
->expr
);
3288 if (c1
->initializer
)
3289 kind_expr
= gfc_copy_expr (c1
->initializer
);
3290 else if (!(actual_param
&& param
->attr
.pdt_len
))
3292 gfc_error ("The derived parameter '%qs' at %C does not "
3293 "have a default value", param
->name
);
3299 /* Store the current parameter expressions in a temporary actual
3300 arglist 'list' so that they can be substituted in the corresponding
3301 expressions in the PDT instance. */
3302 if (type_param_spec_list
== NULL
)
3304 type_param_spec_list
= gfc_get_actual_arglist ();
3305 tail
= type_param_spec_list
;
3309 tail
->next
= gfc_get_actual_arglist ();
3312 tail
->name
= param
->name
;
3316 /* Try simplification even for LEN expressions. */
3317 gfc_resolve_expr (kind_expr
);
3318 gfc_simplify_expr (kind_expr
, 1);
3319 /* Variable expressions seem to default to BT_PROCEDURE.
3320 TODO find out why this is and fix it. */
3321 if (kind_expr
->ts
.type
!= BT_INTEGER
3322 && kind_expr
->ts
.type
!= BT_PROCEDURE
)
3324 gfc_error ("The parameter expression at %C must be of "
3325 "INTEGER type and not %s type",
3326 gfc_basic_typename (kind_expr
->ts
.type
));
3330 tail
->expr
= gfc_copy_expr (kind_expr
);
3334 tail
->spec_type
= actual_param
->spec_type
;
3336 if (!param
->attr
.pdt_kind
)
3338 if (!name_seen
&& actual_param
)
3339 actual_param
= actual_param
->next
;
3342 gfc_free_expr (kind_expr
);
3349 && (actual_param
->spec_type
== SPEC_ASSUMED
3350 || actual_param
->spec_type
== SPEC_DEFERRED
))
3352 gfc_error ("The KIND parameter '%qs' at %C cannot either be "
3353 "ASSUMED or DEFERRED", param
->name
);
3357 if (!kind_expr
|| !gfc_is_constant_expr (kind_expr
))
3359 gfc_error ("The value for the KIND parameter '%qs' at %C does not "
3360 "reduce to a constant expression", param
->name
);
3364 gfc_extract_int (kind_expr
, &kind_value
);
3365 sprintf (name
+ strlen (name
), "_%d", kind_value
);
3367 if (!name_seen
&& actual_param
)
3368 actual_param
= actual_param
->next
;
3369 gfc_free_expr (kind_expr
);
3372 if (!name_seen
&& actual_param
)
3374 gfc_error ("The type parameter spec list at %C contains too many "
3375 "parameter expressions");
3379 /* Now we search for the PDT instance 'name'. If it doesn't exist, we
3380 build it, using 'pdt' as a template. */
3381 if (gfc_get_symbol (name
, pdt
->ns
, &instance
))
3383 gfc_error ("Parameterized derived type at %C is ambiguous");
3389 if (instance
->attr
.flavor
== FL_DERIVED
3390 && instance
->attr
.pdt_type
)
3394 *ext_param_list
= type_param_spec_list
;
3396 gfc_commit_symbols ();
3400 /* Start building the new instance of the parameterized type. */
3401 gfc_copy_attr (&instance
->attr
, &pdt
->attr
, &pdt
->declared_at
);
3402 instance
->attr
.pdt_template
= 0;
3403 instance
->attr
.pdt_type
= 1;
3404 instance
->declared_at
= gfc_current_locus
;
3406 /* Add the components, replacing the parameters in all expressions
3407 with the expressions for their values in 'type_param_spec_list'. */
3408 c1
= pdt
->components
;
3409 tail
= type_param_spec_list
;
3410 for (; c1
; c1
= c1
->next
)
3412 gfc_add_component (instance
, c1
->name
, &c2
);
3415 c2
->attr
= c1
->attr
;
3417 /* The order of declaration of the type_specs might not be the
3418 same as that of the components. */
3419 if (c1
->attr
.pdt_kind
|| c1
->attr
.pdt_len
)
3421 for (tail
= type_param_spec_list
; tail
; tail
= tail
->next
)
3422 if (strcmp (c1
->name
, tail
->name
) == 0)
3426 /* Deal with type extension by recursively calling this function
3427 to obtain the instance of the extended type. */
3428 if (gfc_current_state () != COMP_DERIVED
3429 && c1
== pdt
->components
3430 && (c1
->ts
.type
== BT_DERIVED
|| c1
->ts
.type
== BT_CLASS
)
3431 && c1
->ts
.u
.derived
&& c1
->ts
.u
.derived
->attr
.pdt_template
3432 && gfc_get_derived_super_type (*sym
) == c2
->ts
.u
.derived
)
3434 gfc_formal_arglist
*f
;
3436 old_param_spec_list
= type_param_spec_list
;
3438 /* Obtain a spec list appropriate to the extended type..*/
3439 actual_param
= gfc_copy_actual_arglist (type_param_spec_list
);
3440 type_param_spec_list
= actual_param
;
3441 for (f
= c1
->ts
.u
.derived
->formal
; f
&& f
->next
; f
= f
->next
)
3442 actual_param
= actual_param
->next
;
3445 gfc_free_actual_arglist (actual_param
->next
);
3446 actual_param
->next
= NULL
;
3449 /* Now obtain the PDT instance for the extended type. */
3450 c2
->param_list
= type_param_spec_list
;
3451 m
= gfc_get_pdt_instance (type_param_spec_list
, &c2
->ts
.u
.derived
,
3453 type_param_spec_list
= old_param_spec_list
;
3455 c2
->ts
.u
.derived
->refs
++;
3456 gfc_set_sym_referenced (c2
->ts
.u
.derived
);
3458 /* Set extension level. */
3459 if (c2
->ts
.u
.derived
->attr
.extension
== 255)
3461 /* Since the extension field is 8 bit wide, we can only have
3462 up to 255 extension levels. */
3463 gfc_error ("Maximum extension level reached with type %qs at %L",
3464 c2
->ts
.u
.derived
->name
,
3465 &c2
->ts
.u
.derived
->declared_at
);
3468 instance
->attr
.extension
= c2
->ts
.u
.derived
->attr
.extension
+ 1;
3473 /* Set the component kind using the parameterized expression. */
3474 if ((c1
->ts
.kind
== 0 || c1
->ts
.type
== BT_CHARACTER
)
3475 && c1
->kind_expr
!= NULL
)
3477 gfc_expr
*e
= gfc_copy_expr (c1
->kind_expr
);
3478 gfc_insert_kind_parameter_exprs (e
);
3479 gfc_simplify_expr (e
, 1);
3480 gfc_extract_int (e
, &c2
->ts
.kind
);
3482 if (gfc_validate_kind (c2
->ts
.type
, c2
->ts
.kind
, true) < 0)
3484 gfc_error ("Kind %d not supported for type %s at %C",
3485 c2
->ts
.kind
, gfc_basic_typename (c2
->ts
.type
));
3490 /* Similarly, set the string length if parameterized. */
3491 if (c1
->ts
.type
== BT_CHARACTER
3492 && c1
->ts
.u
.cl
->length
3493 && gfc_derived_parameter_expr (c1
->ts
.u
.cl
->length
))
3496 e
= gfc_copy_expr (c1
->ts
.u
.cl
->length
);
3497 gfc_insert_kind_parameter_exprs (e
);
3498 gfc_simplify_expr (e
, 1);
3499 c2
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
3500 c2
->ts
.u
.cl
->length
= e
;
3501 c2
->attr
.pdt_string
= 1;
3504 /* Set up either the KIND/LEN initializer, if constant,
3505 or the parameterized expression. Use the template
3506 initializer if one is not already set in this instance. */
3507 if (c2
->attr
.pdt_kind
|| c2
->attr
.pdt_len
)
3509 if (tail
&& tail
->expr
&& gfc_is_constant_expr (tail
->expr
))
3510 c2
->initializer
= gfc_copy_expr (tail
->expr
);
3511 else if (tail
&& tail
->expr
)
3513 c2
->param_list
= gfc_get_actual_arglist ();
3514 c2
->param_list
->name
= tail
->name
;
3515 c2
->param_list
->expr
= gfc_copy_expr (tail
->expr
);
3516 c2
->param_list
->next
= NULL
;
3519 if (!c2
->initializer
&& c1
->initializer
)
3520 c2
->initializer
= gfc_copy_expr (c1
->initializer
);
3523 /* Copy the array spec. */
3524 c2
->as
= gfc_copy_array_spec (c1
->as
);
3525 if (c1
->ts
.type
== BT_CLASS
)
3526 CLASS_DATA (c2
)->as
= gfc_copy_array_spec (CLASS_DATA (c1
)->as
);
3528 /* Determine if an array spec is parameterized. If so, substitute
3529 in the parameter expressions for the bounds and set the pdt_array
3530 attribute. Notice that this attribute must be unconditionally set
3531 if this is an array of parameterized character length. */
3532 if (c1
->as
&& c1
->as
->type
== AS_EXPLICIT
)
3534 bool pdt_array
= false;
3536 /* Are the bounds of the array parameterized? */
3537 for (i
= 0; i
< c1
->as
->rank
; i
++)
3539 if (gfc_derived_parameter_expr (c1
->as
->lower
[i
]))
3541 if (gfc_derived_parameter_expr (c1
->as
->upper
[i
]))
3545 /* If they are, free the expressions for the bounds and
3546 replace them with the template expressions with substitute
3548 for (i
= 0; pdt_array
&& i
< c1
->as
->rank
; i
++)
3551 e
= gfc_copy_expr (c1
->as
->lower
[i
]);
3552 gfc_insert_kind_parameter_exprs (e
);
3553 gfc_simplify_expr (e
, 1);
3554 gfc_free_expr (c2
->as
->lower
[i
]);
3555 c2
->as
->lower
[i
] = e
;
3556 e
= gfc_copy_expr (c1
->as
->upper
[i
]);
3557 gfc_insert_kind_parameter_exprs (e
);
3558 gfc_simplify_expr (e
, 1);
3559 gfc_free_expr (c2
->as
->upper
[i
]);
3560 c2
->as
->upper
[i
] = e
;
3562 c2
->attr
.pdt_array
= pdt_array
? 1 : c2
->attr
.pdt_string
;
3565 /* Recurse into this function for PDT components. */
3566 if ((c1
->ts
.type
== BT_DERIVED
|| c1
->ts
.type
== BT_CLASS
)
3567 && c1
->ts
.u
.derived
&& c1
->ts
.u
.derived
->attr
.pdt_template
)
3569 gfc_actual_arglist
*params
;
3570 /* The component in the template has a list of specification
3571 expressions derived from its declaration. */
3572 params
= gfc_copy_actual_arglist (c1
->param_list
);
3573 actual_param
= params
;
3574 /* Substitute the template parameters with the expressions
3575 from the specification list. */
3576 for (;actual_param
; actual_param
= actual_param
->next
)
3577 gfc_insert_parameter_exprs (actual_param
->expr
,
3578 type_param_spec_list
);
3580 /* Now obtain the PDT instance for the component. */
3581 old_param_spec_list
= type_param_spec_list
;
3582 m
= gfc_get_pdt_instance (params
, &c2
->ts
.u
.derived
, NULL
);
3583 type_param_spec_list
= old_param_spec_list
;
3585 c2
->param_list
= params
;
3586 if (!(c2
->attr
.pointer
|| c2
->attr
.allocatable
))
3587 c2
->initializer
= gfc_default_initializer (&c2
->ts
);
3589 if (c2
->attr
.allocatable
)
3590 instance
->attr
.alloc_comp
= 1;
3594 gfc_commit_symbol (instance
);
3596 *ext_param_list
= type_param_spec_list
;
3601 gfc_free_actual_arglist (type_param_spec_list
);
3606 /* Matches a declaration-type-spec (F03:R502). If successful, sets the ts
3607 structure to the matched specification. This is necessary for FUNCTION and
3608 IMPLICIT statements.
3610 If implicit_flag is nonzero, then we don't check for the optional
3611 kind specification. Not doing so is needed for matching an IMPLICIT
3612 statement correctly. */
3615 gfc_match_decl_type_spec (gfc_typespec
*ts
, int implicit_flag
)
3617 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3618 gfc_symbol
*sym
, *dt_sym
;
3621 bool seen_deferred_kind
, matched_type
;
3622 const char *dt_name
;
3624 decl_type_param_list
= NULL
;
3626 /* A belt and braces check that the typespec is correctly being treated
3627 as a deferred characteristic association. */
3628 seen_deferred_kind
= (gfc_current_state () == COMP_FUNCTION
)
3629 && (gfc_current_block ()->result
->ts
.kind
== -1)
3630 && (ts
->kind
== -1);
3632 if (seen_deferred_kind
)
3635 /* Clear the current binding label, in case one is given. */
3636 curr_binding_label
= NULL
;
3638 if (gfc_match (" byte") == MATCH_YES
)
3640 if (!gfc_notify_std (GFC_STD_GNU
, "BYTE type at %C"))
3643 if (gfc_validate_kind (BT_INTEGER
, 1, true) < 0)
3645 gfc_error ("BYTE type used at %C "
3646 "is not available on the target machine");
3650 ts
->type
= BT_INTEGER
;
3656 m
= gfc_match (" type (");
3657 matched_type
= (m
== MATCH_YES
);
3660 gfc_gobble_whitespace ();
3661 if (gfc_peek_ascii_char () == '*')
3663 if ((m
= gfc_match ("*)")) != MATCH_YES
)
3665 if (gfc_comp_struct (gfc_current_state ()))
3667 gfc_error ("Assumed type at %C is not allowed for components");
3670 if (!gfc_notify_std (GFC_STD_F2008_TS
, "Assumed type "
3673 ts
->type
= BT_ASSUMED
;
3677 m
= gfc_match ("%n", name
);
3678 matched_type
= (m
== MATCH_YES
);
3681 if ((matched_type
&& strcmp ("integer", name
) == 0)
3682 || (!matched_type
&& gfc_match (" integer") == MATCH_YES
))
3684 ts
->type
= BT_INTEGER
;
3685 ts
->kind
= gfc_default_integer_kind
;
3689 if ((matched_type
&& strcmp ("character", name
) == 0)
3690 || (!matched_type
&& gfc_match (" character") == MATCH_YES
))
3693 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
3694 "intrinsic-type-spec at %C"))
3697 ts
->type
= BT_CHARACTER
;
3698 if (implicit_flag
== 0)
3699 m
= gfc_match_char_spec (ts
);
3703 if (matched_type
&& m
== MATCH_YES
&& gfc_match_char (')') != MATCH_YES
)
3709 if ((matched_type
&& strcmp ("real", name
) == 0)
3710 || (!matched_type
&& gfc_match (" real") == MATCH_YES
))
3713 ts
->kind
= gfc_default_real_kind
;
3718 && (strcmp ("doubleprecision", name
) == 0
3719 || (strcmp ("double", name
) == 0
3720 && gfc_match (" precision") == MATCH_YES
)))
3721 || (!matched_type
&& gfc_match (" double precision") == MATCH_YES
))
3724 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
3725 "intrinsic-type-spec at %C"))
3727 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
3731 ts
->kind
= gfc_default_double_kind
;
3735 if ((matched_type
&& strcmp ("complex", name
) == 0)
3736 || (!matched_type
&& gfc_match (" complex") == MATCH_YES
))
3738 ts
->type
= BT_COMPLEX
;
3739 ts
->kind
= gfc_default_complex_kind
;
3744 && (strcmp ("doublecomplex", name
) == 0
3745 || (strcmp ("double", name
) == 0
3746 && gfc_match (" complex") == MATCH_YES
)))
3747 || (!matched_type
&& gfc_match (" double complex") == MATCH_YES
))
3749 if (!gfc_notify_std (GFC_STD_GNU
, "DOUBLE COMPLEX at %C"))
3753 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
3754 "intrinsic-type-spec at %C"))
3757 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
3760 ts
->type
= BT_COMPLEX
;
3761 ts
->kind
= gfc_default_double_kind
;
3765 if ((matched_type
&& strcmp ("logical", name
) == 0)
3766 || (!matched_type
&& gfc_match (" logical") == MATCH_YES
))
3768 ts
->type
= BT_LOGICAL
;
3769 ts
->kind
= gfc_default_logical_kind
;
3775 m
= gfc_match_actual_arglist (1, &decl_type_param_list
, true);
3776 if (m
== MATCH_ERROR
)
3779 m
= gfc_match_char (')');
3783 m
= match_record_decl (name
);
3785 if (matched_type
|| m
== MATCH_YES
)
3787 ts
->type
= BT_DERIVED
;
3788 /* We accept record/s/ or type(s) where s is a structure, but we
3789 * don't need all the extra derived-type stuff for structures. */
3790 if (gfc_find_symbol (gfc_dt_upper_string (name
), NULL
, 1, &sym
))
3792 gfc_error ("Type name %qs at %C is ambiguous", name
);
3796 if (sym
&& sym
->attr
.flavor
== FL_DERIVED
3797 && sym
->attr
.pdt_template
3798 && gfc_current_state () != COMP_DERIVED
)
3800 m
= gfc_get_pdt_instance (decl_type_param_list
, &sym
, NULL
);
3803 gcc_assert (!sym
->attr
.pdt_template
&& sym
->attr
.pdt_type
);
3804 ts
->u
.derived
= sym
;
3805 strcpy (name
, gfc_dt_lower_string (sym
->name
));
3808 if (sym
&& sym
->attr
.flavor
== FL_STRUCT
)
3810 ts
->u
.derived
= sym
;
3813 /* Actually a derived type. */
3818 /* Match nested STRUCTURE declarations; only valid within another
3819 structure declaration. */
3820 if (flag_dec_structure
3821 && (gfc_current_state () == COMP_STRUCTURE
3822 || gfc_current_state () == COMP_MAP
))
3824 m
= gfc_match (" structure");
3827 m
= gfc_match_structure_decl ();
3830 /* gfc_new_block is updated by match_structure_decl. */
3831 ts
->type
= BT_DERIVED
;
3832 ts
->u
.derived
= gfc_new_block
;
3836 if (m
== MATCH_ERROR
)
3840 /* Match CLASS declarations. */
3841 m
= gfc_match (" class ( * )");
3842 if (m
== MATCH_ERROR
)
3844 else if (m
== MATCH_YES
)
3848 ts
->type
= BT_CLASS
;
3849 gfc_find_symbol ("STAR", gfc_current_ns
, 1, &upe
);
3852 upe
= gfc_new_symbol ("STAR", gfc_current_ns
);
3853 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "STAR");
3855 gfc_set_sym_referenced (upe
);
3857 upe
->ts
.type
= BT_VOID
;
3858 upe
->attr
.unlimited_polymorphic
= 1;
3859 /* This is essential to force the construction of
3860 unlimited polymorphic component class containers. */
3861 upe
->attr
.zero_comp
= 1;
3862 if (!gfc_add_flavor (&upe
->attr
, FL_DERIVED
, NULL
,
3863 &gfc_current_locus
))
3868 st
= gfc_get_tbp_symtree (&gfc_current_ns
->sym_root
, "STAR");
3872 ts
->u
.derived
= upe
;
3876 m
= gfc_match (" class (");
3879 m
= gfc_match ("%n", name
);
3885 ts
->type
= BT_CLASS
;
3887 if (!gfc_notify_std (GFC_STD_F2003
, "CLASS statement at %C"))
3890 m
= gfc_match_actual_arglist (1, &decl_type_param_list
, true);
3891 if (m
== MATCH_ERROR
)
3894 m
= gfc_match_char (')');
3899 /* Defer association of the derived type until the end of the
3900 specification block. However, if the derived type can be
3901 found, add it to the typespec. */
3902 if (gfc_matching_function
)
3904 ts
->u
.derived
= NULL
;
3905 if (gfc_current_state () != COMP_INTERFACE
3906 && !gfc_find_symbol (name
, NULL
, 1, &sym
) && sym
)
3908 sym
= gfc_find_dt_in_generic (sym
);
3909 ts
->u
.derived
= sym
;
3914 /* Search for the name but allow the components to be defined later. If
3915 type = -1, this typespec has been seen in a function declaration but
3916 the type could not be accessed at that point. The actual derived type is
3917 stored in a symtree with the first letter of the name capitalized; the
3918 symtree with the all lower-case name contains the associated
3919 generic function. */
3920 dt_name
= gfc_dt_upper_string (name
);
3925 gfc_get_ha_symbol (name
, &sym
);
3926 if (sym
->generic
&& gfc_find_symbol (dt_name
, NULL
, 0, &dt_sym
))
3928 gfc_error ("Type name %qs at %C is ambiguous", name
);
3931 if (sym
->generic
&& !dt_sym
)
3932 dt_sym
= gfc_find_dt_in_generic (sym
);
3934 /* Host associated PDTs can get confused with their constructors
3935 because they ar instantiated in the template's namespace. */
3938 if (gfc_find_symbol (dt_name
, NULL
, 1, &dt_sym
))
3940 gfc_error ("Type name %qs at %C is ambiguous", name
);
3943 if (dt_sym
&& !dt_sym
->attr
.pdt_type
)
3947 else if (ts
->kind
== -1)
3949 int iface
= gfc_state_stack
->previous
->state
!= COMP_INTERFACE
3950 || gfc_current_ns
->has_import_set
;
3951 gfc_find_symbol (name
, NULL
, iface
, &sym
);
3952 if (sym
&& sym
->generic
&& gfc_find_symbol (dt_name
, NULL
, 1, &dt_sym
))
3954 gfc_error ("Type name %qs at %C is ambiguous", name
);
3957 if (sym
&& sym
->generic
&& !dt_sym
)
3958 dt_sym
= gfc_find_dt_in_generic (sym
);
3965 if ((sym
->attr
.flavor
!= FL_UNKNOWN
&& sym
->attr
.flavor
!= FL_STRUCT
3966 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.generic
))
3967 || sym
->attr
.subroutine
)
3969 gfc_error ("Type name %qs at %C conflicts with previously declared "
3970 "entity at %L, which has the same name", name
,
3975 if (sym
&& sym
->attr
.flavor
== FL_DERIVED
3976 && sym
->attr
.pdt_template
3977 && gfc_current_state () != COMP_DERIVED
)
3979 m
= gfc_get_pdt_instance (decl_type_param_list
, &sym
, NULL
);
3982 gcc_assert (!sym
->attr
.pdt_template
&& sym
->attr
.pdt_type
);
3983 ts
->u
.derived
= sym
;
3984 strcpy (name
, gfc_dt_lower_string (sym
->name
));
3987 gfc_save_symbol_data (sym
);
3988 gfc_set_sym_referenced (sym
);
3989 if (!sym
->attr
.generic
3990 && !gfc_add_generic (&sym
->attr
, sym
->name
, NULL
))
3993 if (!sym
->attr
.function
3994 && !gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
3997 if (dt_sym
&& dt_sym
->attr
.flavor
== FL_DERIVED
3998 && dt_sym
->attr
.pdt_template
3999 && gfc_current_state () != COMP_DERIVED
)
4001 m
= gfc_get_pdt_instance (decl_type_param_list
, &dt_sym
, NULL
);
4004 gcc_assert (!dt_sym
->attr
.pdt_template
&& dt_sym
->attr
.pdt_type
);
4009 gfc_interface
*intr
, *head
;
4011 /* Use upper case to save the actual derived-type symbol. */
4012 gfc_get_symbol (dt_name
, NULL
, &dt_sym
);
4013 dt_sym
->name
= gfc_get_string ("%s", sym
->name
);
4014 head
= sym
->generic
;
4015 intr
= gfc_get_interface ();
4017 intr
->where
= gfc_current_locus
;
4019 sym
->generic
= intr
;
4020 sym
->attr
.if_source
= IFSRC_DECL
;
4023 gfc_save_symbol_data (dt_sym
);
4025 gfc_set_sym_referenced (dt_sym
);
4027 if (dt_sym
->attr
.flavor
!= FL_DERIVED
&& dt_sym
->attr
.flavor
!= FL_STRUCT
4028 && !gfc_add_flavor (&dt_sym
->attr
, FL_DERIVED
, sym
->name
, NULL
))
4031 ts
->u
.derived
= dt_sym
;
4037 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
4038 "intrinsic-type-spec at %C"))
4041 /* For all types except double, derived and character, look for an
4042 optional kind specifier. MATCH_NO is actually OK at this point. */
4043 if (implicit_flag
== 1)
4045 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
4051 if (gfc_current_form
== FORM_FREE
)
4053 c
= gfc_peek_ascii_char ();
4054 if (!gfc_is_whitespace (c
) && c
!= '*' && c
!= '('
4055 && c
!= ':' && c
!= ',')
4057 if (matched_type
&& c
== ')')
4059 gfc_next_ascii_char ();
4066 m
= gfc_match_kind_spec (ts
, false);
4067 if (m
== MATCH_NO
&& ts
->type
!= BT_CHARACTER
)
4069 m
= gfc_match_old_kind_spec (ts
);
4070 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) == -1)
4074 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
4077 /* Defer association of the KIND expression of function results
4078 until after USE and IMPORT statements. */
4079 if ((gfc_current_state () == COMP_NONE
&& gfc_error_flag_test ())
4080 || gfc_matching_function
)
4084 m
= MATCH_YES
; /* No kind specifier found. */
4090 /* Match an IMPLICIT NONE statement. Actually, this statement is
4091 already matched in parse.c, or we would not end up here in the
4092 first place. So the only thing we need to check, is if there is
4093 trailing garbage. If not, the match is successful. */
4096 gfc_match_implicit_none (void)
4100 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4102 bool external
= false;
4103 locus cur_loc
= gfc_current_locus
;
4105 if (gfc_current_ns
->seen_implicit_none
4106 || gfc_current_ns
->has_implicit_none_export
)
4108 gfc_error ("Duplicate IMPLICIT NONE statement at %C");
4112 gfc_gobble_whitespace ();
4113 c
= gfc_peek_ascii_char ();
4116 (void) gfc_next_ascii_char ();
4117 if (!gfc_notify_std (GFC_STD_F2015
, "IMPORT NONE with spec list at %C"))
4120 gfc_gobble_whitespace ();
4121 if (gfc_peek_ascii_char () == ')')
4123 (void) gfc_next_ascii_char ();
4129 m
= gfc_match (" %n", name
);
4133 if (strcmp (name
, "type") == 0)
4135 else if (strcmp (name
, "external") == 0)
4140 gfc_gobble_whitespace ();
4141 c
= gfc_next_ascii_char ();
4152 if (gfc_match_eos () != MATCH_YES
)
4155 gfc_set_implicit_none (type
, external
, &cur_loc
);
4161 /* Match the letter range(s) of an IMPLICIT statement. */
4164 match_implicit_range (void)
4170 cur_loc
= gfc_current_locus
;
4172 gfc_gobble_whitespace ();
4173 c
= gfc_next_ascii_char ();
4176 gfc_error ("Missing character range in IMPLICIT at %C");
4183 gfc_gobble_whitespace ();
4184 c1
= gfc_next_ascii_char ();
4188 gfc_gobble_whitespace ();
4189 c
= gfc_next_ascii_char ();
4194 inner
= 0; /* Fall through. */
4201 gfc_gobble_whitespace ();
4202 c2
= gfc_next_ascii_char ();
4206 gfc_gobble_whitespace ();
4207 c
= gfc_next_ascii_char ();
4209 if ((c
!= ',') && (c
!= ')'))
4222 gfc_error ("Letters must be in alphabetic order in "
4223 "IMPLICIT statement at %C");
4227 /* See if we can add the newly matched range to the pending
4228 implicits from this IMPLICIT statement. We do not check for
4229 conflicts with whatever earlier IMPLICIT statements may have
4230 set. This is done when we've successfully finished matching
4232 if (!gfc_add_new_implicit_range (c1
, c2
))
4239 gfc_syntax_error (ST_IMPLICIT
);
4241 gfc_current_locus
= cur_loc
;
4246 /* Match an IMPLICIT statement, storing the types for
4247 gfc_set_implicit() if the statement is accepted by the parser.
4248 There is a strange looking, but legal syntactic construction
4249 possible. It looks like:
4251 IMPLICIT INTEGER (a-b) (c-d)
4253 This is legal if "a-b" is a constant expression that happens to
4254 equal one of the legal kinds for integers. The real problem
4255 happens with an implicit specification that looks like:
4257 IMPLICIT INTEGER (a-b)
4259 In this case, a typespec matcher that is "greedy" (as most of the
4260 matchers are) gobbles the character range as a kindspec, leaving
4261 nothing left. We therefore have to go a bit more slowly in the
4262 matching process by inhibiting the kindspec checking during
4263 typespec matching and checking for a kind later. */
4266 gfc_match_implicit (void)
4273 if (gfc_current_ns
->seen_implicit_none
)
4275 gfc_error ("IMPLICIT statement at %C following an IMPLICIT NONE (type) "
4282 /* We don't allow empty implicit statements. */
4283 if (gfc_match_eos () == MATCH_YES
)
4285 gfc_error ("Empty IMPLICIT statement at %C");
4291 /* First cleanup. */
4292 gfc_clear_new_implicit ();
4294 /* A basic type is mandatory here. */
4295 m
= gfc_match_decl_type_spec (&ts
, 1);
4296 if (m
== MATCH_ERROR
)
4301 cur_loc
= gfc_current_locus
;
4302 m
= match_implicit_range ();
4306 /* We may have <TYPE> (<RANGE>). */
4307 gfc_gobble_whitespace ();
4308 c
= gfc_peek_ascii_char ();
4309 if (c
== ',' || c
== '\n' || c
== ';' || c
== '!')
4311 /* Check for CHARACTER with no length parameter. */
4312 if (ts
.type
== BT_CHARACTER
&& !ts
.u
.cl
)
4314 ts
.kind
= gfc_default_character_kind
;
4315 ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4316 ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
,
4320 /* Record the Successful match. */
4321 if (!gfc_merge_new_implicit (&ts
))
4324 c
= gfc_next_ascii_char ();
4325 else if (gfc_match_eos () == MATCH_ERROR
)
4330 gfc_current_locus
= cur_loc
;
4333 /* Discard the (incorrectly) matched range. */
4334 gfc_clear_new_implicit ();
4336 /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
4337 if (ts
.type
== BT_CHARACTER
)
4338 m
= gfc_match_char_spec (&ts
);
4341 m
= gfc_match_kind_spec (&ts
, false);
4344 m
= gfc_match_old_kind_spec (&ts
);
4345 if (m
== MATCH_ERROR
)
4351 if (m
== MATCH_ERROR
)
4354 m
= match_implicit_range ();
4355 if (m
== MATCH_ERROR
)
4360 gfc_gobble_whitespace ();
4361 c
= gfc_next_ascii_char ();
4362 if (c
!= ',' && gfc_match_eos () != MATCH_YES
)
4365 if (!gfc_merge_new_implicit (&ts
))
4373 gfc_syntax_error (ST_IMPLICIT
);
4381 gfc_match_import (void)
4383 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4388 if (gfc_current_ns
->proc_name
== NULL
4389 || gfc_current_ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
4391 gfc_error ("IMPORT statement at %C only permitted in "
4392 "an INTERFACE body");
4396 if (gfc_current_ns
->proc_name
->attr
.module_procedure
)
4398 gfc_error ("F2008: C1210 IMPORT statement at %C is not permitted "
4399 "in a module procedure interface body");
4403 if (!gfc_notify_std (GFC_STD_F2003
, "IMPORT statement at %C"))
4406 if (gfc_match_eos () == MATCH_YES
)
4408 /* All host variables should be imported. */
4409 gfc_current_ns
->has_import_set
= 1;
4413 if (gfc_match (" ::") == MATCH_YES
)
4415 if (gfc_match_eos () == MATCH_YES
)
4417 gfc_error ("Expecting list of named entities at %C");
4425 m
= gfc_match (" %n", name
);
4429 if (gfc_current_ns
->parent
!= NULL
4430 && gfc_find_symbol (name
, gfc_current_ns
->parent
, 1, &sym
))
4432 gfc_error ("Type name %qs at %C is ambiguous", name
);
4435 else if (!sym
&& gfc_current_ns
->proc_name
->ns
->parent
!= NULL
4436 && gfc_find_symbol (name
,
4437 gfc_current_ns
->proc_name
->ns
->parent
,
4440 gfc_error ("Type name %qs at %C is ambiguous", name
);
4446 gfc_error ("Cannot IMPORT %qs from host scoping unit "
4447 "at %C - does not exist.", name
);
4451 if (gfc_find_symtree (gfc_current_ns
->sym_root
, name
))
4453 gfc_warning (0, "%qs is already IMPORTed from host scoping unit "
4458 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, name
);
4461 sym
->attr
.imported
= 1;
4463 if (sym
->attr
.generic
&& (sym
= gfc_find_dt_in_generic (sym
)))
4465 /* The actual derived type is stored in a symtree with the first
4466 letter of the name capitalized; the symtree with the all
4467 lower-case name contains the associated generic function. */
4468 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
,
4469 gfc_dt_upper_string (name
));
4472 sym
->attr
.imported
= 1;
4485 if (gfc_match_eos () == MATCH_YES
)
4487 if (gfc_match_char (',') != MATCH_YES
)
4494 gfc_error ("Syntax error in IMPORT statement at %C");
4499 /* A minimal implementation of gfc_match without whitespace, escape
4500 characters or variable arguments. Returns true if the next
4501 characters match the TARGET template exactly. */
4504 match_string_p (const char *target
)
4508 for (p
= target
; *p
; p
++)
4509 if ((char) gfc_next_ascii_char () != *p
)
4514 /* Matches an attribute specification including array specs. If
4515 successful, leaves the variables current_attr and current_as
4516 holding the specification. Also sets the colon_seen variable for
4517 later use by matchers associated with initializations.
4519 This subroutine is a little tricky in the sense that we don't know
4520 if we really have an attr-spec until we hit the double colon.
4521 Until that time, we can only return MATCH_NO. This forces us to
4522 check for duplicate specification at this level. */
4525 match_attr_spec (void)
4527 /* Modifiers that can exist in a type statement. */
4529 { GFC_DECL_BEGIN
= 0,
4530 DECL_ALLOCATABLE
= GFC_DECL_BEGIN
, DECL_DIMENSION
, DECL_EXTERNAL
,
4531 DECL_IN
, DECL_OUT
, DECL_INOUT
, DECL_INTRINSIC
, DECL_OPTIONAL
,
4532 DECL_PARAMETER
, DECL_POINTER
, DECL_PROTECTED
, DECL_PRIVATE
,
4533 DECL_STATIC
, DECL_AUTOMATIC
,
4534 DECL_PUBLIC
, DECL_SAVE
, DECL_TARGET
, DECL_VALUE
, DECL_VOLATILE
,
4535 DECL_IS_BIND_C
, DECL_CODIMENSION
, DECL_ASYNCHRONOUS
, DECL_CONTIGUOUS
,
4536 DECL_LEN
, DECL_KIND
, DECL_NONE
, GFC_DECL_END
/* Sentinel */
4539 /* GFC_DECL_END is the sentinel, index starts at 0. */
4540 #define NUM_DECL GFC_DECL_END
4542 locus start
, seen_at
[NUM_DECL
];
4549 gfc_clear_attr (¤t_attr
);
4550 start
= gfc_current_locus
;
4556 /* See if we get all of the keywords up to the final double colon. */
4557 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
4565 gfc_gobble_whitespace ();
4567 ch
= gfc_next_ascii_char ();
4570 /* This is the successful exit condition for the loop. */
4571 if (gfc_next_ascii_char () == ':')
4576 gfc_gobble_whitespace ();
4577 switch (gfc_peek_ascii_char ())
4580 gfc_next_ascii_char ();
4581 switch (gfc_next_ascii_char ())
4584 if (match_string_p ("locatable"))
4586 /* Matched "allocatable". */
4587 d
= DECL_ALLOCATABLE
;
4592 if (match_string_p ("ynchronous"))
4594 /* Matched "asynchronous". */
4595 d
= DECL_ASYNCHRONOUS
;
4600 if (match_string_p ("tomatic"))
4602 /* Matched "automatic". */
4610 /* Try and match the bind(c). */
4611 m
= gfc_match_bind_c (NULL
, true);
4614 else if (m
== MATCH_ERROR
)
4619 gfc_next_ascii_char ();
4620 if ('o' != gfc_next_ascii_char ())
4622 switch (gfc_next_ascii_char ())
4625 if (match_string_p ("imension"))
4627 d
= DECL_CODIMENSION
;
4632 if (match_string_p ("tiguous"))
4634 d
= DECL_CONTIGUOUS
;
4641 if (match_string_p ("dimension"))
4646 if (match_string_p ("external"))
4651 if (match_string_p ("int"))
4653 ch
= gfc_next_ascii_char ();
4656 if (match_string_p ("nt"))
4658 /* Matched "intent". */
4659 /* TODO: Call match_intent_spec from here. */
4660 if (gfc_match (" ( in out )") == MATCH_YES
)
4662 else if (gfc_match (" ( in )") == MATCH_YES
)
4664 else if (gfc_match (" ( out )") == MATCH_YES
)
4670 if (match_string_p ("insic"))
4672 /* Matched "intrinsic". */
4680 if (match_string_p ("kind"))
4685 if (match_string_p ("len"))
4690 if (match_string_p ("optional"))
4695 gfc_next_ascii_char ();
4696 switch (gfc_next_ascii_char ())
4699 if (match_string_p ("rameter"))
4701 /* Matched "parameter". */
4707 if (match_string_p ("inter"))
4709 /* Matched "pointer". */
4715 ch
= gfc_next_ascii_char ();
4718 if (match_string_p ("vate"))
4720 /* Matched "private". */
4726 if (match_string_p ("tected"))
4728 /* Matched "protected". */
4735 if (match_string_p ("blic"))
4737 /* Matched "public". */
4745 gfc_next_ascii_char ();
4746 switch (gfc_next_ascii_char ())
4749 if (match_string_p ("ve"))
4751 /* Matched "save". */
4757 if (match_string_p ("atic"))
4759 /* Matched "static". */
4767 if (match_string_p ("target"))
4772 gfc_next_ascii_char ();
4773 ch
= gfc_next_ascii_char ();
4776 if (match_string_p ("lue"))
4778 /* Matched "value". */
4784 if (match_string_p ("latile"))
4786 /* Matched "volatile". */
4794 /* No double colon and no recognizable decl_type, so assume that
4795 we've been looking at something else the whole time. */
4802 /* Check to make sure any parens are paired up correctly. */
4803 if (gfc_match_parens () == MATCH_ERROR
)
4810 seen_at
[d
] = gfc_current_locus
;
4812 if (d
== DECL_DIMENSION
|| d
== DECL_CODIMENSION
)
4814 gfc_array_spec
*as
= NULL
;
4816 m
= gfc_match_array_spec (&as
, d
== DECL_DIMENSION
,
4817 d
== DECL_CODIMENSION
);
4819 if (current_as
== NULL
)
4821 else if (m
== MATCH_YES
)
4823 if (!merge_array_spec (as
, current_as
, false))
4830 if (d
== DECL_CODIMENSION
)
4831 gfc_error ("Missing codimension specification at %C");
4833 gfc_error ("Missing dimension specification at %C");
4837 if (m
== MATCH_ERROR
)
4842 /* Since we've seen a double colon, we have to be looking at an
4843 attr-spec. This means that we can now issue errors. */
4844 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
4849 case DECL_ALLOCATABLE
:
4850 attr
= "ALLOCATABLE";
4852 case DECL_ASYNCHRONOUS
:
4853 attr
= "ASYNCHRONOUS";
4855 case DECL_CODIMENSION
:
4856 attr
= "CODIMENSION";
4858 case DECL_CONTIGUOUS
:
4859 attr
= "CONTIGUOUS";
4861 case DECL_DIMENSION
:
4868 attr
= "INTENT (IN)";
4871 attr
= "INTENT (OUT)";
4874 attr
= "INTENT (IN OUT)";
4876 case DECL_INTRINSIC
:
4888 case DECL_PARAMETER
:
4894 case DECL_PROTECTED
:
4909 case DECL_AUTOMATIC
:
4915 case DECL_IS_BIND_C
:
4925 attr
= NULL
; /* This shouldn't happen. */
4928 gfc_error ("Duplicate %s attribute at %L", attr
, &seen_at
[d
]);
4933 /* Now that we've dealt with duplicate attributes, add the attributes
4934 to the current attribute. */
4935 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
4942 if ((d
== DECL_STATIC
|| d
== DECL_AUTOMATIC
)
4943 && !flag_dec_static
)
4945 gfc_error ("%s at %L is a DEC extension, enable with "
4947 d
== DECL_STATIC
? "STATIC" : "AUTOMATIC", &seen_at
[d
]);
4951 /* Allow SAVE with STATIC, but don't complain. */
4952 if (d
== DECL_STATIC
&& seen
[DECL_SAVE
])
4955 if (gfc_current_state () == COMP_DERIVED
4956 && d
!= DECL_DIMENSION
&& d
!= DECL_CODIMENSION
4957 && d
!= DECL_POINTER
&& d
!= DECL_PRIVATE
4958 && d
!= DECL_PUBLIC
&& d
!= DECL_CONTIGUOUS
&& d
!= DECL_NONE
)
4960 if (d
== DECL_ALLOCATABLE
)
4962 if (!gfc_notify_std (GFC_STD_F2003
, "ALLOCATABLE "
4963 "attribute at %C in a TYPE definition"))
4969 else if (d
== DECL_KIND
)
4971 if (!gfc_notify_std (GFC_STD_F2003
, "KIND "
4972 "attribute at %C in a TYPE definition"))
4977 if (current_ts
.type
!= BT_INTEGER
)
4979 gfc_error ("Component with KIND attribute at %C must be "
4984 if (current_ts
.kind
!= gfc_default_integer_kind
)
4986 gfc_error ("Component with KIND attribute at %C must be "
4987 "default integer kind (%d)",
4988 gfc_default_integer_kind
);
4993 else if (d
== DECL_LEN
)
4995 if (!gfc_notify_std (GFC_STD_F2003
, "LEN "
4996 "attribute at %C in a TYPE definition"))
5001 if (current_ts
.type
!= BT_INTEGER
)
5003 gfc_error ("Component with LEN attribute at %C must be "
5008 if (current_ts
.kind
!= gfc_default_integer_kind
)
5010 gfc_error ("Component with LEN attribute at %C must be "
5011 "default integer kind (%d)",
5012 gfc_default_integer_kind
);
5019 gfc_error ("Attribute at %L is not allowed in a TYPE definition",
5026 if ((d
== DECL_PRIVATE
|| d
== DECL_PUBLIC
)
5027 && gfc_current_state () != COMP_MODULE
)
5029 if (d
== DECL_PRIVATE
)
5033 if (gfc_current_state () == COMP_DERIVED
5034 && gfc_state_stack
->previous
5035 && gfc_state_stack
->previous
->state
== COMP_MODULE
)
5037 if (!gfc_notify_std (GFC_STD_F2003
, "Attribute %s "
5038 "at %L in a TYPE definition", attr
,
5047 gfc_error ("%s attribute at %L is not allowed outside of the "
5048 "specification part of a module", attr
, &seen_at
[d
]);
5054 if (gfc_current_state () != COMP_DERIVED
5055 && (d
== DECL_KIND
|| d
== DECL_LEN
))
5057 gfc_error ("Attribute at %L is not allowed outside a TYPE "
5058 "definition", &seen_at
[d
]);
5065 case DECL_ALLOCATABLE
:
5066 t
= gfc_add_allocatable (¤t_attr
, &seen_at
[d
]);
5069 case DECL_ASYNCHRONOUS
:
5070 if (!gfc_notify_std (GFC_STD_F2003
, "ASYNCHRONOUS attribute at %C"))
5073 t
= gfc_add_asynchronous (¤t_attr
, NULL
, &seen_at
[d
]);
5076 case DECL_CODIMENSION
:
5077 t
= gfc_add_codimension (¤t_attr
, NULL
, &seen_at
[d
]);
5080 case DECL_CONTIGUOUS
:
5081 if (!gfc_notify_std (GFC_STD_F2008
, "CONTIGUOUS attribute at %C"))
5084 t
= gfc_add_contiguous (¤t_attr
, NULL
, &seen_at
[d
]);
5087 case DECL_DIMENSION
:
5088 t
= gfc_add_dimension (¤t_attr
, NULL
, &seen_at
[d
]);
5092 t
= gfc_add_external (¤t_attr
, &seen_at
[d
]);
5096 t
= gfc_add_intent (¤t_attr
, INTENT_IN
, &seen_at
[d
]);
5100 t
= gfc_add_intent (¤t_attr
, INTENT_OUT
, &seen_at
[d
]);
5104 t
= gfc_add_intent (¤t_attr
, INTENT_INOUT
, &seen_at
[d
]);
5107 case DECL_INTRINSIC
:
5108 t
= gfc_add_intrinsic (¤t_attr
, &seen_at
[d
]);
5112 t
= gfc_add_optional (¤t_attr
, &seen_at
[d
]);
5116 t
= gfc_add_kind (¤t_attr
, &seen_at
[d
]);
5120 t
= gfc_add_len (¤t_attr
, &seen_at
[d
]);
5123 case DECL_PARAMETER
:
5124 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, &seen_at
[d
]);
5128 t
= gfc_add_pointer (¤t_attr
, &seen_at
[d
]);
5131 case DECL_PROTECTED
:
5132 if (gfc_current_state () != COMP_MODULE
5133 || (gfc_current_ns
->proc_name
5134 && gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
))
5136 gfc_error ("PROTECTED at %C only allowed in specification "
5137 "part of a module");
5142 if (!gfc_notify_std (GFC_STD_F2003
, "PROTECTED attribute at %C"))
5145 t
= gfc_add_protected (¤t_attr
, NULL
, &seen_at
[d
]);
5149 t
= gfc_add_access (¤t_attr
, ACCESS_PRIVATE
, NULL
,
5154 t
= gfc_add_access (¤t_attr
, ACCESS_PUBLIC
, NULL
,
5160 t
= gfc_add_save (¤t_attr
, SAVE_EXPLICIT
, NULL
, &seen_at
[d
]);
5163 case DECL_AUTOMATIC
:
5164 t
= gfc_add_automatic (¤t_attr
, NULL
, &seen_at
[d
]);
5168 t
= gfc_add_target (¤t_attr
, &seen_at
[d
]);
5171 case DECL_IS_BIND_C
:
5172 t
= gfc_add_is_bind_c(¤t_attr
, NULL
, &seen_at
[d
], 0);
5176 if (!gfc_notify_std (GFC_STD_F2003
, "VALUE attribute at %C"))
5179 t
= gfc_add_value (¤t_attr
, NULL
, &seen_at
[d
]);
5183 if (!gfc_notify_std (GFC_STD_F2003
, "VOLATILE attribute at %C"))
5186 t
= gfc_add_volatile (¤t_attr
, NULL
, &seen_at
[d
]);
5190 gfc_internal_error ("match_attr_spec(): Bad attribute");
5200 /* Since Fortran 2008 module variables implicitly have the SAVE attribute. */
5201 if ((gfc_current_state () == COMP_MODULE
5202 || gfc_current_state () == COMP_SUBMODULE
)
5203 && !current_attr
.save
5204 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
5205 current_attr
.save
= SAVE_IMPLICIT
;
5211 gfc_current_locus
= start
;
5212 gfc_free_array_spec (current_as
);
5219 /* Set the binding label, dest_label, either with the binding label
5220 stored in the given gfc_typespec, ts, or if none was provided, it
5221 will be the symbol name in all lower case, as required by the draft
5222 (J3/04-007, section 15.4.1). If a binding label was given and
5223 there is more than one argument (num_idents), it is an error. */
5226 set_binding_label (const char **dest_label
, const char *sym_name
,
5229 if (num_idents
> 1 && has_name_equals
)
5231 gfc_error ("Multiple identifiers provided with "
5232 "single NAME= specifier at %C");
5236 if (curr_binding_label
)
5237 /* Binding label given; store in temp holder till have sym. */
5238 *dest_label
= curr_binding_label
;
5241 /* No binding label given, and the NAME= specifier did not exist,
5242 which means there was no NAME="". */
5243 if (sym_name
!= NULL
&& has_name_equals
== 0)
5244 *dest_label
= IDENTIFIER_POINTER (get_identifier (sym_name
));
5251 /* Set the status of the given common block as being BIND(C) or not,
5252 depending on the given parameter, is_bind_c. */
5255 set_com_block_bind_c (gfc_common_head
*com_block
, int is_bind_c
)
5257 com_block
->is_bind_c
= is_bind_c
;
5262 /* Verify that the given gfc_typespec is for a C interoperable type. */
5265 gfc_verify_c_interop (gfc_typespec
*ts
)
5267 if (ts
->type
== BT_DERIVED
&& ts
->u
.derived
!= NULL
)
5268 return (ts
->u
.derived
->ts
.is_c_interop
|| ts
->u
.derived
->attr
.is_bind_c
)
5270 else if (ts
->type
== BT_CLASS
)
5272 else if (ts
->is_c_interop
!= 1 && ts
->type
!= BT_ASSUMED
)
5279 /* Verify that the variables of a given common block, which has been
5280 defined with the attribute specifier bind(c), to be of a C
5281 interoperable type. Errors will be reported here, if
5285 verify_com_block_vars_c_interop (gfc_common_head
*com_block
)
5287 gfc_symbol
*curr_sym
= NULL
;
5290 curr_sym
= com_block
->head
;
5292 /* Make sure we have at least one symbol. */
5293 if (curr_sym
== NULL
)
5296 /* Here we know we have a symbol, so we'll execute this loop
5300 /* The second to last param, 1, says this is in a common block. */
5301 retval
= verify_bind_c_sym (curr_sym
, &(curr_sym
->ts
), 1, com_block
);
5302 curr_sym
= curr_sym
->common_next
;
5303 } while (curr_sym
!= NULL
);
5309 /* Verify that a given BIND(C) symbol is C interoperable. If it is not,
5310 an appropriate error message is reported. */
5313 verify_bind_c_sym (gfc_symbol
*tmp_sym
, gfc_typespec
*ts
,
5314 int is_in_common
, gfc_common_head
*com_block
)
5316 bool bind_c_function
= false;
5319 if (tmp_sym
->attr
.function
&& tmp_sym
->attr
.is_bind_c
)
5320 bind_c_function
= true;
5322 if (tmp_sym
->attr
.function
&& tmp_sym
->result
!= NULL
)
5324 tmp_sym
= tmp_sym
->result
;
5325 /* Make sure it wasn't an implicitly typed result. */
5326 if (tmp_sym
->attr
.implicit_type
&& warn_c_binding_type
)
5328 gfc_warning (OPT_Wc_binding_type
,
5329 "Implicitly declared BIND(C) function %qs at "
5330 "%L may not be C interoperable", tmp_sym
->name
,
5331 &tmp_sym
->declared_at
);
5332 tmp_sym
->ts
.f90_type
= tmp_sym
->ts
.type
;
5333 /* Mark it as C interoperable to prevent duplicate warnings. */
5334 tmp_sym
->ts
.is_c_interop
= 1;
5335 tmp_sym
->attr
.is_c_interop
= 1;
5339 /* Here, we know we have the bind(c) attribute, so if we have
5340 enough type info, then verify that it's a C interop kind.
5341 The info could be in the symbol already, or possibly still in
5342 the given ts (current_ts), so look in both. */
5343 if (tmp_sym
->ts
.type
!= BT_UNKNOWN
|| ts
->type
!= BT_UNKNOWN
)
5345 if (!gfc_verify_c_interop (&(tmp_sym
->ts
)))
5347 /* See if we're dealing with a sym in a common block or not. */
5348 if (is_in_common
== 1 && warn_c_binding_type
)
5350 gfc_warning (OPT_Wc_binding_type
,
5351 "Variable %qs in common block %qs at %L "
5352 "may not be a C interoperable "
5353 "kind though common block %qs is BIND(C)",
5354 tmp_sym
->name
, com_block
->name
,
5355 &(tmp_sym
->declared_at
), com_block
->name
);
5359 if (tmp_sym
->ts
.type
== BT_DERIVED
|| ts
->type
== BT_DERIVED
)
5360 gfc_error ("Type declaration %qs at %L is not C "
5361 "interoperable but it is BIND(C)",
5362 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5363 else if (warn_c_binding_type
)
5364 gfc_warning (OPT_Wc_binding_type
, "Variable %qs at %L "
5365 "may not be a C interoperable "
5366 "kind but it is BIND(C)",
5367 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5371 /* Variables declared w/in a common block can't be bind(c)
5372 since there's no way for C to see these variables, so there's
5373 semantically no reason for the attribute. */
5374 if (is_in_common
== 1 && tmp_sym
->attr
.is_bind_c
== 1)
5376 gfc_error ("Variable %qs in common block %qs at "
5377 "%L cannot be declared with BIND(C) "
5378 "since it is not a global",
5379 tmp_sym
->name
, com_block
->name
,
5380 &(tmp_sym
->declared_at
));
5384 /* Scalar variables that are bind(c) can not have the pointer
5385 or allocatable attributes. */
5386 if (tmp_sym
->attr
.is_bind_c
== 1)
5388 if (tmp_sym
->attr
.pointer
== 1)
5390 gfc_error ("Variable %qs at %L cannot have both the "
5391 "POINTER and BIND(C) attributes",
5392 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5396 if (tmp_sym
->attr
.allocatable
== 1)
5398 gfc_error ("Variable %qs at %L cannot have both the "
5399 "ALLOCATABLE and BIND(C) attributes",
5400 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5406 /* If it is a BIND(C) function, make sure the return value is a
5407 scalar value. The previous tests in this function made sure
5408 the type is interoperable. */
5409 if (bind_c_function
&& tmp_sym
->as
!= NULL
)
5410 gfc_error ("Return type of BIND(C) function %qs at %L cannot "
5411 "be an array", tmp_sym
->name
, &(tmp_sym
->declared_at
));
5413 /* BIND(C) functions can not return a character string. */
5414 if (bind_c_function
&& tmp_sym
->ts
.type
== BT_CHARACTER
)
5415 if (tmp_sym
->ts
.u
.cl
== NULL
|| tmp_sym
->ts
.u
.cl
->length
== NULL
5416 || tmp_sym
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
5417 || mpz_cmp_si (tmp_sym
->ts
.u
.cl
->length
->value
.integer
, 1) != 0)
5418 gfc_error ("Return type of BIND(C) function %qs at %L cannot "
5419 "be a character string", tmp_sym
->name
,
5420 &(tmp_sym
->declared_at
));
5423 /* See if the symbol has been marked as private. If it has, make sure
5424 there is no binding label and warn the user if there is one. */
5425 if (tmp_sym
->attr
.access
== ACCESS_PRIVATE
5426 && tmp_sym
->binding_label
)
5427 /* Use gfc_warning_now because we won't say that the symbol fails
5428 just because of this. */
5429 gfc_warning_now (0, "Symbol %qs at %L is marked PRIVATE but has been "
5430 "given the binding label %qs", tmp_sym
->name
,
5431 &(tmp_sym
->declared_at
), tmp_sym
->binding_label
);
5437 /* Set the appropriate fields for a symbol that's been declared as
5438 BIND(C) (the is_bind_c flag and the binding label), and verify that
5439 the type is C interoperable. Errors are reported by the functions
5440 used to set/test these fields. */
5443 set_verify_bind_c_sym (gfc_symbol
*tmp_sym
, int num_idents
)
5447 /* TODO: Do we need to make sure the vars aren't marked private? */
5449 /* Set the is_bind_c bit in symbol_attribute. */
5450 gfc_add_is_bind_c (&(tmp_sym
->attr
), tmp_sym
->name
, &gfc_current_locus
, 0);
5452 if (!set_binding_label (&tmp_sym
->binding_label
, tmp_sym
->name
, num_idents
))
5459 /* Set the fields marking the given common block as BIND(C), including
5460 a binding label, and report any errors encountered. */
5463 set_verify_bind_c_com_block (gfc_common_head
*com_block
, int num_idents
)
5467 /* destLabel, common name, typespec (which may have binding label). */
5468 if (!set_binding_label (&com_block
->binding_label
, com_block
->name
,
5472 /* Set the given common block (com_block) to being bind(c) (1). */
5473 set_com_block_bind_c (com_block
, 1);
5479 /* Retrieve the list of one or more identifiers that the given bind(c)
5480 attribute applies to. */
5483 get_bind_c_idents (void)
5485 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5487 gfc_symbol
*tmp_sym
= NULL
;
5489 gfc_common_head
*com_block
= NULL
;
5491 if (gfc_match_name (name
) == MATCH_YES
)
5493 found_id
= MATCH_YES
;
5494 gfc_get_ha_symbol (name
, &tmp_sym
);
5496 else if (match_common_name (name
) == MATCH_YES
)
5498 found_id
= MATCH_YES
;
5499 com_block
= gfc_get_common (name
, 0);
5503 gfc_error ("Need either entity or common block name for "
5504 "attribute specification statement at %C");
5508 /* Save the current identifier and look for more. */
5511 /* Increment the number of identifiers found for this spec stmt. */
5514 /* Make sure we have a sym or com block, and verify that it can
5515 be bind(c). Set the appropriate field(s) and look for more
5517 if (tmp_sym
!= NULL
|| com_block
!= NULL
)
5519 if (tmp_sym
!= NULL
)
5521 if (!set_verify_bind_c_sym (tmp_sym
, num_idents
))
5526 if (!set_verify_bind_c_com_block (com_block
, num_idents
))
5530 /* Look to see if we have another identifier. */
5532 if (gfc_match_eos () == MATCH_YES
)
5533 found_id
= MATCH_NO
;
5534 else if (gfc_match_char (',') != MATCH_YES
)
5535 found_id
= MATCH_NO
;
5536 else if (gfc_match_name (name
) == MATCH_YES
)
5538 found_id
= MATCH_YES
;
5539 gfc_get_ha_symbol (name
, &tmp_sym
);
5541 else if (match_common_name (name
) == MATCH_YES
)
5543 found_id
= MATCH_YES
;
5544 com_block
= gfc_get_common (name
, 0);
5548 gfc_error ("Missing entity or common block name for "
5549 "attribute specification statement at %C");
5555 gfc_internal_error ("Missing symbol");
5557 } while (found_id
== MATCH_YES
);
5559 /* if we get here we were successful */
5564 /* Try and match a BIND(C) attribute specification statement. */
5567 gfc_match_bind_c_stmt (void)
5569 match found_match
= MATCH_NO
;
5574 /* This may not be necessary. */
5576 /* Clear the temporary binding label holder. */
5577 curr_binding_label
= NULL
;
5579 /* Look for the bind(c). */
5580 found_match
= gfc_match_bind_c (NULL
, true);
5582 if (found_match
== MATCH_YES
)
5584 if (!gfc_notify_std (GFC_STD_F2003
, "BIND(C) statement at %C"))
5587 /* Look for the :: now, but it is not required. */
5590 /* Get the identifier(s) that needs to be updated. This may need to
5591 change to hand the flag(s) for the attr specified so all identifiers
5592 found can have all appropriate parts updated (assuming that the same
5593 spec stmt can have multiple attrs, such as both bind(c) and
5595 if (!get_bind_c_idents ())
5596 /* Error message should have printed already. */
5604 /* Match a data declaration statement. */
5607 gfc_match_data_decl (void)
5613 type_param_spec_list
= NULL
;
5614 decl_type_param_list
= NULL
;
5616 num_idents_on_line
= 0;
5618 m
= gfc_match_decl_type_spec (¤t_ts
, 0);
5622 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
5623 && !gfc_comp_struct (gfc_current_state ()))
5625 sym
= gfc_use_derived (current_ts
.u
.derived
);
5633 current_ts
.u
.derived
= sym
;
5636 m
= match_attr_spec ();
5637 if (m
== MATCH_ERROR
)
5643 if (current_ts
.type
== BT_CLASS
5644 && current_ts
.u
.derived
->attr
.unlimited_polymorphic
)
5647 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
5648 && current_ts
.u
.derived
->components
== NULL
5649 && !current_ts
.u
.derived
->attr
.zero_comp
)
5652 if (current_attr
.pointer
&& gfc_comp_struct (gfc_current_state ()))
5655 if (current_attr
.allocatable
&& gfc_current_state () == COMP_DERIVED
5656 && current_ts
.u
.derived
== gfc_current_block ())
5659 gfc_find_symbol (current_ts
.u
.derived
->name
,
5660 current_ts
.u
.derived
->ns
, 1, &sym
);
5662 /* Any symbol that we find had better be a type definition
5663 which has its components defined, or be a structure definition
5664 actively being parsed. */
5665 if (sym
!= NULL
&& gfc_fl_struct (sym
->attr
.flavor
)
5666 && (current_ts
.u
.derived
->components
!= NULL
5667 || current_ts
.u
.derived
->attr
.zero_comp
5668 || current_ts
.u
.derived
== gfc_new_block
))
5671 gfc_error ("Derived type at %C has not been previously defined "
5672 "and so cannot appear in a derived type definition");
5678 /* If we have an old-style character declaration, and no new-style
5679 attribute specifications, then there a comma is optional between
5680 the type specification and the variable list. */
5681 if (m
== MATCH_NO
&& current_ts
.type
== BT_CHARACTER
&& old_char_selector
)
5682 gfc_match_char (',');
5684 /* Give the types/attributes to symbols that follow. Give the element
5685 a number so that repeat character length expressions can be copied. */
5689 num_idents_on_line
++;
5690 m
= variable_decl (elem
++);
5691 if (m
== MATCH_ERROR
)
5696 if (gfc_match_eos () == MATCH_YES
)
5698 if (gfc_match_char (',') != MATCH_YES
)
5702 if (!gfc_error_flag_test ())
5704 /* An anonymous structure declaration is unambiguous; if we matched one
5705 according to gfc_match_structure_decl, we need to return MATCH_YES
5706 here to avoid confusing the remaining matchers, even if there was an
5707 error during variable_decl. We must flush any such errors. Note this
5708 causes the parser to gracefully continue parsing the remaining input
5709 as a structure body, which likely follows. */
5710 if (current_ts
.type
== BT_DERIVED
&& current_ts
.u
.derived
5711 && gfc_fl_struct (current_ts
.u
.derived
->attr
.flavor
))
5713 gfc_error_now ("Syntax error in anonymous structure declaration"
5715 /* Skip the bad variable_decl and line up for the start of the
5717 gfc_error_recovery ();
5722 gfc_error ("Syntax error in data declaration at %C");
5727 gfc_free_data_all (gfc_current_ns
);
5730 if (saved_kind_expr
)
5731 gfc_free_expr (saved_kind_expr
);
5732 if (type_param_spec_list
)
5733 gfc_free_actual_arglist (type_param_spec_list
);
5734 if (decl_type_param_list
)
5735 gfc_free_actual_arglist (decl_type_param_list
);
5736 saved_kind_expr
= NULL
;
5737 gfc_free_array_spec (current_as
);
5743 /* Match a prefix associated with a function or subroutine
5744 declaration. If the typespec pointer is nonnull, then a typespec
5745 can be matched. Note that if nothing matches, MATCH_YES is
5746 returned (the null string was matched). */
5749 gfc_match_prefix (gfc_typespec
*ts
)
5755 gfc_clear_attr (¤t_attr
);
5757 seen_impure
= false;
5759 gcc_assert (!gfc_matching_prefix
);
5760 gfc_matching_prefix
= true;
5764 found_prefix
= false;
5766 /* MODULE is a prefix like PURE, ELEMENTAL, etc., having a
5767 corresponding attribute seems natural and distinguishes these
5768 procedures from procedure types of PROC_MODULE, which these are
5770 if (gfc_match ("module% ") == MATCH_YES
)
5772 if (!gfc_notify_std (GFC_STD_F2008
, "MODULE prefix at %C"))
5775 current_attr
.module_procedure
= 1;
5776 found_prefix
= true;
5779 if (!seen_type
&& ts
!= NULL
5780 && gfc_match_decl_type_spec (ts
, 0) == MATCH_YES
5781 && gfc_match_space () == MATCH_YES
)
5785 found_prefix
= true;
5788 if (gfc_match ("elemental% ") == MATCH_YES
)
5790 if (!gfc_add_elemental (¤t_attr
, NULL
))
5793 found_prefix
= true;
5796 if (gfc_match ("pure% ") == MATCH_YES
)
5798 if (!gfc_add_pure (¤t_attr
, NULL
))
5801 found_prefix
= true;
5804 if (gfc_match ("recursive% ") == MATCH_YES
)
5806 if (!gfc_add_recursive (¤t_attr
, NULL
))
5809 found_prefix
= true;
5812 /* IMPURE is a somewhat special case, as it needs not set an actual
5813 attribute but rather only prevents ELEMENTAL routines from being
5814 automatically PURE. */
5815 if (gfc_match ("impure% ") == MATCH_YES
)
5817 if (!gfc_notify_std (GFC_STD_F2008
, "IMPURE procedure at %C"))
5821 found_prefix
= true;
5824 while (found_prefix
);
5826 /* IMPURE and PURE must not both appear, of course. */
5827 if (seen_impure
&& current_attr
.pure
)
5829 gfc_error ("PURE and IMPURE must not appear both at %C");
5833 /* If IMPURE it not seen but the procedure is ELEMENTAL, mark it as PURE. */
5834 if (!seen_impure
&& current_attr
.elemental
&& !current_attr
.pure
)
5836 if (!gfc_add_pure (¤t_attr
, NULL
))
5840 /* At this point, the next item is not a prefix. */
5841 gcc_assert (gfc_matching_prefix
);
5843 gfc_matching_prefix
= false;
5847 gcc_assert (gfc_matching_prefix
);
5848 gfc_matching_prefix
= false;
5853 /* Copy attributes matched by gfc_match_prefix() to attributes on a symbol. */
5856 copy_prefix (symbol_attribute
*dest
, locus
*where
)
5858 if (dest
->module_procedure
)
5860 if (current_attr
.elemental
)
5861 dest
->elemental
= 1;
5863 if (current_attr
.pure
)
5866 if (current_attr
.recursive
)
5867 dest
->recursive
= 1;
5869 /* Module procedures are unusual in that the 'dest' is copied from
5870 the interface declaration. However, this is an oportunity to
5871 check that the submodule declaration is compliant with the
5873 if (dest
->elemental
&& !current_attr
.elemental
)
5875 gfc_error ("ELEMENTAL prefix in MODULE PROCEDURE interface is "
5876 "missing at %L", where
);
5880 if (dest
->pure
&& !current_attr
.pure
)
5882 gfc_error ("PURE prefix in MODULE PROCEDURE interface is "
5883 "missing at %L", where
);
5887 if (dest
->recursive
&& !current_attr
.recursive
)
5889 gfc_error ("RECURSIVE prefix in MODULE PROCEDURE interface is "
5890 "missing at %L", where
);
5897 if (current_attr
.elemental
&& !gfc_add_elemental (dest
, where
))
5900 if (current_attr
.pure
&& !gfc_add_pure (dest
, where
))
5903 if (current_attr
.recursive
&& !gfc_add_recursive (dest
, where
))
5910 /* Match a formal argument list or, if typeparam is true, a
5911 type_param_name_list. */
5914 gfc_match_formal_arglist (gfc_symbol
*progname
, int st_flag
,
5915 int null_flag
, bool typeparam
)
5917 gfc_formal_arglist
*head
, *tail
, *p
, *q
;
5918 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5921 gfc_formal_arglist
*formal
= NULL
;
5925 /* Keep the interface formal argument list and null it so that the
5926 matching for the new declaration can be done. The numbers and
5927 names of the arguments are checked here. The interface formal
5928 arguments are retained in formal_arglist and the characteristics
5929 are compared in resolve.c(resolve_fl_procedure). See the remark
5930 in get_proc_name about the eventual need to copy the formal_arglist
5931 and populate the formal namespace of the interface symbol. */
5932 if (progname
->attr
.module_procedure
5933 && progname
->attr
.host_assoc
)
5935 formal
= progname
->formal
;
5936 progname
->formal
= NULL
;
5939 if (gfc_match_char ('(') != MATCH_YES
)
5946 if (gfc_match_char (')') == MATCH_YES
)
5951 if (gfc_match_char ('*') == MATCH_YES
)
5954 if (!typeparam
&& !gfc_notify_std (GFC_STD_F95_OBS
,
5955 "Alternate-return argument at %C"))
5961 gfc_error_now ("A parameter name is required at %C");
5965 m
= gfc_match_name (name
);
5969 gfc_error_now ("A parameter name is required at %C");
5973 if (!typeparam
&& gfc_get_symbol (name
, NULL
, &sym
))
5976 && gfc_get_symbol (name
, progname
->f2k_derived
, &sym
))
5980 p
= gfc_get_formal_arglist ();
5992 /* We don't add the VARIABLE flavor because the name could be a
5993 dummy procedure. We don't apply these attributes to formal
5994 arguments of statement functions. */
5995 if (sym
!= NULL
&& !st_flag
5996 && (!gfc_add_dummy(&sym
->attr
, sym
->name
, NULL
)
5997 || !gfc_missing_attr (&sym
->attr
, NULL
)))
6003 /* The name of a program unit can be in a different namespace,
6004 so check for it explicitly. After the statement is accepted,
6005 the name is checked for especially in gfc_get_symbol(). */
6006 if (gfc_new_block
!= NULL
&& sym
!= NULL
&& !typeparam
6007 && strcmp (sym
->name
, gfc_new_block
->name
) == 0)
6009 gfc_error ("Name %qs at %C is the name of the procedure",
6015 if (gfc_match_char (')') == MATCH_YES
)
6018 m
= gfc_match_char (',');
6022 gfc_error_now ("Expected parameter list in type declaration "
6025 gfc_error ("Unexpected junk in formal argument list at %C");
6031 /* Check for duplicate symbols in the formal argument list. */
6034 for (p
= head
; p
->next
; p
= p
->next
)
6039 for (q
= p
->next
; q
; q
= q
->next
)
6040 if (p
->sym
== q
->sym
)
6043 gfc_error_now ("Duplicate name %qs in parameter "
6044 "list at %C", p
->sym
->name
);
6046 gfc_error ("Duplicate symbol %qs in formal argument "
6047 "list at %C", p
->sym
->name
);
6055 if (!gfc_add_explicit_interface (progname
, IFSRC_DECL
, head
, NULL
))
6061 /* gfc_error_now used in following and return with MATCH_YES because
6062 doing otherwise results in a cascade of extraneous errors and in
6063 some cases an ICE in symbol.c(gfc_release_symbol). */
6064 if (progname
->attr
.module_procedure
&& progname
->attr
.host_assoc
)
6066 bool arg_count_mismatch
= false;
6068 if (!formal
&& head
)
6069 arg_count_mismatch
= true;
6071 /* Abbreviated module procedure declaration is not meant to have any
6072 formal arguments! */
6073 if (!progname
->abr_modproc_decl
&& formal
&& !head
)
6074 arg_count_mismatch
= true;
6076 for (p
= formal
, q
= head
; p
&& q
; p
= p
->next
, q
= q
->next
)
6078 if ((p
->next
!= NULL
&& q
->next
== NULL
)
6079 || (p
->next
== NULL
&& q
->next
!= NULL
))
6080 arg_count_mismatch
= true;
6081 else if ((p
->sym
== NULL
&& q
->sym
== NULL
)
6082 || strcmp (p
->sym
->name
, q
->sym
->name
) == 0)
6085 gfc_error_now ("Mismatch in MODULE PROCEDURE formal "
6086 "argument names (%s/%s) at %C",
6087 p
->sym
->name
, q
->sym
->name
);
6090 if (arg_count_mismatch
)
6091 gfc_error_now ("Mismatch in number of MODULE PROCEDURE "
6092 "formal arguments at %C");
6098 gfc_free_formal_arglist (head
);
6103 /* Match a RESULT specification following a function declaration or
6104 ENTRY statement. Also matches the end-of-statement. */
6107 match_result (gfc_symbol
*function
, gfc_symbol
**result
)
6109 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6113 if (gfc_match (" result (") != MATCH_YES
)
6116 m
= gfc_match_name (name
);
6120 /* Get the right paren, and that's it because there could be the
6121 bind(c) attribute after the result clause. */
6122 if (gfc_match_char (')') != MATCH_YES
)
6124 /* TODO: should report the missing right paren here. */
6128 if (strcmp (function
->name
, name
) == 0)
6130 gfc_error ("RESULT variable at %C must be different than function name");
6134 if (gfc_get_symbol (name
, NULL
, &r
))
6137 if (!gfc_add_result (&r
->attr
, r
->name
, NULL
))
6146 /* Match a function suffix, which could be a combination of a result
6147 clause and BIND(C), either one, or neither. The draft does not
6148 require them to come in a specific order. */
6151 gfc_match_suffix (gfc_symbol
*sym
, gfc_symbol
**result
)
6153 match is_bind_c
; /* Found bind(c). */
6154 match is_result
; /* Found result clause. */
6155 match found_match
; /* Status of whether we've found a good match. */
6156 char peek_char
; /* Character we're going to peek at. */
6157 bool allow_binding_name
;
6159 /* Initialize to having found nothing. */
6160 found_match
= MATCH_NO
;
6161 is_bind_c
= MATCH_NO
;
6162 is_result
= MATCH_NO
;
6164 /* Get the next char to narrow between result and bind(c). */
6165 gfc_gobble_whitespace ();
6166 peek_char
= gfc_peek_ascii_char ();
6168 /* C binding names are not allowed for internal procedures. */
6169 if (gfc_current_state () == COMP_CONTAINS
6170 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
6171 allow_binding_name
= false;
6173 allow_binding_name
= true;
6178 /* Look for result clause. */
6179 is_result
= match_result (sym
, result
);
6180 if (is_result
== MATCH_YES
)
6182 /* Now see if there is a bind(c) after it. */
6183 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
6184 /* We've found the result clause and possibly bind(c). */
6185 found_match
= MATCH_YES
;
6188 /* This should only be MATCH_ERROR. */
6189 found_match
= is_result
;
6192 /* Look for bind(c) first. */
6193 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
6194 if (is_bind_c
== MATCH_YES
)
6196 /* Now see if a result clause followed it. */
6197 is_result
= match_result (sym
, result
);
6198 found_match
= MATCH_YES
;
6202 /* Should only be a MATCH_ERROR if we get here after seeing 'b'. */
6203 found_match
= MATCH_ERROR
;
6207 gfc_error ("Unexpected junk after function declaration at %C");
6208 found_match
= MATCH_ERROR
;
6212 if (is_bind_c
== MATCH_YES
)
6214 /* Fortran 2008 draft allows BIND(C) for internal procedures. */
6215 if (gfc_current_state () == COMP_CONTAINS
6216 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
6217 && !gfc_notify_std (GFC_STD_F2008
, "BIND(C) attribute "
6218 "at %L may not be specified for an internal "
6219 "procedure", &gfc_current_locus
))
6222 if (!gfc_add_is_bind_c (&(sym
->attr
), sym
->name
, &gfc_current_locus
, 1))
6230 /* Procedure pointer return value without RESULT statement:
6231 Add "hidden" result variable named "ppr@". */
6234 add_hidden_procptr_result (gfc_symbol
*sym
)
6238 if (gfc_notification_std (GFC_STD_F2003
) == ERROR
)
6241 /* First usage case: PROCEDURE and EXTERNAL statements. */
6242 case1
= gfc_current_state () == COMP_FUNCTION
&& gfc_current_block ()
6243 && strcmp (gfc_current_block ()->name
, sym
->name
) == 0
6244 && sym
->attr
.external
;
6245 /* Second usage case: INTERFACE statements. */
6246 case2
= gfc_current_state () == COMP_INTERFACE
&& gfc_state_stack
->previous
6247 && gfc_state_stack
->previous
->state
== COMP_FUNCTION
6248 && strcmp (gfc_state_stack
->previous
->sym
->name
, sym
->name
) == 0;
6254 gfc_get_sym_tree ("ppr@", gfc_current_ns
, &stree
, false);
6258 gfc_get_sym_tree ("ppr@", gfc_current_ns
->parent
, &stree
, false);
6259 st2
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "ppr@");
6260 st2
->n
.sym
= stree
->n
.sym
;
6261 stree
->n
.sym
->refs
++;
6263 sym
->result
= stree
->n
.sym
;
6265 sym
->result
->attr
.proc_pointer
= sym
->attr
.proc_pointer
;
6266 sym
->result
->attr
.pointer
= sym
->attr
.pointer
;
6267 sym
->result
->attr
.external
= sym
->attr
.external
;
6268 sym
->result
->attr
.referenced
= sym
->attr
.referenced
;
6269 sym
->result
->ts
= sym
->ts
;
6270 sym
->attr
.proc_pointer
= 0;
6271 sym
->attr
.pointer
= 0;
6272 sym
->attr
.external
= 0;
6273 if (sym
->result
->attr
.external
&& sym
->result
->attr
.pointer
)
6275 sym
->result
->attr
.pointer
= 0;
6276 sym
->result
->attr
.proc_pointer
= 1;
6279 return gfc_add_result (&sym
->result
->attr
, sym
->result
->name
, NULL
);
6281 /* POINTER after PROCEDURE/EXTERNAL/INTERFACE statement. */
6282 else if (sym
->attr
.function
&& !sym
->attr
.external
&& sym
->attr
.pointer
6283 && sym
->result
&& sym
->result
!= sym
&& sym
->result
->attr
.external
6284 && sym
== gfc_current_ns
->proc_name
6285 && sym
== sym
->result
->ns
->proc_name
6286 && strcmp ("ppr@", sym
->result
->name
) == 0)
6288 sym
->result
->attr
.proc_pointer
= 1;
6289 sym
->attr
.pointer
= 0;
6297 /* Match the interface for a PROCEDURE declaration,
6298 including brackets (R1212). */
6301 match_procedure_interface (gfc_symbol
**proc_if
)
6305 locus old_loc
, entry_loc
;
6306 gfc_namespace
*old_ns
= gfc_current_ns
;
6307 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6309 old_loc
= entry_loc
= gfc_current_locus
;
6310 gfc_clear_ts (¤t_ts
);
6312 if (gfc_match (" (") != MATCH_YES
)
6314 gfc_current_locus
= entry_loc
;
6318 /* Get the type spec. for the procedure interface. */
6319 old_loc
= gfc_current_locus
;
6320 m
= gfc_match_decl_type_spec (¤t_ts
, 0);
6321 gfc_gobble_whitespace ();
6322 if (m
== MATCH_YES
|| (m
== MATCH_NO
&& gfc_peek_ascii_char () == ')'))
6325 if (m
== MATCH_ERROR
)
6328 /* Procedure interface is itself a procedure. */
6329 gfc_current_locus
= old_loc
;
6330 m
= gfc_match_name (name
);
6332 /* First look to see if it is already accessible in the current
6333 namespace because it is use associated or contained. */
6335 if (gfc_find_sym_tree (name
, NULL
, 0, &st
))
6338 /* If it is still not found, then try the parent namespace, if it
6339 exists and create the symbol there if it is still not found. */
6340 if (gfc_current_ns
->parent
)
6341 gfc_current_ns
= gfc_current_ns
->parent
;
6342 if (st
== NULL
&& gfc_get_ha_sym_tree (name
, &st
))
6345 gfc_current_ns
= old_ns
;
6346 *proc_if
= st
->n
.sym
;
6351 /* Resolve interface if possible. That way, attr.procedure is only set
6352 if it is declared by a later procedure-declaration-stmt, which is
6353 invalid per F08:C1216 (cf. resolve_procedure_interface). */
6354 while ((*proc_if
)->ts
.interface
6355 && *proc_if
!= (*proc_if
)->ts
.interface
)
6356 *proc_if
= (*proc_if
)->ts
.interface
;
6358 if ((*proc_if
)->attr
.flavor
== FL_UNKNOWN
6359 && (*proc_if
)->ts
.type
== BT_UNKNOWN
6360 && !gfc_add_flavor (&(*proc_if
)->attr
, FL_PROCEDURE
,
6361 (*proc_if
)->name
, NULL
))
6366 if (gfc_match (" )") != MATCH_YES
)
6368 gfc_current_locus
= entry_loc
;
6376 /* Match a PROCEDURE declaration (R1211). */
6379 match_procedure_decl (void)
6382 gfc_symbol
*sym
, *proc_if
= NULL
;
6384 gfc_expr
*initializer
= NULL
;
6386 /* Parse interface (with brackets). */
6387 m
= match_procedure_interface (&proc_if
);
6391 /* Parse attributes (with colons). */
6392 m
= match_attr_spec();
6393 if (m
== MATCH_ERROR
)
6396 if (proc_if
&& proc_if
->attr
.is_bind_c
&& !current_attr
.is_bind_c
)
6398 current_attr
.is_bind_c
= 1;
6399 has_name_equals
= 0;
6400 curr_binding_label
= NULL
;
6403 /* Get procedure symbols. */
6406 m
= gfc_match_symbol (&sym
, 0);
6409 else if (m
== MATCH_ERROR
)
6412 /* Add current_attr to the symbol attributes. */
6413 if (!gfc_copy_attr (&sym
->attr
, ¤t_attr
, NULL
))
6416 if (sym
->attr
.is_bind_c
)
6418 /* Check for C1218. */
6419 if (!proc_if
|| !proc_if
->attr
.is_bind_c
)
6421 gfc_error ("BIND(C) attribute at %C requires "
6422 "an interface with BIND(C)");
6425 /* Check for C1217. */
6426 if (has_name_equals
&& sym
->attr
.pointer
)
6428 gfc_error ("BIND(C) procedure with NAME may not have "
6429 "POINTER attribute at %C");
6432 if (has_name_equals
&& sym
->attr
.dummy
)
6434 gfc_error ("Dummy procedure at %C may not have "
6435 "BIND(C) attribute with NAME");
6438 /* Set binding label for BIND(C). */
6439 if (!set_binding_label (&sym
->binding_label
, sym
->name
, num
))
6443 if (!gfc_add_external (&sym
->attr
, NULL
))
6446 if (add_hidden_procptr_result (sym
))
6449 if (!gfc_add_proc (&sym
->attr
, sym
->name
, NULL
))
6452 /* Set interface. */
6453 if (proc_if
!= NULL
)
6455 if (sym
->ts
.type
!= BT_UNKNOWN
)
6457 gfc_error ("Procedure %qs at %L already has basic type of %s",
6458 sym
->name
, &gfc_current_locus
,
6459 gfc_basic_typename (sym
->ts
.type
));
6462 sym
->ts
.interface
= proc_if
;
6463 sym
->attr
.untyped
= 1;
6464 sym
->attr
.if_source
= IFSRC_IFBODY
;
6466 else if (current_ts
.type
!= BT_UNKNOWN
)
6468 if (!gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
6470 sym
->ts
.interface
= gfc_new_symbol ("", gfc_current_ns
);
6471 sym
->ts
.interface
->ts
= current_ts
;
6472 sym
->ts
.interface
->attr
.flavor
= FL_PROCEDURE
;
6473 sym
->ts
.interface
->attr
.function
= 1;
6474 sym
->attr
.function
= 1;
6475 sym
->attr
.if_source
= IFSRC_UNKNOWN
;
6478 if (gfc_match (" =>") == MATCH_YES
)
6480 if (!current_attr
.pointer
)
6482 gfc_error ("Initialization at %C isn't for a pointer variable");
6487 m
= match_pointer_init (&initializer
, 1);
6491 if (!add_init_expr_to_sym (sym
->name
, &initializer
, &gfc_current_locus
))
6496 if (gfc_match_eos () == MATCH_YES
)
6498 if (gfc_match_char (',') != MATCH_YES
)
6503 gfc_error ("Syntax error in PROCEDURE statement at %C");
6507 /* Free stuff up and return. */
6508 gfc_free_expr (initializer
);
6514 match_binding_attributes (gfc_typebound_proc
* ba
, bool generic
, bool ppc
);
6517 /* Match a procedure pointer component declaration (R445). */
6520 match_ppc_decl (void)
6523 gfc_symbol
*proc_if
= NULL
;
6527 gfc_expr
*initializer
= NULL
;
6528 gfc_typebound_proc
* tb
;
6529 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6531 /* Parse interface (with brackets). */
6532 m
= match_procedure_interface (&proc_if
);
6536 /* Parse attributes. */
6537 tb
= XCNEW (gfc_typebound_proc
);
6538 tb
->where
= gfc_current_locus
;
6539 m
= match_binding_attributes (tb
, false, true);
6540 if (m
== MATCH_ERROR
)
6543 gfc_clear_attr (¤t_attr
);
6544 current_attr
.procedure
= 1;
6545 current_attr
.proc_pointer
= 1;
6546 current_attr
.access
= tb
->access
;
6547 current_attr
.flavor
= FL_PROCEDURE
;
6549 /* Match the colons (required). */
6550 if (gfc_match (" ::") != MATCH_YES
)
6552 gfc_error ("Expected %<::%> after binding-attributes at %C");
6556 /* Check for C450. */
6557 if (!tb
->nopass
&& proc_if
== NULL
)
6559 gfc_error("NOPASS or explicit interface required at %C");
6563 if (!gfc_notify_std (GFC_STD_F2003
, "Procedure pointer component at %C"))
6566 /* Match PPC names. */
6570 m
= gfc_match_name (name
);
6573 else if (m
== MATCH_ERROR
)
6576 if (!gfc_add_component (gfc_current_block(), name
, &c
))
6579 /* Add current_attr to the symbol attributes. */
6580 if (!gfc_copy_attr (&c
->attr
, ¤t_attr
, NULL
))
6583 if (!gfc_add_external (&c
->attr
, NULL
))
6586 if (!gfc_add_proc (&c
->attr
, name
, NULL
))
6593 c
->tb
= XCNEW (gfc_typebound_proc
);
6594 c
->tb
->where
= gfc_current_locus
;
6598 /* Set interface. */
6599 if (proc_if
!= NULL
)
6601 c
->ts
.interface
= proc_if
;
6602 c
->attr
.untyped
= 1;
6603 c
->attr
.if_source
= IFSRC_IFBODY
;
6605 else if (ts
.type
!= BT_UNKNOWN
)
6608 c
->ts
.interface
= gfc_new_symbol ("", gfc_current_ns
);
6609 c
->ts
.interface
->result
= c
->ts
.interface
;
6610 c
->ts
.interface
->ts
= ts
;
6611 c
->ts
.interface
->attr
.flavor
= FL_PROCEDURE
;
6612 c
->ts
.interface
->attr
.function
= 1;
6613 c
->attr
.function
= 1;
6614 c
->attr
.if_source
= IFSRC_UNKNOWN
;
6617 if (gfc_match (" =>") == MATCH_YES
)
6619 m
= match_pointer_init (&initializer
, 1);
6622 gfc_free_expr (initializer
);
6625 c
->initializer
= initializer
;
6628 if (gfc_match_eos () == MATCH_YES
)
6630 if (gfc_match_char (',') != MATCH_YES
)
6635 gfc_error ("Syntax error in procedure pointer component at %C");
6640 /* Match a PROCEDURE declaration inside an interface (R1206). */
6643 match_procedure_in_interface (void)
6647 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6650 if (current_interface
.type
== INTERFACE_NAMELESS
6651 || current_interface
.type
== INTERFACE_ABSTRACT
)
6653 gfc_error ("PROCEDURE at %C must be in a generic interface");
6657 /* Check if the F2008 optional double colon appears. */
6658 gfc_gobble_whitespace ();
6659 old_locus
= gfc_current_locus
;
6660 if (gfc_match ("::") == MATCH_YES
)
6662 if (!gfc_notify_std (GFC_STD_F2008
, "double colon in "
6663 "MODULE PROCEDURE statement at %L", &old_locus
))
6667 gfc_current_locus
= old_locus
;
6671 m
= gfc_match_name (name
);
6674 else if (m
== MATCH_ERROR
)
6676 if (gfc_get_symbol (name
, gfc_current_ns
->parent
, &sym
))
6679 if (!gfc_add_interface (sym
))
6682 if (gfc_match_eos () == MATCH_YES
)
6684 if (gfc_match_char (',') != MATCH_YES
)
6691 gfc_error ("Syntax error in PROCEDURE statement at %C");
6696 /* General matcher for PROCEDURE declarations. */
6698 static match
match_procedure_in_type (void);
6701 gfc_match_procedure (void)
6705 switch (gfc_current_state ())
6710 case COMP_SUBMODULE
:
6711 case COMP_SUBROUTINE
:
6714 m
= match_procedure_decl ();
6716 case COMP_INTERFACE
:
6717 m
= match_procedure_in_interface ();
6720 m
= match_ppc_decl ();
6722 case COMP_DERIVED_CONTAINS
:
6723 m
= match_procedure_in_type ();
6732 if (!gfc_notify_std (GFC_STD_F2003
, "PROCEDURE statement at %C"))
6739 /* Warn if a matched procedure has the same name as an intrinsic; this is
6740 simply a wrapper around gfc_warn_intrinsic_shadow that interprets the current
6741 parser-state-stack to find out whether we're in a module. */
6744 do_warn_intrinsic_shadow (const gfc_symbol
* sym
, bool func
)
6748 in_module
= (gfc_state_stack
->previous
6749 && (gfc_state_stack
->previous
->state
== COMP_MODULE
6750 || gfc_state_stack
->previous
->state
== COMP_SUBMODULE
));
6752 gfc_warn_intrinsic_shadow (sym
, in_module
, func
);
6756 /* Match a function declaration. */
6759 gfc_match_function_decl (void)
6761 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6762 gfc_symbol
*sym
, *result
;
6766 match found_match
; /* Status returned by match func. */
6768 if (gfc_current_state () != COMP_NONE
6769 && gfc_current_state () != COMP_INTERFACE
6770 && gfc_current_state () != COMP_CONTAINS
)
6773 gfc_clear_ts (¤t_ts
);
6775 old_loc
= gfc_current_locus
;
6777 m
= gfc_match_prefix (¤t_ts
);
6780 gfc_current_locus
= old_loc
;
6784 if (gfc_match ("function% %n", name
) != MATCH_YES
)
6786 gfc_current_locus
= old_loc
;
6790 if (get_proc_name (name
, &sym
, false))
6793 if (add_hidden_procptr_result (sym
))
6796 if (current_attr
.module_procedure
)
6797 sym
->attr
.module_procedure
= 1;
6799 gfc_new_block
= sym
;
6801 m
= gfc_match_formal_arglist (sym
, 0, 0);
6804 gfc_error ("Expected formal argument list in function "
6805 "definition at %C");
6809 else if (m
== MATCH_ERROR
)
6814 /* According to the draft, the bind(c) and result clause can
6815 come in either order after the formal_arg_list (i.e., either
6816 can be first, both can exist together or by themselves or neither
6817 one). Therefore, the match_result can't match the end of the
6818 string, and check for the bind(c) or result clause in either order. */
6819 found_match
= gfc_match_eos ();
6821 /* Make sure that it isn't already declared as BIND(C). If it is, it
6822 must have been marked BIND(C) with a BIND(C) attribute and that is
6823 not allowed for procedures. */
6824 if (sym
->attr
.is_bind_c
== 1)
6826 sym
->attr
.is_bind_c
= 0;
6827 if (sym
->old_symbol
!= NULL
)
6828 gfc_error_now ("BIND(C) attribute at %L can only be used for "
6829 "variables or common blocks",
6830 &(sym
->old_symbol
->declared_at
));
6832 gfc_error_now ("BIND(C) attribute at %L can only be used for "
6833 "variables or common blocks", &gfc_current_locus
);
6836 if (found_match
!= MATCH_YES
)
6838 /* If we haven't found the end-of-statement, look for a suffix. */
6839 suffix_match
= gfc_match_suffix (sym
, &result
);
6840 if (suffix_match
== MATCH_YES
)
6841 /* Need to get the eos now. */
6842 found_match
= gfc_match_eos ();
6844 found_match
= suffix_match
;
6847 if(found_match
!= MATCH_YES
)
6851 /* Make changes to the symbol. */
6854 if (!gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
6857 if (!gfc_missing_attr (&sym
->attr
, NULL
))
6860 if (!copy_prefix (&sym
->attr
, &sym
->declared_at
))
6862 if(!sym
->attr
.module_procedure
)
6868 /* Delay matching the function characteristics until after the
6869 specification block by signalling kind=-1. */
6870 sym
->declared_at
= old_loc
;
6871 if (current_ts
.type
!= BT_UNKNOWN
)
6872 current_ts
.kind
= -1;
6874 current_ts
.kind
= 0;
6878 if (current_ts
.type
!= BT_UNKNOWN
6879 && !gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
6885 if (current_ts
.type
!= BT_UNKNOWN
6886 && !gfc_add_type (result
, ¤t_ts
, &gfc_current_locus
))
6888 sym
->result
= result
;
6891 /* Warn if this procedure has the same name as an intrinsic. */
6892 do_warn_intrinsic_shadow (sym
, true);
6898 gfc_current_locus
= old_loc
;
6903 /* This is mostly a copy of parse.c(add_global_procedure) but modified to
6904 pass the name of the entry, rather than the gfc_current_block name, and
6905 to return false upon finding an existing global entry. */
6908 add_global_entry (const char *name
, const char *binding_label
, bool sub
,
6912 enum gfc_symbol_type type
;
6914 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
6916 /* Only in Fortran 2003: For procedures with a binding label also the Fortran
6917 name is a global identifier. */
6918 if (!binding_label
|| gfc_notification_std (GFC_STD_F2008
))
6920 s
= gfc_get_gsymbol (name
);
6922 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= type
))
6924 gfc_global_used (s
, where
);
6933 s
->ns
= gfc_current_ns
;
6937 /* Don't add the symbol multiple times. */
6939 && (!gfc_notification_std (GFC_STD_F2008
)
6940 || strcmp (name
, binding_label
) != 0))
6942 s
= gfc_get_gsymbol (binding_label
);
6944 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= type
))
6946 gfc_global_used (s
, where
);
6953 s
->binding_label
= binding_label
;
6956 s
->ns
= gfc_current_ns
;
6964 /* Match an ENTRY statement. */
6967 gfc_match_entry (void)
6972 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6973 gfc_compile_state state
;
6977 bool module_procedure
;
6981 m
= gfc_match_name (name
);
6985 if (!gfc_notify_std (GFC_STD_F2008_OBS
, "ENTRY statement at %C"))
6988 state
= gfc_current_state ();
6989 if (state
!= COMP_SUBROUTINE
&& state
!= COMP_FUNCTION
)
6994 gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
6997 gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
6999 case COMP_SUBMODULE
:
7000 gfc_error ("ENTRY statement at %C cannot appear within a SUBMODULE");
7002 case COMP_BLOCK_DATA
:
7003 gfc_error ("ENTRY statement at %C cannot appear within "
7006 case COMP_INTERFACE
:
7007 gfc_error ("ENTRY statement at %C cannot appear within "
7010 case COMP_STRUCTURE
:
7011 gfc_error ("ENTRY statement at %C cannot appear within "
7012 "a STRUCTURE block");
7015 gfc_error ("ENTRY statement at %C cannot appear within "
7016 "a DERIVED TYPE block");
7019 gfc_error ("ENTRY statement at %C cannot appear within "
7020 "an IF-THEN block");
7023 case COMP_DO_CONCURRENT
:
7024 gfc_error ("ENTRY statement at %C cannot appear within "
7028 gfc_error ("ENTRY statement at %C cannot appear within "
7032 gfc_error ("ENTRY statement at %C cannot appear within "
7036 gfc_error ("ENTRY statement at %C cannot appear within "
7040 gfc_error ("ENTRY statement at %C cannot appear within "
7041 "a contained subprogram");
7044 gfc_error ("Unexpected ENTRY statement at %C");
7049 if ((state
== COMP_SUBROUTINE
|| state
== COMP_FUNCTION
)
7050 && gfc_state_stack
->previous
->state
== COMP_INTERFACE
)
7052 gfc_error ("ENTRY statement at %C cannot appear within an INTERFACE");
7056 module_procedure
= gfc_current_ns
->parent
!= NULL
7057 && gfc_current_ns
->parent
->proc_name
7058 && gfc_current_ns
->parent
->proc_name
->attr
.flavor
7061 if (gfc_current_ns
->parent
!= NULL
7062 && gfc_current_ns
->parent
->proc_name
7063 && !module_procedure
)
7065 gfc_error("ENTRY statement at %C cannot appear in a "
7066 "contained procedure");
7070 /* Module function entries need special care in get_proc_name
7071 because previous references within the function will have
7072 created symbols attached to the current namespace. */
7073 if (get_proc_name (name
, &entry
,
7074 gfc_current_ns
->parent
!= NULL
7075 && module_procedure
))
7078 proc
= gfc_current_block ();
7080 /* Make sure that it isn't already declared as BIND(C). If it is, it
7081 must have been marked BIND(C) with a BIND(C) attribute and that is
7082 not allowed for procedures. */
7083 if (entry
->attr
.is_bind_c
== 1)
7085 entry
->attr
.is_bind_c
= 0;
7086 if (entry
->old_symbol
!= NULL
)
7087 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7088 "variables or common blocks",
7089 &(entry
->old_symbol
->declared_at
));
7091 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7092 "variables or common blocks", &gfc_current_locus
);
7095 /* Check what next non-whitespace character is so we can tell if there
7096 is the required parens if we have a BIND(C). */
7097 old_loc
= gfc_current_locus
;
7098 gfc_gobble_whitespace ();
7099 peek_char
= gfc_peek_ascii_char ();
7101 if (state
== COMP_SUBROUTINE
)
7103 m
= gfc_match_formal_arglist (entry
, 0, 1);
7107 /* Call gfc_match_bind_c with allow_binding_name = true as ENTRY can
7108 never be an internal procedure. */
7109 is_bind_c
= gfc_match_bind_c (entry
, true);
7110 if (is_bind_c
== MATCH_ERROR
)
7112 if (is_bind_c
== MATCH_YES
)
7114 if (peek_char
!= '(')
7116 gfc_error ("Missing required parentheses before BIND(C) at %C");
7119 if (!gfc_add_is_bind_c (&(entry
->attr
), entry
->name
,
7120 &(entry
->declared_at
), 1))
7124 if (!gfc_current_ns
->parent
7125 && !add_global_entry (name
, entry
->binding_label
, true,
7129 /* An entry in a subroutine. */
7130 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
7131 || !gfc_add_subroutine (&entry
->attr
, entry
->name
, NULL
))
7136 /* An entry in a function.
7137 We need to take special care because writing
7142 ENTRY f() RESULT (r)
7144 ENTRY f RESULT (r). */
7145 if (gfc_match_eos () == MATCH_YES
)
7147 gfc_current_locus
= old_loc
;
7148 /* Match the empty argument list, and add the interface to
7150 m
= gfc_match_formal_arglist (entry
, 0, 1);
7153 m
= gfc_match_formal_arglist (entry
, 0, 0);
7160 if (gfc_match_eos () == MATCH_YES
)
7162 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
7163 || !gfc_add_function (&entry
->attr
, entry
->name
, NULL
))
7166 entry
->result
= entry
;
7170 m
= gfc_match_suffix (entry
, &result
);
7172 gfc_syntax_error (ST_ENTRY
);
7178 if (!gfc_add_result (&result
->attr
, result
->name
, NULL
)
7179 || !gfc_add_entry (&entry
->attr
, result
->name
, NULL
)
7180 || !gfc_add_function (&entry
->attr
, result
->name
, NULL
))
7182 entry
->result
= result
;
7186 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
7187 || !gfc_add_function (&entry
->attr
, entry
->name
, NULL
))
7189 entry
->result
= entry
;
7193 if (!gfc_current_ns
->parent
7194 && !add_global_entry (name
, entry
->binding_label
, false,
7199 if (gfc_match_eos () != MATCH_YES
)
7201 gfc_syntax_error (ST_ENTRY
);
7205 entry
->attr
.recursive
= proc
->attr
.recursive
;
7206 entry
->attr
.elemental
= proc
->attr
.elemental
;
7207 entry
->attr
.pure
= proc
->attr
.pure
;
7209 el
= gfc_get_entry_list ();
7211 el
->next
= gfc_current_ns
->entries
;
7212 gfc_current_ns
->entries
= el
;
7214 el
->id
= el
->next
->id
+ 1;
7218 new_st
.op
= EXEC_ENTRY
;
7219 new_st
.ext
.entry
= el
;
7225 /* Match a subroutine statement, including optional prefixes. */
7228 gfc_match_subroutine (void)
7230 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7235 bool allow_binding_name
;
7237 if (gfc_current_state () != COMP_NONE
7238 && gfc_current_state () != COMP_INTERFACE
7239 && gfc_current_state () != COMP_CONTAINS
)
7242 m
= gfc_match_prefix (NULL
);
7246 m
= gfc_match ("subroutine% %n", name
);
7250 if (get_proc_name (name
, &sym
, false))
7253 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
7254 the symbol existed before. */
7255 sym
->declared_at
= gfc_current_locus
;
7257 if (current_attr
.module_procedure
)
7258 sym
->attr
.module_procedure
= 1;
7260 if (add_hidden_procptr_result (sym
))
7263 gfc_new_block
= sym
;
7265 /* Check what next non-whitespace character is so we can tell if there
7266 is the required parens if we have a BIND(C). */
7267 gfc_gobble_whitespace ();
7268 peek_char
= gfc_peek_ascii_char ();
7270 if (!gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
))
7273 if (gfc_match_formal_arglist (sym
, 0, 1) != MATCH_YES
)
7276 /* Make sure that it isn't already declared as BIND(C). If it is, it
7277 must have been marked BIND(C) with a BIND(C) attribute and that is
7278 not allowed for procedures. */
7279 if (sym
->attr
.is_bind_c
== 1)
7281 sym
->attr
.is_bind_c
= 0;
7282 if (sym
->old_symbol
!= NULL
)
7283 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7284 "variables or common blocks",
7285 &(sym
->old_symbol
->declared_at
));
7287 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7288 "variables or common blocks", &gfc_current_locus
);
7291 /* C binding names are not allowed for internal procedures. */
7292 if (gfc_current_state () == COMP_CONTAINS
7293 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
7294 allow_binding_name
= false;
7296 allow_binding_name
= true;
7298 /* Here, we are just checking if it has the bind(c) attribute, and if
7299 so, then we need to make sure it's all correct. If it doesn't,
7300 we still need to continue matching the rest of the subroutine line. */
7301 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
7302 if (is_bind_c
== MATCH_ERROR
)
7304 /* There was an attempt at the bind(c), but it was wrong. An
7305 error message should have been printed w/in the gfc_match_bind_c
7306 so here we'll just return the MATCH_ERROR. */
7310 if (is_bind_c
== MATCH_YES
)
7312 /* The following is allowed in the Fortran 2008 draft. */
7313 if (gfc_current_state () == COMP_CONTAINS
7314 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
7315 && !gfc_notify_std (GFC_STD_F2008
, "BIND(C) attribute "
7316 "at %L may not be specified for an internal "
7317 "procedure", &gfc_current_locus
))
7320 if (peek_char
!= '(')
7322 gfc_error ("Missing required parentheses before BIND(C) at %C");
7325 if (!gfc_add_is_bind_c (&(sym
->attr
), sym
->name
,
7326 &(sym
->declared_at
), 1))
7330 if (gfc_match_eos () != MATCH_YES
)
7332 gfc_syntax_error (ST_SUBROUTINE
);
7336 if (!copy_prefix (&sym
->attr
, &sym
->declared_at
))
7338 if(!sym
->attr
.module_procedure
)
7344 /* Warn if it has the same name as an intrinsic. */
7345 do_warn_intrinsic_shadow (sym
, false);
7351 /* Check that the NAME identifier in a BIND attribute or statement
7352 is conform to C identifier rules. */
7355 check_bind_name_identifier (char **name
)
7357 char *n
= *name
, *p
;
7359 /* Remove leading spaces. */
7363 /* On an empty string, free memory and set name to NULL. */
7371 /* Remove trailing spaces. */
7372 p
= n
+ strlen(n
) - 1;
7376 /* Insert the identifier into the symbol table. */
7381 /* Now check that identifier is valid under C rules. */
7384 gfc_error ("Invalid C identifier in NAME= specifier at %C");
7389 if (!(ISALNUM (*p
) || *p
== '_' || *p
== '$'))
7391 gfc_error ("Invalid C identifier in NAME= specifier at %C");
7399 /* Match a BIND(C) specifier, with the optional 'name=' specifier if
7400 given, and set the binding label in either the given symbol (if not
7401 NULL), or in the current_ts. The symbol may be NULL because we may
7402 encounter the BIND(C) before the declaration itself. Return
7403 MATCH_NO if what we're looking at isn't a BIND(C) specifier,
7404 MATCH_ERROR if it is a BIND(C) clause but an error was encountered,
7405 or MATCH_YES if the specifier was correct and the binding label and
7406 bind(c) fields were set correctly for the given symbol or the
7407 current_ts. If allow_binding_name is false, no binding name may be
7411 gfc_match_bind_c (gfc_symbol
*sym
, bool allow_binding_name
)
7413 char *binding_label
= NULL
;
7416 /* Initialize the flag that specifies whether we encountered a NAME=
7417 specifier or not. */
7418 has_name_equals
= 0;
7420 /* This much we have to be able to match, in this order, if
7421 there is a bind(c) label. */
7422 if (gfc_match (" bind ( c ") != MATCH_YES
)
7425 /* Now see if there is a binding label, or if we've reached the
7426 end of the bind(c) attribute without one. */
7427 if (gfc_match_char (',') == MATCH_YES
)
7429 if (gfc_match (" name = ") != MATCH_YES
)
7431 gfc_error ("Syntax error in NAME= specifier for binding label "
7433 /* should give an error message here */
7437 has_name_equals
= 1;
7439 if (gfc_match_init_expr (&e
) != MATCH_YES
)
7445 if (!gfc_simplify_expr(e
, 0))
7447 gfc_error ("NAME= specifier at %C should be a constant expression");
7452 if (e
->expr_type
!= EXPR_CONSTANT
|| e
->ts
.type
!= BT_CHARACTER
7453 || e
->ts
.kind
!= gfc_default_character_kind
|| e
->rank
!= 0)
7455 gfc_error ("NAME= specifier at %C should be a scalar of "
7456 "default character kind");
7461 // Get a C string from the Fortran string constant
7462 binding_label
= gfc_widechar_to_char (e
->value
.character
.string
,
7463 e
->value
.character
.length
);
7466 // Check that it is valid (old gfc_match_name_C)
7467 if (check_bind_name_identifier (&binding_label
) != MATCH_YES
)
7471 /* Get the required right paren. */
7472 if (gfc_match_char (')') != MATCH_YES
)
7474 gfc_error ("Missing closing paren for binding label at %C");
7478 if (has_name_equals
&& !allow_binding_name
)
7480 gfc_error ("No binding name is allowed in BIND(C) at %C");
7484 if (has_name_equals
&& sym
!= NULL
&& sym
->attr
.dummy
)
7486 gfc_error ("For dummy procedure %s, no binding name is "
7487 "allowed in BIND(C) at %C", sym
->name
);
7492 /* Save the binding label to the symbol. If sym is null, we're
7493 probably matching the typespec attributes of a declaration and
7494 haven't gotten the name yet, and therefore, no symbol yet. */
7498 sym
->binding_label
= binding_label
;
7500 curr_binding_label
= binding_label
;
7502 else if (allow_binding_name
)
7504 /* No binding label, but if symbol isn't null, we
7505 can set the label for it here.
7506 If name="" or allow_binding_name is false, no C binding name is
7508 if (sym
!= NULL
&& sym
->name
!= NULL
&& has_name_equals
== 0)
7509 sym
->binding_label
= IDENTIFIER_POINTER (get_identifier (sym
->name
));
7512 if (has_name_equals
&& gfc_current_state () == COMP_INTERFACE
7513 && current_interface
.type
== INTERFACE_ABSTRACT
)
7515 gfc_error ("NAME not allowed on BIND(C) for ABSTRACT INTERFACE at %C");
7523 /* Return nonzero if we're currently compiling a contained procedure. */
7526 contained_procedure (void)
7528 gfc_state_data
*s
= gfc_state_stack
;
7530 if ((s
->state
== COMP_SUBROUTINE
|| s
->state
== COMP_FUNCTION
)
7531 && s
->previous
!= NULL
&& s
->previous
->state
== COMP_CONTAINS
)
7537 /* Set the kind of each enumerator. The kind is selected such that it is
7538 interoperable with the corresponding C enumeration type, making
7539 sure that -fshort-enums is honored. */
7544 enumerator_history
*current_history
= NULL
;
7548 if (max_enum
== NULL
|| enum_history
== NULL
)
7551 if (!flag_short_enums
)
7557 kind
= gfc_integer_kinds
[i
++].kind
;
7559 while (kind
< gfc_c_int_kind
7560 && gfc_check_integer_range (max_enum
->initializer
->value
.integer
,
7563 current_history
= enum_history
;
7564 while (current_history
!= NULL
)
7566 current_history
->sym
->ts
.kind
= kind
;
7567 current_history
= current_history
->next
;
7572 /* Match any of the various end-block statements. Returns the type of
7573 END to the caller. The END INTERFACE, END IF, END DO, END SELECT
7574 and END BLOCK statements cannot be replaced by a single END statement. */
7577 gfc_match_end (gfc_statement
*st
)
7579 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7580 gfc_compile_state state
;
7582 const char *block_name
;
7586 gfc_namespace
*parent_ns
, *ns
, *prev_ns
;
7587 gfc_namespace
**nsp
;
7588 bool abreviated_modproc_decl
= false;
7589 bool got_matching_end
= false;
7591 old_loc
= gfc_current_locus
;
7592 if (gfc_match ("end") != MATCH_YES
)
7595 state
= gfc_current_state ();
7596 block_name
= gfc_current_block () == NULL
7597 ? NULL
: gfc_current_block ()->name
;
7601 case COMP_ASSOCIATE
:
7603 if (!strncmp (block_name
, "block@", strlen("block@")))
7608 case COMP_DERIVED_CONTAINS
:
7609 state
= gfc_state_stack
->previous
->state
;
7610 block_name
= gfc_state_stack
->previous
->sym
== NULL
7611 ? NULL
: gfc_state_stack
->previous
->sym
->name
;
7612 abreviated_modproc_decl
= gfc_state_stack
->previous
->sym
7613 && gfc_state_stack
->previous
->sym
->abr_modproc_decl
;
7620 if (!abreviated_modproc_decl
)
7621 abreviated_modproc_decl
= gfc_current_block ()
7622 && gfc_current_block ()->abr_modproc_decl
;
7628 *st
= ST_END_PROGRAM
;
7629 target
= " program";
7633 case COMP_SUBROUTINE
:
7634 *st
= ST_END_SUBROUTINE
;
7635 if (!abreviated_modproc_decl
)
7636 target
= " subroutine";
7638 target
= " procedure";
7639 eos_ok
= !contained_procedure ();
7643 *st
= ST_END_FUNCTION
;
7644 if (!abreviated_modproc_decl
)
7645 target
= " function";
7647 target
= " procedure";
7648 eos_ok
= !contained_procedure ();
7651 case COMP_BLOCK_DATA
:
7652 *st
= ST_END_BLOCK_DATA
;
7653 target
= " block data";
7658 *st
= ST_END_MODULE
;
7663 case COMP_SUBMODULE
:
7664 *st
= ST_END_SUBMODULE
;
7665 target
= " submodule";
7669 case COMP_INTERFACE
:
7670 *st
= ST_END_INTERFACE
;
7671 target
= " interface";
7687 case COMP_STRUCTURE
:
7688 *st
= ST_END_STRUCTURE
;
7689 target
= " structure";
7694 case COMP_DERIVED_CONTAINS
:
7700 case COMP_ASSOCIATE
:
7701 *st
= ST_END_ASSOCIATE
;
7702 target
= " associate";
7719 case COMP_DO_CONCURRENT
:
7726 *st
= ST_END_CRITICAL
;
7727 target
= " critical";
7732 case COMP_SELECT_TYPE
:
7733 *st
= ST_END_SELECT
;
7739 *st
= ST_END_FORALL
;
7754 last_initializer
= NULL
;
7756 gfc_free_enum_history ();
7760 gfc_error ("Unexpected END statement at %C");
7764 old_loc
= gfc_current_locus
;
7765 if (gfc_match_eos () == MATCH_YES
)
7767 if (!eos_ok
&& (*st
== ST_END_SUBROUTINE
|| *st
== ST_END_FUNCTION
))
7769 if (!gfc_notify_std (GFC_STD_F2008
, "END statement "
7770 "instead of %s statement at %L",
7771 abreviated_modproc_decl
? "END PROCEDURE"
7772 : gfc_ascii_statement(*st
), &old_loc
))
7777 /* We would have required END [something]. */
7778 gfc_error ("%s statement expected at %L",
7779 gfc_ascii_statement (*st
), &old_loc
);
7786 /* Verify that we've got the sort of end-block that we're expecting. */
7787 if (gfc_match (target
) != MATCH_YES
)
7789 gfc_error ("Expecting %s statement at %L", abreviated_modproc_decl
7790 ? "END PROCEDURE" : gfc_ascii_statement(*st
), &old_loc
);
7794 got_matching_end
= true;
7796 old_loc
= gfc_current_locus
;
7797 /* If we're at the end, make sure a block name wasn't required. */
7798 if (gfc_match_eos () == MATCH_YES
)
7801 if (*st
!= ST_ENDDO
&& *st
!= ST_ENDIF
&& *st
!= ST_END_SELECT
7802 && *st
!= ST_END_FORALL
&& *st
!= ST_END_WHERE
&& *st
!= ST_END_BLOCK
7803 && *st
!= ST_END_ASSOCIATE
&& *st
!= ST_END_CRITICAL
)
7809 gfc_error ("Expected block name of %qs in %s statement at %L",
7810 block_name
, gfc_ascii_statement (*st
), &old_loc
);
7815 /* END INTERFACE has a special handler for its several possible endings. */
7816 if (*st
== ST_END_INTERFACE
)
7817 return gfc_match_end_interface ();
7819 /* We haven't hit the end of statement, so what is left must be an
7821 m
= gfc_match_space ();
7823 m
= gfc_match_name (name
);
7826 gfc_error ("Expected terminating name at %C");
7830 if (block_name
== NULL
)
7833 /* We have to pick out the declared submodule name from the composite
7834 required by F2008:11.2.3 para 2, which ends in the declared name. */
7835 if (state
== COMP_SUBMODULE
)
7836 block_name
= strchr (block_name
, '.') + 1;
7838 if (strcmp (name
, block_name
) != 0 && strcmp (block_name
, "ppr@") != 0)
7840 gfc_error ("Expected label %qs for %s statement at %C", block_name
,
7841 gfc_ascii_statement (*st
));
7844 /* Procedure pointer as function result. */
7845 else if (strcmp (block_name
, "ppr@") == 0
7846 && strcmp (name
, gfc_current_block ()->ns
->proc_name
->name
) != 0)
7848 gfc_error ("Expected label %qs for %s statement at %C",
7849 gfc_current_block ()->ns
->proc_name
->name
,
7850 gfc_ascii_statement (*st
));
7854 if (gfc_match_eos () == MATCH_YES
)
7858 gfc_syntax_error (*st
);
7861 gfc_current_locus
= old_loc
;
7863 /* If we are missing an END BLOCK, we created a half-ready namespace.
7864 Remove it from the parent namespace's sibling list. */
7866 while (state
== COMP_BLOCK
&& !got_matching_end
)
7868 parent_ns
= gfc_current_ns
->parent
;
7870 nsp
= &(gfc_state_stack
->previous
->tail
->ext
.block
.ns
);
7876 if (ns
== gfc_current_ns
)
7878 if (prev_ns
== NULL
)
7881 prev_ns
->sibling
= ns
->sibling
;
7887 gfc_free_namespace (gfc_current_ns
);
7888 gfc_current_ns
= parent_ns
;
7889 gfc_state_stack
= gfc_state_stack
->previous
;
7890 state
= gfc_current_state ();
7898 /***************** Attribute declaration statements ****************/
7900 /* Set the attribute of a single variable. */
7905 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7908 /* Workaround -Wmaybe-uninitialized false positive during
7909 profiledbootstrap by initializing them. */
7910 gfc_symbol
*sym
= NULL
;
7916 m
= gfc_match_name (name
);
7920 if (find_special (name
, &sym
, false))
7923 if (!check_function_name (name
))
7929 var_locus
= gfc_current_locus
;
7931 /* Deal with possible array specification for certain attributes. */
7932 if (current_attr
.dimension
7933 || current_attr
.codimension
7934 || current_attr
.allocatable
7935 || current_attr
.pointer
7936 || current_attr
.target
)
7938 m
= gfc_match_array_spec (&as
, !current_attr
.codimension
,
7939 !current_attr
.dimension
7940 && !current_attr
.pointer
7941 && !current_attr
.target
);
7942 if (m
== MATCH_ERROR
)
7945 if (current_attr
.dimension
&& m
== MATCH_NO
)
7947 gfc_error ("Missing array specification at %L in DIMENSION "
7948 "statement", &var_locus
);
7953 if (current_attr
.dimension
&& sym
->value
)
7955 gfc_error ("Dimensions specified for %s at %L after its "
7956 "initialization", sym
->name
, &var_locus
);
7961 if (current_attr
.codimension
&& m
== MATCH_NO
)
7963 gfc_error ("Missing array specification at %L in CODIMENSION "
7964 "statement", &var_locus
);
7969 if ((current_attr
.allocatable
|| current_attr
.pointer
)
7970 && (m
== MATCH_YES
) && (as
->type
!= AS_DEFERRED
))
7972 gfc_error ("Array specification must be deferred at %L", &var_locus
);
7978 /* Update symbol table. DIMENSION attribute is set in
7979 gfc_set_array_spec(). For CLASS variables, this must be applied
7980 to the first component, or '_data' field. */
7981 if (sym
->ts
.type
== BT_CLASS
&& sym
->ts
.u
.derived
->attr
.is_class
)
7983 if (!gfc_copy_attr (&CLASS_DATA(sym
)->attr
, ¤t_attr
, &var_locus
))
7991 if (current_attr
.dimension
== 0 && current_attr
.codimension
== 0
7992 && !gfc_copy_attr (&sym
->attr
, ¤t_attr
, &var_locus
))
7999 if (sym
->ts
.type
== BT_CLASS
8000 && !gfc_build_class_symbol (&sym
->ts
, &sym
->attr
, &sym
->as
))
8006 if (!gfc_set_array_spec (sym
, as
, &var_locus
))
8012 if (sym
->attr
.cray_pointee
&& sym
->as
!= NULL
)
8014 /* Fix the array spec. */
8015 m
= gfc_mod_pointee_as (sym
->as
);
8016 if (m
== MATCH_ERROR
)
8020 if (!gfc_add_attribute (&sym
->attr
, &var_locus
))
8026 if ((current_attr
.external
|| current_attr
.intrinsic
)
8027 && sym
->attr
.flavor
!= FL_PROCEDURE
8028 && !gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, NULL
))
8034 add_hidden_procptr_result (sym
);
8039 gfc_free_array_spec (as
);
8044 /* Generic attribute declaration subroutine. Used for attributes that
8045 just have a list of names. */
8052 /* Gobble the optional double colon, by simply ignoring the result
8062 if (gfc_match_eos () == MATCH_YES
)
8068 if (gfc_match_char (',') != MATCH_YES
)
8070 gfc_error ("Unexpected character in variable list at %C");
8080 /* This routine matches Cray Pointer declarations of the form:
8081 pointer ( <pointer>, <pointee> )
8083 pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...
8084 The pointer, if already declared, should be an integer. Otherwise, we
8085 set it as BT_INTEGER with kind gfc_index_integer_kind. The pointee may
8086 be either a scalar, or an array declaration. No space is allocated for
8087 the pointee. For the statement
8088 pointer (ipt, ar(10))
8089 any subsequent uses of ar will be translated (in C-notation) as
8090 ar(i) => ((<type> *) ipt)(i)
8091 After gimplification, pointee variable will disappear in the code. */
8094 cray_pointer_decl (void)
8097 gfc_array_spec
*as
= NULL
;
8098 gfc_symbol
*cptr
; /* Pointer symbol. */
8099 gfc_symbol
*cpte
; /* Pointee symbol. */
8105 if (gfc_match_char ('(') != MATCH_YES
)
8107 gfc_error ("Expected %<(%> at %C");
8111 /* Match pointer. */
8112 var_locus
= gfc_current_locus
;
8113 gfc_clear_attr (¤t_attr
);
8114 gfc_add_cray_pointer (¤t_attr
, &var_locus
);
8115 current_ts
.type
= BT_INTEGER
;
8116 current_ts
.kind
= gfc_index_integer_kind
;
8118 m
= gfc_match_symbol (&cptr
, 0);
8121 gfc_error ("Expected variable name at %C");
8125 if (!gfc_add_cray_pointer (&cptr
->attr
, &var_locus
))
8128 gfc_set_sym_referenced (cptr
);
8130 if (cptr
->ts
.type
== BT_UNKNOWN
) /* Override the type, if necessary. */
8132 cptr
->ts
.type
= BT_INTEGER
;
8133 cptr
->ts
.kind
= gfc_index_integer_kind
;
8135 else if (cptr
->ts
.type
!= BT_INTEGER
)
8137 gfc_error ("Cray pointer at %C must be an integer");
8140 else if (cptr
->ts
.kind
< gfc_index_integer_kind
)
8141 gfc_warning (0, "Cray pointer at %C has %d bytes of precision;"
8142 " memory addresses require %d bytes",
8143 cptr
->ts
.kind
, gfc_index_integer_kind
);
8145 if (gfc_match_char (',') != MATCH_YES
)
8147 gfc_error ("Expected \",\" at %C");
8151 /* Match Pointee. */
8152 var_locus
= gfc_current_locus
;
8153 gfc_clear_attr (¤t_attr
);
8154 gfc_add_cray_pointee (¤t_attr
, &var_locus
);
8155 current_ts
.type
= BT_UNKNOWN
;
8156 current_ts
.kind
= 0;
8158 m
= gfc_match_symbol (&cpte
, 0);
8161 gfc_error ("Expected variable name at %C");
8165 /* Check for an optional array spec. */
8166 m
= gfc_match_array_spec (&as
, true, false);
8167 if (m
== MATCH_ERROR
)
8169 gfc_free_array_spec (as
);
8172 else if (m
== MATCH_NO
)
8174 gfc_free_array_spec (as
);
8178 if (!gfc_add_cray_pointee (&cpte
->attr
, &var_locus
))
8181 gfc_set_sym_referenced (cpte
);
8183 if (cpte
->as
== NULL
)
8185 if (!gfc_set_array_spec (cpte
, as
, &var_locus
))
8186 gfc_internal_error ("Couldn't set Cray pointee array spec.");
8188 else if (as
!= NULL
)
8190 gfc_error ("Duplicate array spec for Cray pointee at %C");
8191 gfc_free_array_spec (as
);
8197 if (cpte
->as
!= NULL
)
8199 /* Fix array spec. */
8200 m
= gfc_mod_pointee_as (cpte
->as
);
8201 if (m
== MATCH_ERROR
)
8205 /* Point the Pointee at the Pointer. */
8206 cpte
->cp_pointer
= cptr
;
8208 if (gfc_match_char (')') != MATCH_YES
)
8210 gfc_error ("Expected \")\" at %C");
8213 m
= gfc_match_char (',');
8215 done
= true; /* Stop searching for more declarations. */
8219 if (m
== MATCH_ERROR
/* Failed when trying to find ',' above. */
8220 || gfc_match_eos () != MATCH_YES
)
8222 gfc_error ("Expected %<,%> or end of statement at %C");
8230 gfc_match_external (void)
8233 gfc_clear_attr (¤t_attr
);
8234 current_attr
.external
= 1;
8236 return attr_decl ();
8241 gfc_match_intent (void)
8245 /* This is not allowed within a BLOCK construct! */
8246 if (gfc_current_state () == COMP_BLOCK
)
8248 gfc_error ("INTENT is not allowed inside of BLOCK at %C");
8252 intent
= match_intent_spec ();
8253 if (intent
== INTENT_UNKNOWN
)
8256 gfc_clear_attr (¤t_attr
);
8257 current_attr
.intent
= intent
;
8259 return attr_decl ();
8264 gfc_match_intrinsic (void)
8267 gfc_clear_attr (¤t_attr
);
8268 current_attr
.intrinsic
= 1;
8270 return attr_decl ();
8275 gfc_match_optional (void)
8277 /* This is not allowed within a BLOCK construct! */
8278 if (gfc_current_state () == COMP_BLOCK
)
8280 gfc_error ("OPTIONAL is not allowed inside of BLOCK at %C");
8284 gfc_clear_attr (¤t_attr
);
8285 current_attr
.optional
= 1;
8287 return attr_decl ();
8292 gfc_match_pointer (void)
8294 gfc_gobble_whitespace ();
8295 if (gfc_peek_ascii_char () == '(')
8297 if (!flag_cray_pointer
)
8299 gfc_error ("Cray pointer declaration at %C requires -fcray-pointer "
8303 return cray_pointer_decl ();
8307 gfc_clear_attr (¤t_attr
);
8308 current_attr
.pointer
= 1;
8310 return attr_decl ();
8316 gfc_match_allocatable (void)
8318 gfc_clear_attr (¤t_attr
);
8319 current_attr
.allocatable
= 1;
8321 return attr_decl ();
8326 gfc_match_codimension (void)
8328 gfc_clear_attr (¤t_attr
);
8329 current_attr
.codimension
= 1;
8331 return attr_decl ();
8336 gfc_match_contiguous (void)
8338 if (!gfc_notify_std (GFC_STD_F2008
, "CONTIGUOUS statement at %C"))
8341 gfc_clear_attr (¤t_attr
);
8342 current_attr
.contiguous
= 1;
8344 return attr_decl ();
8349 gfc_match_dimension (void)
8351 gfc_clear_attr (¤t_attr
);
8352 current_attr
.dimension
= 1;
8354 return attr_decl ();
8359 gfc_match_target (void)
8361 gfc_clear_attr (¤t_attr
);
8362 current_attr
.target
= 1;
8364 return attr_decl ();
8368 /* Match the list of entities being specified in a PUBLIC or PRIVATE
8372 access_attr_decl (gfc_statement st
)
8374 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8375 interface_type type
;
8377 gfc_symbol
*sym
, *dt_sym
;
8378 gfc_intrinsic_op op
;
8381 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
8386 m
= gfc_match_generic_spec (&type
, name
, &op
);
8389 if (m
== MATCH_ERROR
)
8394 case INTERFACE_NAMELESS
:
8395 case INTERFACE_ABSTRACT
:
8398 case INTERFACE_GENERIC
:
8399 case INTERFACE_DTIO
:
8401 if (gfc_get_symbol (name
, NULL
, &sym
))
8404 if (type
== INTERFACE_DTIO
8405 && gfc_current_ns
->proc_name
8406 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
8407 && sym
->attr
.flavor
== FL_UNKNOWN
)
8408 sym
->attr
.flavor
= FL_PROCEDURE
;
8410 if (!gfc_add_access (&sym
->attr
,
8412 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
,
8416 if (sym
->attr
.generic
&& (dt_sym
= gfc_find_dt_in_generic (sym
))
8417 && !gfc_add_access (&dt_sym
->attr
,
8419 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
,
8425 case INTERFACE_INTRINSIC_OP
:
8426 if (gfc_current_ns
->operator_access
[op
] == ACCESS_UNKNOWN
)
8428 gfc_intrinsic_op other_op
;
8430 gfc_current_ns
->operator_access
[op
] =
8431 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
8433 /* Handle the case if there is another op with the same
8434 function, for INTRINSIC_EQ vs. INTRINSIC_EQ_OS and so on. */
8435 other_op
= gfc_equivalent_op (op
);
8437 if (other_op
!= INTRINSIC_NONE
)
8438 gfc_current_ns
->operator_access
[other_op
] =
8439 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
8444 gfc_error ("Access specification of the %s operator at %C has "
8445 "already been specified", gfc_op2string (op
));
8451 case INTERFACE_USER_OP
:
8452 uop
= gfc_get_uop (name
);
8454 if (uop
->access
== ACCESS_UNKNOWN
)
8456 uop
->access
= (st
== ST_PUBLIC
)
8457 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
8461 gfc_error ("Access specification of the .%s. operator at %C "
8462 "has already been specified", sym
->name
);
8469 if (gfc_match_char (',') == MATCH_NO
)
8473 if (gfc_match_eos () != MATCH_YES
)
8478 gfc_syntax_error (st
);
8486 gfc_match_protected (void)
8491 if (!gfc_current_ns
->proc_name
8492 || gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
8494 gfc_error ("PROTECTED at %C only allowed in specification "
8495 "part of a module");
8500 if (!gfc_notify_std (GFC_STD_F2003
, "PROTECTED statement at %C"))
8503 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
8508 if (gfc_match_eos () == MATCH_YES
)
8513 m
= gfc_match_symbol (&sym
, 0);
8517 if (!gfc_add_protected (&sym
->attr
, sym
->name
, &gfc_current_locus
))
8529 if (gfc_match_eos () == MATCH_YES
)
8531 if (gfc_match_char (',') != MATCH_YES
)
8538 gfc_error ("Syntax error in PROTECTED statement at %C");
8543 /* The PRIVATE statement is a bit weird in that it can be an attribute
8544 declaration, but also works as a standalone statement inside of a
8545 type declaration or a module. */
8548 gfc_match_private (gfc_statement
*st
)
8551 if (gfc_match ("private") != MATCH_YES
)
8554 if (gfc_current_state () != COMP_MODULE
8555 && !(gfc_current_state () == COMP_DERIVED
8556 && gfc_state_stack
->previous
8557 && gfc_state_stack
->previous
->state
== COMP_MODULE
)
8558 && !(gfc_current_state () == COMP_DERIVED_CONTAINS
8559 && gfc_state_stack
->previous
&& gfc_state_stack
->previous
->previous
8560 && gfc_state_stack
->previous
->previous
->state
== COMP_MODULE
))
8562 gfc_error ("PRIVATE statement at %C is only allowed in the "
8563 "specification part of a module");
8567 if (gfc_current_state () == COMP_DERIVED
)
8569 if (gfc_match_eos () == MATCH_YES
)
8575 gfc_syntax_error (ST_PRIVATE
);
8579 if (gfc_match_eos () == MATCH_YES
)
8586 return access_attr_decl (ST_PRIVATE
);
8591 gfc_match_public (gfc_statement
*st
)
8594 if (gfc_match ("public") != MATCH_YES
)
8597 if (gfc_current_state () != COMP_MODULE
)
8599 gfc_error ("PUBLIC statement at %C is only allowed in the "
8600 "specification part of a module");
8604 if (gfc_match_eos () == MATCH_YES
)
8611 return access_attr_decl (ST_PUBLIC
);
8615 /* Workhorse for gfc_match_parameter. */
8625 m
= gfc_match_symbol (&sym
, 0);
8627 gfc_error ("Expected variable name at %C in PARAMETER statement");
8632 if (gfc_match_char ('=') == MATCH_NO
)
8634 gfc_error ("Expected = sign in PARAMETER statement at %C");
8638 m
= gfc_match_init_expr (&init
);
8640 gfc_error ("Expected expression at %C in PARAMETER statement");
8644 if (sym
->ts
.type
== BT_UNKNOWN
8645 && !gfc_set_default_type (sym
, 1, NULL
))
8651 if (!gfc_check_assign_symbol (sym
, NULL
, init
)
8652 || !gfc_add_flavor (&sym
->attr
, FL_PARAMETER
, sym
->name
, NULL
))
8660 gfc_error ("Initializing already initialized variable at %C");
8665 t
= add_init_expr_to_sym (sym
->name
, &init
, &gfc_current_locus
);
8666 return (t
) ? MATCH_YES
: MATCH_ERROR
;
8669 gfc_free_expr (init
);
8674 /* Match a parameter statement, with the weird syntax that these have. */
8677 gfc_match_parameter (void)
8679 const char *term
= " )%t";
8682 if (gfc_match_char ('(') == MATCH_NO
)
8684 /* With legacy PARAMETER statements, don't expect a terminating ')'. */
8685 if (!gfc_notify_std (GFC_STD_LEGACY
, "PARAMETER without '()' at %C"))
8696 if (gfc_match (term
) == MATCH_YES
)
8699 if (gfc_match_char (',') != MATCH_YES
)
8701 gfc_error ("Unexpected characters in PARAMETER statement at %C");
8712 gfc_match_automatic (void)
8716 bool seen_symbol
= false;
8718 if (!flag_dec_static
)
8720 gfc_error ("%s at %C is a DEC extension, enable with "
8731 m
= gfc_match_symbol (&sym
, 0);
8741 if (!gfc_add_automatic (&sym
->attr
, sym
->name
, &gfc_current_locus
))
8747 if (gfc_match_eos () == MATCH_YES
)
8749 if (gfc_match_char (',') != MATCH_YES
)
8755 gfc_error ("Expected entity-list in AUTOMATIC statement at %C");
8762 gfc_error ("Syntax error in AUTOMATIC statement at %C");
8768 gfc_match_static (void)
8772 bool seen_symbol
= false;
8774 if (!flag_dec_static
)
8776 gfc_error ("%s at %C is a DEC extension, enable with "
8786 m
= gfc_match_symbol (&sym
, 0);
8796 if (!gfc_add_save (&sym
->attr
, SAVE_EXPLICIT
, sym
->name
,
8797 &gfc_current_locus
))
8803 if (gfc_match_eos () == MATCH_YES
)
8805 if (gfc_match_char (',') != MATCH_YES
)
8811 gfc_error ("Expected entity-list in STATIC statement at %C");
8818 gfc_error ("Syntax error in STATIC statement at %C");
8823 /* Save statements have a special syntax. */
8826 gfc_match_save (void)
8828 char n
[GFC_MAX_SYMBOL_LEN
+1];
8833 if (gfc_match_eos () == MATCH_YES
)
8835 if (gfc_current_ns
->seen_save
)
8837 if (!gfc_notify_std (GFC_STD_LEGACY
, "Blanket SAVE statement at %C "
8838 "follows previous SAVE statement"))
8842 gfc_current_ns
->save_all
= gfc_current_ns
->seen_save
= 1;
8846 if (gfc_current_ns
->save_all
)
8848 if (!gfc_notify_std (GFC_STD_LEGACY
, "SAVE statement at %C follows "
8849 "blanket SAVE statement"))
8857 m
= gfc_match_symbol (&sym
, 0);
8861 if (!gfc_add_save (&sym
->attr
, SAVE_EXPLICIT
, sym
->name
,
8862 &gfc_current_locus
))
8873 m
= gfc_match (" / %n /", &n
);
8874 if (m
== MATCH_ERROR
)
8879 c
= gfc_get_common (n
, 0);
8882 gfc_current_ns
->seen_save
= 1;
8885 if (gfc_match_eos () == MATCH_YES
)
8887 if (gfc_match_char (',') != MATCH_YES
)
8894 gfc_error ("Syntax error in SAVE statement at %C");
8900 gfc_match_value (void)
8905 /* This is not allowed within a BLOCK construct! */
8906 if (gfc_current_state () == COMP_BLOCK
)
8908 gfc_error ("VALUE is not allowed inside of BLOCK at %C");
8912 if (!gfc_notify_std (GFC_STD_F2003
, "VALUE statement at %C"))
8915 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
8920 if (gfc_match_eos () == MATCH_YES
)
8925 m
= gfc_match_symbol (&sym
, 0);
8929 if (!gfc_add_value (&sym
->attr
, sym
->name
, &gfc_current_locus
))
8941 if (gfc_match_eos () == MATCH_YES
)
8943 if (gfc_match_char (',') != MATCH_YES
)
8950 gfc_error ("Syntax error in VALUE statement at %C");
8956 gfc_match_volatile (void)
8961 if (!gfc_notify_std (GFC_STD_F2003
, "VOLATILE statement at %C"))
8964 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
8969 if (gfc_match_eos () == MATCH_YES
)
8974 /* VOLATILE is special because it can be added to host-associated
8975 symbols locally. Except for coarrays. */
8976 m
= gfc_match_symbol (&sym
, 1);
8980 /* F2008, C560+C561. VOLATILE for host-/use-associated variable or
8981 for variable in a BLOCK which is defined outside of the BLOCK. */
8982 if (sym
->ns
!= gfc_current_ns
&& sym
->attr
.codimension
)
8984 gfc_error ("Specifying VOLATILE for coarray variable %qs at "
8985 "%C, which is use-/host-associated", sym
->name
);
8988 if (!gfc_add_volatile (&sym
->attr
, sym
->name
, &gfc_current_locus
))
9000 if (gfc_match_eos () == MATCH_YES
)
9002 if (gfc_match_char (',') != MATCH_YES
)
9009 gfc_error ("Syntax error in VOLATILE statement at %C");
9015 gfc_match_asynchronous (void)
9020 if (!gfc_notify_std (GFC_STD_F2003
, "ASYNCHRONOUS statement at %C"))
9023 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
9028 if (gfc_match_eos () == MATCH_YES
)
9033 /* ASYNCHRONOUS is special because it can be added to host-associated
9035 m
= gfc_match_symbol (&sym
, 1);
9039 if (!gfc_add_asynchronous (&sym
->attr
, sym
->name
, &gfc_current_locus
))
9051 if (gfc_match_eos () == MATCH_YES
)
9053 if (gfc_match_char (',') != MATCH_YES
)
9060 gfc_error ("Syntax error in ASYNCHRONOUS statement at %C");
9065 /* Match a module procedure statement in a submodule. */
9068 gfc_match_submod_proc (void)
9070 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9071 gfc_symbol
*sym
, *fsym
;
9073 gfc_formal_arglist
*formal
, *head
, *tail
;
9075 if (gfc_current_state () != COMP_CONTAINS
9076 || !(gfc_state_stack
->previous
9077 && (gfc_state_stack
->previous
->state
== COMP_SUBMODULE
9078 || gfc_state_stack
->previous
->state
== COMP_MODULE
)))
9081 m
= gfc_match (" module% procedure% %n", name
);
9085 if (!gfc_notify_std (GFC_STD_F2008
, "MODULE PROCEDURE declaration "
9089 if (get_proc_name (name
, &sym
, false))
9092 /* Make sure that the result field is appropriately filled, even though
9093 the result symbol will be replaced later on. */
9094 if (sym
->tlink
&& sym
->tlink
->attr
.function
)
9096 if (sym
->tlink
->result
9097 && sym
->tlink
->result
!= sym
->tlink
)
9098 sym
->result
= sym
->tlink
->result
;
9103 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
9104 the symbol existed before. */
9105 sym
->declared_at
= gfc_current_locus
;
9107 if (!sym
->attr
.module_procedure
)
9110 /* Signal match_end to expect "end procedure". */
9111 sym
->abr_modproc_decl
= 1;
9113 /* Change from IFSRC_IFBODY coming from the interface declaration. */
9114 sym
->attr
.if_source
= IFSRC_DECL
;
9116 gfc_new_block
= sym
;
9118 /* Make a new formal arglist with the symbols in the procedure
9121 for (formal
= sym
->formal
; formal
&& formal
->sym
; formal
= formal
->next
)
9123 if (formal
== sym
->formal
)
9124 head
= tail
= gfc_get_formal_arglist ();
9127 tail
->next
= gfc_get_formal_arglist ();
9131 if (gfc_copy_dummy_sym (&fsym
, formal
->sym
, 0))
9135 gfc_set_sym_referenced (fsym
);
9138 /* The dummy symbols get cleaned up, when the formal_namespace of the
9139 interface declaration is cleared. This allows us to add the
9140 explicit interface as is done for other type of procedure. */
9141 if (!gfc_add_explicit_interface (sym
, IFSRC_DECL
, head
,
9142 &gfc_current_locus
))
9145 if (gfc_match_eos () != MATCH_YES
)
9147 gfc_syntax_error (ST_MODULE_PROC
);
9154 gfc_free_formal_arglist (head
);
9159 /* Match a module procedure statement. Note that we have to modify
9160 symbols in the parent's namespace because the current one was there
9161 to receive symbols that are in an interface's formal argument list. */
9164 gfc_match_modproc (void)
9166 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9170 gfc_namespace
*module_ns
;
9171 gfc_interface
*old_interface_head
, *interface
;
9173 if (gfc_state_stack
->state
!= COMP_INTERFACE
9174 || gfc_state_stack
->previous
== NULL
9175 || current_interface
.type
== INTERFACE_NAMELESS
9176 || current_interface
.type
== INTERFACE_ABSTRACT
)
9178 gfc_error ("MODULE PROCEDURE at %C must be in a generic module "
9183 module_ns
= gfc_current_ns
->parent
;
9184 for (; module_ns
; module_ns
= module_ns
->parent
)
9185 if (module_ns
->proc_name
->attr
.flavor
== FL_MODULE
9186 || module_ns
->proc_name
->attr
.flavor
== FL_PROGRAM
9187 || (module_ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
9188 && !module_ns
->proc_name
->attr
.contained
))
9191 if (module_ns
== NULL
)
9194 /* Store the current state of the interface. We will need it if we
9195 end up with a syntax error and need to recover. */
9196 old_interface_head
= gfc_current_interface_head ();
9198 /* Check if the F2008 optional double colon appears. */
9199 gfc_gobble_whitespace ();
9200 old_locus
= gfc_current_locus
;
9201 if (gfc_match ("::") == MATCH_YES
)
9203 if (!gfc_notify_std (GFC_STD_F2008
, "double colon in "
9204 "MODULE PROCEDURE statement at %L", &old_locus
))
9208 gfc_current_locus
= old_locus
;
9213 old_locus
= gfc_current_locus
;
9215 m
= gfc_match_name (name
);
9221 /* Check for syntax error before starting to add symbols to the
9222 current namespace. */
9223 if (gfc_match_eos () == MATCH_YES
)
9226 if (!last
&& gfc_match_char (',') != MATCH_YES
)
9229 /* Now we're sure the syntax is valid, we process this item
9231 if (gfc_get_symbol (name
, module_ns
, &sym
))
9234 if (sym
->attr
.intrinsic
)
9236 gfc_error ("Intrinsic procedure at %L cannot be a MODULE "
9237 "PROCEDURE", &old_locus
);
9241 if (sym
->attr
.proc
!= PROC_MODULE
9242 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
9245 if (!gfc_add_interface (sym
))
9248 sym
->attr
.mod_proc
= 1;
9249 sym
->declared_at
= old_locus
;
9258 /* Restore the previous state of the interface. */
9259 interface
= gfc_current_interface_head ();
9260 gfc_set_current_interface_head (old_interface_head
);
9262 /* Free the new interfaces. */
9263 while (interface
!= old_interface_head
)
9265 gfc_interface
*i
= interface
->next
;
9270 /* And issue a syntax error. */
9271 gfc_syntax_error (ST_MODULE_PROC
);
9276 /* Check a derived type that is being extended. */
9279 check_extended_derived_type (char *name
)
9281 gfc_symbol
*extended
;
9283 if (gfc_find_symbol (name
, gfc_current_ns
, 1, &extended
))
9285 gfc_error ("Ambiguous symbol in TYPE definition at %C");
9289 extended
= gfc_find_dt_in_generic (extended
);
9294 gfc_error ("Symbol %qs at %C has not been previously defined", name
);
9298 if (extended
->attr
.flavor
!= FL_DERIVED
)
9300 gfc_error ("%qs in EXTENDS expression at %C is not a "
9301 "derived type", name
);
9305 if (extended
->attr
.is_bind_c
)
9307 gfc_error ("%qs cannot be extended at %C because it "
9308 "is BIND(C)", extended
->name
);
9312 if (extended
->attr
.sequence
)
9314 gfc_error ("%qs cannot be extended at %C because it "
9315 "is a SEQUENCE type", extended
->name
);
9323 /* Match the optional attribute specifiers for a type declaration.
9324 Return MATCH_ERROR if an error is encountered in one of the handled
9325 attributes (public, private, bind(c)), MATCH_NO if what's found is
9326 not a handled attribute, and MATCH_YES otherwise. TODO: More error
9327 checking on attribute conflicts needs to be done. */
9330 gfc_get_type_attr_spec (symbol_attribute
*attr
, char *name
)
9332 /* See if the derived type is marked as private. */
9333 if (gfc_match (" , private") == MATCH_YES
)
9335 if (gfc_current_state () != COMP_MODULE
)
9337 gfc_error ("Derived type at %C can only be PRIVATE in the "
9338 "specification part of a module");
9342 if (!gfc_add_access (attr
, ACCESS_PRIVATE
, NULL
, NULL
))
9345 else if (gfc_match (" , public") == MATCH_YES
)
9347 if (gfc_current_state () != COMP_MODULE
)
9349 gfc_error ("Derived type at %C can only be PUBLIC in the "
9350 "specification part of a module");
9354 if (!gfc_add_access (attr
, ACCESS_PUBLIC
, NULL
, NULL
))
9357 else if (gfc_match (" , bind ( c )") == MATCH_YES
)
9359 /* If the type is defined to be bind(c) it then needs to make
9360 sure that all fields are interoperable. This will
9361 need to be a semantic check on the finished derived type.
9362 See 15.2.3 (lines 9-12) of F2003 draft. */
9363 if (!gfc_add_is_bind_c (attr
, NULL
, &gfc_current_locus
, 0))
9366 /* TODO: attr conflicts need to be checked, probably in symbol.c. */
9368 else if (gfc_match (" , abstract") == MATCH_YES
)
9370 if (!gfc_notify_std (GFC_STD_F2003
, "ABSTRACT type at %C"))
9373 if (!gfc_add_abstract (attr
, &gfc_current_locus
))
9376 else if (name
&& gfc_match (" , extends ( %n )", name
) == MATCH_YES
)
9378 if (!gfc_add_extension (attr
, &gfc_current_locus
))
9384 /* If we get here, something matched. */
9389 /* Common function for type declaration blocks similar to derived types, such
9390 as STRUCTURES and MAPs. Unlike derived types, a structure type
9391 does NOT have a generic symbol matching the name given by the user.
9392 STRUCTUREs can share names with variables and PARAMETERs so we must allow
9393 for the creation of an independent symbol.
9394 Other parameters are a message to prefix errors with, the name of the new
9395 type to be created, and the flavor to add to the resulting symbol. */
9398 get_struct_decl (const char *name
, sym_flavor fl
, locus
*decl
,
9399 gfc_symbol
**result
)
9404 gcc_assert (name
[0] == (char) TOUPPER (name
[0]));
9409 where
= gfc_current_locus
;
9411 if (gfc_get_symbol (name
, NULL
, &sym
))
9416 gfc_internal_error ("Failed to create structure type '%s' at %C", name
);
9420 if (sym
->components
!= NULL
|| sym
->attr
.zero_comp
)
9422 gfc_error ("Type definition of %qs at %C was already defined at %L",
9423 sym
->name
, &sym
->declared_at
);
9427 sym
->declared_at
= where
;
9429 if (sym
->attr
.flavor
!= fl
9430 && !gfc_add_flavor (&sym
->attr
, fl
, sym
->name
, NULL
))
9433 if (!sym
->hash_value
)
9434 /* Set the hash for the compound name for this type. */
9435 sym
->hash_value
= gfc_hash_value (sym
);
9437 /* Normally the type is expected to have been completely parsed by the time
9438 a field declaration with this type is seen. For unions, maps, and nested
9439 structure declarations, we need to indicate that it is okay that we
9440 haven't seen any components yet. This will be updated after the structure
9442 sym
->attr
.zero_comp
= 0;
9444 /* Structures always act like derived-types with the SEQUENCE attribute */
9445 gfc_add_sequence (&sym
->attr
, sym
->name
, NULL
);
9447 if (result
) *result
= sym
;
9453 /* Match the opening of a MAP block. Like a struct within a union in C;
9454 behaves identical to STRUCTURE blocks. */
9457 gfc_match_map (void)
9459 /* Counter used to give unique internal names to map structures. */
9460 static unsigned int gfc_map_id
= 0;
9461 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9465 old_loc
= gfc_current_locus
;
9467 if (gfc_match_eos () != MATCH_YES
)
9469 gfc_error ("Junk after MAP statement at %C");
9470 gfc_current_locus
= old_loc
;
9474 /* Map blocks are anonymous so we make up unique names for the symbol table
9475 which are invalid Fortran identifiers. */
9476 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "MM$%u", gfc_map_id
++);
9478 if (!get_struct_decl (name
, FL_STRUCT
, &old_loc
, &sym
))
9481 gfc_new_block
= sym
;
9487 /* Match the opening of a UNION block. */
9490 gfc_match_union (void)
9492 /* Counter used to give unique internal names to union types. */
9493 static unsigned int gfc_union_id
= 0;
9494 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9498 old_loc
= gfc_current_locus
;
9500 if (gfc_match_eos () != MATCH_YES
)
9502 gfc_error ("Junk after UNION statement at %C");
9503 gfc_current_locus
= old_loc
;
9507 /* Unions are anonymous so we make up unique names for the symbol table
9508 which are invalid Fortran identifiers. */
9509 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "UU$%u", gfc_union_id
++);
9511 if (!get_struct_decl (name
, FL_UNION
, &old_loc
, &sym
))
9514 gfc_new_block
= sym
;
9520 /* Match the beginning of a STRUCTURE declaration. This is similar to
9521 matching the beginning of a derived type declaration with a few
9522 twists. The resulting type symbol has no access control or other
9523 interesting attributes. */
9526 gfc_match_structure_decl (void)
9528 /* Counter used to give unique internal names to anonymous structures. */
9529 static unsigned int gfc_structure_id
= 0;
9530 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9535 if (!flag_dec_structure
)
9537 gfc_error ("%s at %C is a DEC extension, enable with "
9538 "%<-fdec-structure%>",
9545 m
= gfc_match (" /%n/", name
);
9548 /* Non-nested structure declarations require a structure name. */
9549 if (!gfc_comp_struct (gfc_current_state ()))
9551 gfc_error ("Structure name expected in non-nested structure "
9552 "declaration at %C");
9555 /* This is an anonymous structure; make up a unique name for it
9556 (upper-case letters never make it to symbol names from the source).
9557 The important thing is initializing the type variable
9558 and setting gfc_new_symbol, which is immediately used by
9559 parse_structure () and variable_decl () to add components of
9561 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "SS$%u", gfc_structure_id
++);
9564 where
= gfc_current_locus
;
9565 /* No field list allowed after non-nested structure declaration. */
9566 if (!gfc_comp_struct (gfc_current_state ())
9567 && gfc_match_eos () != MATCH_YES
)
9569 gfc_error ("Junk after non-nested STRUCTURE statement at %C");
9573 /* Make sure the name is not the name of an intrinsic type. */
9574 if (gfc_is_intrinsic_typename (name
))
9576 gfc_error ("Structure name %qs at %C cannot be the same as an"
9577 " intrinsic type", name
);
9581 /* Store the actual type symbol for the structure with an upper-case first
9582 letter (an invalid Fortran identifier). */
9584 if (!get_struct_decl (gfc_dt_upper_string (name
), FL_STRUCT
, &where
, &sym
))
9587 gfc_new_block
= sym
;
9592 /* This function does some work to determine which matcher should be used to
9593 * match a statement beginning with "TYPE". This is used to disambiguate TYPE
9594 * as an alias for PRINT from derived type declarations, TYPE IS statements,
9595 * and derived type data declarations. */
9598 gfc_match_type (gfc_statement
*st
)
9600 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9604 /* Requires -fdec. */
9608 m
= gfc_match ("type");
9611 /* If we already have an error in the buffer, it is probably from failing to
9612 * match a derived type data declaration. Let it happen. */
9613 else if (gfc_error_flag_test ())
9616 old_loc
= gfc_current_locus
;
9619 /* If we see an attribute list before anything else it's definitely a derived
9620 * type declaration. */
9621 if (gfc_match (" ,") == MATCH_YES
|| gfc_match (" ::") == MATCH_YES
)
9623 gfc_current_locus
= old_loc
;
9624 *st
= ST_DERIVED_DECL
;
9625 return gfc_match_derived_decl ();
9628 /* By now "TYPE" has already been matched. If we do not see a name, this may
9629 * be something like "TYPE *" or "TYPE <fmt>". */
9630 m
= gfc_match_name (name
);
9633 /* Let print match if it can, otherwise throw an error from
9634 * gfc_match_derived_decl. */
9635 gfc_current_locus
= old_loc
;
9636 if (gfc_match_print () == MATCH_YES
)
9641 gfc_current_locus
= old_loc
;
9642 *st
= ST_DERIVED_DECL
;
9643 return gfc_match_derived_decl ();
9646 /* A derived type declaration requires an EOS. Without it, assume print. */
9647 m
= gfc_match_eos ();
9650 /* Check manually for TYPE IS (... - this is invalid print syntax. */
9651 if (strncmp ("is", name
, 3) == 0
9652 && gfc_match (" (", name
) == MATCH_YES
)
9654 gfc_current_locus
= old_loc
;
9655 gcc_assert (gfc_match (" is") == MATCH_YES
);
9657 return gfc_match_type_is ();
9659 gfc_current_locus
= old_loc
;
9661 return gfc_match_print ();
9665 /* By now we have "TYPE <name> <EOS>". Check first if the name is an
9666 * intrinsic typename - if so let gfc_match_derived_decl dump an error.
9667 * Otherwise if gfc_match_derived_decl fails it's probably an existing
9668 * symbol which can be printed. */
9669 gfc_current_locus
= old_loc
;
9670 m
= gfc_match_derived_decl ();
9671 if (gfc_is_intrinsic_typename (name
) || m
== MATCH_YES
)
9673 *st
= ST_DERIVED_DECL
;
9676 gfc_current_locus
= old_loc
;
9678 return gfc_match_print ();
9685 /* Match the beginning of a derived type declaration. If a type name
9686 was the result of a function, then it is possible to have a symbol
9687 already to be known as a derived type yet have no components. */
9690 gfc_match_derived_decl (void)
9692 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9693 char parent
[GFC_MAX_SYMBOL_LEN
+ 1];
9694 symbol_attribute attr
;
9695 gfc_symbol
*sym
, *gensym
;
9696 gfc_symbol
*extended
;
9698 match is_type_attr_spec
= MATCH_NO
;
9699 bool seen_attr
= false;
9700 gfc_interface
*intr
= NULL
, *head
;
9701 bool parameterized_type
= false;
9702 bool seen_colons
= false;
9704 if (gfc_comp_struct (gfc_current_state ()))
9709 gfc_clear_attr (&attr
);
9714 is_type_attr_spec
= gfc_get_type_attr_spec (&attr
, parent
);
9715 if (is_type_attr_spec
== MATCH_ERROR
)
9717 if (is_type_attr_spec
== MATCH_YES
)
9719 } while (is_type_attr_spec
== MATCH_YES
);
9721 /* Deal with derived type extensions. The extension attribute has
9722 been added to 'attr' but now the parent type must be found and
9725 extended
= check_extended_derived_type (parent
);
9727 if (parent
[0] && !extended
)
9730 m
= gfc_match (" ::");
9737 gfc_error ("Expected :: in TYPE definition at %C");
9741 m
= gfc_match (" %n ", name
);
9745 /* Make sure that we don't identify TYPE IS (...) as a parameterized
9746 derived type named 'is'.
9747 TODO Expand the check, when 'name' = "is" by matching " (tname) "
9748 and checking if this is a(n intrinsic) typename. his picks up
9749 misplaced TYPE IS statements such as in select_type_1.f03. */
9750 if (gfc_peek_ascii_char () == '(')
9752 if (gfc_current_state () == COMP_SELECT_TYPE
9753 || (!seen_colons
&& !strcmp (name
, "is")))
9755 parameterized_type
= true;
9758 m
= gfc_match_eos ();
9759 if (m
!= MATCH_YES
&& !parameterized_type
)
9762 /* Make sure the name is not the name of an intrinsic type. */
9763 if (gfc_is_intrinsic_typename (name
))
9765 gfc_error ("Type name %qs at %C cannot be the same as an intrinsic "
9770 if (gfc_get_symbol (name
, NULL
, &gensym
))
9773 if (!gensym
->attr
.generic
&& gensym
->ts
.type
!= BT_UNKNOWN
)
9775 gfc_error ("Derived type name %qs at %C already has a basic type "
9776 "of %s", gensym
->name
, gfc_typename (&gensym
->ts
));
9780 if (!gensym
->attr
.generic
9781 && !gfc_add_generic (&gensym
->attr
, gensym
->name
, NULL
))
9784 if (!gensym
->attr
.function
9785 && !gfc_add_function (&gensym
->attr
, gensym
->name
, NULL
))
9788 sym
= gfc_find_dt_in_generic (gensym
);
9790 if (sym
&& (sym
->components
!= NULL
|| sym
->attr
.zero_comp
))
9792 gfc_error ("Derived type definition of %qs at %C has already been "
9793 "defined", sym
->name
);
9799 /* Use upper case to save the actual derived-type symbol. */
9800 gfc_get_symbol (gfc_dt_upper_string (gensym
->name
), NULL
, &sym
);
9801 sym
->name
= gfc_get_string ("%s", gensym
->name
);
9802 head
= gensym
->generic
;
9803 intr
= gfc_get_interface ();
9805 intr
->where
= gfc_current_locus
;
9806 intr
->sym
->declared_at
= gfc_current_locus
;
9808 gensym
->generic
= intr
;
9809 gensym
->attr
.if_source
= IFSRC_DECL
;
9812 /* The symbol may already have the derived attribute without the
9813 components. The ways this can happen is via a function
9814 definition, an INTRINSIC statement or a subtype in another
9815 derived type that is a pointer. The first part of the AND clause
9816 is true if the symbol is not the return value of a function. */
9817 if (sym
->attr
.flavor
!= FL_DERIVED
9818 && !gfc_add_flavor (&sym
->attr
, FL_DERIVED
, sym
->name
, NULL
))
9821 if (attr
.access
!= ACCESS_UNKNOWN
9822 && !gfc_add_access (&sym
->attr
, attr
.access
, sym
->name
, NULL
))
9824 else if (sym
->attr
.access
== ACCESS_UNKNOWN
9825 && gensym
->attr
.access
!= ACCESS_UNKNOWN
9826 && !gfc_add_access (&sym
->attr
, gensym
->attr
.access
,
9830 if (sym
->attr
.access
!= ACCESS_UNKNOWN
9831 && gensym
->attr
.access
== ACCESS_UNKNOWN
)
9832 gensym
->attr
.access
= sym
->attr
.access
;
9834 /* See if the derived type was labeled as bind(c). */
9835 if (attr
.is_bind_c
!= 0)
9836 sym
->attr
.is_bind_c
= attr
.is_bind_c
;
9838 /* Construct the f2k_derived namespace if it is not yet there. */
9839 if (!sym
->f2k_derived
)
9840 sym
->f2k_derived
= gfc_get_namespace (NULL
, 0);
9842 if (parameterized_type
)
9844 /* Ignore error or mismatches by going to the end of the statement
9845 in order to avoid the component declarations causing problems. */
9846 m
= gfc_match_formal_arglist (sym
, 0, 0, true);
9848 gfc_error_recovery ();
9849 m
= gfc_match_eos ();
9852 sym
->attr
.pdt_template
= 1;
9855 if (extended
&& !sym
->components
)
9858 gfc_formal_arglist
*f
, *g
, *h
;
9860 /* Add the extended derived type as the first component. */
9861 gfc_add_component (sym
, parent
, &p
);
9863 gfc_set_sym_referenced (extended
);
9865 p
->ts
.type
= BT_DERIVED
;
9866 p
->ts
.u
.derived
= extended
;
9867 p
->initializer
= gfc_default_initializer (&p
->ts
);
9869 /* Set extension level. */
9870 if (extended
->attr
.extension
== 255)
9872 /* Since the extension field is 8 bit wide, we can only have
9873 up to 255 extension levels. */
9874 gfc_error ("Maximum extension level reached with type %qs at %L",
9875 extended
->name
, &extended
->declared_at
);
9878 sym
->attr
.extension
= extended
->attr
.extension
+ 1;
9880 /* Provide the links between the extended type and its extension. */
9881 if (!extended
->f2k_derived
)
9882 extended
->f2k_derived
= gfc_get_namespace (NULL
, 0);
9884 /* Copy the extended type-param-name-list from the extended type,
9885 append those of the extension and add the whole lot to the
9887 if (extended
->attr
.pdt_template
)
9890 sym
->attr
.pdt_template
= 1;
9891 for (f
= extended
->formal
; f
; f
= f
->next
)
9893 if (f
== extended
->formal
)
9895 g
= gfc_get_formal_arglist ();
9900 g
->next
= gfc_get_formal_arglist ();
9905 g
->next
= sym
->formal
;
9910 if (!sym
->hash_value
)
9911 /* Set the hash for the compound name for this type. */
9912 sym
->hash_value
= gfc_hash_value (sym
);
9914 /* Take over the ABSTRACT attribute. */
9915 sym
->attr
.abstract
= attr
.abstract
;
9917 gfc_new_block
= sym
;
9923 /* Cray Pointees can be declared as:
9924 pointer (ipt, a (n,m,...,*)) */
9927 gfc_mod_pointee_as (gfc_array_spec
*as
)
9929 as
->cray_pointee
= true; /* This will be useful to know later. */
9930 if (as
->type
== AS_ASSUMED_SIZE
)
9931 as
->cp_was_assumed
= true;
9932 else if (as
->type
== AS_ASSUMED_SHAPE
)
9934 gfc_error ("Cray Pointee at %C cannot be assumed shape array");
9941 /* Match the enum definition statement, here we are trying to match
9942 the first line of enum definition statement.
9943 Returns MATCH_YES if match is found. */
9946 gfc_match_enum (void)
9950 m
= gfc_match_eos ();
9954 if (!gfc_notify_std (GFC_STD_F2003
, "ENUM and ENUMERATOR at %C"))
9961 /* Returns an initializer whose value is one higher than the value of the
9962 LAST_INITIALIZER argument. If the argument is NULL, the
9963 initializers value will be set to zero. The initializer's kind
9964 will be set to gfc_c_int_kind.
9966 If -fshort-enums is given, the appropriate kind will be selected
9967 later after all enumerators have been parsed. A warning is issued
9968 here if an initializer exceeds gfc_c_int_kind. */
9971 enum_initializer (gfc_expr
*last_initializer
, locus where
)
9974 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_c_int_kind
, &where
);
9976 mpz_init (result
->value
.integer
);
9978 if (last_initializer
!= NULL
)
9980 mpz_add_ui (result
->value
.integer
, last_initializer
->value
.integer
, 1);
9981 result
->where
= last_initializer
->where
;
9983 if (gfc_check_integer_range (result
->value
.integer
,
9984 gfc_c_int_kind
) != ARITH_OK
)
9986 gfc_error ("Enumerator exceeds the C integer type at %C");
9992 /* Control comes here, if it's the very first enumerator and no
9993 initializer has been given. It will be initialized to zero. */
9994 mpz_set_si (result
->value
.integer
, 0);
10001 /* Match a variable name with an optional initializer. When this
10002 subroutine is called, a variable is expected to be parsed next.
10003 Depending on what is happening at the moment, updates either the
10004 symbol table or the current interface. */
10007 enumerator_decl (void)
10009 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10010 gfc_expr
*initializer
;
10011 gfc_array_spec
*as
= NULL
;
10018 initializer
= NULL
;
10019 old_locus
= gfc_current_locus
;
10021 /* When we get here, we've just matched a list of attributes and
10022 maybe a type and a double colon. The next thing we expect to see
10023 is the name of the symbol. */
10024 m
= gfc_match_name (name
);
10025 if (m
!= MATCH_YES
)
10028 var_locus
= gfc_current_locus
;
10030 /* OK, we've successfully matched the declaration. Now put the
10031 symbol in the current namespace. If we fail to create the symbol,
10033 if (!build_sym (name
, NULL
, false, &as
, &var_locus
))
10039 /* The double colon must be present in order to have initializers.
10040 Otherwise the statement is ambiguous with an assignment statement. */
10043 if (gfc_match_char ('=') == MATCH_YES
)
10045 m
= gfc_match_init_expr (&initializer
);
10048 gfc_error ("Expected an initialization expression at %C");
10052 if (m
!= MATCH_YES
)
10057 /* If we do not have an initializer, the initialization value of the
10058 previous enumerator (stored in last_initializer) is incremented
10059 by 1 and is used to initialize the current enumerator. */
10060 if (initializer
== NULL
)
10061 initializer
= enum_initializer (last_initializer
, old_locus
);
10063 if (initializer
== NULL
|| initializer
->ts
.type
!= BT_INTEGER
)
10065 gfc_error ("ENUMERATOR %L not initialized with integer expression",
10071 /* Store this current initializer, for the next enumerator variable
10072 to be parsed. add_init_expr_to_sym() zeros initializer, so we
10073 use last_initializer below. */
10074 last_initializer
= initializer
;
10075 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
10077 /* Maintain enumerator history. */
10078 gfc_find_symbol (name
, NULL
, 0, &sym
);
10079 create_enum_history (sym
, last_initializer
);
10081 return (t
) ? MATCH_YES
: MATCH_ERROR
;
10084 /* Free stuff up and return. */
10085 gfc_free_expr (initializer
);
10091 /* Match the enumerator definition statement. */
10094 gfc_match_enumerator_def (void)
10099 gfc_clear_ts (¤t_ts
);
10101 m
= gfc_match (" enumerator");
10102 if (m
!= MATCH_YES
)
10105 m
= gfc_match (" :: ");
10106 if (m
== MATCH_ERROR
)
10109 colon_seen
= (m
== MATCH_YES
);
10111 if (gfc_current_state () != COMP_ENUM
)
10113 gfc_error ("ENUM definition statement expected before %C");
10114 gfc_free_enum_history ();
10115 return MATCH_ERROR
;
10118 (¤t_ts
)->type
= BT_INTEGER
;
10119 (¤t_ts
)->kind
= gfc_c_int_kind
;
10121 gfc_clear_attr (¤t_attr
);
10122 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, NULL
);
10131 m
= enumerator_decl ();
10132 if (m
== MATCH_ERROR
)
10134 gfc_free_enum_history ();
10140 if (gfc_match_eos () == MATCH_YES
)
10142 if (gfc_match_char (',') != MATCH_YES
)
10146 if (gfc_current_state () == COMP_ENUM
)
10148 gfc_free_enum_history ();
10149 gfc_error ("Syntax error in ENUMERATOR definition at %C");
10154 gfc_free_array_spec (current_as
);
10161 /* Match binding attributes. */
10164 match_binding_attributes (gfc_typebound_proc
* ba
, bool generic
, bool ppc
)
10166 bool found_passing
= false;
10167 bool seen_ptr
= false;
10168 match m
= MATCH_YES
;
10170 /* Initialize to defaults. Do so even before the MATCH_NO check so that in
10171 this case the defaults are in there. */
10172 ba
->access
= ACCESS_UNKNOWN
;
10173 ba
->pass_arg
= NULL
;
10174 ba
->pass_arg_num
= 0;
10176 ba
->non_overridable
= 0;
10180 /* If we find a comma, we believe there are binding attributes. */
10181 m
= gfc_match_char (',');
10187 /* Access specifier. */
10189 m
= gfc_match (" public");
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_PUBLIC
;
10204 m
= gfc_match (" private");
10205 if (m
== MATCH_ERROR
)
10207 if (m
== MATCH_YES
)
10209 if (ba
->access
!= ACCESS_UNKNOWN
)
10211 gfc_error ("Duplicate access-specifier at %C");
10215 ba
->access
= ACCESS_PRIVATE
;
10219 /* If inside GENERIC, the following is not allowed. */
10224 m
= gfc_match (" nopass");
10225 if (m
== MATCH_ERROR
)
10227 if (m
== MATCH_YES
)
10231 gfc_error ("Binding attributes already specify passing,"
10232 " illegal NOPASS at %C");
10236 found_passing
= true;
10241 /* PASS possibly including argument. */
10242 m
= gfc_match (" pass");
10243 if (m
== MATCH_ERROR
)
10245 if (m
== MATCH_YES
)
10247 char arg
[GFC_MAX_SYMBOL_LEN
+ 1];
10251 gfc_error ("Binding attributes already specify passing,"
10252 " illegal PASS at %C");
10256 m
= gfc_match (" ( %n )", arg
);
10257 if (m
== MATCH_ERROR
)
10259 if (m
== MATCH_YES
)
10260 ba
->pass_arg
= gfc_get_string ("%s", arg
);
10261 gcc_assert ((m
== MATCH_YES
) == (ba
->pass_arg
!= NULL
));
10263 found_passing
= true;
10270 /* POINTER flag. */
10271 m
= gfc_match (" pointer");
10272 if (m
== MATCH_ERROR
)
10274 if (m
== MATCH_YES
)
10278 gfc_error ("Duplicate POINTER attribute at %C");
10288 /* NON_OVERRIDABLE flag. */
10289 m
= gfc_match (" non_overridable");
10290 if (m
== MATCH_ERROR
)
10292 if (m
== MATCH_YES
)
10294 if (ba
->non_overridable
)
10296 gfc_error ("Duplicate NON_OVERRIDABLE at %C");
10300 ba
->non_overridable
= 1;
10304 /* DEFERRED flag. */
10305 m
= gfc_match (" deferred");
10306 if (m
== MATCH_ERROR
)
10308 if (m
== MATCH_YES
)
10312 gfc_error ("Duplicate DEFERRED at %C");
10323 /* Nothing matching found. */
10325 gfc_error ("Expected access-specifier at %C");
10327 gfc_error ("Expected binding attribute at %C");
10330 while (gfc_match_char (',') == MATCH_YES
);
10332 /* NON_OVERRIDABLE and DEFERRED exclude themselves. */
10333 if (ba
->non_overridable
&& ba
->deferred
)
10335 gfc_error ("NON_OVERRIDABLE and DEFERRED can't both appear at %C");
10342 if (ba
->access
== ACCESS_UNKNOWN
)
10343 ba
->access
= gfc_typebound_default_access
;
10345 if (ppc
&& !seen_ptr
)
10347 gfc_error ("POINTER attribute is required for procedure pointer component"
10355 return MATCH_ERROR
;
10359 /* Match a PROCEDURE specific binding inside a derived type. */
10362 match_procedure_in_type (void)
10364 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10365 char target_buf
[GFC_MAX_SYMBOL_LEN
+ 1];
10366 char* target
= NULL
, *ifc
= NULL
;
10367 gfc_typebound_proc tb
;
10371 gfc_symtree
* stree
;
10376 /* Check current state. */
10377 gcc_assert (gfc_state_stack
->state
== COMP_DERIVED_CONTAINS
);
10378 block
= gfc_state_stack
->previous
->sym
;
10379 gcc_assert (block
);
10381 /* Try to match PROCEDURE(interface). */
10382 if (gfc_match (" (") == MATCH_YES
)
10384 m
= gfc_match_name (target_buf
);
10385 if (m
== MATCH_ERROR
)
10387 if (m
!= MATCH_YES
)
10389 gfc_error ("Interface-name expected after %<(%> at %C");
10390 return MATCH_ERROR
;
10393 if (gfc_match (" )") != MATCH_YES
)
10395 gfc_error ("%<)%> expected at %C");
10396 return MATCH_ERROR
;
10402 /* Construct the data structure. */
10403 memset (&tb
, 0, sizeof (tb
));
10404 tb
.where
= gfc_current_locus
;
10406 /* Match binding attributes. */
10407 m
= match_binding_attributes (&tb
, false, false);
10408 if (m
== MATCH_ERROR
)
10410 seen_attrs
= (m
== MATCH_YES
);
10412 /* Check that attribute DEFERRED is given if an interface is specified. */
10413 if (tb
.deferred
&& !ifc
)
10415 gfc_error ("Interface must be specified for DEFERRED binding at %C");
10416 return MATCH_ERROR
;
10418 if (ifc
&& !tb
.deferred
)
10420 gfc_error ("PROCEDURE(interface) at %C should be declared DEFERRED");
10421 return MATCH_ERROR
;
10424 /* Match the colons. */
10425 m
= gfc_match (" ::");
10426 if (m
== MATCH_ERROR
)
10428 seen_colons
= (m
== MATCH_YES
);
10429 if (seen_attrs
&& !seen_colons
)
10431 gfc_error ("Expected %<::%> after binding-attributes at %C");
10432 return MATCH_ERROR
;
10435 /* Match the binding names. */
10438 m
= gfc_match_name (name
);
10439 if (m
== MATCH_ERROR
)
10443 gfc_error ("Expected binding name at %C");
10444 return MATCH_ERROR
;
10447 if (num
>1 && !gfc_notify_std (GFC_STD_F2008
, "PROCEDURE list at %C"))
10448 return MATCH_ERROR
;
10450 /* Try to match the '=> target', if it's there. */
10452 m
= gfc_match (" =>");
10453 if (m
== MATCH_ERROR
)
10455 if (m
== MATCH_YES
)
10459 gfc_error ("%<=> target%> is invalid for DEFERRED binding at %C");
10460 return MATCH_ERROR
;
10465 gfc_error ("%<::%> needed in PROCEDURE binding with explicit target"
10467 return MATCH_ERROR
;
10470 m
= gfc_match_name (target_buf
);
10471 if (m
== MATCH_ERROR
)
10475 gfc_error ("Expected binding target after %<=>%> at %C");
10476 return MATCH_ERROR
;
10478 target
= target_buf
;
10481 /* If no target was found, it has the same name as the binding. */
10485 /* Get the namespace to insert the symbols into. */
10486 ns
= block
->f2k_derived
;
10489 /* If the binding is DEFERRED, check that the containing type is ABSTRACT. */
10490 if (tb
.deferred
&& !block
->attr
.abstract
)
10492 gfc_error ("Type %qs containing DEFERRED binding at %C "
10493 "is not ABSTRACT", block
->name
);
10494 return MATCH_ERROR
;
10497 /* See if we already have a binding with this name in the symtree which
10498 would be an error. If a GENERIC already targeted this binding, it may
10499 be already there but then typebound is still NULL. */
10500 stree
= gfc_find_symtree (ns
->tb_sym_root
, name
);
10501 if (stree
&& stree
->n
.tb
)
10503 gfc_error ("There is already a procedure with binding name %qs for "
10504 "the derived type %qs at %C", name
, block
->name
);
10505 return MATCH_ERROR
;
10508 /* Insert it and set attributes. */
10512 stree
= gfc_new_symtree (&ns
->tb_sym_root
, name
);
10513 gcc_assert (stree
);
10515 stree
->n
.tb
= gfc_get_typebound_proc (&tb
);
10517 if (gfc_get_sym_tree (target
, gfc_current_ns
, &stree
->n
.tb
->u
.specific
,
10519 return MATCH_ERROR
;
10520 gfc_set_sym_referenced (stree
->n
.tb
->u
.specific
->n
.sym
);
10521 gfc_add_flavor(&stree
->n
.tb
->u
.specific
->n
.sym
->attr
, FL_PROCEDURE
,
10522 target
, &stree
->n
.tb
->u
.specific
->n
.sym
->declared_at
);
10524 if (gfc_match_eos () == MATCH_YES
)
10526 if (gfc_match_char (',') != MATCH_YES
)
10531 gfc_error ("Syntax error in PROCEDURE statement at %C");
10532 return MATCH_ERROR
;
10536 /* Match a GENERIC procedure binding inside a derived type. */
10539 gfc_match_generic (void)
10541 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10542 char bind_name
[GFC_MAX_SYMBOL_LEN
+ 16]; /* Allow space for OPERATOR(...). */
10544 gfc_typebound_proc tbattr
; /* Used for match_binding_attributes. */
10545 gfc_typebound_proc
* tb
;
10547 interface_type op_type
;
10548 gfc_intrinsic_op op
;
10551 /* Check current state. */
10552 if (gfc_current_state () == COMP_DERIVED
)
10554 gfc_error ("GENERIC at %C must be inside a derived-type CONTAINS");
10555 return MATCH_ERROR
;
10557 if (gfc_current_state () != COMP_DERIVED_CONTAINS
)
10559 block
= gfc_state_stack
->previous
->sym
;
10560 ns
= block
->f2k_derived
;
10561 gcc_assert (block
&& ns
);
10563 memset (&tbattr
, 0, sizeof (tbattr
));
10564 tbattr
.where
= gfc_current_locus
;
10566 /* See if we get an access-specifier. */
10567 m
= match_binding_attributes (&tbattr
, true, false);
10568 if (m
== MATCH_ERROR
)
10571 /* Now the colons, those are required. */
10572 if (gfc_match (" ::") != MATCH_YES
)
10574 gfc_error ("Expected %<::%> at %C");
10578 /* Match the binding name; depending on type (operator / generic) format
10579 it for future error messages into bind_name. */
10581 m
= gfc_match_generic_spec (&op_type
, name
, &op
);
10582 if (m
== MATCH_ERROR
)
10583 return MATCH_ERROR
;
10586 gfc_error ("Expected generic name or operator descriptor at %C");
10592 case INTERFACE_GENERIC
:
10593 case INTERFACE_DTIO
:
10594 snprintf (bind_name
, sizeof (bind_name
), "%s", name
);
10597 case INTERFACE_USER_OP
:
10598 snprintf (bind_name
, sizeof (bind_name
), "OPERATOR(.%s.)", name
);
10601 case INTERFACE_INTRINSIC_OP
:
10602 snprintf (bind_name
, sizeof (bind_name
), "OPERATOR(%s)",
10603 gfc_op2string (op
));
10606 case INTERFACE_NAMELESS
:
10607 gfc_error ("Malformed GENERIC statement at %C");
10612 gcc_unreachable ();
10615 /* Match the required =>. */
10616 if (gfc_match (" =>") != MATCH_YES
)
10618 gfc_error ("Expected %<=>%> at %C");
10622 /* Try to find existing GENERIC binding with this name / for this operator;
10623 if there is something, check that it is another GENERIC and then extend
10624 it rather than building a new node. Otherwise, create it and put it
10625 at the right position. */
10629 case INTERFACE_DTIO
:
10630 case INTERFACE_USER_OP
:
10631 case INTERFACE_GENERIC
:
10633 const bool is_op
= (op_type
== INTERFACE_USER_OP
);
10636 st
= gfc_find_symtree (is_op
? ns
->tb_uop_root
: ns
->tb_sym_root
, name
);
10637 tb
= st
? st
->n
.tb
: NULL
;
10641 case INTERFACE_INTRINSIC_OP
:
10642 tb
= ns
->tb_op
[op
];
10646 gcc_unreachable ();
10651 if (!tb
->is_generic
)
10653 gcc_assert (op_type
== INTERFACE_GENERIC
);
10654 gfc_error ("There's already a non-generic procedure with binding name"
10655 " %qs for the derived type %qs at %C",
10656 bind_name
, block
->name
);
10660 if (tb
->access
!= tbattr
.access
)
10662 gfc_error ("Binding at %C must have the same access as already"
10663 " defined binding %qs", bind_name
);
10669 tb
= gfc_get_typebound_proc (NULL
);
10670 tb
->where
= gfc_current_locus
;
10671 tb
->access
= tbattr
.access
;
10672 tb
->is_generic
= 1;
10673 tb
->u
.generic
= NULL
;
10677 case INTERFACE_DTIO
:
10678 case INTERFACE_GENERIC
:
10679 case INTERFACE_USER_OP
:
10681 const bool is_op
= (op_type
== INTERFACE_USER_OP
);
10682 gfc_symtree
* st
= gfc_get_tbp_symtree (is_op
? &ns
->tb_uop_root
:
10683 &ns
->tb_sym_root
, name
);
10690 case INTERFACE_INTRINSIC_OP
:
10691 ns
->tb_op
[op
] = tb
;
10695 gcc_unreachable ();
10699 /* Now, match all following names as specific targets. */
10702 gfc_symtree
* target_st
;
10703 gfc_tbp_generic
* target
;
10705 m
= gfc_match_name (name
);
10706 if (m
== MATCH_ERROR
)
10710 gfc_error ("Expected specific binding name at %C");
10714 target_st
= gfc_get_tbp_symtree (&ns
->tb_sym_root
, name
);
10716 /* See if this is a duplicate specification. */
10717 for (target
= tb
->u
.generic
; target
; target
= target
->next
)
10718 if (target_st
== target
->specific_st
)
10720 gfc_error ("%qs already defined as specific binding for the"
10721 " generic %qs at %C", name
, bind_name
);
10725 target
= gfc_get_tbp_generic ();
10726 target
->specific_st
= target_st
;
10727 target
->specific
= NULL
;
10728 target
->next
= tb
->u
.generic
;
10729 target
->is_operator
= ((op_type
== INTERFACE_USER_OP
)
10730 || (op_type
== INTERFACE_INTRINSIC_OP
));
10731 tb
->u
.generic
= target
;
10733 while (gfc_match (" ,") == MATCH_YES
);
10735 /* Here should be the end. */
10736 if (gfc_match_eos () != MATCH_YES
)
10738 gfc_error ("Junk after GENERIC binding at %C");
10745 return MATCH_ERROR
;
10749 /* Match a FINAL declaration inside a derived type. */
10752 gfc_match_final_decl (void)
10754 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10757 gfc_namespace
* module_ns
;
10761 if (gfc_current_form
== FORM_FREE
)
10763 char c
= gfc_peek_ascii_char ();
10764 if (!gfc_is_whitespace (c
) && c
!= ':')
10768 if (gfc_state_stack
->state
!= COMP_DERIVED_CONTAINS
)
10770 if (gfc_current_form
== FORM_FIXED
)
10773 gfc_error ("FINAL declaration at %C must be inside a derived type "
10774 "CONTAINS section");
10775 return MATCH_ERROR
;
10778 block
= gfc_state_stack
->previous
->sym
;
10779 gcc_assert (block
);
10781 if (!gfc_state_stack
->previous
|| !gfc_state_stack
->previous
->previous
10782 || gfc_state_stack
->previous
->previous
->state
!= COMP_MODULE
)
10784 gfc_error ("Derived type declaration with FINAL at %C must be in the"
10785 " specification part of a MODULE");
10786 return MATCH_ERROR
;
10789 module_ns
= gfc_current_ns
;
10790 gcc_assert (module_ns
);
10791 gcc_assert (module_ns
->proc_name
->attr
.flavor
== FL_MODULE
);
10793 /* Match optional ::, don't care about MATCH_YES or MATCH_NO. */
10794 if (gfc_match (" ::") == MATCH_ERROR
)
10795 return MATCH_ERROR
;
10797 /* Match the sequence of procedure names. */
10804 if (first
&& gfc_match_eos () == MATCH_YES
)
10806 gfc_error ("Empty FINAL at %C");
10807 return MATCH_ERROR
;
10810 m
= gfc_match_name (name
);
10813 gfc_error ("Expected module procedure name at %C");
10814 return MATCH_ERROR
;
10816 else if (m
!= MATCH_YES
)
10817 return MATCH_ERROR
;
10819 if (gfc_match_eos () == MATCH_YES
)
10821 if (!last
&& gfc_match_char (',') != MATCH_YES
)
10823 gfc_error ("Expected %<,%> at %C");
10824 return MATCH_ERROR
;
10827 if (gfc_get_symbol (name
, module_ns
, &sym
))
10829 gfc_error ("Unknown procedure name %qs at %C", name
);
10830 return MATCH_ERROR
;
10833 /* Mark the symbol as module procedure. */
10834 if (sym
->attr
.proc
!= PROC_MODULE
10835 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
10836 return MATCH_ERROR
;
10838 /* Check if we already have this symbol in the list, this is an error. */
10839 for (f
= block
->f2k_derived
->finalizers
; f
; f
= f
->next
)
10840 if (f
->proc_sym
== sym
)
10842 gfc_error ("%qs at %C is already defined as FINAL procedure",
10844 return MATCH_ERROR
;
10847 /* Add this symbol to the list of finalizers. */
10848 gcc_assert (block
->f2k_derived
);
10850 f
= XCNEW (gfc_finalizer
);
10852 f
->proc_tree
= NULL
;
10853 f
->where
= gfc_current_locus
;
10854 f
->next
= block
->f2k_derived
->finalizers
;
10855 block
->f2k_derived
->finalizers
= f
;
10865 const ext_attr_t ext_attr_list
[] = {
10866 { "dllimport", EXT_ATTR_DLLIMPORT
, "dllimport" },
10867 { "dllexport", EXT_ATTR_DLLEXPORT
, "dllexport" },
10868 { "cdecl", EXT_ATTR_CDECL
, "cdecl" },
10869 { "stdcall", EXT_ATTR_STDCALL
, "stdcall" },
10870 { "fastcall", EXT_ATTR_FASTCALL
, "fastcall" },
10871 { "no_arg_check", EXT_ATTR_NO_ARG_CHECK
, NULL
},
10872 { NULL
, EXT_ATTR_LAST
, NULL
}
10875 /* Match a !GCC$ ATTRIBUTES statement of the form:
10876 !GCC$ ATTRIBUTES attribute-list :: var-name [, var-name] ...
10877 When we come here, we have already matched the !GCC$ ATTRIBUTES string.
10879 TODO: We should support all GCC attributes using the same syntax for
10880 the attribute list, i.e. the list in C
10881 __attributes(( attribute-list ))
10883 !GCC$ ATTRIBUTES attribute-list ::
10884 Cf. c-parser.c's c_parser_attributes; the data can then directly be
10887 As there is absolutely no risk of confusion, we should never return
10890 gfc_match_gcc_attributes (void)
10892 symbol_attribute attr
;
10893 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10898 gfc_clear_attr (&attr
);
10903 if (gfc_match_name (name
) != MATCH_YES
)
10904 return MATCH_ERROR
;
10906 for (id
= 0; id
< EXT_ATTR_LAST
; id
++)
10907 if (strcmp (name
, ext_attr_list
[id
].name
) == 0)
10910 if (id
== EXT_ATTR_LAST
)
10912 gfc_error ("Unknown attribute in !GCC$ ATTRIBUTES statement at %C");
10913 return MATCH_ERROR
;
10916 if (!gfc_add_ext_attribute (&attr
, (ext_attr_id_t
)id
, &gfc_current_locus
))
10917 return MATCH_ERROR
;
10919 gfc_gobble_whitespace ();
10920 ch
= gfc_next_ascii_char ();
10923 /* This is the successful exit condition for the loop. */
10924 if (gfc_next_ascii_char () == ':')
10934 if (gfc_match_eos () == MATCH_YES
)
10939 m
= gfc_match_name (name
);
10940 if (m
!= MATCH_YES
)
10943 if (find_special (name
, &sym
, true))
10944 return MATCH_ERROR
;
10946 sym
->attr
.ext_attr
|= attr
.ext_attr
;
10948 if (gfc_match_eos () == MATCH_YES
)
10951 if (gfc_match_char (',') != MATCH_YES
)
10958 gfc_error ("Syntax error in !GCC$ ATTRIBUTES statement at %C");
10959 return MATCH_ERROR
;