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
;
641 mpz_init_set_ui (repeat
, 0);
643 scalar
= !as
|| !as
->rank
;
645 /* We have already matched '/' - now look for a constant list, as with
646 top_val_list from decl.c, but append the result to an array. */
647 if (gfc_match ("/") == MATCH_YES
)
649 gfc_error ("Empty old style initializer list at %C");
653 where
= gfc_current_locus
;
656 m
= match_data_constant (&expr
);
658 expr
= NULL
; /* match_data_constant may set expr to garbage */
661 if (m
== MATCH_ERROR
)
664 /* Found r in repeat spec r*c; look for the constant to repeat. */
665 if ( gfc_match_char ('*') == MATCH_YES
)
669 gfc_error ("Repeat spec invalid in scalar initializer at %C");
672 if (expr
->ts
.type
!= BT_INTEGER
)
674 gfc_error ("Repeat spec must be an integer at %C");
677 mpz_set (repeat
, expr
->value
.integer
);
678 gfc_free_expr (expr
);
681 m
= match_data_constant (&expr
);
683 gfc_error ("Expected data constant after repeat spec at %C");
687 /* No repeat spec, we matched the data constant itself. */
689 mpz_set_ui (repeat
, 1);
693 /* Add the constant initializer as many times as repeated. */
694 for (; mpz_cmp_ui (repeat
, 0) > 0; mpz_sub_ui (repeat
, repeat
, 1))
696 /* Make sure types of elements match */
697 if(ts
&& !gfc_compare_types (&expr
->ts
, ts
)
698 && !gfc_convert_type (expr
, ts
, 1))
701 gfc_constructor_append_expr (&array_head
,
702 gfc_copy_expr (expr
), &gfc_current_locus
);
705 gfc_free_expr (expr
);
709 /* For scalar initializers quit after one element. */
712 if(gfc_match_char ('/') != MATCH_YES
)
714 gfc_error ("End of scalar initializer expected at %C");
720 if (gfc_match_char ('/') == MATCH_YES
)
722 if (gfc_match_char (',') == MATCH_NO
)
726 /* Set up expr as an array constructor. */
729 expr
= gfc_get_array_expr (ts
->type
, ts
->kind
, &where
);
731 expr
->value
.constructor
= array_head
;
733 expr
->rank
= as
->rank
;
734 expr
->shape
= gfc_get_shape (expr
->rank
);
736 /* Validate sizes. */
737 gcc_assert (gfc_array_size (expr
, &size
));
738 gcc_assert (spec_size (as
, &repeat
));
739 cmp
= mpz_cmp (size
, repeat
);
741 gfc_error ("Not enough elements in array initializer at %C");
743 gfc_error ("Too many elements in array initializer at %C");
748 /* Make sure scalar types match. */
749 else if (!gfc_compare_types (&expr
->ts
, ts
)
750 && !gfc_convert_type (expr
, ts
, 1))
754 expr
->ts
.u
.cl
->length_from_typespec
= 1;
762 gfc_error ("Syntax error in old style initializer list at %C");
766 expr
->value
.constructor
= NULL
;
767 gfc_free_expr (expr
);
768 gfc_constructor_free (array_head
);
775 /* Auxiliary function to merge DIMENSION and CODIMENSION array specs. */
778 merge_array_spec (gfc_array_spec
*from
, gfc_array_spec
*to
, bool copy
)
782 if ((from
->type
== AS_ASSUMED_RANK
&& to
->corank
)
783 || (to
->type
== AS_ASSUMED_RANK
&& from
->corank
))
785 gfc_error ("The assumed-rank array at %C shall not have a codimension");
789 if (to
->rank
== 0 && from
->rank
> 0)
791 to
->rank
= from
->rank
;
792 to
->type
= from
->type
;
793 to
->cray_pointee
= from
->cray_pointee
;
794 to
->cp_was_assumed
= from
->cp_was_assumed
;
796 for (i
= 0; i
< to
->corank
; i
++)
798 to
->lower
[from
->rank
+ i
] = to
->lower
[i
];
799 to
->upper
[from
->rank
+ i
] = to
->upper
[i
];
801 for (i
= 0; i
< from
->rank
; i
++)
805 to
->lower
[i
] = gfc_copy_expr (from
->lower
[i
]);
806 to
->upper
[i
] = gfc_copy_expr (from
->upper
[i
]);
810 to
->lower
[i
] = from
->lower
[i
];
811 to
->upper
[i
] = from
->upper
[i
];
815 else if (to
->corank
== 0 && from
->corank
> 0)
817 to
->corank
= from
->corank
;
818 to
->cotype
= from
->cotype
;
820 for (i
= 0; i
< from
->corank
; i
++)
824 to
->lower
[to
->rank
+ i
] = gfc_copy_expr (from
->lower
[i
]);
825 to
->upper
[to
->rank
+ i
] = gfc_copy_expr (from
->upper
[i
]);
829 to
->lower
[to
->rank
+ i
] = from
->lower
[i
];
830 to
->upper
[to
->rank
+ i
] = from
->upper
[i
];
839 /* Match an intent specification. Since this can only happen after an
840 INTENT word, a legal intent-spec must follow. */
843 match_intent_spec (void)
846 if (gfc_match (" ( in out )") == MATCH_YES
)
848 if (gfc_match (" ( in )") == MATCH_YES
)
850 if (gfc_match (" ( out )") == MATCH_YES
)
853 gfc_error ("Bad INTENT specification at %C");
854 return INTENT_UNKNOWN
;
858 /* Matches a character length specification, which is either a
859 specification expression, '*', or ':'. */
862 char_len_param_value (gfc_expr
**expr
, bool *deferred
)
869 if (gfc_match_char ('*') == MATCH_YES
)
872 if (gfc_match_char (':') == MATCH_YES
)
874 if (!gfc_notify_std (GFC_STD_F2003
, "deferred type parameter at %C"))
882 m
= gfc_match_expr (expr
);
884 if (m
== MATCH_NO
|| m
== MATCH_ERROR
)
887 if (!gfc_expr_check_typed (*expr
, gfc_current_ns
, false))
890 if ((*expr
)->expr_type
== EXPR_FUNCTION
)
892 if ((*expr
)->ts
.type
== BT_INTEGER
893 || ((*expr
)->ts
.type
== BT_UNKNOWN
894 && strcmp((*expr
)->symtree
->name
, "null") != 0))
899 else if ((*expr
)->expr_type
== EXPR_CONSTANT
)
901 /* F2008, 4.4.3.1: The length is a type parameter; its kind is
902 processor dependent and its value is greater than or equal to zero.
903 F2008, 4.4.3.2: If the character length parameter value evaluates
904 to a negative value, the length of character entities declared
907 if ((*expr
)->ts
.type
== BT_INTEGER
)
909 if (mpz_cmp_si ((*expr
)->value
.integer
, 0) < 0)
910 mpz_set_si ((*expr
)->value
.integer
, 0);
915 else if ((*expr
)->expr_type
== EXPR_ARRAY
)
917 else if ((*expr
)->expr_type
== EXPR_VARIABLE
)
922 e
= gfc_copy_expr (*expr
);
924 /* This catches the invalid code "[character(m(2:3)) :: 'x', 'y']",
925 which causes an ICE if gfc_reduce_init_expr() is called. */
926 if (e
->ref
&& e
->ref
->type
== REF_ARRAY
927 && e
->ref
->u
.ar
.type
== AR_UNKNOWN
928 && e
->ref
->u
.ar
.dimen_type
[0] == DIMEN_RANGE
)
931 t
= gfc_reduce_init_expr (e
);
933 if (!t
&& e
->ts
.type
== BT_UNKNOWN
934 && e
->symtree
->n
.sym
->attr
.untyped
== 1
935 && (flag_implicit_none
936 || e
->symtree
->n
.sym
->ns
->seen_implicit_none
== 1
937 || e
->symtree
->n
.sym
->ns
->parent
->seen_implicit_none
== 1))
943 if ((e
->ref
&& e
->ref
->type
== REF_ARRAY
944 && e
->ref
->u
.ar
.type
!= AR_ELEMENT
)
945 || (!e
->ref
&& e
->expr_type
== EXPR_ARRAY
))
957 gfc_error ("Scalar INTEGER expression expected at %L", &(*expr
)->where
);
962 /* A character length is a '*' followed by a literal integer or a
963 char_len_param_value in parenthesis. */
966 match_char_length (gfc_expr
**expr
, bool *deferred
, bool obsolescent_check
)
972 m
= gfc_match_char ('*');
976 m
= gfc_match_small_literal_int (&length
, NULL
);
977 if (m
== MATCH_ERROR
)
982 if (obsolescent_check
983 && !gfc_notify_std (GFC_STD_F95_OBS
, "Old-style character length at %C"))
985 *expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, length
);
989 if (gfc_match_char ('(') == MATCH_NO
)
992 m
= char_len_param_value (expr
, deferred
);
993 if (m
!= MATCH_YES
&& gfc_matching_function
)
999 if (m
== MATCH_ERROR
)
1004 if (gfc_match_char (')') == MATCH_NO
)
1006 gfc_free_expr (*expr
);
1014 gfc_error ("Syntax error in character length specification at %C");
1019 /* Special subroutine for finding a symbol. Check if the name is found
1020 in the current name space. If not, and we're compiling a function or
1021 subroutine and the parent compilation unit is an interface, then check
1022 to see if the name we've been given is the name of the interface
1023 (located in another namespace). */
1026 find_special (const char *name
, gfc_symbol
**result
, bool allow_subroutine
)
1032 i
= gfc_get_sym_tree (name
, NULL
, &st
, allow_subroutine
);
1035 *result
= st
? st
->n
.sym
: NULL
;
1039 if (gfc_current_state () != COMP_SUBROUTINE
1040 && gfc_current_state () != COMP_FUNCTION
)
1043 s
= gfc_state_stack
->previous
;
1047 if (s
->state
!= COMP_INTERFACE
)
1050 goto end
; /* Nameless interface. */
1052 if (strcmp (name
, s
->sym
->name
) == 0)
1063 /* Special subroutine for getting a symbol node associated with a
1064 procedure name, used in SUBROUTINE and FUNCTION statements. The
1065 symbol is created in the parent using with symtree node in the
1066 child unit pointing to the symbol. If the current namespace has no
1067 parent, then the symbol is just created in the current unit. */
1070 get_proc_name (const char *name
, gfc_symbol
**result
, bool module_fcn_entry
)
1076 /* Module functions have to be left in their own namespace because
1077 they have potentially (almost certainly!) already been referenced.
1078 In this sense, they are rather like external functions. This is
1079 fixed up in resolve.c(resolve_entries), where the symbol name-
1080 space is set to point to the master function, so that the fake
1081 result mechanism can work. */
1082 if (module_fcn_entry
)
1084 /* Present if entry is declared to be a module procedure. */
1085 rc
= gfc_find_symbol (name
, gfc_current_ns
->parent
, 0, result
);
1087 if (*result
== NULL
)
1088 rc
= gfc_get_symbol (name
, NULL
, result
);
1089 else if (!gfc_get_symbol (name
, NULL
, &sym
) && sym
1090 && (*result
)->ts
.type
== BT_UNKNOWN
1091 && sym
->attr
.flavor
== FL_UNKNOWN
)
1092 /* Pick up the typespec for the entry, if declared in the function
1093 body. Note that this symbol is FL_UNKNOWN because it will
1094 only have appeared in a type declaration. The local symtree
1095 is set to point to the module symbol and a unique symtree
1096 to the local version. This latter ensures a correct clearing
1099 /* If the ENTRY proceeds its specification, we need to ensure
1100 that this does not raise a "has no IMPLICIT type" error. */
1101 if (sym
->ts
.type
== BT_UNKNOWN
)
1102 sym
->attr
.untyped
= 1;
1104 (*result
)->ts
= sym
->ts
;
1106 /* Put the symbol in the procedure namespace so that, should
1107 the ENTRY precede its specification, the specification
1109 (*result
)->ns
= gfc_current_ns
;
1111 gfc_find_sym_tree (name
, gfc_current_ns
, 0, &st
);
1112 st
->n
.sym
= *result
;
1113 st
= gfc_get_unique_symtree (gfc_current_ns
);
1119 rc
= gfc_get_symbol (name
, gfc_current_ns
->parent
, result
);
1125 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
1128 if (sym
->attr
.module_procedure
1129 && sym
->attr
.if_source
== IFSRC_IFBODY
)
1131 /* Create a partially populated interface symbol to carry the
1132 characteristics of the procedure and the result. */
1133 sym
->tlink
= gfc_new_symbol (name
, sym
->ns
);
1134 gfc_add_type (sym
->tlink
, &(sym
->ts
),
1135 &gfc_current_locus
);
1136 gfc_copy_attr (&sym
->tlink
->attr
, &sym
->attr
, NULL
);
1137 if (sym
->attr
.dimension
)
1138 sym
->tlink
->as
= gfc_copy_array_spec (sym
->as
);
1140 /* Ideally, at this point, a copy would be made of the formal
1141 arguments and their namespace. However, this does not appear
1142 to be necessary, albeit at the expense of not being able to
1143 use gfc_compare_interfaces directly. */
1145 if (sym
->result
&& sym
->result
!= sym
)
1147 sym
->tlink
->result
= sym
->result
;
1150 else if (sym
->result
)
1152 sym
->tlink
->result
= sym
->tlink
;
1155 else if (sym
&& !sym
->gfc_new
1156 && gfc_current_state () != COMP_INTERFACE
)
1158 /* Trap another encompassed procedure with the same name. All
1159 these conditions are necessary to avoid picking up an entry
1160 whose name clashes with that of the encompassing procedure;
1161 this is handled using gsymbols to register unique, globally
1162 accessible names. */
1163 if (sym
->attr
.flavor
!= 0
1164 && sym
->attr
.proc
!= 0
1165 && (sym
->attr
.subroutine
|| sym
->attr
.function
)
1166 && sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
1167 gfc_error_now ("Procedure %qs at %C is already defined at %L",
1168 name
, &sym
->declared_at
);
1170 /* Trap a procedure with a name the same as interface in the
1171 encompassing scope. */
1172 if (sym
->attr
.generic
!= 0
1173 && (sym
->attr
.subroutine
|| sym
->attr
.function
)
1174 && !sym
->attr
.mod_proc
)
1175 gfc_error_now ("Name %qs at %C is already defined"
1176 " as a generic interface at %L",
1177 name
, &sym
->declared_at
);
1179 /* Trap declarations of attributes in encompassing scope. The
1180 signature for this is that ts.kind is set. Legitimate
1181 references only set ts.type. */
1182 if (sym
->ts
.kind
!= 0
1183 && !sym
->attr
.implicit_type
1184 && sym
->attr
.proc
== 0
1185 && gfc_current_ns
->parent
!= NULL
1186 && sym
->attr
.access
== 0
1187 && !module_fcn_entry
)
1188 gfc_error_now ("Procedure %qs at %C has an explicit interface "
1189 "and must not have attributes declared at %L",
1190 name
, &sym
->declared_at
);
1193 if (gfc_current_ns
->parent
== NULL
|| *result
== NULL
)
1196 /* Module function entries will already have a symtree in
1197 the current namespace but will need one at module level. */
1198 if (module_fcn_entry
)
1200 /* Present if entry is declared to be a module procedure. */
1201 rc
= gfc_find_sym_tree (name
, gfc_current_ns
->parent
, 0, &st
);
1203 st
= gfc_new_symtree (&gfc_current_ns
->parent
->sym_root
, name
);
1206 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, name
);
1211 /* See if the procedure should be a module procedure. */
1213 if (((sym
->ns
->proc_name
!= NULL
1214 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
1215 && sym
->attr
.proc
!= PROC_MODULE
)
1216 || (module_fcn_entry
&& sym
->attr
.proc
!= PROC_MODULE
))
1217 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
1224 /* Verify that the given symbol representing a parameter is C
1225 interoperable, by checking to see if it was marked as such after
1226 its declaration. If the given symbol is not interoperable, a
1227 warning is reported, thus removing the need to return the status to
1228 the calling function. The standard does not require the user use
1229 one of the iso_c_binding named constants to declare an
1230 interoperable parameter, but we can't be sure if the param is C
1231 interop or not if the user doesn't. For example, integer(4) may be
1232 legal Fortran, but doesn't have meaning in C. It may interop with
1233 a number of the C types, which causes a problem because the
1234 compiler can't know which one. This code is almost certainly not
1235 portable, and the user will get what they deserve if the C type
1236 across platforms isn't always interoperable with integer(4). If
1237 the user had used something like integer(c_int) or integer(c_long),
1238 the compiler could have automatically handled the varying sizes
1239 across platforms. */
1242 gfc_verify_c_interop_param (gfc_symbol
*sym
)
1244 int is_c_interop
= 0;
1247 /* We check implicitly typed variables in symbol.c:gfc_set_default_type().
1248 Don't repeat the checks here. */
1249 if (sym
->attr
.implicit_type
)
1252 /* For subroutines or functions that are passed to a BIND(C) procedure,
1253 they're interoperable if they're BIND(C) and their params are all
1255 if (sym
->attr
.flavor
== FL_PROCEDURE
)
1257 if (sym
->attr
.is_bind_c
== 0)
1259 gfc_error_now ("Procedure %qs at %L must have the BIND(C) "
1260 "attribute to be C interoperable", sym
->name
,
1261 &(sym
->declared_at
));
1266 if (sym
->attr
.is_c_interop
== 1)
1267 /* We've already checked this procedure; don't check it again. */
1270 return verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
1275 /* See if we've stored a reference to a procedure that owns sym. */
1276 if (sym
->ns
!= NULL
&& sym
->ns
->proc_name
!= NULL
)
1278 if (sym
->ns
->proc_name
->attr
.is_bind_c
== 1)
1280 is_c_interop
= (gfc_verify_c_interop(&(sym
->ts
)) ? 1 : 0);
1282 if (is_c_interop
!= 1)
1284 /* Make personalized messages to give better feedback. */
1285 if (sym
->ts
.type
== BT_DERIVED
)
1286 gfc_error ("Variable %qs at %L is a dummy argument to the "
1287 "BIND(C) procedure %qs but is not C interoperable "
1288 "because derived type %qs is not C interoperable",
1289 sym
->name
, &(sym
->declared_at
),
1290 sym
->ns
->proc_name
->name
,
1291 sym
->ts
.u
.derived
->name
);
1292 else if (sym
->ts
.type
== BT_CLASS
)
1293 gfc_error ("Variable %qs at %L is a dummy argument to the "
1294 "BIND(C) procedure %qs but is not C interoperable "
1295 "because it is polymorphic",
1296 sym
->name
, &(sym
->declared_at
),
1297 sym
->ns
->proc_name
->name
);
1298 else if (warn_c_binding_type
)
1299 gfc_warning (OPT_Wc_binding_type
,
1300 "Variable %qs at %L is a dummy argument of the "
1301 "BIND(C) procedure %qs but may not be C "
1303 sym
->name
, &(sym
->declared_at
),
1304 sym
->ns
->proc_name
->name
);
1307 /* Character strings are only C interoperable if they have a
1309 if (sym
->ts
.type
== BT_CHARACTER
)
1311 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
1312 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
1313 || mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
1315 gfc_error ("Character argument %qs at %L "
1316 "must be length 1 because "
1317 "procedure %qs is BIND(C)",
1318 sym
->name
, &sym
->declared_at
,
1319 sym
->ns
->proc_name
->name
);
1324 /* We have to make sure that any param to a bind(c) routine does
1325 not have the allocatable, pointer, or optional attributes,
1326 according to J3/04-007, section 5.1. */
1327 if (sym
->attr
.allocatable
== 1
1328 && !gfc_notify_std (GFC_STD_F2008_TS
, "Variable %qs at %L with "
1329 "ALLOCATABLE attribute in procedure %qs "
1330 "with BIND(C)", sym
->name
,
1331 &(sym
->declared_at
),
1332 sym
->ns
->proc_name
->name
))
1335 if (sym
->attr
.pointer
== 1
1336 && !gfc_notify_std (GFC_STD_F2008_TS
, "Variable %qs at %L with "
1337 "POINTER attribute in procedure %qs "
1338 "with BIND(C)", sym
->name
,
1339 &(sym
->declared_at
),
1340 sym
->ns
->proc_name
->name
))
1343 if ((sym
->attr
.allocatable
|| sym
->attr
.pointer
) && !sym
->as
)
1345 gfc_error ("Scalar variable %qs at %L with POINTER or "
1346 "ALLOCATABLE in procedure %qs with BIND(C) is not yet"
1347 " supported", sym
->name
, &(sym
->declared_at
),
1348 sym
->ns
->proc_name
->name
);
1352 if (sym
->attr
.optional
== 1 && sym
->attr
.value
)
1354 gfc_error ("Variable %qs at %L cannot have both the OPTIONAL "
1355 "and the VALUE attribute because procedure %qs "
1356 "is BIND(C)", sym
->name
, &(sym
->declared_at
),
1357 sym
->ns
->proc_name
->name
);
1360 else if (sym
->attr
.optional
== 1
1361 && !gfc_notify_std (GFC_STD_F2008_TS
, "Variable %qs "
1362 "at %L with OPTIONAL attribute in "
1363 "procedure %qs which is BIND(C)",
1364 sym
->name
, &(sym
->declared_at
),
1365 sym
->ns
->proc_name
->name
))
1368 /* Make sure that if it has the dimension attribute, that it is
1369 either assumed size or explicit shape. Deferred shape is already
1370 covered by the pointer/allocatable attribute. */
1371 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SHAPE
1372 && !gfc_notify_std (GFC_STD_F2008_TS
, "Assumed-shape array %qs "
1373 "at %L as dummy argument to the BIND(C) "
1374 "procedure %qs at %L", sym
->name
,
1375 &(sym
->declared_at
),
1376 sym
->ns
->proc_name
->name
,
1377 &(sym
->ns
->proc_name
->declared_at
)))
1387 /* Function called by variable_decl() that adds a name to the symbol table. */
1390 build_sym (const char *name
, gfc_charlen
*cl
, bool cl_deferred
,
1391 gfc_array_spec
**as
, locus
*var_locus
)
1393 symbol_attribute attr
;
1398 /* Symbols in a submodule are host associated from the parent module or
1399 submodules. Therefore, they can be overridden by declarations in the
1400 submodule scope. Deal with this by attaching the existing symbol to
1401 a new symtree and recycling the old symtree with a new symbol... */
1402 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
1403 if (st
!= NULL
&& gfc_state_stack
->state
== COMP_SUBMODULE
1404 && st
->n
.sym
!= NULL
1405 && st
->n
.sym
->attr
.host_assoc
&& st
->n
.sym
->attr
.used_in_submodule
)
1407 gfc_symtree
*s
= gfc_get_unique_symtree (gfc_current_ns
);
1408 s
->n
.sym
= st
->n
.sym
;
1409 sym
= gfc_new_symbol (name
, gfc_current_ns
);
1414 gfc_set_sym_referenced (sym
);
1416 /* ...Otherwise generate a new symtree and new symbol. */
1417 else if (gfc_get_symbol (name
, NULL
, &sym
))
1420 /* Check if the name has already been defined as a type. The
1421 first letter of the symtree will be in upper case then. Of
1422 course, this is only necessary if the upper case letter is
1423 actually different. */
1425 upper
= TOUPPER(name
[0]);
1426 if (upper
!= name
[0])
1428 char u_name
[GFC_MAX_SYMBOL_LEN
+ 1];
1432 nlen
= strlen(name
);
1433 gcc_assert (nlen
<= GFC_MAX_SYMBOL_LEN
);
1434 strncpy (u_name
, name
, nlen
+ 1);
1437 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, u_name
);
1439 /* STRUCTURE types can alias symbol names */
1440 if (st
!= 0 && st
->n
.sym
->attr
.flavor
!= FL_STRUCT
)
1442 gfc_error ("Symbol %qs at %C also declared as a type at %L", name
,
1443 &st
->n
.sym
->declared_at
);
1448 /* Start updating the symbol table. Add basic type attribute if present. */
1449 if (current_ts
.type
!= BT_UNKNOWN
1450 && (sym
->attr
.implicit_type
== 0
1451 || !gfc_compare_types (&sym
->ts
, ¤t_ts
))
1452 && !gfc_add_type (sym
, ¤t_ts
, var_locus
))
1455 if (sym
->ts
.type
== BT_CHARACTER
)
1458 sym
->ts
.deferred
= cl_deferred
;
1461 /* Add dimension attribute if present. */
1462 if (!gfc_set_array_spec (sym
, *as
, var_locus
))
1466 /* Add attribute to symbol. The copy is so that we can reset the
1467 dimension attribute. */
1468 attr
= current_attr
;
1470 attr
.codimension
= 0;
1472 if (!gfc_copy_attr (&sym
->attr
, &attr
, var_locus
))
1475 /* Finish any work that may need to be done for the binding label,
1476 if it's a bind(c). The bind(c) attr is found before the symbol
1477 is made, and before the symbol name (for data decls), so the
1478 current_ts is holding the binding label, or nothing if the
1479 name= attr wasn't given. Therefore, test here if we're dealing
1480 with a bind(c) and make sure the binding label is set correctly. */
1481 if (sym
->attr
.is_bind_c
== 1)
1483 if (!sym
->binding_label
)
1485 /* Set the binding label and verify that if a NAME= was specified
1486 then only one identifier was in the entity-decl-list. */
1487 if (!set_binding_label (&sym
->binding_label
, sym
->name
,
1488 num_idents_on_line
))
1493 /* See if we know we're in a common block, and if it's a bind(c)
1494 common then we need to make sure we're an interoperable type. */
1495 if (sym
->attr
.in_common
== 1)
1497 /* Test the common block object. */
1498 if (sym
->common_block
!= NULL
&& sym
->common_block
->is_bind_c
== 1
1499 && sym
->ts
.is_c_interop
!= 1)
1501 gfc_error_now ("Variable %qs in common block %qs at %C "
1502 "must be declared with a C interoperable "
1503 "kind since common block %qs is BIND(C)",
1504 sym
->name
, sym
->common_block
->name
,
1505 sym
->common_block
->name
);
1510 sym
->attr
.implied_index
= 0;
1512 /* Use the parameter expressions for a parameterized derived type. */
1513 if ((sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
1514 && sym
->ts
.u
.derived
->attr
.pdt_type
&& type_param_spec_list
)
1515 sym
->param_list
= gfc_copy_actual_arglist (type_param_spec_list
);
1517 if (sym
->ts
.type
== BT_CLASS
)
1518 return gfc_build_class_symbol (&sym
->ts
, &sym
->attr
, &sym
->as
);
1524 /* Set character constant to the given length. The constant will be padded or
1525 truncated. If we're inside an array constructor without a typespec, we
1526 additionally check that all elements have the same length; check_len -1
1527 means no checking. */
1530 gfc_set_constant_character_len (int len
, gfc_expr
*expr
, int check_len
)
1535 if (expr
->ts
.type
!= BT_CHARACTER
)
1538 if (expr
->expr_type
!= EXPR_CONSTANT
)
1540 gfc_error_now ("CHARACTER length must be a constant at %L", &expr
->where
);
1544 slen
= expr
->value
.character
.length
;
1547 s
= gfc_get_wide_string (len
+ 1);
1548 memcpy (s
, expr
->value
.character
.string
,
1549 MIN (len
, slen
) * sizeof (gfc_char_t
));
1551 gfc_wide_memset (&s
[slen
], ' ', len
- slen
);
1553 if (warn_character_truncation
&& slen
> len
)
1554 gfc_warning_now (OPT_Wcharacter_truncation
,
1555 "CHARACTER expression at %L is being truncated "
1556 "(%d/%d)", &expr
->where
, slen
, len
);
1558 /* Apply the standard by 'hand' otherwise it gets cleared for
1560 if (check_len
!= -1 && slen
!= check_len
1561 && !(gfc_option
.allow_std
& GFC_STD_GNU
))
1562 gfc_error_now ("The CHARACTER elements of the array constructor "
1563 "at %L must have the same length (%d/%d)",
1564 &expr
->where
, slen
, check_len
);
1567 free (expr
->value
.character
.string
);
1568 expr
->value
.character
.string
= s
;
1569 expr
->value
.character
.length
= len
;
1574 /* Function to create and update the enumerator history
1575 using the information passed as arguments.
1576 Pointer "max_enum" is also updated, to point to
1577 enum history node containing largest initializer.
1579 SYM points to the symbol node of enumerator.
1580 INIT points to its enumerator value. */
1583 create_enum_history (gfc_symbol
*sym
, gfc_expr
*init
)
1585 enumerator_history
*new_enum_history
;
1586 gcc_assert (sym
!= NULL
&& init
!= NULL
);
1588 new_enum_history
= XCNEW (enumerator_history
);
1590 new_enum_history
->sym
= sym
;
1591 new_enum_history
->initializer
= init
;
1592 new_enum_history
->next
= NULL
;
1594 if (enum_history
== NULL
)
1596 enum_history
= new_enum_history
;
1597 max_enum
= enum_history
;
1601 new_enum_history
->next
= enum_history
;
1602 enum_history
= new_enum_history
;
1604 if (mpz_cmp (max_enum
->initializer
->value
.integer
,
1605 new_enum_history
->initializer
->value
.integer
) < 0)
1606 max_enum
= new_enum_history
;
1611 /* Function to free enum kind history. */
1614 gfc_free_enum_history (void)
1616 enumerator_history
*current
= enum_history
;
1617 enumerator_history
*next
;
1619 while (current
!= NULL
)
1621 next
= current
->next
;
1626 enum_history
= NULL
;
1630 /* Function called by variable_decl() that adds an initialization
1631 expression to a symbol. */
1634 add_init_expr_to_sym (const char *name
, gfc_expr
**initp
, locus
*var_locus
)
1636 symbol_attribute attr
;
1641 if (find_special (name
, &sym
, false))
1646 /* If this symbol is confirming an implicit parameter type,
1647 then an initialization expression is not allowed. */
1648 if (attr
.flavor
== FL_PARAMETER
1649 && sym
->value
!= NULL
1652 gfc_error ("Initializer not allowed for PARAMETER %qs at %C",
1659 /* An initializer is required for PARAMETER declarations. */
1660 if (attr
.flavor
== FL_PARAMETER
)
1662 gfc_error ("PARAMETER at %L is missing an initializer", var_locus
);
1668 /* If a variable appears in a DATA block, it cannot have an
1672 gfc_error ("Variable %qs at %C with an initializer already "
1673 "appears in a DATA statement", sym
->name
);
1677 /* Check if the assignment can happen. This has to be put off
1678 until later for derived type variables and procedure pointers. */
1679 if (!gfc_bt_struct (sym
->ts
.type
) && !gfc_bt_struct (init
->ts
.type
)
1680 && sym
->ts
.type
!= BT_CLASS
&& init
->ts
.type
!= BT_CLASS
1681 && !sym
->attr
.proc_pointer
1682 && !gfc_check_assign_symbol (sym
, NULL
, init
))
1685 if (sym
->ts
.type
== BT_CHARACTER
&& sym
->ts
.u
.cl
1686 && init
->ts
.type
== BT_CHARACTER
)
1688 /* Update symbol character length according initializer. */
1689 if (!gfc_check_assign_symbol (sym
, NULL
, init
))
1692 if (sym
->ts
.u
.cl
->length
== NULL
)
1695 /* If there are multiple CHARACTER variables declared on the
1696 same line, we don't want them to share the same length. */
1697 sym
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1699 if (sym
->attr
.flavor
== FL_PARAMETER
)
1701 if (init
->expr_type
== EXPR_CONSTANT
)
1703 clen
= init
->value
.character
.length
;
1704 sym
->ts
.u
.cl
->length
1705 = gfc_get_int_expr (gfc_default_integer_kind
,
1708 else if (init
->expr_type
== EXPR_ARRAY
)
1712 const gfc_expr
*length
= init
->ts
.u
.cl
->length
;
1713 if (length
->expr_type
!= EXPR_CONSTANT
)
1715 gfc_error ("Cannot initialize parameter array "
1717 "with variable length elements",
1721 clen
= mpz_get_si (length
->value
.integer
);
1723 else if (init
->value
.constructor
)
1726 c
= gfc_constructor_first (init
->value
.constructor
);
1727 clen
= c
->expr
->value
.character
.length
;
1731 sym
->ts
.u
.cl
->length
1732 = gfc_get_int_expr (gfc_default_integer_kind
,
1735 else if (init
->ts
.u
.cl
&& init
->ts
.u
.cl
->length
)
1736 sym
->ts
.u
.cl
->length
=
1737 gfc_copy_expr (sym
->value
->ts
.u
.cl
->length
);
1740 /* Update initializer character length according symbol. */
1741 else if (sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1745 if (!gfc_specification_expr (sym
->ts
.u
.cl
->length
))
1748 len
= mpz_get_si (sym
->ts
.u
.cl
->length
->value
.integer
);
1750 if (init
->expr_type
== EXPR_CONSTANT
)
1751 gfc_set_constant_character_len (len
, init
, -1);
1752 else if (init
->expr_type
== EXPR_ARRAY
)
1756 /* Build a new charlen to prevent simplification from
1757 deleting the length before it is resolved. */
1758 init
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1759 init
->ts
.u
.cl
->length
= gfc_copy_expr (sym
->ts
.u
.cl
->length
);
1761 for (c
= gfc_constructor_first (init
->value
.constructor
);
1762 c
; c
= gfc_constructor_next (c
))
1763 gfc_set_constant_character_len (len
, c
->expr
, -1);
1768 /* If sym is implied-shape, set its upper bounds from init. */
1769 if (sym
->attr
.flavor
== FL_PARAMETER
&& sym
->attr
.dimension
1770 && sym
->as
->type
== AS_IMPLIED_SHAPE
)
1774 if (init
->rank
== 0)
1776 gfc_error ("Can't initialize implied-shape array at %L"
1777 " with scalar", &sym
->declared_at
);
1781 /* Shape should be present, we get an initialization expression. */
1782 gcc_assert (init
->shape
);
1784 for (dim
= 0; dim
< sym
->as
->rank
; ++dim
)
1787 gfc_expr
*e
, *lower
;
1789 lower
= sym
->as
->lower
[dim
];
1791 /* If the lower bound is an array element from another
1792 parameterized array, then it is marked with EXPR_VARIABLE and
1793 is an initialization expression. Try to reduce it. */
1794 if (lower
->expr_type
== EXPR_VARIABLE
)
1795 gfc_reduce_init_expr (lower
);
1797 if (lower
->expr_type
== EXPR_CONSTANT
)
1799 /* All dimensions must be without upper bound. */
1800 gcc_assert (!sym
->as
->upper
[dim
]);
1803 e
= gfc_get_constant_expr (BT_INTEGER
, k
, &sym
->declared_at
);
1804 mpz_add (e
->value
.integer
, lower
->value
.integer
,
1806 mpz_sub_ui (e
->value
.integer
, e
->value
.integer
, 1);
1807 sym
->as
->upper
[dim
] = e
;
1811 gfc_error ("Non-constant lower bound in implied-shape"
1812 " declaration at %L", &lower
->where
);
1817 sym
->as
->type
= AS_EXPLICIT
;
1820 /* Need to check if the expression we initialized this
1821 to was one of the iso_c_binding named constants. If so,
1822 and we're a parameter (constant), let it be iso_c.
1824 integer(c_int), parameter :: my_int = c_int
1825 integer(my_int) :: my_int_2
1826 If we mark my_int as iso_c (since we can see it's value
1827 is equal to one of the named constants), then my_int_2
1828 will be considered C interoperable. */
1829 if (sym
->ts
.type
!= BT_CHARACTER
&& !gfc_bt_struct (sym
->ts
.type
))
1831 sym
->ts
.is_iso_c
|= init
->ts
.is_iso_c
;
1832 sym
->ts
.is_c_interop
|= init
->ts
.is_c_interop
;
1833 /* attr bits needed for module files. */
1834 sym
->attr
.is_iso_c
|= init
->ts
.is_iso_c
;
1835 sym
->attr
.is_c_interop
|= init
->ts
.is_c_interop
;
1836 if (init
->ts
.is_iso_c
)
1837 sym
->ts
.f90_type
= init
->ts
.f90_type
;
1840 /* Add initializer. Make sure we keep the ranks sane. */
1841 if (sym
->attr
.dimension
&& init
->rank
== 0)
1846 if (sym
->attr
.flavor
== FL_PARAMETER
1847 && init
->expr_type
== EXPR_CONSTANT
1848 && spec_size (sym
->as
, &size
)
1849 && mpz_cmp_si (size
, 0) > 0)
1851 array
= gfc_get_array_expr (init
->ts
.type
, init
->ts
.kind
,
1853 for (n
= 0; n
< (int)mpz_get_si (size
); n
++)
1854 gfc_constructor_append_expr (&array
->value
.constructor
,
1857 : gfc_copy_expr (init
),
1860 array
->shape
= gfc_get_shape (sym
->as
->rank
);
1861 for (n
= 0; n
< sym
->as
->rank
; n
++)
1862 spec_dimen_size (sym
->as
, n
, &array
->shape
[n
]);
1867 init
->rank
= sym
->as
->rank
;
1871 if (sym
->attr
.save
== SAVE_NONE
)
1872 sym
->attr
.save
= SAVE_IMPLICIT
;
1880 /* Function called by variable_decl() that adds a name to a structure
1884 build_struct (const char *name
, gfc_charlen
*cl
, gfc_expr
**init
,
1885 gfc_array_spec
**as
)
1890 /* F03:C438/C439. If the current symbol is of the same derived type that we're
1891 constructing, it must have the pointer attribute. */
1892 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
1893 && current_ts
.u
.derived
== gfc_current_block ()
1894 && current_attr
.pointer
== 0)
1896 if (current_attr
.allocatable
1897 && !gfc_notify_std(GFC_STD_F2008
, "Component at %C "
1898 "must have the POINTER attribute"))
1902 else if (current_attr
.allocatable
== 0)
1904 gfc_error ("Component at %C must have the POINTER attribute");
1910 if (current_ts
.type
== BT_CLASS
1911 && !(current_attr
.pointer
|| current_attr
.allocatable
))
1913 gfc_error ("Component %qs with CLASS at %C must be allocatable "
1914 "or pointer", name
);
1918 if (gfc_current_block ()->attr
.pointer
&& (*as
)->rank
!= 0)
1920 if ((*as
)->type
!= AS_DEFERRED
&& (*as
)->type
!= AS_EXPLICIT
)
1922 gfc_error ("Array component of structure at %C must have explicit "
1923 "or deferred shape");
1928 /* If we are in a nested union/map definition, gfc_add_component will not
1929 properly find repeated components because:
1930 (i) gfc_add_component does a flat search, where components of unions
1931 and maps are implicity chained so nested components may conflict.
1932 (ii) Unions and maps are not linked as components of their parent
1933 structures until after they are parsed.
1934 For (i) we use gfc_find_component which searches recursively, and for (ii)
1935 we search each block directly from the parse stack until we find the top
1938 s
= gfc_state_stack
;
1939 if (s
->state
== COMP_UNION
|| s
->state
== COMP_MAP
)
1941 while (s
->state
== COMP_UNION
|| gfc_comp_struct (s
->state
))
1943 c
= gfc_find_component (s
->sym
, name
, true, true, NULL
);
1946 gfc_error_now ("Component %qs at %C already declared at %L",
1950 /* Break after we've searched the entire chain. */
1951 if (s
->state
== COMP_DERIVED
|| s
->state
== COMP_STRUCTURE
)
1957 if (!gfc_add_component (gfc_current_block(), name
, &c
))
1961 if (c
->ts
.type
== BT_CHARACTER
)
1964 if (c
->ts
.type
!= BT_CLASS
&& c
->ts
.type
!= BT_DERIVED
1965 && c
->ts
.kind
== 0 && saved_kind_expr
!= NULL
)
1966 c
->kind_expr
= gfc_copy_expr (saved_kind_expr
);
1968 c
->attr
= current_attr
;
1970 c
->initializer
= *init
;
1977 c
->attr
.codimension
= 1;
1979 c
->attr
.dimension
= 1;
1983 gfc_apply_init (&c
->ts
, &c
->attr
, c
->initializer
);
1985 /* Check array components. */
1986 if (!c
->attr
.dimension
)
1989 if (c
->attr
.pointer
)
1991 if (c
->as
->type
!= AS_DEFERRED
)
1993 gfc_error ("Pointer array component of structure at %C must have a "
1998 else if (c
->attr
.allocatable
)
2000 if (c
->as
->type
!= AS_DEFERRED
)
2002 gfc_error ("Allocatable component of structure at %C must have a "
2009 if (c
->as
->type
!= AS_EXPLICIT
)
2011 gfc_error ("Array component of structure at %C must have an "
2018 if (c
->ts
.type
== BT_CLASS
)
2019 return gfc_build_class_symbol (&c
->ts
, &c
->attr
, &c
->as
);
2021 if (c
->attr
.pdt_kind
|| c
->attr
.pdt_len
)
2024 gfc_find_symbol (c
->name
, gfc_current_block ()->f2k_derived
,
2028 gfc_error ("Type parameter %qs at %C has no corresponding entry "
2029 "in the type parameter name list at %L",
2030 c
->name
, &gfc_current_block ()->declared_at
);
2034 sym
->attr
.pdt_kind
= c
->attr
.pdt_kind
;
2035 sym
->attr
.pdt_len
= c
->attr
.pdt_len
;
2037 sym
->value
= gfc_copy_expr (c
->initializer
);
2038 sym
->attr
.flavor
= FL_VARIABLE
;
2041 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
2042 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_template
2043 && decl_type_param_list
)
2044 c
->param_list
= gfc_copy_actual_arglist (decl_type_param_list
);
2050 /* Match a 'NULL()', and possibly take care of some side effects. */
2053 gfc_match_null (gfc_expr
**result
)
2056 match m
, m2
= MATCH_NO
;
2058 if ((m
= gfc_match (" null ( )")) == MATCH_ERROR
)
2064 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2066 if ((m2
= gfc_match (" null (")) != MATCH_YES
)
2069 old_loc
= gfc_current_locus
;
2070 if ((m2
= gfc_match (" %n ) ", name
)) == MATCH_ERROR
)
2073 && ((m2
= gfc_match (" mold = %n )", name
)) == MATCH_ERROR
))
2077 gfc_current_locus
= old_loc
;
2082 /* The NULL symbol now has to be/become an intrinsic function. */
2083 if (gfc_get_symbol ("null", NULL
, &sym
))
2085 gfc_error ("NULL() initialization at %C is ambiguous");
2089 gfc_intrinsic_symbol (sym
);
2091 if (sym
->attr
.proc
!= PROC_INTRINSIC
2092 && !(sym
->attr
.use_assoc
&& sym
->attr
.intrinsic
)
2093 && (!gfc_add_procedure(&sym
->attr
, PROC_INTRINSIC
, sym
->name
, NULL
)
2094 || !gfc_add_function (&sym
->attr
, sym
->name
, NULL
)))
2097 *result
= gfc_get_null_expr (&gfc_current_locus
);
2099 /* Invalid per F2008, C512. */
2100 if (m2
== MATCH_YES
)
2102 gfc_error ("NULL() initialization at %C may not have MOLD");
2110 /* Match the initialization expr for a data pointer or procedure pointer. */
2113 match_pointer_init (gfc_expr
**init
, int procptr
)
2117 if (gfc_pure (NULL
) && !gfc_comp_struct (gfc_state_stack
->state
))
2119 gfc_error ("Initialization of pointer at %C is not allowed in "
2120 "a PURE procedure");
2123 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
2125 /* Match NULL() initialization. */
2126 m
= gfc_match_null (init
);
2130 /* Match non-NULL initialization. */
2131 gfc_matching_ptr_assignment
= !procptr
;
2132 gfc_matching_procptr_assignment
= procptr
;
2133 m
= gfc_match_rvalue (init
);
2134 gfc_matching_ptr_assignment
= 0;
2135 gfc_matching_procptr_assignment
= 0;
2136 if (m
== MATCH_ERROR
)
2138 else if (m
== MATCH_NO
)
2140 gfc_error ("Error in pointer initialization at %C");
2144 if (!procptr
&& !gfc_resolve_expr (*init
))
2147 if (!gfc_notify_std (GFC_STD_F2008
, "non-NULL pointer "
2148 "initialization at %C"))
2156 check_function_name (char *name
)
2158 /* In functions that have a RESULT variable defined, the function name always
2159 refers to function calls. Therefore, the name is not allowed to appear in
2160 specification statements. When checking this, be careful about
2161 'hidden' procedure pointer results ('ppr@'). */
2163 if (gfc_current_state () == COMP_FUNCTION
)
2165 gfc_symbol
*block
= gfc_current_block ();
2166 if (block
&& block
->result
&& block
->result
!= block
2167 && strcmp (block
->result
->name
, "ppr@") != 0
2168 && strcmp (block
->name
, name
) == 0)
2170 gfc_error ("Function name %qs not allowed at %C", name
);
2179 /* Match a variable name with an optional initializer. When this
2180 subroutine is called, a variable is expected to be parsed next.
2181 Depending on what is happening at the moment, updates either the
2182 symbol table or the current interface. */
2185 variable_decl (int elem
)
2187 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2188 static unsigned int fill_id
= 0;
2189 gfc_expr
*initializer
, *char_len
;
2191 gfc_array_spec
*cp_as
; /* Extra copy for Cray Pointees. */
2203 /* When we get here, we've just matched a list of attributes and
2204 maybe a type and a double colon. The next thing we expect to see
2205 is the name of the symbol. */
2207 /* If we are parsing a structure with legacy support, we allow the symbol
2208 name to be '%FILL' which gives it an anonymous (inaccessible) name. */
2210 gfc_gobble_whitespace ();
2211 if (gfc_peek_ascii_char () == '%')
2213 gfc_next_ascii_char ();
2214 m
= gfc_match ("fill");
2219 m
= gfc_match_name (name
);
2227 if (gfc_current_state () != COMP_STRUCTURE
)
2229 if (flag_dec_structure
)
2230 gfc_error ("%qs not allowed outside STRUCTURE at %C", "%FILL");
2232 gfc_error ("%qs at %C is a DEC extension, enable with "
2233 "%<-fdec-structure%>", "%FILL");
2239 gfc_error ("%qs entity cannot have attributes at %C", "%FILL");
2243 /* %FILL components are given invalid fortran names. */
2244 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "%%FILL%u", fill_id
++);
2248 var_locus
= gfc_current_locus
;
2250 /* Now we could see the optional array spec. or character length. */
2251 m
= gfc_match_array_spec (&as
, true, true);
2252 if (m
== MATCH_ERROR
)
2256 as
= gfc_copy_array_spec (current_as
);
2258 && !merge_array_spec (current_as
, as
, true))
2264 if (flag_cray_pointer
)
2265 cp_as
= gfc_copy_array_spec (as
);
2267 /* At this point, we know for sure if the symbol is PARAMETER and can thus
2268 determine (and check) whether it can be implied-shape. If it
2269 was parsed as assumed-size, change it because PARAMETERs can not
2273 if (as
->type
== AS_IMPLIED_SHAPE
&& current_attr
.flavor
!= FL_PARAMETER
)
2276 gfc_error ("Non-PARAMETER symbol %qs at %L can't be implied-shape",
2281 if (as
->type
== AS_ASSUMED_SIZE
&& as
->rank
== 1
2282 && current_attr
.flavor
== FL_PARAMETER
)
2283 as
->type
= AS_IMPLIED_SHAPE
;
2285 if (as
->type
== AS_IMPLIED_SHAPE
2286 && !gfc_notify_std (GFC_STD_F2008
, "Implied-shape array at %L",
2296 cl_deferred
= false;
2298 if (current_ts
.type
== BT_CHARACTER
)
2300 switch (match_char_length (&char_len
, &cl_deferred
, false))
2303 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2305 cl
->length
= char_len
;
2308 /* Non-constant lengths need to be copied after the first
2309 element. Also copy assumed lengths. */
2312 && (current_ts
.u
.cl
->length
== NULL
2313 || current_ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
2315 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2316 cl
->length
= gfc_copy_expr (current_ts
.u
.cl
->length
);
2319 cl
= current_ts
.u
.cl
;
2321 cl_deferred
= current_ts
.deferred
;
2330 /* The dummy arguments and result of the abreviated form of MODULE
2331 PROCEDUREs, used in SUBMODULES should not be redefined. */
2332 if (gfc_current_ns
->proc_name
2333 && gfc_current_ns
->proc_name
->abr_modproc_decl
)
2335 gfc_find_symbol (name
, gfc_current_ns
, 1, &sym
);
2336 if (sym
!= NULL
&& (sym
->attr
.dummy
|| sym
->attr
.result
))
2339 gfc_error ("%qs at %C is a redefinition of the declaration "
2340 "in the corresponding interface for MODULE "
2341 "PROCEDURE %qs", sym
->name
,
2342 gfc_current_ns
->proc_name
->name
);
2347 /* %FILL components may not have initializers. */
2348 if (strncmp (name
, "%FILL", 5) == 0 && gfc_match_eos () != MATCH_YES
)
2350 gfc_error ("%qs entity cannot have an initializer at %C", "%FILL");
2355 /* If this symbol has already shown up in a Cray Pointer declaration,
2356 and this is not a component declaration,
2357 then we want to set the type & bail out. */
2358 if (flag_cray_pointer
&& !gfc_comp_struct (gfc_current_state ()))
2360 gfc_find_symbol (name
, gfc_current_ns
, 1, &sym
);
2361 if (sym
!= NULL
&& sym
->attr
.cray_pointee
)
2363 sym
->ts
.type
= current_ts
.type
;
2364 sym
->ts
.kind
= current_ts
.kind
;
2366 sym
->ts
.u
.derived
= current_ts
.u
.derived
;
2367 sym
->ts
.is_c_interop
= current_ts
.is_c_interop
;
2368 sym
->ts
.is_iso_c
= current_ts
.is_iso_c
;
2371 /* Check to see if we have an array specification. */
2374 if (sym
->as
!= NULL
)
2376 gfc_error ("Duplicate array spec for Cray pointee at %C");
2377 gfc_free_array_spec (cp_as
);
2383 if (!gfc_set_array_spec (sym
, cp_as
, &var_locus
))
2384 gfc_internal_error ("Couldn't set pointee array spec.");
2386 /* Fix the array spec. */
2387 m
= gfc_mod_pointee_as (sym
->as
);
2388 if (m
== MATCH_ERROR
)
2396 gfc_free_array_spec (cp_as
);
2400 /* Procedure pointer as function result. */
2401 if (gfc_current_state () == COMP_FUNCTION
2402 && strcmp ("ppr@", gfc_current_block ()->name
) == 0
2403 && strcmp (name
, gfc_current_block ()->ns
->proc_name
->name
) == 0)
2404 strcpy (name
, "ppr@");
2406 if (gfc_current_state () == COMP_FUNCTION
2407 && strcmp (name
, gfc_current_block ()->name
) == 0
2408 && gfc_current_block ()->result
2409 && strcmp ("ppr@", gfc_current_block ()->result
->name
) == 0)
2410 strcpy (name
, "ppr@");
2412 /* OK, we've successfully matched the declaration. Now put the
2413 symbol in the current namespace, because it might be used in the
2414 optional initialization expression for this symbol, e.g. this is
2417 integer, parameter :: i = huge(i)
2419 This is only true for parameters or variables of a basic type.
2420 For components of derived types, it is not true, so we don't
2421 create a symbol for those yet. If we fail to create the symbol,
2423 if (!gfc_comp_struct (gfc_current_state ())
2424 && !build_sym (name
, cl
, cl_deferred
, &as
, &var_locus
))
2430 if (!check_function_name (name
))
2436 /* We allow old-style initializations of the form
2437 integer i /2/, j(4) /3*3, 1/
2438 (if no colon has been seen). These are different from data
2439 statements in that initializers are only allowed to apply to the
2440 variable immediately preceding, i.e.
2442 is not allowed. Therefore we have to do some work manually, that
2443 could otherwise be left to the matchers for DATA statements. */
2445 if (!colon_seen
&& gfc_match (" /") == MATCH_YES
)
2447 if (!gfc_notify_std (GFC_STD_GNU
, "Old-style "
2448 "initialization at %C"))
2451 /* Allow old style initializations for components of STRUCTUREs and MAPs
2452 but not components of derived types. */
2453 else if (gfc_current_state () == COMP_DERIVED
)
2455 gfc_error ("Invalid old style initialization for derived type "
2461 /* For structure components, read the initializer as a special
2462 expression and let the rest of this function apply the initializer
2464 else if (gfc_comp_struct (gfc_current_state ()))
2466 m
= match_clist_expr (&initializer
, ¤t_ts
, as
);
2468 gfc_error ("Syntax error in old style initialization of %s at %C",
2474 /* Otherwise we treat the old style initialization just like a
2475 DATA declaration for the current variable. */
2477 return match_old_style_init (name
);
2480 /* The double colon must be present in order to have initializers.
2481 Otherwise the statement is ambiguous with an assignment statement. */
2484 if (gfc_match (" =>") == MATCH_YES
)
2486 if (!current_attr
.pointer
)
2488 gfc_error ("Initialization at %C isn't for a pointer variable");
2493 m
= match_pointer_init (&initializer
, 0);
2497 else if (gfc_match_char ('=') == MATCH_YES
)
2499 if (current_attr
.pointer
)
2501 gfc_error ("Pointer initialization at %C requires %<=>%>, "
2507 m
= gfc_match_init_expr (&initializer
);
2510 gfc_error ("Expected an initialization expression at %C");
2514 if (current_attr
.flavor
!= FL_PARAMETER
&& gfc_pure (NULL
)
2515 && !gfc_comp_struct (gfc_state_stack
->state
))
2517 gfc_error ("Initialization of variable at %C is not allowed in "
2518 "a PURE procedure");
2522 if (current_attr
.flavor
!= FL_PARAMETER
2523 && !gfc_comp_struct (gfc_state_stack
->state
))
2524 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
2531 if (initializer
!= NULL
&& current_attr
.allocatable
2532 && gfc_comp_struct (gfc_current_state ()))
2534 gfc_error ("Initialization of allocatable component at %C is not "
2540 if (gfc_current_state () == COMP_DERIVED
2541 && gfc_current_block ()->attr
.pdt_template
)
2544 gfc_find_symbol (name
, gfc_current_block ()->f2k_derived
,
2546 if (!param
&& (current_attr
.pdt_kind
|| current_attr
.pdt_len
))
2548 gfc_error ("The component with KIND or LEN attribute at %C does not "
2549 "not appear in the type parameter list at %L",
2550 &gfc_current_block ()->declared_at
);
2554 else if (param
&& !(current_attr
.pdt_kind
|| current_attr
.pdt_len
))
2556 gfc_error ("The component at %C that appears in the type parameter "
2557 "list at %L has neither the KIND nor LEN attribute",
2558 &gfc_current_block ()->declared_at
);
2562 else if (as
&& (current_attr
.pdt_kind
|| current_attr
.pdt_len
))
2564 gfc_error ("The component at %C which is a type parameter must be "
2569 else if (param
&& initializer
)
2570 param
->value
= gfc_copy_expr (initializer
);
2573 /* Add the initializer. Note that it is fine if initializer is
2574 NULL here, because we sometimes also need to check if a
2575 declaration *must* have an initialization expression. */
2576 if (!gfc_comp_struct (gfc_current_state ()))
2577 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
2580 if (current_ts
.type
== BT_DERIVED
2581 && !current_attr
.pointer
&& !initializer
)
2582 initializer
= gfc_default_initializer (¤t_ts
);
2583 t
= build_struct (name
, cl
, &initializer
, &as
);
2585 /* If we match a nested structure definition we expect to see the
2586 * body even if the variable declarations blow up, so we need to keep
2587 * the structure declaration around. */
2588 if (gfc_new_block
&& gfc_new_block
->attr
.flavor
== FL_STRUCT
)
2589 gfc_commit_symbol (gfc_new_block
);
2592 m
= (t
) ? MATCH_YES
: MATCH_ERROR
;
2595 /* Free stuff up and return. */
2596 gfc_free_expr (initializer
);
2597 gfc_free_array_spec (as
);
2603 /* Match an extended-f77 "TYPESPEC*bytesize"-style kind specification.
2604 This assumes that the byte size is equal to the kind number for
2605 non-COMPLEX types, and equal to twice the kind number for COMPLEX. */
2608 gfc_match_old_kind_spec (gfc_typespec
*ts
)
2613 if (gfc_match_char ('*') != MATCH_YES
)
2616 m
= gfc_match_small_literal_int (&ts
->kind
, NULL
);
2620 original_kind
= ts
->kind
;
2622 /* Massage the kind numbers for complex types. */
2623 if (ts
->type
== BT_COMPLEX
)
2627 gfc_error ("Old-style type declaration %s*%d not supported at %C",
2628 gfc_basic_typename (ts
->type
), original_kind
);
2635 if (ts
->type
== BT_INTEGER
&& ts
->kind
== 4 && flag_integer4_kind
== 8)
2638 if (ts
->type
== BT_REAL
|| ts
->type
== BT_COMPLEX
)
2642 if (flag_real4_kind
== 8)
2644 if (flag_real4_kind
== 10)
2646 if (flag_real4_kind
== 16)
2652 if (flag_real8_kind
== 4)
2654 if (flag_real8_kind
== 10)
2656 if (flag_real8_kind
== 16)
2661 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
2663 gfc_error ("Old-style type declaration %s*%d not supported at %C",
2664 gfc_basic_typename (ts
->type
), original_kind
);
2668 if (!gfc_notify_std (GFC_STD_GNU
,
2669 "Nonstandard type declaration %s*%d at %C",
2670 gfc_basic_typename(ts
->type
), original_kind
))
2677 /* Match a kind specification. Since kinds are generally optional, we
2678 usually return MATCH_NO if something goes wrong. If a "kind="
2679 string is found, then we know we have an error. */
2682 gfc_match_kind_spec (gfc_typespec
*ts
, bool kind_expr_only
)
2692 saved_kind_expr
= NULL
;
2694 where
= loc
= gfc_current_locus
;
2699 if (gfc_match_char ('(') == MATCH_NO
)
2702 /* Also gobbles optional text. */
2703 if (gfc_match (" kind = ") == MATCH_YES
)
2706 loc
= gfc_current_locus
;
2710 n
= gfc_match_init_expr (&e
);
2712 if (gfc_derived_parameter_expr (e
))
2715 saved_kind_expr
= gfc_copy_expr (e
);
2716 goto close_brackets
;
2721 if (gfc_matching_function
)
2723 /* The function kind expression might include use associated or
2724 imported parameters and try again after the specification
2726 if (gfc_match_char (')') != MATCH_YES
)
2728 gfc_error ("Missing right parenthesis at %C");
2734 gfc_undo_symbols ();
2739 /* ....or else, the match is real. */
2741 gfc_error ("Expected initialization expression at %C");
2749 gfc_error ("Expected scalar initialization expression at %C");
2754 if (gfc_extract_int (e
, &ts
->kind
, 1))
2760 /* Before throwing away the expression, let's see if we had a
2761 C interoperable kind (and store the fact). */
2762 if (e
->ts
.is_c_interop
== 1)
2764 /* Mark this as C interoperable if being declared with one
2765 of the named constants from iso_c_binding. */
2766 ts
->is_c_interop
= e
->ts
.is_iso_c
;
2767 ts
->f90_type
= e
->ts
.f90_type
;
2769 ts
->interop_kind
= e
->symtree
->n
.sym
;
2775 /* Ignore errors to this point, if we've gotten here. This means
2776 we ignore the m=MATCH_ERROR from above. */
2777 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
2779 gfc_error ("Kind %d not supported for type %s at %C", ts
->kind
,
2780 gfc_basic_typename (ts
->type
));
2781 gfc_current_locus
= where
;
2785 /* Warn if, e.g., c_int is used for a REAL variable, but not
2786 if, e.g., c_double is used for COMPLEX as the standard
2787 explicitly says that the kind type parameter for complex and real
2788 variable is the same, i.e. c_float == c_float_complex. */
2789 if (ts
->f90_type
!= BT_UNKNOWN
&& ts
->f90_type
!= ts
->type
2790 && !((ts
->f90_type
== BT_REAL
&& ts
->type
== BT_COMPLEX
)
2791 || (ts
->f90_type
== BT_COMPLEX
&& ts
->type
== BT_REAL
)))
2792 gfc_warning_now (0, "C kind type parameter is for type %s but type at %L "
2793 "is %s", gfc_basic_typename (ts
->f90_type
), &where
,
2794 gfc_basic_typename (ts
->type
));
2798 gfc_gobble_whitespace ();
2799 if ((c
= gfc_next_ascii_char ()) != ')'
2800 && (ts
->type
!= BT_CHARACTER
|| c
!= ','))
2802 if (ts
->type
== BT_CHARACTER
)
2803 gfc_error ("Missing right parenthesis or comma at %C");
2805 gfc_error ("Missing right parenthesis at %C");
2809 /* All tests passed. */
2812 if(m
== MATCH_ERROR
)
2813 gfc_current_locus
= where
;
2815 if (ts
->type
== BT_INTEGER
&& ts
->kind
== 4 && flag_integer4_kind
== 8)
2818 if (ts
->type
== BT_REAL
|| ts
->type
== BT_COMPLEX
)
2822 if (flag_real4_kind
== 8)
2824 if (flag_real4_kind
== 10)
2826 if (flag_real4_kind
== 16)
2832 if (flag_real8_kind
== 4)
2834 if (flag_real8_kind
== 10)
2836 if (flag_real8_kind
== 16)
2841 /* Return what we know from the test(s). */
2846 gfc_current_locus
= where
;
2852 match_char_kind (int * kind
, int * is_iso_c
)
2861 where
= gfc_current_locus
;
2863 n
= gfc_match_init_expr (&e
);
2865 if (n
!= MATCH_YES
&& gfc_matching_function
)
2867 /* The expression might include use-associated or imported
2868 parameters and try again after the specification
2871 gfc_undo_symbols ();
2876 gfc_error ("Expected initialization expression at %C");
2882 gfc_error ("Expected scalar initialization expression at %C");
2887 if (gfc_derived_parameter_expr (e
))
2889 saved_kind_expr
= e
;
2894 fail
= gfc_extract_int (e
, kind
, 1);
2895 *is_iso_c
= e
->ts
.is_iso_c
;
2904 /* Ignore errors to this point, if we've gotten here. This means
2905 we ignore the m=MATCH_ERROR from above. */
2906 if (gfc_validate_kind (BT_CHARACTER
, *kind
, true) < 0)
2908 gfc_error ("Kind %d is not supported for CHARACTER at %C", *kind
);
2912 /* All tests passed. */
2915 if (m
== MATCH_ERROR
)
2916 gfc_current_locus
= where
;
2918 /* Return what we know from the test(s). */
2923 gfc_current_locus
= where
;
2928 /* Match the various kind/length specifications in a CHARACTER
2929 declaration. We don't return MATCH_NO. */
2932 gfc_match_char_spec (gfc_typespec
*ts
)
2934 int kind
, seen_length
, is_iso_c
;
2946 /* Try the old-style specification first. */
2947 old_char_selector
= 0;
2949 m
= match_char_length (&len
, &deferred
, true);
2953 old_char_selector
= 1;
2958 m
= gfc_match_char ('(');
2961 m
= MATCH_YES
; /* Character without length is a single char. */
2965 /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ). */
2966 if (gfc_match (" kind =") == MATCH_YES
)
2968 m
= match_char_kind (&kind
, &is_iso_c
);
2970 if (m
== MATCH_ERROR
)
2975 if (gfc_match (" , len =") == MATCH_NO
)
2978 m
= char_len_param_value (&len
, &deferred
);
2981 if (m
== MATCH_ERROR
)
2988 /* Try to match "LEN = <len-param>" or "LEN = <len-param>, KIND = <int>". */
2989 if (gfc_match (" len =") == MATCH_YES
)
2991 m
= char_len_param_value (&len
, &deferred
);
2994 if (m
== MATCH_ERROR
)
2998 if (gfc_match_char (')') == MATCH_YES
)
3001 if (gfc_match (" , kind =") != MATCH_YES
)
3004 if (match_char_kind (&kind
, &is_iso_c
) == MATCH_ERROR
)
3010 /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ). */
3011 m
= char_len_param_value (&len
, &deferred
);
3014 if (m
== MATCH_ERROR
)
3018 m
= gfc_match_char (')');
3022 if (gfc_match_char (',') != MATCH_YES
)
3025 gfc_match (" kind ="); /* Gobble optional text. */
3027 m
= match_char_kind (&kind
, &is_iso_c
);
3028 if (m
== MATCH_ERROR
)
3034 /* Require a right-paren at this point. */
3035 m
= gfc_match_char (')');
3040 gfc_error ("Syntax error in CHARACTER declaration at %C");
3042 gfc_free_expr (len
);
3046 /* Deal with character functions after USE and IMPORT statements. */
3047 if (gfc_matching_function
)
3049 gfc_free_expr (len
);
3050 gfc_undo_symbols ();
3056 gfc_free_expr (len
);
3060 /* Do some final massaging of the length values. */
3061 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
3063 if (seen_length
== 0)
3064 cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
3069 ts
->kind
= kind
== 0 ? gfc_default_character_kind
: kind
;
3070 ts
->deferred
= deferred
;
3072 /* We have to know if it was a C interoperable kind so we can
3073 do accurate type checking of bind(c) procs, etc. */
3075 /* Mark this as C interoperable if being declared with one
3076 of the named constants from iso_c_binding. */
3077 ts
->is_c_interop
= is_iso_c
;
3078 else if (len
!= NULL
)
3079 /* Here, we might have parsed something such as: character(c_char)
3080 In this case, the parsing code above grabs the c_char when
3081 looking for the length (line 1690, roughly). it's the last
3082 testcase for parsing the kind params of a character variable.
3083 However, it's not actually the length. this seems like it
3085 To see if the user used a C interop kind, test the expr
3086 of the so called length, and see if it's C interoperable. */
3087 ts
->is_c_interop
= len
->ts
.is_iso_c
;
3093 /* Matches a RECORD declaration. */
3096 match_record_decl (char *name
)
3099 old_loc
= gfc_current_locus
;
3102 m
= gfc_match (" record /");
3105 if (!flag_dec_structure
)
3107 gfc_current_locus
= old_loc
;
3108 gfc_error ("RECORD at %C is an extension, enable it with "
3112 m
= gfc_match (" %n/", name
);
3117 gfc_current_locus
= old_loc
;
3118 if (flag_dec_structure
3119 && (gfc_match (" record% ") == MATCH_YES
3120 || gfc_match (" record%t") == MATCH_YES
))
3121 gfc_error ("Structure name expected after RECORD at %C");
3129 /* This function uses the gfc_actual_arglist 'type_param_spec_list' as a source
3130 of expressions to substitute into the possibly parameterized expression
3131 'e'. Using a list is inefficient but should not be too bad since the
3132 number of type parameters is not likely to be large. */
3134 insert_parameter_exprs (gfc_expr
* e
, gfc_symbol
* sym ATTRIBUTE_UNUSED
,
3137 gfc_actual_arglist
*param
;
3140 if (e
->expr_type
!= EXPR_VARIABLE
)
3143 gcc_assert (e
->symtree
);
3144 if (e
->symtree
->n
.sym
->attr
.pdt_kind
3145 || (*f
!= 0 && e
->symtree
->n
.sym
->attr
.pdt_len
))
3147 for (param
= type_param_spec_list
; param
; param
= param
->next
)
3148 if (strcmp (e
->symtree
->n
.sym
->name
, param
->name
) == 0)
3153 copy
= gfc_copy_expr (param
->expr
);
3164 gfc_insert_kind_parameter_exprs (gfc_expr
*e
)
3166 return gfc_traverse_expr (e
, NULL
, &insert_parameter_exprs
, 0);
3171 gfc_insert_parameter_exprs (gfc_expr
*e
, gfc_actual_arglist
*param_list
)
3173 gfc_actual_arglist
*old_param_spec_list
= type_param_spec_list
;
3174 type_param_spec_list
= param_list
;
3175 return gfc_traverse_expr (e
, NULL
, &insert_parameter_exprs
, 1);
3176 type_param_spec_list
= NULL
;
3177 type_param_spec_list
= old_param_spec_list
;
3180 /* Determines the instance of a parameterized derived type to be used by
3181 matching determining the values of the kind parameters and using them
3182 in the name of the instance. If the instance exists, it is used, otherwise
3183 a new derived type is created. */
3185 gfc_get_pdt_instance (gfc_actual_arglist
*param_list
, gfc_symbol
**sym
,
3186 gfc_actual_arglist
**ext_param_list
)
3188 /* The PDT template symbol. */
3189 gfc_symbol
*pdt
= *sym
;
3190 /* The symbol for the parameter in the template f2k_namespace. */
3192 /* The hoped for instance of the PDT. */
3193 gfc_symbol
*instance
;
3194 /* The list of parameters appearing in the PDT declaration. */
3195 gfc_formal_arglist
*type_param_name_list
;
3196 /* Used to store the parameter specification list during recursive calls. */
3197 gfc_actual_arglist
*old_param_spec_list
;
3198 /* Pointers to the parameter specification being used. */
3199 gfc_actual_arglist
*actual_param
;
3200 gfc_actual_arglist
*tail
= NULL
;
3201 /* Used to build up the name of the PDT instance. The prefix uses 4
3202 characters and each KIND parameter 2 more. Allow 8 of the latter. */
3203 char name
[GFC_MAX_SYMBOL_LEN
+ 21];
3205 bool name_seen
= (param_list
== NULL
);
3206 bool assumed_seen
= false;
3207 bool deferred_seen
= false;
3208 bool spec_error
= false;
3210 gfc_expr
*kind_expr
;
3211 gfc_component
*c1
, *c2
;
3214 type_param_spec_list
= NULL
;
3216 type_param_name_list
= pdt
->formal
;
3217 actual_param
= param_list
;
3218 sprintf (name
, "Pdt%s", pdt
->name
);
3220 /* Run through the parameter name list and pick up the actual
3221 parameter values or use the default values in the PDT declaration. */
3222 for (; type_param_name_list
;
3223 type_param_name_list
= type_param_name_list
->next
)
3225 if (actual_param
&& actual_param
->spec_type
!= SPEC_EXPLICIT
)
3227 if (actual_param
->spec_type
== SPEC_ASSUMED
)
3228 spec_error
= deferred_seen
;
3230 spec_error
= assumed_seen
;
3234 gfc_error ("The type parameter spec list at %C cannot contain "
3235 "both ASSUMED and DEFERRED parameters");
3240 if (actual_param
&& actual_param
->name
)
3242 param
= type_param_name_list
->sym
;
3244 c1
= gfc_find_component (pdt
, param
->name
, false, true, NULL
);
3245 if (!pdt
->attr
.use_assoc
&& !c1
)
3247 gfc_error ("The type parameter name list at %L contains a parameter "
3248 "'%qs' , which is not declared as a component of the type",
3249 &pdt
->declared_at
, param
->name
);
3256 if (!actual_param
&& !(c1
&& c1
->initializer
))
3258 gfc_error ("The type parameter spec list at %C does not contain "
3259 "enough parameter expressions");
3262 else if (!actual_param
&& c1
&& c1
->initializer
)
3263 kind_expr
= gfc_copy_expr (c1
->initializer
);
3264 else if (actual_param
&& actual_param
->spec_type
== SPEC_EXPLICIT
)
3265 kind_expr
= gfc_copy_expr (actual_param
->expr
);
3269 actual_param
= param_list
;
3270 for (;actual_param
; actual_param
= actual_param
->next
)
3271 if (actual_param
->name
3272 && strcmp (actual_param
->name
, param
->name
) == 0)
3274 if (actual_param
&& actual_param
->spec_type
== SPEC_EXPLICIT
)
3275 kind_expr
= gfc_copy_expr (actual_param
->expr
);
3278 if (c1
->initializer
)
3279 kind_expr
= gfc_copy_expr (c1
->initializer
);
3280 else if (!(actual_param
&& param
->attr
.pdt_len
))
3282 gfc_error ("The derived parameter '%qs' at %C does not "
3283 "have a default value", param
->name
);
3289 /* Store the current parameter expressions in a temporary actual
3290 arglist 'list' so that they can be substituted in the corresponding
3291 expressions in the PDT instance. */
3292 if (type_param_spec_list
== NULL
)
3294 type_param_spec_list
= gfc_get_actual_arglist ();
3295 tail
= type_param_spec_list
;
3299 tail
->next
= gfc_get_actual_arglist ();
3302 tail
->name
= param
->name
;
3306 /* Try simplification even for LEN expressions. */
3307 gfc_resolve_expr (kind_expr
);
3308 gfc_simplify_expr (kind_expr
, 1);
3309 /* Variable expressions seem to default to BT_PROCEDURE.
3310 TODO find out why this is and fix it. */
3311 if (kind_expr
->ts
.type
!= BT_INTEGER
3312 && kind_expr
->ts
.type
!= BT_PROCEDURE
)
3314 gfc_error ("The parameter expression at %C must be of "
3315 "INTEGER type and not %s type",
3316 gfc_basic_typename (kind_expr
->ts
.type
));
3320 tail
->expr
= gfc_copy_expr (kind_expr
);
3324 tail
->spec_type
= actual_param
->spec_type
;
3326 if (!param
->attr
.pdt_kind
)
3328 if (!name_seen
&& actual_param
)
3329 actual_param
= actual_param
->next
;
3332 gfc_free_expr (kind_expr
);
3339 && (actual_param
->spec_type
== SPEC_ASSUMED
3340 || actual_param
->spec_type
== SPEC_DEFERRED
))
3342 gfc_error ("The KIND parameter '%qs' at %C cannot either be "
3343 "ASSUMED or DEFERRED", param
->name
);
3347 if (!kind_expr
|| !gfc_is_constant_expr (kind_expr
))
3349 gfc_error ("The value for the KIND parameter '%qs' at %C does not "
3350 "reduce to a constant expression", param
->name
);
3354 gfc_extract_int (kind_expr
, &kind_value
);
3355 sprintf (name
, "%s_%d", name
, kind_value
);
3357 if (!name_seen
&& actual_param
)
3358 actual_param
= actual_param
->next
;
3359 gfc_free_expr (kind_expr
);
3362 if (!name_seen
&& actual_param
)
3364 gfc_error ("The type parameter spec list at %C contains too many "
3365 "parameter expressions");
3369 /* Now we search for the PDT instance 'name'. If it doesn't exist, we
3370 build it, using 'pdt' as a template. */
3371 if (gfc_get_symbol (name
, pdt
->ns
, &instance
))
3373 gfc_error ("Parameterized derived type at %C is ambiguous");
3379 if (instance
->attr
.flavor
== FL_DERIVED
3380 && instance
->attr
.pdt_type
)
3384 *ext_param_list
= type_param_spec_list
;
3386 gfc_commit_symbols ();
3390 /* Start building the new instance of the parameterized type. */
3391 gfc_copy_attr (&instance
->attr
, &pdt
->attr
, &pdt
->declared_at
);
3392 instance
->attr
.pdt_template
= 0;
3393 instance
->attr
.pdt_type
= 1;
3394 instance
->declared_at
= gfc_current_locus
;
3396 /* Add the components, replacing the parameters in all expressions
3397 with the expressions for their values in 'type_param_spec_list'. */
3398 c1
= pdt
->components
;
3399 tail
= type_param_spec_list
;
3400 for (; c1
; c1
= c1
->next
)
3402 gfc_add_component (instance
, c1
->name
, &c2
);
3404 c2
->attr
= c1
->attr
;
3406 /* Deal with type extension by recursively calling this function
3407 to obtain the instance of the extended type. */
3408 if (gfc_current_state () != COMP_DERIVED
3409 && c1
== pdt
->components
3410 && (c1
->ts
.type
== BT_DERIVED
|| c1
->ts
.type
== BT_CLASS
)
3411 && c1
->ts
.u
.derived
&& c1
->ts
.u
.derived
->attr
.pdt_template
3412 && gfc_get_derived_super_type (*sym
) == c2
->ts
.u
.derived
)
3414 gfc_formal_arglist
*f
;
3416 old_param_spec_list
= type_param_spec_list
;
3418 /* Obtain a spec list appropriate to the extended type..*/
3419 actual_param
= gfc_copy_actual_arglist (type_param_spec_list
);
3420 type_param_spec_list
= actual_param
;
3421 for (f
= c1
->ts
.u
.derived
->formal
; f
&& f
->next
; f
= f
->next
)
3422 actual_param
= actual_param
->next
;
3425 gfc_free_actual_arglist (actual_param
->next
);
3426 actual_param
->next
= NULL
;
3429 /* Now obtain the PDT instance for the extended type. */
3430 c2
->param_list
= type_param_spec_list
;
3431 m
= gfc_get_pdt_instance (type_param_spec_list
, &c2
->ts
.u
.derived
,
3433 type_param_spec_list
= old_param_spec_list
;
3435 c2
->ts
.u
.derived
->refs
++;
3436 gfc_set_sym_referenced (c2
->ts
.u
.derived
);
3438 /* Set extension level. */
3439 if (c2
->ts
.u
.derived
->attr
.extension
== 255)
3441 /* Since the extension field is 8 bit wide, we can only have
3442 up to 255 extension levels. */
3443 gfc_error ("Maximum extension level reached with type %qs at %L",
3444 c2
->ts
.u
.derived
->name
,
3445 &c2
->ts
.u
.derived
->declared_at
);
3448 instance
->attr
.extension
= c2
->ts
.u
.derived
->attr
.extension
+ 1;
3450 /* Advance the position in the spec list by the number of
3451 parameters in the extended type. */
3452 tail
= type_param_spec_list
;
3453 for (f
= c1
->ts
.u
.derived
->formal
; f
&& f
->next
; f
= f
->next
)
3459 /* Set the component kind using the parameterized expression. */
3460 if (c1
->ts
.kind
== 0 && c1
->kind_expr
!= NULL
)
3462 gfc_expr
*e
= gfc_copy_expr (c1
->kind_expr
);
3463 gfc_insert_kind_parameter_exprs (e
);
3464 gfc_simplify_expr (e
, 1);
3465 gfc_extract_int (e
, &c2
->ts
.kind
);
3467 if (gfc_validate_kind (c2
->ts
.type
, c2
->ts
.kind
, true) < 0)
3469 gfc_error ("Kind %d not supported for type %s at %C",
3470 c2
->ts
.kind
, gfc_basic_typename (c2
->ts
.type
));
3475 /* Similarly, set the string length if parameterized. */
3476 if (c1
->ts
.type
== BT_CHARACTER
3477 && c1
->ts
.u
.cl
->length
3478 && gfc_derived_parameter_expr (c1
->ts
.u
.cl
->length
))
3481 e
= gfc_copy_expr (c1
->ts
.u
.cl
->length
);
3482 gfc_insert_kind_parameter_exprs (e
);
3483 gfc_simplify_expr (e
, 1);
3484 c2
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
3485 c2
->ts
.u
.cl
->length
= e
;
3486 c2
->attr
.pdt_string
= 1;
3489 /* Set up either the KIND/LEN initializer, if constant,
3490 or the parameterized expression. Use the template
3491 initializer if one is not already set in this instance. */
3492 if (c2
->attr
.pdt_kind
|| c2
->attr
.pdt_len
)
3494 if (tail
&& tail
->expr
&& gfc_is_constant_expr (tail
->expr
))
3495 c2
->initializer
= gfc_copy_expr (tail
->expr
);
3496 else if (tail
&& tail
->expr
)
3498 c2
->param_list
= gfc_get_actual_arglist ();
3499 c2
->param_list
->name
= tail
->name
;
3500 c2
->param_list
->expr
= gfc_copy_expr (tail
->expr
);
3501 c2
->param_list
->next
= NULL
;
3504 if (!c2
->initializer
&& c1
->initializer
)
3505 c2
->initializer
= gfc_copy_expr (c1
->initializer
);
3510 /* Copy the array spec. */
3511 c2
->as
= gfc_copy_array_spec (c1
->as
);
3512 if (c1
->ts
.type
== BT_CLASS
)
3513 CLASS_DATA (c2
)->as
= gfc_copy_array_spec (CLASS_DATA (c1
)->as
);
3515 /* Determine if an array spec is parameterized. If so, substitute
3516 in the parameter expressions for the bounds and set the pdt_array
3517 attribute. Notice that this attribute must be unconditionally set
3518 if this is an array of parameterized character length. */
3519 if (c1
->as
&& c1
->as
->type
== AS_EXPLICIT
)
3521 bool pdt_array
= false;
3523 /* Are the bounds of the array parameterized? */
3524 for (i
= 0; i
< c1
->as
->rank
; i
++)
3526 if (gfc_derived_parameter_expr (c1
->as
->lower
[i
]))
3528 if (gfc_derived_parameter_expr (c1
->as
->upper
[i
]))
3532 /* If they are, free the expressions for the bounds and
3533 replace them with the template expressions with substitute
3535 for (i
= 0; pdt_array
&& i
< c1
->as
->rank
; i
++)
3538 e
= gfc_copy_expr (c1
->as
->lower
[i
]);
3539 gfc_insert_kind_parameter_exprs (e
);
3540 gfc_simplify_expr (e
, 1);
3541 gfc_free_expr (c2
->as
->lower
[i
]);
3542 c2
->as
->lower
[i
] = e
;
3543 e
= gfc_copy_expr (c1
->as
->upper
[i
]);
3544 gfc_insert_kind_parameter_exprs (e
);
3545 gfc_simplify_expr (e
, 1);
3546 gfc_free_expr (c2
->as
->upper
[i
]);
3547 c2
->as
->upper
[i
] = e
;
3549 c2
->attr
.pdt_array
= pdt_array
? 1 : c2
->attr
.pdt_string
;
3552 /* Recurse into this function for PDT components. */
3553 if ((c1
->ts
.type
== BT_DERIVED
|| c1
->ts
.type
== BT_CLASS
)
3554 && c1
->ts
.u
.derived
&& c1
->ts
.u
.derived
->attr
.pdt_template
)
3556 gfc_actual_arglist
*params
;
3557 /* The component in the template has a list of specification
3558 expressions derived from its declaration. */
3559 params
= gfc_copy_actual_arglist (c1
->param_list
);
3560 actual_param
= params
;
3561 /* Substitute the template parameters with the expressions
3562 from the specification list. */
3563 for (;actual_param
; actual_param
= actual_param
->next
)
3564 gfc_insert_parameter_exprs (actual_param
->expr
,
3565 type_param_spec_list
);
3567 /* Now obtain the PDT instance for the component. */
3568 old_param_spec_list
= type_param_spec_list
;
3569 m
= gfc_get_pdt_instance (params
, &c2
->ts
.u
.derived
, NULL
);
3570 type_param_spec_list
= old_param_spec_list
;
3572 c2
->param_list
= params
;
3573 c2
->initializer
= gfc_default_initializer (&c2
->ts
);
3577 gfc_commit_symbol (instance
);
3579 *ext_param_list
= type_param_spec_list
;
3584 gfc_free_actual_arglist (type_param_spec_list
);
3589 /* Matches a declaration-type-spec (F03:R502). If successful, sets the ts
3590 structure to the matched specification. This is necessary for FUNCTION and
3591 IMPLICIT statements.
3593 If implicit_flag is nonzero, then we don't check for the optional
3594 kind specification. Not doing so is needed for matching an IMPLICIT
3595 statement correctly. */
3598 gfc_match_decl_type_spec (gfc_typespec
*ts
, int implicit_flag
)
3600 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3601 gfc_symbol
*sym
, *dt_sym
;
3604 bool seen_deferred_kind
, matched_type
;
3605 const char *dt_name
;
3607 decl_type_param_list
= NULL
;
3609 /* A belt and braces check that the typespec is correctly being treated
3610 as a deferred characteristic association. */
3611 seen_deferred_kind
= (gfc_current_state () == COMP_FUNCTION
)
3612 && (gfc_current_block ()->result
->ts
.kind
== -1)
3613 && (ts
->kind
== -1);
3615 if (seen_deferred_kind
)
3618 /* Clear the current binding label, in case one is given. */
3619 curr_binding_label
= NULL
;
3621 if (gfc_match (" byte") == MATCH_YES
)
3623 if (!gfc_notify_std (GFC_STD_GNU
, "BYTE type at %C"))
3626 if (gfc_validate_kind (BT_INTEGER
, 1, true) < 0)
3628 gfc_error ("BYTE type used at %C "
3629 "is not available on the target machine");
3633 ts
->type
= BT_INTEGER
;
3639 m
= gfc_match (" type (");
3640 matched_type
= (m
== MATCH_YES
);
3643 gfc_gobble_whitespace ();
3644 if (gfc_peek_ascii_char () == '*')
3646 if ((m
= gfc_match ("*)")) != MATCH_YES
)
3648 if (gfc_comp_struct (gfc_current_state ()))
3650 gfc_error ("Assumed type at %C is not allowed for components");
3653 if (!gfc_notify_std (GFC_STD_F2008_TS
, "Assumed type "
3656 ts
->type
= BT_ASSUMED
;
3660 m
= gfc_match ("%n", name
);
3661 matched_type
= (m
== MATCH_YES
);
3664 if ((matched_type
&& strcmp ("integer", name
) == 0)
3665 || (!matched_type
&& gfc_match (" integer") == MATCH_YES
))
3667 ts
->type
= BT_INTEGER
;
3668 ts
->kind
= gfc_default_integer_kind
;
3672 if ((matched_type
&& strcmp ("character", name
) == 0)
3673 || (!matched_type
&& gfc_match (" character") == MATCH_YES
))
3676 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
3677 "intrinsic-type-spec at %C"))
3680 ts
->type
= BT_CHARACTER
;
3681 if (implicit_flag
== 0)
3682 m
= gfc_match_char_spec (ts
);
3686 if (matched_type
&& m
== MATCH_YES
&& gfc_match_char (')') != MATCH_YES
)
3692 if ((matched_type
&& strcmp ("real", name
) == 0)
3693 || (!matched_type
&& gfc_match (" real") == MATCH_YES
))
3696 ts
->kind
= gfc_default_real_kind
;
3701 && (strcmp ("doubleprecision", name
) == 0
3702 || (strcmp ("double", name
) == 0
3703 && gfc_match (" precision") == MATCH_YES
)))
3704 || (!matched_type
&& gfc_match (" double precision") == MATCH_YES
))
3707 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
3708 "intrinsic-type-spec at %C"))
3710 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
3714 ts
->kind
= gfc_default_double_kind
;
3718 if ((matched_type
&& strcmp ("complex", name
) == 0)
3719 || (!matched_type
&& gfc_match (" complex") == MATCH_YES
))
3721 ts
->type
= BT_COMPLEX
;
3722 ts
->kind
= gfc_default_complex_kind
;
3727 && (strcmp ("doublecomplex", name
) == 0
3728 || (strcmp ("double", name
) == 0
3729 && gfc_match (" complex") == MATCH_YES
)))
3730 || (!matched_type
&& gfc_match (" double complex") == MATCH_YES
))
3732 if (!gfc_notify_std (GFC_STD_GNU
, "DOUBLE COMPLEX at %C"))
3736 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
3737 "intrinsic-type-spec at %C"))
3740 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
3743 ts
->type
= BT_COMPLEX
;
3744 ts
->kind
= gfc_default_double_kind
;
3748 if ((matched_type
&& strcmp ("logical", name
) == 0)
3749 || (!matched_type
&& gfc_match (" logical") == MATCH_YES
))
3751 ts
->type
= BT_LOGICAL
;
3752 ts
->kind
= gfc_default_logical_kind
;
3758 m
= gfc_match_actual_arglist (1, &decl_type_param_list
, true);
3759 if (m
== MATCH_ERROR
)
3762 m
= gfc_match_char (')');
3766 m
= match_record_decl (name
);
3768 if (matched_type
|| m
== MATCH_YES
)
3770 ts
->type
= BT_DERIVED
;
3771 /* We accept record/s/ or type(s) where s is a structure, but we
3772 * don't need all the extra derived-type stuff for structures. */
3773 if (gfc_find_symbol (gfc_dt_upper_string (name
), NULL
, 1, &sym
))
3775 gfc_error ("Type name %qs at %C is ambiguous", name
);
3779 if (sym
&& sym
->attr
.flavor
== FL_DERIVED
3780 && sym
->attr
.pdt_template
3781 && gfc_current_state () != COMP_DERIVED
)
3783 m
= gfc_get_pdt_instance (decl_type_param_list
, &sym
, NULL
);
3786 gcc_assert (!sym
->attr
.pdt_template
&& sym
->attr
.pdt_type
);
3787 ts
->u
.derived
= sym
;
3788 strcpy (name
, gfc_dt_lower_string (sym
->name
));
3791 if (sym
&& sym
->attr
.flavor
== FL_STRUCT
)
3793 ts
->u
.derived
= sym
;
3796 /* Actually a derived type. */
3801 /* Match nested STRUCTURE declarations; only valid within another
3802 structure declaration. */
3803 if (flag_dec_structure
3804 && (gfc_current_state () == COMP_STRUCTURE
3805 || gfc_current_state () == COMP_MAP
))
3807 m
= gfc_match (" structure");
3810 m
= gfc_match_structure_decl ();
3813 /* gfc_new_block is updated by match_structure_decl. */
3814 ts
->type
= BT_DERIVED
;
3815 ts
->u
.derived
= gfc_new_block
;
3819 if (m
== MATCH_ERROR
)
3823 /* Match CLASS declarations. */
3824 m
= gfc_match (" class ( * )");
3825 if (m
== MATCH_ERROR
)
3827 else if (m
== MATCH_YES
)
3831 ts
->type
= BT_CLASS
;
3832 gfc_find_symbol ("STAR", gfc_current_ns
, 1, &upe
);
3835 upe
= gfc_new_symbol ("STAR", gfc_current_ns
);
3836 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "STAR");
3838 gfc_set_sym_referenced (upe
);
3840 upe
->ts
.type
= BT_VOID
;
3841 upe
->attr
.unlimited_polymorphic
= 1;
3842 /* This is essential to force the construction of
3843 unlimited polymorphic component class containers. */
3844 upe
->attr
.zero_comp
= 1;
3845 if (!gfc_add_flavor (&upe
->attr
, FL_DERIVED
, NULL
,
3846 &gfc_current_locus
))
3851 st
= gfc_get_tbp_symtree (&gfc_current_ns
->sym_root
, "STAR");
3855 ts
->u
.derived
= upe
;
3859 m
= gfc_match (" class (");
3862 m
= gfc_match ("%n", name
);
3868 ts
->type
= BT_CLASS
;
3870 if (!gfc_notify_std (GFC_STD_F2003
, "CLASS statement at %C"))
3873 m
= gfc_match_actual_arglist (1, &decl_type_param_list
, true);
3874 if (m
== MATCH_ERROR
)
3877 m
= gfc_match_char (')');
3882 /* Defer association of the derived type until the end of the
3883 specification block. However, if the derived type can be
3884 found, add it to the typespec. */
3885 if (gfc_matching_function
)
3887 ts
->u
.derived
= NULL
;
3888 if (gfc_current_state () != COMP_INTERFACE
3889 && !gfc_find_symbol (name
, NULL
, 1, &sym
) && sym
)
3891 sym
= gfc_find_dt_in_generic (sym
);
3892 ts
->u
.derived
= sym
;
3897 /* Search for the name but allow the components to be defined later. If
3898 type = -1, this typespec has been seen in a function declaration but
3899 the type could not be accessed at that point. The actual derived type is
3900 stored in a symtree with the first letter of the name capitalized; the
3901 symtree with the all lower-case name contains the associated
3902 generic function. */
3903 dt_name
= gfc_dt_upper_string (name
);
3908 gfc_get_ha_symbol (name
, &sym
);
3909 if (sym
->generic
&& gfc_find_symbol (dt_name
, NULL
, 0, &dt_sym
))
3911 gfc_error ("Type name %qs at %C is ambiguous", name
);
3914 if (sym
->generic
&& !dt_sym
)
3915 dt_sym
= gfc_find_dt_in_generic (sym
);
3917 /* Host associated PDTs can get confused with their constructors
3918 because they ar instantiated in the template's namespace. */
3921 if (gfc_find_symbol (dt_name
, NULL
, 1, &dt_sym
))
3923 gfc_error ("Type name %qs at %C is ambiguous", name
);
3926 if (dt_sym
&& !dt_sym
->attr
.pdt_type
)
3930 else if (ts
->kind
== -1)
3932 int iface
= gfc_state_stack
->previous
->state
!= COMP_INTERFACE
3933 || gfc_current_ns
->has_import_set
;
3934 gfc_find_symbol (name
, NULL
, iface
, &sym
);
3935 if (sym
&& sym
->generic
&& gfc_find_symbol (dt_name
, NULL
, 1, &dt_sym
))
3937 gfc_error ("Type name %qs at %C is ambiguous", name
);
3940 if (sym
&& sym
->generic
&& !dt_sym
)
3941 dt_sym
= gfc_find_dt_in_generic (sym
);
3948 if ((sym
->attr
.flavor
!= FL_UNKNOWN
&& sym
->attr
.flavor
!= FL_STRUCT
3949 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.generic
))
3950 || sym
->attr
.subroutine
)
3952 gfc_error ("Type name %qs at %C conflicts with previously declared "
3953 "entity at %L, which has the same name", name
,
3958 if (sym
&& sym
->attr
.flavor
== FL_DERIVED
3959 && sym
->attr
.pdt_template
3960 && gfc_current_state () != COMP_DERIVED
)
3962 m
= gfc_get_pdt_instance (decl_type_param_list
, &sym
, NULL
);
3965 gcc_assert (!sym
->attr
.pdt_template
&& sym
->attr
.pdt_type
);
3966 ts
->u
.derived
= sym
;
3967 strcpy (name
, gfc_dt_lower_string (sym
->name
));
3970 gfc_save_symbol_data (sym
);
3971 gfc_set_sym_referenced (sym
);
3972 if (!sym
->attr
.generic
3973 && !gfc_add_generic (&sym
->attr
, sym
->name
, NULL
))
3976 if (!sym
->attr
.function
3977 && !gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
3980 if (dt_sym
&& dt_sym
->attr
.flavor
== FL_DERIVED
3981 && dt_sym
->attr
.pdt_template
3982 && gfc_current_state () != COMP_DERIVED
)
3984 m
= gfc_get_pdt_instance (decl_type_param_list
, &dt_sym
, NULL
);
3987 gcc_assert (!dt_sym
->attr
.pdt_template
&& dt_sym
->attr
.pdt_type
);
3992 gfc_interface
*intr
, *head
;
3994 /* Use upper case to save the actual derived-type symbol. */
3995 gfc_get_symbol (dt_name
, NULL
, &dt_sym
);
3996 dt_sym
->name
= gfc_get_string ("%s", sym
->name
);
3997 head
= sym
->generic
;
3998 intr
= gfc_get_interface ();
4000 intr
->where
= gfc_current_locus
;
4002 sym
->generic
= intr
;
4003 sym
->attr
.if_source
= IFSRC_DECL
;
4006 gfc_save_symbol_data (dt_sym
);
4008 gfc_set_sym_referenced (dt_sym
);
4010 if (dt_sym
->attr
.flavor
!= FL_DERIVED
&& dt_sym
->attr
.flavor
!= FL_STRUCT
4011 && !gfc_add_flavor (&dt_sym
->attr
, FL_DERIVED
, sym
->name
, NULL
))
4014 ts
->u
.derived
= dt_sym
;
4020 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
4021 "intrinsic-type-spec at %C"))
4024 /* For all types except double, derived and character, look for an
4025 optional kind specifier. MATCH_NO is actually OK at this point. */
4026 if (implicit_flag
== 1)
4028 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
4034 if (gfc_current_form
== FORM_FREE
)
4036 c
= gfc_peek_ascii_char ();
4037 if (!gfc_is_whitespace (c
) && c
!= '*' && c
!= '('
4038 && c
!= ':' && c
!= ',')
4040 if (matched_type
&& c
== ')')
4042 gfc_next_ascii_char ();
4049 m
= gfc_match_kind_spec (ts
, false);
4050 if (m
== MATCH_NO
&& ts
->type
!= BT_CHARACTER
)
4052 m
= gfc_match_old_kind_spec (ts
);
4053 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) == -1)
4057 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
4060 /* Defer association of the KIND expression of function results
4061 until after USE and IMPORT statements. */
4062 if ((gfc_current_state () == COMP_NONE
&& gfc_error_flag_test ())
4063 || gfc_matching_function
)
4067 m
= MATCH_YES
; /* No kind specifier found. */
4073 /* Match an IMPLICIT NONE statement. Actually, this statement is
4074 already matched in parse.c, or we would not end up here in the
4075 first place. So the only thing we need to check, is if there is
4076 trailing garbage. If not, the match is successful. */
4079 gfc_match_implicit_none (void)
4083 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4085 bool external
= false;
4086 locus cur_loc
= gfc_current_locus
;
4088 if (gfc_current_ns
->seen_implicit_none
4089 || gfc_current_ns
->has_implicit_none_export
)
4091 gfc_error ("Duplicate IMPLICIT NONE statement at %C");
4095 gfc_gobble_whitespace ();
4096 c
= gfc_peek_ascii_char ();
4099 (void) gfc_next_ascii_char ();
4100 if (!gfc_notify_std (GFC_STD_F2015
, "IMPORT NONE with spec list at %C"))
4103 gfc_gobble_whitespace ();
4104 if (gfc_peek_ascii_char () == ')')
4106 (void) gfc_next_ascii_char ();
4112 m
= gfc_match (" %n", name
);
4116 if (strcmp (name
, "type") == 0)
4118 else if (strcmp (name
, "external") == 0)
4123 gfc_gobble_whitespace ();
4124 c
= gfc_next_ascii_char ();
4135 if (gfc_match_eos () != MATCH_YES
)
4138 gfc_set_implicit_none (type
, external
, &cur_loc
);
4144 /* Match the letter range(s) of an IMPLICIT statement. */
4147 match_implicit_range (void)
4153 cur_loc
= gfc_current_locus
;
4155 gfc_gobble_whitespace ();
4156 c
= gfc_next_ascii_char ();
4159 gfc_error ("Missing character range in IMPLICIT at %C");
4166 gfc_gobble_whitespace ();
4167 c1
= gfc_next_ascii_char ();
4171 gfc_gobble_whitespace ();
4172 c
= gfc_next_ascii_char ();
4177 inner
= 0; /* Fall through. */
4184 gfc_gobble_whitespace ();
4185 c2
= gfc_next_ascii_char ();
4189 gfc_gobble_whitespace ();
4190 c
= gfc_next_ascii_char ();
4192 if ((c
!= ',') && (c
!= ')'))
4205 gfc_error ("Letters must be in alphabetic order in "
4206 "IMPLICIT statement at %C");
4210 /* See if we can add the newly matched range to the pending
4211 implicits from this IMPLICIT statement. We do not check for
4212 conflicts with whatever earlier IMPLICIT statements may have
4213 set. This is done when we've successfully finished matching
4215 if (!gfc_add_new_implicit_range (c1
, c2
))
4222 gfc_syntax_error (ST_IMPLICIT
);
4224 gfc_current_locus
= cur_loc
;
4229 /* Match an IMPLICIT statement, storing the types for
4230 gfc_set_implicit() if the statement is accepted by the parser.
4231 There is a strange looking, but legal syntactic construction
4232 possible. It looks like:
4234 IMPLICIT INTEGER (a-b) (c-d)
4236 This is legal if "a-b" is a constant expression that happens to
4237 equal one of the legal kinds for integers. The real problem
4238 happens with an implicit specification that looks like:
4240 IMPLICIT INTEGER (a-b)
4242 In this case, a typespec matcher that is "greedy" (as most of the
4243 matchers are) gobbles the character range as a kindspec, leaving
4244 nothing left. We therefore have to go a bit more slowly in the
4245 matching process by inhibiting the kindspec checking during
4246 typespec matching and checking for a kind later. */
4249 gfc_match_implicit (void)
4256 if (gfc_current_ns
->seen_implicit_none
)
4258 gfc_error ("IMPLICIT statement at %C following an IMPLICIT NONE (type) "
4265 /* We don't allow empty implicit statements. */
4266 if (gfc_match_eos () == MATCH_YES
)
4268 gfc_error ("Empty IMPLICIT statement at %C");
4274 /* First cleanup. */
4275 gfc_clear_new_implicit ();
4277 /* A basic type is mandatory here. */
4278 m
= gfc_match_decl_type_spec (&ts
, 1);
4279 if (m
== MATCH_ERROR
)
4284 cur_loc
= gfc_current_locus
;
4285 m
= match_implicit_range ();
4289 /* We may have <TYPE> (<RANGE>). */
4290 gfc_gobble_whitespace ();
4291 c
= gfc_peek_ascii_char ();
4292 if (c
== ',' || c
== '\n' || c
== ';' || c
== '!')
4294 /* Check for CHARACTER with no length parameter. */
4295 if (ts
.type
== BT_CHARACTER
&& !ts
.u
.cl
)
4297 ts
.kind
= gfc_default_character_kind
;
4298 ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4299 ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
,
4303 /* Record the Successful match. */
4304 if (!gfc_merge_new_implicit (&ts
))
4307 c
= gfc_next_ascii_char ();
4308 else if (gfc_match_eos () == MATCH_ERROR
)
4313 gfc_current_locus
= cur_loc
;
4316 /* Discard the (incorrectly) matched range. */
4317 gfc_clear_new_implicit ();
4319 /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
4320 if (ts
.type
== BT_CHARACTER
)
4321 m
= gfc_match_char_spec (&ts
);
4324 m
= gfc_match_kind_spec (&ts
, false);
4327 m
= gfc_match_old_kind_spec (&ts
);
4328 if (m
== MATCH_ERROR
)
4334 if (m
== MATCH_ERROR
)
4337 m
= match_implicit_range ();
4338 if (m
== MATCH_ERROR
)
4343 gfc_gobble_whitespace ();
4344 c
= gfc_next_ascii_char ();
4345 if (c
!= ',' && gfc_match_eos () != MATCH_YES
)
4348 if (!gfc_merge_new_implicit (&ts
))
4356 gfc_syntax_error (ST_IMPLICIT
);
4364 gfc_match_import (void)
4366 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4371 if (gfc_current_ns
->proc_name
== NULL
4372 || gfc_current_ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
4374 gfc_error ("IMPORT statement at %C only permitted in "
4375 "an INTERFACE body");
4379 if (gfc_current_ns
->proc_name
->attr
.module_procedure
)
4381 gfc_error ("F2008: C1210 IMPORT statement at %C is not permitted "
4382 "in a module procedure interface body");
4386 if (!gfc_notify_std (GFC_STD_F2003
, "IMPORT statement at %C"))
4389 if (gfc_match_eos () == MATCH_YES
)
4391 /* All host variables should be imported. */
4392 gfc_current_ns
->has_import_set
= 1;
4396 if (gfc_match (" ::") == MATCH_YES
)
4398 if (gfc_match_eos () == MATCH_YES
)
4400 gfc_error ("Expecting list of named entities at %C");
4408 m
= gfc_match (" %n", name
);
4412 if (gfc_current_ns
->parent
!= NULL
4413 && gfc_find_symbol (name
, gfc_current_ns
->parent
, 1, &sym
))
4415 gfc_error ("Type name %qs at %C is ambiguous", name
);
4418 else if (!sym
&& gfc_current_ns
->proc_name
->ns
->parent
!= NULL
4419 && gfc_find_symbol (name
,
4420 gfc_current_ns
->proc_name
->ns
->parent
,
4423 gfc_error ("Type name %qs at %C is ambiguous", name
);
4429 gfc_error ("Cannot IMPORT %qs from host scoping unit "
4430 "at %C - does not exist.", name
);
4434 if (gfc_find_symtree (gfc_current_ns
->sym_root
, name
))
4436 gfc_warning (0, "%qs is already IMPORTed from host scoping unit "
4441 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, name
);
4444 sym
->attr
.imported
= 1;
4446 if (sym
->attr
.generic
&& (sym
= gfc_find_dt_in_generic (sym
)))
4448 /* The actual derived type is stored in a symtree with the first
4449 letter of the name capitalized; the symtree with the all
4450 lower-case name contains the associated generic function. */
4451 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
,
4452 gfc_dt_upper_string (name
));
4455 sym
->attr
.imported
= 1;
4468 if (gfc_match_eos () == MATCH_YES
)
4470 if (gfc_match_char (',') != MATCH_YES
)
4477 gfc_error ("Syntax error in IMPORT statement at %C");
4482 /* A minimal implementation of gfc_match without whitespace, escape
4483 characters or variable arguments. Returns true if the next
4484 characters match the TARGET template exactly. */
4487 match_string_p (const char *target
)
4491 for (p
= target
; *p
; p
++)
4492 if ((char) gfc_next_ascii_char () != *p
)
4497 /* Matches an attribute specification including array specs. If
4498 successful, leaves the variables current_attr and current_as
4499 holding the specification. Also sets the colon_seen variable for
4500 later use by matchers associated with initializations.
4502 This subroutine is a little tricky in the sense that we don't know
4503 if we really have an attr-spec until we hit the double colon.
4504 Until that time, we can only return MATCH_NO. This forces us to
4505 check for duplicate specification at this level. */
4508 match_attr_spec (void)
4510 /* Modifiers that can exist in a type statement. */
4512 { GFC_DECL_BEGIN
= 0,
4513 DECL_ALLOCATABLE
= GFC_DECL_BEGIN
, DECL_DIMENSION
, DECL_EXTERNAL
,
4514 DECL_IN
, DECL_OUT
, DECL_INOUT
, DECL_INTRINSIC
, DECL_OPTIONAL
,
4515 DECL_PARAMETER
, DECL_POINTER
, DECL_PROTECTED
, DECL_PRIVATE
,
4516 DECL_STATIC
, DECL_AUTOMATIC
,
4517 DECL_PUBLIC
, DECL_SAVE
, DECL_TARGET
, DECL_VALUE
, DECL_VOLATILE
,
4518 DECL_IS_BIND_C
, DECL_CODIMENSION
, DECL_ASYNCHRONOUS
, DECL_CONTIGUOUS
,
4519 DECL_LEN
, DECL_KIND
, DECL_NONE
, GFC_DECL_END
/* Sentinel */
4522 /* GFC_DECL_END is the sentinel, index starts at 0. */
4523 #define NUM_DECL GFC_DECL_END
4525 locus start
, seen_at
[NUM_DECL
];
4532 gfc_clear_attr (¤t_attr
);
4533 start
= gfc_current_locus
;
4539 /* See if we get all of the keywords up to the final double colon. */
4540 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
4548 gfc_gobble_whitespace ();
4550 ch
= gfc_next_ascii_char ();
4553 /* This is the successful exit condition for the loop. */
4554 if (gfc_next_ascii_char () == ':')
4559 gfc_gobble_whitespace ();
4560 switch (gfc_peek_ascii_char ())
4563 gfc_next_ascii_char ();
4564 switch (gfc_next_ascii_char ())
4567 if (match_string_p ("locatable"))
4569 /* Matched "allocatable". */
4570 d
= DECL_ALLOCATABLE
;
4575 if (match_string_p ("ynchronous"))
4577 /* Matched "asynchronous". */
4578 d
= DECL_ASYNCHRONOUS
;
4583 if (match_string_p ("tomatic"))
4585 /* Matched "automatic". */
4593 /* Try and match the bind(c). */
4594 m
= gfc_match_bind_c (NULL
, true);
4597 else if (m
== MATCH_ERROR
)
4602 gfc_next_ascii_char ();
4603 if ('o' != gfc_next_ascii_char ())
4605 switch (gfc_next_ascii_char ())
4608 if (match_string_p ("imension"))
4610 d
= DECL_CODIMENSION
;
4615 if (match_string_p ("tiguous"))
4617 d
= DECL_CONTIGUOUS
;
4624 if (match_string_p ("dimension"))
4629 if (match_string_p ("external"))
4634 if (match_string_p ("int"))
4636 ch
= gfc_next_ascii_char ();
4639 if (match_string_p ("nt"))
4641 /* Matched "intent". */
4642 /* TODO: Call match_intent_spec from here. */
4643 if (gfc_match (" ( in out )") == MATCH_YES
)
4645 else if (gfc_match (" ( in )") == MATCH_YES
)
4647 else if (gfc_match (" ( out )") == MATCH_YES
)
4653 if (match_string_p ("insic"))
4655 /* Matched "intrinsic". */
4663 if (match_string_p ("kind"))
4668 if (match_string_p ("len"))
4673 if (match_string_p ("optional"))
4678 gfc_next_ascii_char ();
4679 switch (gfc_next_ascii_char ())
4682 if (match_string_p ("rameter"))
4684 /* Matched "parameter". */
4690 if (match_string_p ("inter"))
4692 /* Matched "pointer". */
4698 ch
= gfc_next_ascii_char ();
4701 if (match_string_p ("vate"))
4703 /* Matched "private". */
4709 if (match_string_p ("tected"))
4711 /* Matched "protected". */
4718 if (match_string_p ("blic"))
4720 /* Matched "public". */
4728 gfc_next_ascii_char ();
4729 switch (gfc_next_ascii_char ())
4732 if (match_string_p ("ve"))
4734 /* Matched "save". */
4740 if (match_string_p ("atic"))
4742 /* Matched "static". */
4750 if (match_string_p ("target"))
4755 gfc_next_ascii_char ();
4756 ch
= gfc_next_ascii_char ();
4759 if (match_string_p ("lue"))
4761 /* Matched "value". */
4767 if (match_string_p ("latile"))
4769 /* Matched "volatile". */
4777 /* No double colon and no recognizable decl_type, so assume that
4778 we've been looking at something else the whole time. */
4785 /* Check to make sure any parens are paired up correctly. */
4786 if (gfc_match_parens () == MATCH_ERROR
)
4793 seen_at
[d
] = gfc_current_locus
;
4795 if (d
== DECL_DIMENSION
|| d
== DECL_CODIMENSION
)
4797 gfc_array_spec
*as
= NULL
;
4799 m
= gfc_match_array_spec (&as
, d
== DECL_DIMENSION
,
4800 d
== DECL_CODIMENSION
);
4802 if (current_as
== NULL
)
4804 else if (m
== MATCH_YES
)
4806 if (!merge_array_spec (as
, current_as
, false))
4813 if (d
== DECL_CODIMENSION
)
4814 gfc_error ("Missing codimension specification at %C");
4816 gfc_error ("Missing dimension specification at %C");
4820 if (m
== MATCH_ERROR
)
4825 /* Since we've seen a double colon, we have to be looking at an
4826 attr-spec. This means that we can now issue errors. */
4827 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
4832 case DECL_ALLOCATABLE
:
4833 attr
= "ALLOCATABLE";
4835 case DECL_ASYNCHRONOUS
:
4836 attr
= "ASYNCHRONOUS";
4838 case DECL_CODIMENSION
:
4839 attr
= "CODIMENSION";
4841 case DECL_CONTIGUOUS
:
4842 attr
= "CONTIGUOUS";
4844 case DECL_DIMENSION
:
4851 attr
= "INTENT (IN)";
4854 attr
= "INTENT (OUT)";
4857 attr
= "INTENT (IN OUT)";
4859 case DECL_INTRINSIC
:
4871 case DECL_PARAMETER
:
4877 case DECL_PROTECTED
:
4892 case DECL_AUTOMATIC
:
4898 case DECL_IS_BIND_C
:
4908 attr
= NULL
; /* This shouldn't happen. */
4911 gfc_error ("Duplicate %s attribute at %L", attr
, &seen_at
[d
]);
4916 /* Now that we've dealt with duplicate attributes, add the attributes
4917 to the current attribute. */
4918 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
4925 if ((d
== DECL_STATIC
|| d
== DECL_AUTOMATIC
)
4926 && !flag_dec_static
)
4928 gfc_error ("%s at %L is a DEC extension, enable with "
4930 d
== DECL_STATIC
? "STATIC" : "AUTOMATIC", &seen_at
[d
]);
4934 /* Allow SAVE with STATIC, but don't complain. */
4935 if (d
== DECL_STATIC
&& seen
[DECL_SAVE
])
4938 if (gfc_current_state () == COMP_DERIVED
4939 && d
!= DECL_DIMENSION
&& d
!= DECL_CODIMENSION
4940 && d
!= DECL_POINTER
&& d
!= DECL_PRIVATE
4941 && d
!= DECL_PUBLIC
&& d
!= DECL_CONTIGUOUS
&& d
!= DECL_NONE
)
4943 if (d
== DECL_ALLOCATABLE
)
4945 if (!gfc_notify_std (GFC_STD_F2003
, "ALLOCATABLE "
4946 "attribute at %C in a TYPE definition"))
4952 else if (d
== DECL_KIND
)
4954 if (!gfc_notify_std (GFC_STD_F2003
, "KIND "
4955 "attribute at %C in a TYPE definition"))
4960 if (current_ts
.type
!= BT_INTEGER
)
4962 gfc_error ("Component with KIND attribute at %C must be "
4967 if (current_ts
.kind
!= gfc_default_integer_kind
)
4969 gfc_error ("Component with KIND attribute at %C must be "
4970 "default integer kind (%d)",
4971 gfc_default_integer_kind
);
4976 else if (d
== DECL_LEN
)
4978 if (!gfc_notify_std (GFC_STD_F2003
, "LEN "
4979 "attribute at %C in a TYPE definition"))
4984 if (current_ts
.type
!= BT_INTEGER
)
4986 gfc_error ("Component with LEN attribute at %C must be "
4991 if (current_ts
.kind
!= gfc_default_integer_kind
)
4993 gfc_error ("Component with LEN attribute at %C must be "
4994 "default integer kind (%d)",
4995 gfc_default_integer_kind
);
5002 gfc_error ("Attribute at %L is not allowed in a TYPE definition",
5009 if ((d
== DECL_PRIVATE
|| d
== DECL_PUBLIC
)
5010 && gfc_current_state () != COMP_MODULE
)
5012 if (d
== DECL_PRIVATE
)
5016 if (gfc_current_state () == COMP_DERIVED
5017 && gfc_state_stack
->previous
5018 && gfc_state_stack
->previous
->state
== COMP_MODULE
)
5020 if (!gfc_notify_std (GFC_STD_F2003
, "Attribute %s "
5021 "at %L in a TYPE definition", attr
,
5030 gfc_error ("%s attribute at %L is not allowed outside of the "
5031 "specification part of a module", attr
, &seen_at
[d
]);
5037 if (gfc_current_state () != COMP_DERIVED
5038 && (d
== DECL_KIND
|| d
== DECL_LEN
))
5040 gfc_error ("Attribute at %L is not allowed outside a TYPE "
5041 "definition", &seen_at
[d
]);
5048 case DECL_ALLOCATABLE
:
5049 t
= gfc_add_allocatable (¤t_attr
, &seen_at
[d
]);
5052 case DECL_ASYNCHRONOUS
:
5053 if (!gfc_notify_std (GFC_STD_F2003
, "ASYNCHRONOUS attribute at %C"))
5056 t
= gfc_add_asynchronous (¤t_attr
, NULL
, &seen_at
[d
]);
5059 case DECL_CODIMENSION
:
5060 t
= gfc_add_codimension (¤t_attr
, NULL
, &seen_at
[d
]);
5063 case DECL_CONTIGUOUS
:
5064 if (!gfc_notify_std (GFC_STD_F2008
, "CONTIGUOUS attribute at %C"))
5067 t
= gfc_add_contiguous (¤t_attr
, NULL
, &seen_at
[d
]);
5070 case DECL_DIMENSION
:
5071 t
= gfc_add_dimension (¤t_attr
, NULL
, &seen_at
[d
]);
5075 t
= gfc_add_external (¤t_attr
, &seen_at
[d
]);
5079 t
= gfc_add_intent (¤t_attr
, INTENT_IN
, &seen_at
[d
]);
5083 t
= gfc_add_intent (¤t_attr
, INTENT_OUT
, &seen_at
[d
]);
5087 t
= gfc_add_intent (¤t_attr
, INTENT_INOUT
, &seen_at
[d
]);
5090 case DECL_INTRINSIC
:
5091 t
= gfc_add_intrinsic (¤t_attr
, &seen_at
[d
]);
5095 t
= gfc_add_optional (¤t_attr
, &seen_at
[d
]);
5099 t
= gfc_add_kind (¤t_attr
, &seen_at
[d
]);
5103 t
= gfc_add_len (¤t_attr
, &seen_at
[d
]);
5106 case DECL_PARAMETER
:
5107 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, &seen_at
[d
]);
5111 t
= gfc_add_pointer (¤t_attr
, &seen_at
[d
]);
5114 case DECL_PROTECTED
:
5115 if (gfc_current_state () != COMP_MODULE
5116 || (gfc_current_ns
->proc_name
5117 && gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
))
5119 gfc_error ("PROTECTED at %C only allowed in specification "
5120 "part of a module");
5125 if (!gfc_notify_std (GFC_STD_F2003
, "PROTECTED attribute at %C"))
5128 t
= gfc_add_protected (¤t_attr
, NULL
, &seen_at
[d
]);
5132 t
= gfc_add_access (¤t_attr
, ACCESS_PRIVATE
, NULL
,
5137 t
= gfc_add_access (¤t_attr
, ACCESS_PUBLIC
, NULL
,
5143 t
= gfc_add_save (¤t_attr
, SAVE_EXPLICIT
, NULL
, &seen_at
[d
]);
5146 case DECL_AUTOMATIC
:
5147 t
= gfc_add_automatic (¤t_attr
, NULL
, &seen_at
[d
]);
5151 t
= gfc_add_target (¤t_attr
, &seen_at
[d
]);
5154 case DECL_IS_BIND_C
:
5155 t
= gfc_add_is_bind_c(¤t_attr
, NULL
, &seen_at
[d
], 0);
5159 if (!gfc_notify_std (GFC_STD_F2003
, "VALUE attribute at %C"))
5162 t
= gfc_add_value (¤t_attr
, NULL
, &seen_at
[d
]);
5166 if (!gfc_notify_std (GFC_STD_F2003
, "VOLATILE attribute at %C"))
5169 t
= gfc_add_volatile (¤t_attr
, NULL
, &seen_at
[d
]);
5173 gfc_internal_error ("match_attr_spec(): Bad attribute");
5183 /* Since Fortran 2008 module variables implicitly have the SAVE attribute. */
5184 if ((gfc_current_state () == COMP_MODULE
5185 || gfc_current_state () == COMP_SUBMODULE
)
5186 && !current_attr
.save
5187 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
5188 current_attr
.save
= SAVE_IMPLICIT
;
5194 gfc_current_locus
= start
;
5195 gfc_free_array_spec (current_as
);
5202 /* Set the binding label, dest_label, either with the binding label
5203 stored in the given gfc_typespec, ts, or if none was provided, it
5204 will be the symbol name in all lower case, as required by the draft
5205 (J3/04-007, section 15.4.1). If a binding label was given and
5206 there is more than one argument (num_idents), it is an error. */
5209 set_binding_label (const char **dest_label
, const char *sym_name
,
5212 if (num_idents
> 1 && has_name_equals
)
5214 gfc_error ("Multiple identifiers provided with "
5215 "single NAME= specifier at %C");
5219 if (curr_binding_label
)
5220 /* Binding label given; store in temp holder till have sym. */
5221 *dest_label
= curr_binding_label
;
5224 /* No binding label given, and the NAME= specifier did not exist,
5225 which means there was no NAME="". */
5226 if (sym_name
!= NULL
&& has_name_equals
== 0)
5227 *dest_label
= IDENTIFIER_POINTER (get_identifier (sym_name
));
5234 /* Set the status of the given common block as being BIND(C) or not,
5235 depending on the given parameter, is_bind_c. */
5238 set_com_block_bind_c (gfc_common_head
*com_block
, int is_bind_c
)
5240 com_block
->is_bind_c
= is_bind_c
;
5245 /* Verify that the given gfc_typespec is for a C interoperable type. */
5248 gfc_verify_c_interop (gfc_typespec
*ts
)
5250 if (ts
->type
== BT_DERIVED
&& ts
->u
.derived
!= NULL
)
5251 return (ts
->u
.derived
->ts
.is_c_interop
|| ts
->u
.derived
->attr
.is_bind_c
)
5253 else if (ts
->type
== BT_CLASS
)
5255 else if (ts
->is_c_interop
!= 1 && ts
->type
!= BT_ASSUMED
)
5262 /* Verify that the variables of a given common block, which has been
5263 defined with the attribute specifier bind(c), to be of a C
5264 interoperable type. Errors will be reported here, if
5268 verify_com_block_vars_c_interop (gfc_common_head
*com_block
)
5270 gfc_symbol
*curr_sym
= NULL
;
5273 curr_sym
= com_block
->head
;
5275 /* Make sure we have at least one symbol. */
5276 if (curr_sym
== NULL
)
5279 /* Here we know we have a symbol, so we'll execute this loop
5283 /* The second to last param, 1, says this is in a common block. */
5284 retval
= verify_bind_c_sym (curr_sym
, &(curr_sym
->ts
), 1, com_block
);
5285 curr_sym
= curr_sym
->common_next
;
5286 } while (curr_sym
!= NULL
);
5292 /* Verify that a given BIND(C) symbol is C interoperable. If it is not,
5293 an appropriate error message is reported. */
5296 verify_bind_c_sym (gfc_symbol
*tmp_sym
, gfc_typespec
*ts
,
5297 int is_in_common
, gfc_common_head
*com_block
)
5299 bool bind_c_function
= false;
5302 if (tmp_sym
->attr
.function
&& tmp_sym
->attr
.is_bind_c
)
5303 bind_c_function
= true;
5305 if (tmp_sym
->attr
.function
&& tmp_sym
->result
!= NULL
)
5307 tmp_sym
= tmp_sym
->result
;
5308 /* Make sure it wasn't an implicitly typed result. */
5309 if (tmp_sym
->attr
.implicit_type
&& warn_c_binding_type
)
5311 gfc_warning (OPT_Wc_binding_type
,
5312 "Implicitly declared BIND(C) function %qs at "
5313 "%L may not be C interoperable", tmp_sym
->name
,
5314 &tmp_sym
->declared_at
);
5315 tmp_sym
->ts
.f90_type
= tmp_sym
->ts
.type
;
5316 /* Mark it as C interoperable to prevent duplicate warnings. */
5317 tmp_sym
->ts
.is_c_interop
= 1;
5318 tmp_sym
->attr
.is_c_interop
= 1;
5322 /* Here, we know we have the bind(c) attribute, so if we have
5323 enough type info, then verify that it's a C interop kind.
5324 The info could be in the symbol already, or possibly still in
5325 the given ts (current_ts), so look in both. */
5326 if (tmp_sym
->ts
.type
!= BT_UNKNOWN
|| ts
->type
!= BT_UNKNOWN
)
5328 if (!gfc_verify_c_interop (&(tmp_sym
->ts
)))
5330 /* See if we're dealing with a sym in a common block or not. */
5331 if (is_in_common
== 1 && warn_c_binding_type
)
5333 gfc_warning (OPT_Wc_binding_type
,
5334 "Variable %qs in common block %qs at %L "
5335 "may not be a C interoperable "
5336 "kind though common block %qs is BIND(C)",
5337 tmp_sym
->name
, com_block
->name
,
5338 &(tmp_sym
->declared_at
), com_block
->name
);
5342 if (tmp_sym
->ts
.type
== BT_DERIVED
|| ts
->type
== BT_DERIVED
)
5343 gfc_error ("Type declaration %qs at %L is not C "
5344 "interoperable but it is BIND(C)",
5345 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5346 else if (warn_c_binding_type
)
5347 gfc_warning (OPT_Wc_binding_type
, "Variable %qs at %L "
5348 "may not be a C interoperable "
5349 "kind but it is BIND(C)",
5350 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5354 /* Variables declared w/in a common block can't be bind(c)
5355 since there's no way for C to see these variables, so there's
5356 semantically no reason for the attribute. */
5357 if (is_in_common
== 1 && tmp_sym
->attr
.is_bind_c
== 1)
5359 gfc_error ("Variable %qs in common block %qs at "
5360 "%L cannot be declared with BIND(C) "
5361 "since it is not a global",
5362 tmp_sym
->name
, com_block
->name
,
5363 &(tmp_sym
->declared_at
));
5367 /* Scalar variables that are bind(c) can not have the pointer
5368 or allocatable attributes. */
5369 if (tmp_sym
->attr
.is_bind_c
== 1)
5371 if (tmp_sym
->attr
.pointer
== 1)
5373 gfc_error ("Variable %qs at %L cannot have both the "
5374 "POINTER and BIND(C) attributes",
5375 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5379 if (tmp_sym
->attr
.allocatable
== 1)
5381 gfc_error ("Variable %qs at %L cannot have both the "
5382 "ALLOCATABLE and BIND(C) attributes",
5383 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5389 /* If it is a BIND(C) function, make sure the return value is a
5390 scalar value. The previous tests in this function made sure
5391 the type is interoperable. */
5392 if (bind_c_function
&& tmp_sym
->as
!= NULL
)
5393 gfc_error ("Return type of BIND(C) function %qs at %L cannot "
5394 "be an array", tmp_sym
->name
, &(tmp_sym
->declared_at
));
5396 /* BIND(C) functions can not return a character string. */
5397 if (bind_c_function
&& tmp_sym
->ts
.type
== BT_CHARACTER
)
5398 if (tmp_sym
->ts
.u
.cl
== NULL
|| tmp_sym
->ts
.u
.cl
->length
== NULL
5399 || tmp_sym
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
5400 || mpz_cmp_si (tmp_sym
->ts
.u
.cl
->length
->value
.integer
, 1) != 0)
5401 gfc_error ("Return type of BIND(C) function %qs at %L cannot "
5402 "be a character string", tmp_sym
->name
,
5403 &(tmp_sym
->declared_at
));
5406 /* See if the symbol has been marked as private. If it has, make sure
5407 there is no binding label and warn the user if there is one. */
5408 if (tmp_sym
->attr
.access
== ACCESS_PRIVATE
5409 && tmp_sym
->binding_label
)
5410 /* Use gfc_warning_now because we won't say that the symbol fails
5411 just because of this. */
5412 gfc_warning_now (0, "Symbol %qs at %L is marked PRIVATE but has been "
5413 "given the binding label %qs", tmp_sym
->name
,
5414 &(tmp_sym
->declared_at
), tmp_sym
->binding_label
);
5420 /* Set the appropriate fields for a symbol that's been declared as
5421 BIND(C) (the is_bind_c flag and the binding label), and verify that
5422 the type is C interoperable. Errors are reported by the functions
5423 used to set/test these fields. */
5426 set_verify_bind_c_sym (gfc_symbol
*tmp_sym
, int num_idents
)
5430 /* TODO: Do we need to make sure the vars aren't marked private? */
5432 /* Set the is_bind_c bit in symbol_attribute. */
5433 gfc_add_is_bind_c (&(tmp_sym
->attr
), tmp_sym
->name
, &gfc_current_locus
, 0);
5435 if (!set_binding_label (&tmp_sym
->binding_label
, tmp_sym
->name
, num_idents
))
5442 /* Set the fields marking the given common block as BIND(C), including
5443 a binding label, and report any errors encountered. */
5446 set_verify_bind_c_com_block (gfc_common_head
*com_block
, int num_idents
)
5450 /* destLabel, common name, typespec (which may have binding label). */
5451 if (!set_binding_label (&com_block
->binding_label
, com_block
->name
,
5455 /* Set the given common block (com_block) to being bind(c) (1). */
5456 set_com_block_bind_c (com_block
, 1);
5462 /* Retrieve the list of one or more identifiers that the given bind(c)
5463 attribute applies to. */
5466 get_bind_c_idents (void)
5468 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5470 gfc_symbol
*tmp_sym
= NULL
;
5472 gfc_common_head
*com_block
= NULL
;
5474 if (gfc_match_name (name
) == MATCH_YES
)
5476 found_id
= MATCH_YES
;
5477 gfc_get_ha_symbol (name
, &tmp_sym
);
5479 else if (match_common_name (name
) == MATCH_YES
)
5481 found_id
= MATCH_YES
;
5482 com_block
= gfc_get_common (name
, 0);
5486 gfc_error ("Need either entity or common block name for "
5487 "attribute specification statement at %C");
5491 /* Save the current identifier and look for more. */
5494 /* Increment the number of identifiers found for this spec stmt. */
5497 /* Make sure we have a sym or com block, and verify that it can
5498 be bind(c). Set the appropriate field(s) and look for more
5500 if (tmp_sym
!= NULL
|| com_block
!= NULL
)
5502 if (tmp_sym
!= NULL
)
5504 if (!set_verify_bind_c_sym (tmp_sym
, num_idents
))
5509 if (!set_verify_bind_c_com_block (com_block
, num_idents
))
5513 /* Look to see if we have another identifier. */
5515 if (gfc_match_eos () == MATCH_YES
)
5516 found_id
= MATCH_NO
;
5517 else if (gfc_match_char (',') != MATCH_YES
)
5518 found_id
= MATCH_NO
;
5519 else if (gfc_match_name (name
) == MATCH_YES
)
5521 found_id
= MATCH_YES
;
5522 gfc_get_ha_symbol (name
, &tmp_sym
);
5524 else if (match_common_name (name
) == MATCH_YES
)
5526 found_id
= MATCH_YES
;
5527 com_block
= gfc_get_common (name
, 0);
5531 gfc_error ("Missing entity or common block name for "
5532 "attribute specification statement at %C");
5538 gfc_internal_error ("Missing symbol");
5540 } while (found_id
== MATCH_YES
);
5542 /* if we get here we were successful */
5547 /* Try and match a BIND(C) attribute specification statement. */
5550 gfc_match_bind_c_stmt (void)
5552 match found_match
= MATCH_NO
;
5557 /* This may not be necessary. */
5559 /* Clear the temporary binding label holder. */
5560 curr_binding_label
= NULL
;
5562 /* Look for the bind(c). */
5563 found_match
= gfc_match_bind_c (NULL
, true);
5565 if (found_match
== MATCH_YES
)
5567 if (!gfc_notify_std (GFC_STD_F2003
, "BIND(C) statement at %C"))
5570 /* Look for the :: now, but it is not required. */
5573 /* Get the identifier(s) that needs to be updated. This may need to
5574 change to hand the flag(s) for the attr specified so all identifiers
5575 found can have all appropriate parts updated (assuming that the same
5576 spec stmt can have multiple attrs, such as both bind(c) and
5578 if (!get_bind_c_idents ())
5579 /* Error message should have printed already. */
5587 /* Match a data declaration statement. */
5590 gfc_match_data_decl (void)
5596 type_param_spec_list
= NULL
;
5597 decl_type_param_list
= NULL
;
5599 num_idents_on_line
= 0;
5601 m
= gfc_match_decl_type_spec (¤t_ts
, 0);
5605 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
5606 && !gfc_comp_struct (gfc_current_state ()))
5608 sym
= gfc_use_derived (current_ts
.u
.derived
);
5616 current_ts
.u
.derived
= sym
;
5619 m
= match_attr_spec ();
5620 if (m
== MATCH_ERROR
)
5626 if (current_ts
.type
== BT_CLASS
5627 && current_ts
.u
.derived
->attr
.unlimited_polymorphic
)
5630 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
5631 && current_ts
.u
.derived
->components
== NULL
5632 && !current_ts
.u
.derived
->attr
.zero_comp
)
5635 if (current_attr
.pointer
&& gfc_comp_struct (gfc_current_state ()))
5638 if (current_attr
.allocatable
&& gfc_current_state () == COMP_DERIVED
5639 && current_ts
.u
.derived
== gfc_current_block ())
5642 gfc_find_symbol (current_ts
.u
.derived
->name
,
5643 current_ts
.u
.derived
->ns
, 1, &sym
);
5645 /* Any symbol that we find had better be a type definition
5646 which has its components defined, or be a structure definition
5647 actively being parsed. */
5648 if (sym
!= NULL
&& gfc_fl_struct (sym
->attr
.flavor
)
5649 && (current_ts
.u
.derived
->components
!= NULL
5650 || current_ts
.u
.derived
->attr
.zero_comp
5651 || current_ts
.u
.derived
== gfc_new_block
))
5654 gfc_error ("Derived type at %C has not been previously defined "
5655 "and so cannot appear in a derived type definition");
5661 /* If we have an old-style character declaration, and no new-style
5662 attribute specifications, then there a comma is optional between
5663 the type specification and the variable list. */
5664 if (m
== MATCH_NO
&& current_ts
.type
== BT_CHARACTER
&& old_char_selector
)
5665 gfc_match_char (',');
5667 /* Give the types/attributes to symbols that follow. Give the element
5668 a number so that repeat character length expressions can be copied. */
5672 num_idents_on_line
++;
5673 m
= variable_decl (elem
++);
5674 if (m
== MATCH_ERROR
)
5679 if (gfc_match_eos () == MATCH_YES
)
5681 if (gfc_match_char (',') != MATCH_YES
)
5685 if (!gfc_error_flag_test ())
5687 /* An anonymous structure declaration is unambiguous; if we matched one
5688 according to gfc_match_structure_decl, we need to return MATCH_YES
5689 here to avoid confusing the remaining matchers, even if there was an
5690 error during variable_decl. We must flush any such errors. Note this
5691 causes the parser to gracefully continue parsing the remaining input
5692 as a structure body, which likely follows. */
5693 if (current_ts
.type
== BT_DERIVED
&& current_ts
.u
.derived
5694 && gfc_fl_struct (current_ts
.u
.derived
->attr
.flavor
))
5696 gfc_error_now ("Syntax error in anonymous structure declaration"
5698 /* Skip the bad variable_decl and line up for the start of the
5700 gfc_error_recovery ();
5705 gfc_error ("Syntax error in data declaration at %C");
5710 gfc_free_data_all (gfc_current_ns
);
5713 if (saved_kind_expr
)
5714 gfc_free_expr (saved_kind_expr
);
5715 if (type_param_spec_list
)
5716 gfc_free_actual_arglist (type_param_spec_list
);
5717 if (decl_type_param_list
)
5718 gfc_free_actual_arglist (decl_type_param_list
);
5719 saved_kind_expr
= NULL
;
5720 gfc_free_array_spec (current_as
);
5726 /* Match a prefix associated with a function or subroutine
5727 declaration. If the typespec pointer is nonnull, then a typespec
5728 can be matched. Note that if nothing matches, MATCH_YES is
5729 returned (the null string was matched). */
5732 gfc_match_prefix (gfc_typespec
*ts
)
5738 gfc_clear_attr (¤t_attr
);
5740 seen_impure
= false;
5742 gcc_assert (!gfc_matching_prefix
);
5743 gfc_matching_prefix
= true;
5747 found_prefix
= false;
5749 /* MODULE is a prefix like PURE, ELEMENTAL, etc., having a
5750 corresponding attribute seems natural and distinguishes these
5751 procedures from procedure types of PROC_MODULE, which these are
5753 if (gfc_match ("module% ") == MATCH_YES
)
5755 if (!gfc_notify_std (GFC_STD_F2008
, "MODULE prefix at %C"))
5758 current_attr
.module_procedure
= 1;
5759 found_prefix
= true;
5762 if (!seen_type
&& ts
!= NULL
5763 && gfc_match_decl_type_spec (ts
, 0) == MATCH_YES
5764 && gfc_match_space () == MATCH_YES
)
5768 found_prefix
= true;
5771 if (gfc_match ("elemental% ") == MATCH_YES
)
5773 if (!gfc_add_elemental (¤t_attr
, NULL
))
5776 found_prefix
= true;
5779 if (gfc_match ("pure% ") == MATCH_YES
)
5781 if (!gfc_add_pure (¤t_attr
, NULL
))
5784 found_prefix
= true;
5787 if (gfc_match ("recursive% ") == MATCH_YES
)
5789 if (!gfc_add_recursive (¤t_attr
, NULL
))
5792 found_prefix
= true;
5795 /* IMPURE is a somewhat special case, as it needs not set an actual
5796 attribute but rather only prevents ELEMENTAL routines from being
5797 automatically PURE. */
5798 if (gfc_match ("impure% ") == MATCH_YES
)
5800 if (!gfc_notify_std (GFC_STD_F2008
, "IMPURE procedure at %C"))
5804 found_prefix
= true;
5807 while (found_prefix
);
5809 /* IMPURE and PURE must not both appear, of course. */
5810 if (seen_impure
&& current_attr
.pure
)
5812 gfc_error ("PURE and IMPURE must not appear both at %C");
5816 /* If IMPURE it not seen but the procedure is ELEMENTAL, mark it as PURE. */
5817 if (!seen_impure
&& current_attr
.elemental
&& !current_attr
.pure
)
5819 if (!gfc_add_pure (¤t_attr
, NULL
))
5823 /* At this point, the next item is not a prefix. */
5824 gcc_assert (gfc_matching_prefix
);
5826 gfc_matching_prefix
= false;
5830 gcc_assert (gfc_matching_prefix
);
5831 gfc_matching_prefix
= false;
5836 /* Copy attributes matched by gfc_match_prefix() to attributes on a symbol. */
5839 copy_prefix (symbol_attribute
*dest
, locus
*where
)
5841 if (dest
->module_procedure
)
5843 if (current_attr
.elemental
)
5844 dest
->elemental
= 1;
5846 if (current_attr
.pure
)
5849 if (current_attr
.recursive
)
5850 dest
->recursive
= 1;
5852 /* Module procedures are unusual in that the 'dest' is copied from
5853 the interface declaration. However, this is an oportunity to
5854 check that the submodule declaration is compliant with the
5856 if (dest
->elemental
&& !current_attr
.elemental
)
5858 gfc_error ("ELEMENTAL prefix in MODULE PROCEDURE interface is "
5859 "missing at %L", where
);
5863 if (dest
->pure
&& !current_attr
.pure
)
5865 gfc_error ("PURE prefix in MODULE PROCEDURE interface is "
5866 "missing at %L", where
);
5870 if (dest
->recursive
&& !current_attr
.recursive
)
5872 gfc_error ("RECURSIVE prefix in MODULE PROCEDURE interface is "
5873 "missing at %L", where
);
5880 if (current_attr
.elemental
&& !gfc_add_elemental (dest
, where
))
5883 if (current_attr
.pure
&& !gfc_add_pure (dest
, where
))
5886 if (current_attr
.recursive
&& !gfc_add_recursive (dest
, where
))
5893 /* Match a formal argument list or, if typeparam is true, a
5894 type_param_name_list. */
5897 gfc_match_formal_arglist (gfc_symbol
*progname
, int st_flag
,
5898 int null_flag
, bool typeparam
)
5900 gfc_formal_arglist
*head
, *tail
, *p
, *q
;
5901 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5904 gfc_formal_arglist
*formal
= NULL
;
5908 /* Keep the interface formal argument list and null it so that the
5909 matching for the new declaration can be done. The numbers and
5910 names of the arguments are checked here. The interface formal
5911 arguments are retained in formal_arglist and the characteristics
5912 are compared in resolve.c(resolve_fl_procedure). See the remark
5913 in get_proc_name about the eventual need to copy the formal_arglist
5914 and populate the formal namespace of the interface symbol. */
5915 if (progname
->attr
.module_procedure
5916 && progname
->attr
.host_assoc
)
5918 formal
= progname
->formal
;
5919 progname
->formal
= NULL
;
5922 if (gfc_match_char ('(') != MATCH_YES
)
5929 if (gfc_match_char (')') == MATCH_YES
)
5934 if (gfc_match_char ('*') == MATCH_YES
)
5937 if (!gfc_notify_std (GFC_STD_F95_OBS
, "Alternate-return argument "
5946 m
= gfc_match_name (name
);
5950 if (!typeparam
&& gfc_get_symbol (name
, NULL
, &sym
))
5953 && gfc_get_symbol (name
, progname
->f2k_derived
, &sym
))
5957 p
= gfc_get_formal_arglist ();
5969 /* We don't add the VARIABLE flavor because the name could be a
5970 dummy procedure. We don't apply these attributes to formal
5971 arguments of statement functions. */
5972 if (sym
!= NULL
&& !st_flag
5973 && (!gfc_add_dummy(&sym
->attr
, sym
->name
, NULL
)
5974 || !gfc_missing_attr (&sym
->attr
, NULL
)))
5980 /* The name of a program unit can be in a different namespace,
5981 so check for it explicitly. After the statement is accepted,
5982 the name is checked for especially in gfc_get_symbol(). */
5983 if (gfc_new_block
!= NULL
&& sym
!= NULL
5984 && strcmp (sym
->name
, gfc_new_block
->name
) == 0)
5986 gfc_error ("Name %qs at %C is the name of the procedure",
5992 if (gfc_match_char (')') == MATCH_YES
)
5995 m
= gfc_match_char (',');
5998 gfc_error ("Unexpected junk in formal argument list at %C");
6004 /* Check for duplicate symbols in the formal argument list. */
6007 for (p
= head
; p
->next
; p
= p
->next
)
6012 for (q
= p
->next
; q
; q
= q
->next
)
6013 if (p
->sym
== q
->sym
)
6015 gfc_error ("Duplicate symbol %qs in formal argument list "
6016 "at %C", p
->sym
->name
);
6024 if (!gfc_add_explicit_interface (progname
, IFSRC_DECL
, head
, NULL
))
6030 /* gfc_error_now used in following and return with MATCH_YES because
6031 doing otherwise results in a cascade of extraneous errors and in
6032 some cases an ICE in symbol.c(gfc_release_symbol). */
6033 if (progname
->attr
.module_procedure
&& progname
->attr
.host_assoc
)
6035 bool arg_count_mismatch
= false;
6037 if (!formal
&& head
)
6038 arg_count_mismatch
= true;
6040 /* Abbreviated module procedure declaration is not meant to have any
6041 formal arguments! */
6042 if (!progname
->abr_modproc_decl
&& formal
&& !head
)
6043 arg_count_mismatch
= true;
6045 for (p
= formal
, q
= head
; p
&& q
; p
= p
->next
, q
= q
->next
)
6047 if ((p
->next
!= NULL
&& q
->next
== NULL
)
6048 || (p
->next
== NULL
&& q
->next
!= NULL
))
6049 arg_count_mismatch
= true;
6050 else if ((p
->sym
== NULL
&& q
->sym
== NULL
)
6051 || strcmp (p
->sym
->name
, q
->sym
->name
) == 0)
6054 gfc_error_now ("Mismatch in MODULE PROCEDURE formal "
6055 "argument names (%s/%s) at %C",
6056 p
->sym
->name
, q
->sym
->name
);
6059 if (arg_count_mismatch
)
6060 gfc_error_now ("Mismatch in number of MODULE PROCEDURE "
6061 "formal arguments at %C");
6067 gfc_free_formal_arglist (head
);
6072 /* Match a RESULT specification following a function declaration or
6073 ENTRY statement. Also matches the end-of-statement. */
6076 match_result (gfc_symbol
*function
, gfc_symbol
**result
)
6078 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6082 if (gfc_match (" result (") != MATCH_YES
)
6085 m
= gfc_match_name (name
);
6089 /* Get the right paren, and that's it because there could be the
6090 bind(c) attribute after the result clause. */
6091 if (gfc_match_char (')') != MATCH_YES
)
6093 /* TODO: should report the missing right paren here. */
6097 if (strcmp (function
->name
, name
) == 0)
6099 gfc_error ("RESULT variable at %C must be different than function name");
6103 if (gfc_get_symbol (name
, NULL
, &r
))
6106 if (!gfc_add_result (&r
->attr
, r
->name
, NULL
))
6115 /* Match a function suffix, which could be a combination of a result
6116 clause and BIND(C), either one, or neither. The draft does not
6117 require them to come in a specific order. */
6120 gfc_match_suffix (gfc_symbol
*sym
, gfc_symbol
**result
)
6122 match is_bind_c
; /* Found bind(c). */
6123 match is_result
; /* Found result clause. */
6124 match found_match
; /* Status of whether we've found a good match. */
6125 char peek_char
; /* Character we're going to peek at. */
6126 bool allow_binding_name
;
6128 /* Initialize to having found nothing. */
6129 found_match
= MATCH_NO
;
6130 is_bind_c
= MATCH_NO
;
6131 is_result
= MATCH_NO
;
6133 /* Get the next char to narrow between result and bind(c). */
6134 gfc_gobble_whitespace ();
6135 peek_char
= gfc_peek_ascii_char ();
6137 /* C binding names are not allowed for internal procedures. */
6138 if (gfc_current_state () == COMP_CONTAINS
6139 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
6140 allow_binding_name
= false;
6142 allow_binding_name
= true;
6147 /* Look for result clause. */
6148 is_result
= match_result (sym
, result
);
6149 if (is_result
== MATCH_YES
)
6151 /* Now see if there is a bind(c) after it. */
6152 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
6153 /* We've found the result clause and possibly bind(c). */
6154 found_match
= MATCH_YES
;
6157 /* This should only be MATCH_ERROR. */
6158 found_match
= is_result
;
6161 /* Look for bind(c) first. */
6162 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
6163 if (is_bind_c
== MATCH_YES
)
6165 /* Now see if a result clause followed it. */
6166 is_result
= match_result (sym
, result
);
6167 found_match
= MATCH_YES
;
6171 /* Should only be a MATCH_ERROR if we get here after seeing 'b'. */
6172 found_match
= MATCH_ERROR
;
6176 gfc_error ("Unexpected junk after function declaration at %C");
6177 found_match
= MATCH_ERROR
;
6181 if (is_bind_c
== MATCH_YES
)
6183 /* Fortran 2008 draft allows BIND(C) for internal procedures. */
6184 if (gfc_current_state () == COMP_CONTAINS
6185 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
6186 && !gfc_notify_std (GFC_STD_F2008
, "BIND(C) attribute "
6187 "at %L may not be specified for an internal "
6188 "procedure", &gfc_current_locus
))
6191 if (!gfc_add_is_bind_c (&(sym
->attr
), sym
->name
, &gfc_current_locus
, 1))
6199 /* Procedure pointer return value without RESULT statement:
6200 Add "hidden" result variable named "ppr@". */
6203 add_hidden_procptr_result (gfc_symbol
*sym
)
6207 if (gfc_notification_std (GFC_STD_F2003
) == ERROR
)
6210 /* First usage case: PROCEDURE and EXTERNAL statements. */
6211 case1
= gfc_current_state () == COMP_FUNCTION
&& gfc_current_block ()
6212 && strcmp (gfc_current_block ()->name
, sym
->name
) == 0
6213 && sym
->attr
.external
;
6214 /* Second usage case: INTERFACE statements. */
6215 case2
= gfc_current_state () == COMP_INTERFACE
&& gfc_state_stack
->previous
6216 && gfc_state_stack
->previous
->state
== COMP_FUNCTION
6217 && strcmp (gfc_state_stack
->previous
->sym
->name
, sym
->name
) == 0;
6223 gfc_get_sym_tree ("ppr@", gfc_current_ns
, &stree
, false);
6227 gfc_get_sym_tree ("ppr@", gfc_current_ns
->parent
, &stree
, false);
6228 st2
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "ppr@");
6229 st2
->n
.sym
= stree
->n
.sym
;
6230 stree
->n
.sym
->refs
++;
6232 sym
->result
= stree
->n
.sym
;
6234 sym
->result
->attr
.proc_pointer
= sym
->attr
.proc_pointer
;
6235 sym
->result
->attr
.pointer
= sym
->attr
.pointer
;
6236 sym
->result
->attr
.external
= sym
->attr
.external
;
6237 sym
->result
->attr
.referenced
= sym
->attr
.referenced
;
6238 sym
->result
->ts
= sym
->ts
;
6239 sym
->attr
.proc_pointer
= 0;
6240 sym
->attr
.pointer
= 0;
6241 sym
->attr
.external
= 0;
6242 if (sym
->result
->attr
.external
&& sym
->result
->attr
.pointer
)
6244 sym
->result
->attr
.pointer
= 0;
6245 sym
->result
->attr
.proc_pointer
= 1;
6248 return gfc_add_result (&sym
->result
->attr
, sym
->result
->name
, NULL
);
6250 /* POINTER after PROCEDURE/EXTERNAL/INTERFACE statement. */
6251 else if (sym
->attr
.function
&& !sym
->attr
.external
&& sym
->attr
.pointer
6252 && sym
->result
&& sym
->result
!= sym
&& sym
->result
->attr
.external
6253 && sym
== gfc_current_ns
->proc_name
6254 && sym
== sym
->result
->ns
->proc_name
6255 && strcmp ("ppr@", sym
->result
->name
) == 0)
6257 sym
->result
->attr
.proc_pointer
= 1;
6258 sym
->attr
.pointer
= 0;
6266 /* Match the interface for a PROCEDURE declaration,
6267 including brackets (R1212). */
6270 match_procedure_interface (gfc_symbol
**proc_if
)
6274 locus old_loc
, entry_loc
;
6275 gfc_namespace
*old_ns
= gfc_current_ns
;
6276 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6278 old_loc
= entry_loc
= gfc_current_locus
;
6279 gfc_clear_ts (¤t_ts
);
6281 if (gfc_match (" (") != MATCH_YES
)
6283 gfc_current_locus
= entry_loc
;
6287 /* Get the type spec. for the procedure interface. */
6288 old_loc
= gfc_current_locus
;
6289 m
= gfc_match_decl_type_spec (¤t_ts
, 0);
6290 gfc_gobble_whitespace ();
6291 if (m
== MATCH_YES
|| (m
== MATCH_NO
&& gfc_peek_ascii_char () == ')'))
6294 if (m
== MATCH_ERROR
)
6297 /* Procedure interface is itself a procedure. */
6298 gfc_current_locus
= old_loc
;
6299 m
= gfc_match_name (name
);
6301 /* First look to see if it is already accessible in the current
6302 namespace because it is use associated or contained. */
6304 if (gfc_find_sym_tree (name
, NULL
, 0, &st
))
6307 /* If it is still not found, then try the parent namespace, if it
6308 exists and create the symbol there if it is still not found. */
6309 if (gfc_current_ns
->parent
)
6310 gfc_current_ns
= gfc_current_ns
->parent
;
6311 if (st
== NULL
&& gfc_get_ha_sym_tree (name
, &st
))
6314 gfc_current_ns
= old_ns
;
6315 *proc_if
= st
->n
.sym
;
6320 /* Resolve interface if possible. That way, attr.procedure is only set
6321 if it is declared by a later procedure-declaration-stmt, which is
6322 invalid per F08:C1216 (cf. resolve_procedure_interface). */
6323 while ((*proc_if
)->ts
.interface
6324 && *proc_if
!= (*proc_if
)->ts
.interface
)
6325 *proc_if
= (*proc_if
)->ts
.interface
;
6327 if ((*proc_if
)->attr
.flavor
== FL_UNKNOWN
6328 && (*proc_if
)->ts
.type
== BT_UNKNOWN
6329 && !gfc_add_flavor (&(*proc_if
)->attr
, FL_PROCEDURE
,
6330 (*proc_if
)->name
, NULL
))
6335 if (gfc_match (" )") != MATCH_YES
)
6337 gfc_current_locus
= entry_loc
;
6345 /* Match a PROCEDURE declaration (R1211). */
6348 match_procedure_decl (void)
6351 gfc_symbol
*sym
, *proc_if
= NULL
;
6353 gfc_expr
*initializer
= NULL
;
6355 /* Parse interface (with brackets). */
6356 m
= match_procedure_interface (&proc_if
);
6360 /* Parse attributes (with colons). */
6361 m
= match_attr_spec();
6362 if (m
== MATCH_ERROR
)
6365 if (proc_if
&& proc_if
->attr
.is_bind_c
&& !current_attr
.is_bind_c
)
6367 current_attr
.is_bind_c
= 1;
6368 has_name_equals
= 0;
6369 curr_binding_label
= NULL
;
6372 /* Get procedure symbols. */
6375 m
= gfc_match_symbol (&sym
, 0);
6378 else if (m
== MATCH_ERROR
)
6381 /* Add current_attr to the symbol attributes. */
6382 if (!gfc_copy_attr (&sym
->attr
, ¤t_attr
, NULL
))
6385 if (sym
->attr
.is_bind_c
)
6387 /* Check for C1218. */
6388 if (!proc_if
|| !proc_if
->attr
.is_bind_c
)
6390 gfc_error ("BIND(C) attribute at %C requires "
6391 "an interface with BIND(C)");
6394 /* Check for C1217. */
6395 if (has_name_equals
&& sym
->attr
.pointer
)
6397 gfc_error ("BIND(C) procedure with NAME may not have "
6398 "POINTER attribute at %C");
6401 if (has_name_equals
&& sym
->attr
.dummy
)
6403 gfc_error ("Dummy procedure at %C may not have "
6404 "BIND(C) attribute with NAME");
6407 /* Set binding label for BIND(C). */
6408 if (!set_binding_label (&sym
->binding_label
, sym
->name
, num
))
6412 if (!gfc_add_external (&sym
->attr
, NULL
))
6415 if (add_hidden_procptr_result (sym
))
6418 if (!gfc_add_proc (&sym
->attr
, sym
->name
, NULL
))
6421 /* Set interface. */
6422 if (proc_if
!= NULL
)
6424 if (sym
->ts
.type
!= BT_UNKNOWN
)
6426 gfc_error ("Procedure %qs at %L already has basic type of %s",
6427 sym
->name
, &gfc_current_locus
,
6428 gfc_basic_typename (sym
->ts
.type
));
6431 sym
->ts
.interface
= proc_if
;
6432 sym
->attr
.untyped
= 1;
6433 sym
->attr
.if_source
= IFSRC_IFBODY
;
6435 else if (current_ts
.type
!= BT_UNKNOWN
)
6437 if (!gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
6439 sym
->ts
.interface
= gfc_new_symbol ("", gfc_current_ns
);
6440 sym
->ts
.interface
->ts
= current_ts
;
6441 sym
->ts
.interface
->attr
.flavor
= FL_PROCEDURE
;
6442 sym
->ts
.interface
->attr
.function
= 1;
6443 sym
->attr
.function
= 1;
6444 sym
->attr
.if_source
= IFSRC_UNKNOWN
;
6447 if (gfc_match (" =>") == MATCH_YES
)
6449 if (!current_attr
.pointer
)
6451 gfc_error ("Initialization at %C isn't for a pointer variable");
6456 m
= match_pointer_init (&initializer
, 1);
6460 if (!add_init_expr_to_sym (sym
->name
, &initializer
, &gfc_current_locus
))
6465 if (gfc_match_eos () == MATCH_YES
)
6467 if (gfc_match_char (',') != MATCH_YES
)
6472 gfc_error ("Syntax error in PROCEDURE statement at %C");
6476 /* Free stuff up and return. */
6477 gfc_free_expr (initializer
);
6483 match_binding_attributes (gfc_typebound_proc
* ba
, bool generic
, bool ppc
);
6486 /* Match a procedure pointer component declaration (R445). */
6489 match_ppc_decl (void)
6492 gfc_symbol
*proc_if
= NULL
;
6496 gfc_expr
*initializer
= NULL
;
6497 gfc_typebound_proc
* tb
;
6498 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6500 /* Parse interface (with brackets). */
6501 m
= match_procedure_interface (&proc_if
);
6505 /* Parse attributes. */
6506 tb
= XCNEW (gfc_typebound_proc
);
6507 tb
->where
= gfc_current_locus
;
6508 m
= match_binding_attributes (tb
, false, true);
6509 if (m
== MATCH_ERROR
)
6512 gfc_clear_attr (¤t_attr
);
6513 current_attr
.procedure
= 1;
6514 current_attr
.proc_pointer
= 1;
6515 current_attr
.access
= tb
->access
;
6516 current_attr
.flavor
= FL_PROCEDURE
;
6518 /* Match the colons (required). */
6519 if (gfc_match (" ::") != MATCH_YES
)
6521 gfc_error ("Expected %<::%> after binding-attributes at %C");
6525 /* Check for C450. */
6526 if (!tb
->nopass
&& proc_if
== NULL
)
6528 gfc_error("NOPASS or explicit interface required at %C");
6532 if (!gfc_notify_std (GFC_STD_F2003
, "Procedure pointer component at %C"))
6535 /* Match PPC names. */
6539 m
= gfc_match_name (name
);
6542 else if (m
== MATCH_ERROR
)
6545 if (!gfc_add_component (gfc_current_block(), name
, &c
))
6548 /* Add current_attr to the symbol attributes. */
6549 if (!gfc_copy_attr (&c
->attr
, ¤t_attr
, NULL
))
6552 if (!gfc_add_external (&c
->attr
, NULL
))
6555 if (!gfc_add_proc (&c
->attr
, name
, NULL
))
6562 c
->tb
= XCNEW (gfc_typebound_proc
);
6563 c
->tb
->where
= gfc_current_locus
;
6567 /* Set interface. */
6568 if (proc_if
!= NULL
)
6570 c
->ts
.interface
= proc_if
;
6571 c
->attr
.untyped
= 1;
6572 c
->attr
.if_source
= IFSRC_IFBODY
;
6574 else if (ts
.type
!= BT_UNKNOWN
)
6577 c
->ts
.interface
= gfc_new_symbol ("", gfc_current_ns
);
6578 c
->ts
.interface
->result
= c
->ts
.interface
;
6579 c
->ts
.interface
->ts
= ts
;
6580 c
->ts
.interface
->attr
.flavor
= FL_PROCEDURE
;
6581 c
->ts
.interface
->attr
.function
= 1;
6582 c
->attr
.function
= 1;
6583 c
->attr
.if_source
= IFSRC_UNKNOWN
;
6586 if (gfc_match (" =>") == MATCH_YES
)
6588 m
= match_pointer_init (&initializer
, 1);
6591 gfc_free_expr (initializer
);
6594 c
->initializer
= initializer
;
6597 if (gfc_match_eos () == MATCH_YES
)
6599 if (gfc_match_char (',') != MATCH_YES
)
6604 gfc_error ("Syntax error in procedure pointer component at %C");
6609 /* Match a PROCEDURE declaration inside an interface (R1206). */
6612 match_procedure_in_interface (void)
6616 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6619 if (current_interface
.type
== INTERFACE_NAMELESS
6620 || current_interface
.type
== INTERFACE_ABSTRACT
)
6622 gfc_error ("PROCEDURE at %C must be in a generic interface");
6626 /* Check if the F2008 optional double colon appears. */
6627 gfc_gobble_whitespace ();
6628 old_locus
= gfc_current_locus
;
6629 if (gfc_match ("::") == MATCH_YES
)
6631 if (!gfc_notify_std (GFC_STD_F2008
, "double colon in "
6632 "MODULE PROCEDURE statement at %L", &old_locus
))
6636 gfc_current_locus
= old_locus
;
6640 m
= gfc_match_name (name
);
6643 else if (m
== MATCH_ERROR
)
6645 if (gfc_get_symbol (name
, gfc_current_ns
->parent
, &sym
))
6648 if (!gfc_add_interface (sym
))
6651 if (gfc_match_eos () == MATCH_YES
)
6653 if (gfc_match_char (',') != MATCH_YES
)
6660 gfc_error ("Syntax error in PROCEDURE statement at %C");
6665 /* General matcher for PROCEDURE declarations. */
6667 static match
match_procedure_in_type (void);
6670 gfc_match_procedure (void)
6674 switch (gfc_current_state ())
6679 case COMP_SUBMODULE
:
6680 case COMP_SUBROUTINE
:
6683 m
= match_procedure_decl ();
6685 case COMP_INTERFACE
:
6686 m
= match_procedure_in_interface ();
6689 m
= match_ppc_decl ();
6691 case COMP_DERIVED_CONTAINS
:
6692 m
= match_procedure_in_type ();
6701 if (!gfc_notify_std (GFC_STD_F2003
, "PROCEDURE statement at %C"))
6708 /* Warn if a matched procedure has the same name as an intrinsic; this is
6709 simply a wrapper around gfc_warn_intrinsic_shadow that interprets the current
6710 parser-state-stack to find out whether we're in a module. */
6713 do_warn_intrinsic_shadow (const gfc_symbol
* sym
, bool func
)
6717 in_module
= (gfc_state_stack
->previous
6718 && (gfc_state_stack
->previous
->state
== COMP_MODULE
6719 || gfc_state_stack
->previous
->state
== COMP_SUBMODULE
));
6721 gfc_warn_intrinsic_shadow (sym
, in_module
, func
);
6725 /* Match a function declaration. */
6728 gfc_match_function_decl (void)
6730 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6731 gfc_symbol
*sym
, *result
;
6735 match found_match
; /* Status returned by match func. */
6737 if (gfc_current_state () != COMP_NONE
6738 && gfc_current_state () != COMP_INTERFACE
6739 && gfc_current_state () != COMP_CONTAINS
)
6742 gfc_clear_ts (¤t_ts
);
6744 old_loc
= gfc_current_locus
;
6746 m
= gfc_match_prefix (¤t_ts
);
6749 gfc_current_locus
= old_loc
;
6753 if (gfc_match ("function% %n", name
) != MATCH_YES
)
6755 gfc_current_locus
= old_loc
;
6759 if (get_proc_name (name
, &sym
, false))
6762 if (add_hidden_procptr_result (sym
))
6765 if (current_attr
.module_procedure
)
6766 sym
->attr
.module_procedure
= 1;
6768 gfc_new_block
= sym
;
6770 m
= gfc_match_formal_arglist (sym
, 0, 0);
6773 gfc_error ("Expected formal argument list in function "
6774 "definition at %C");
6778 else if (m
== MATCH_ERROR
)
6783 /* According to the draft, the bind(c) and result clause can
6784 come in either order after the formal_arg_list (i.e., either
6785 can be first, both can exist together or by themselves or neither
6786 one). Therefore, the match_result can't match the end of the
6787 string, and check for the bind(c) or result clause in either order. */
6788 found_match
= gfc_match_eos ();
6790 /* Make sure that it isn't already declared as BIND(C). If it is, it
6791 must have been marked BIND(C) with a BIND(C) attribute and that is
6792 not allowed for procedures. */
6793 if (sym
->attr
.is_bind_c
== 1)
6795 sym
->attr
.is_bind_c
= 0;
6796 if (sym
->old_symbol
!= NULL
)
6797 gfc_error_now ("BIND(C) attribute at %L can only be used for "
6798 "variables or common blocks",
6799 &(sym
->old_symbol
->declared_at
));
6801 gfc_error_now ("BIND(C) attribute at %L can only be used for "
6802 "variables or common blocks", &gfc_current_locus
);
6805 if (found_match
!= MATCH_YES
)
6807 /* If we haven't found the end-of-statement, look for a suffix. */
6808 suffix_match
= gfc_match_suffix (sym
, &result
);
6809 if (suffix_match
== MATCH_YES
)
6810 /* Need to get the eos now. */
6811 found_match
= gfc_match_eos ();
6813 found_match
= suffix_match
;
6816 if(found_match
!= MATCH_YES
)
6820 /* Make changes to the symbol. */
6823 if (!gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
6826 if (!gfc_missing_attr (&sym
->attr
, NULL
))
6829 if (!copy_prefix (&sym
->attr
, &sym
->declared_at
))
6831 if(!sym
->attr
.module_procedure
)
6837 /* Delay matching the function characteristics until after the
6838 specification block by signalling kind=-1. */
6839 sym
->declared_at
= old_loc
;
6840 if (current_ts
.type
!= BT_UNKNOWN
)
6841 current_ts
.kind
= -1;
6843 current_ts
.kind
= 0;
6847 if (current_ts
.type
!= BT_UNKNOWN
6848 && !gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
6854 if (current_ts
.type
!= BT_UNKNOWN
6855 && !gfc_add_type (result
, ¤t_ts
, &gfc_current_locus
))
6857 sym
->result
= result
;
6860 /* Warn if this procedure has the same name as an intrinsic. */
6861 do_warn_intrinsic_shadow (sym
, true);
6867 gfc_current_locus
= old_loc
;
6872 /* This is mostly a copy of parse.c(add_global_procedure) but modified to
6873 pass the name of the entry, rather than the gfc_current_block name, and
6874 to return false upon finding an existing global entry. */
6877 add_global_entry (const char *name
, const char *binding_label
, bool sub
,
6881 enum gfc_symbol_type type
;
6883 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
6885 /* Only in Fortran 2003: For procedures with a binding label also the Fortran
6886 name is a global identifier. */
6887 if (!binding_label
|| gfc_notification_std (GFC_STD_F2008
))
6889 s
= gfc_get_gsymbol (name
);
6891 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= type
))
6893 gfc_global_used (s
, where
);
6902 s
->ns
= gfc_current_ns
;
6906 /* Don't add the symbol multiple times. */
6908 && (!gfc_notification_std (GFC_STD_F2008
)
6909 || strcmp (name
, binding_label
) != 0))
6911 s
= gfc_get_gsymbol (binding_label
);
6913 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= type
))
6915 gfc_global_used (s
, where
);
6922 s
->binding_label
= binding_label
;
6925 s
->ns
= gfc_current_ns
;
6933 /* Match an ENTRY statement. */
6936 gfc_match_entry (void)
6941 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6942 gfc_compile_state state
;
6946 bool module_procedure
;
6950 m
= gfc_match_name (name
);
6954 if (!gfc_notify_std (GFC_STD_F2008_OBS
, "ENTRY statement at %C"))
6957 state
= gfc_current_state ();
6958 if (state
!= COMP_SUBROUTINE
&& state
!= COMP_FUNCTION
)
6963 gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
6966 gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
6968 case COMP_SUBMODULE
:
6969 gfc_error ("ENTRY statement at %C cannot appear within a SUBMODULE");
6971 case COMP_BLOCK_DATA
:
6972 gfc_error ("ENTRY statement at %C cannot appear within "
6975 case COMP_INTERFACE
:
6976 gfc_error ("ENTRY statement at %C cannot appear within "
6979 case COMP_STRUCTURE
:
6980 gfc_error ("ENTRY statement at %C cannot appear within "
6981 "a STRUCTURE block");
6984 gfc_error ("ENTRY statement at %C cannot appear within "
6985 "a DERIVED TYPE block");
6988 gfc_error ("ENTRY statement at %C cannot appear within "
6989 "an IF-THEN block");
6992 case COMP_DO_CONCURRENT
:
6993 gfc_error ("ENTRY statement at %C cannot appear within "
6997 gfc_error ("ENTRY statement at %C cannot appear within "
7001 gfc_error ("ENTRY statement at %C cannot appear within "
7005 gfc_error ("ENTRY statement at %C cannot appear within "
7009 gfc_error ("ENTRY statement at %C cannot appear within "
7010 "a contained subprogram");
7013 gfc_error ("Unexpected ENTRY statement at %C");
7018 if ((state
== COMP_SUBROUTINE
|| state
== COMP_FUNCTION
)
7019 && gfc_state_stack
->previous
->state
== COMP_INTERFACE
)
7021 gfc_error ("ENTRY statement at %C cannot appear within an INTERFACE");
7025 module_procedure
= gfc_current_ns
->parent
!= NULL
7026 && gfc_current_ns
->parent
->proc_name
7027 && gfc_current_ns
->parent
->proc_name
->attr
.flavor
7030 if (gfc_current_ns
->parent
!= NULL
7031 && gfc_current_ns
->parent
->proc_name
7032 && !module_procedure
)
7034 gfc_error("ENTRY statement at %C cannot appear in a "
7035 "contained procedure");
7039 /* Module function entries need special care in get_proc_name
7040 because previous references within the function will have
7041 created symbols attached to the current namespace. */
7042 if (get_proc_name (name
, &entry
,
7043 gfc_current_ns
->parent
!= NULL
7044 && module_procedure
))
7047 proc
= gfc_current_block ();
7049 /* Make sure that it isn't already declared as BIND(C). If it is, it
7050 must have been marked BIND(C) with a BIND(C) attribute and that is
7051 not allowed for procedures. */
7052 if (entry
->attr
.is_bind_c
== 1)
7054 entry
->attr
.is_bind_c
= 0;
7055 if (entry
->old_symbol
!= NULL
)
7056 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7057 "variables or common blocks",
7058 &(entry
->old_symbol
->declared_at
));
7060 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7061 "variables or common blocks", &gfc_current_locus
);
7064 /* Check what next non-whitespace character is so we can tell if there
7065 is the required parens if we have a BIND(C). */
7066 old_loc
= gfc_current_locus
;
7067 gfc_gobble_whitespace ();
7068 peek_char
= gfc_peek_ascii_char ();
7070 if (state
== COMP_SUBROUTINE
)
7072 m
= gfc_match_formal_arglist (entry
, 0, 1);
7076 /* Call gfc_match_bind_c with allow_binding_name = true as ENTRY can
7077 never be an internal procedure. */
7078 is_bind_c
= gfc_match_bind_c (entry
, true);
7079 if (is_bind_c
== MATCH_ERROR
)
7081 if (is_bind_c
== MATCH_YES
)
7083 if (peek_char
!= '(')
7085 gfc_error ("Missing required parentheses before BIND(C) at %C");
7088 if (!gfc_add_is_bind_c (&(entry
->attr
), entry
->name
,
7089 &(entry
->declared_at
), 1))
7093 if (!gfc_current_ns
->parent
7094 && !add_global_entry (name
, entry
->binding_label
, true,
7098 /* An entry in a subroutine. */
7099 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
7100 || !gfc_add_subroutine (&entry
->attr
, entry
->name
, NULL
))
7105 /* An entry in a function.
7106 We need to take special care because writing
7111 ENTRY f() RESULT (r)
7113 ENTRY f RESULT (r). */
7114 if (gfc_match_eos () == MATCH_YES
)
7116 gfc_current_locus
= old_loc
;
7117 /* Match the empty argument list, and add the interface to
7119 m
= gfc_match_formal_arglist (entry
, 0, 1);
7122 m
= gfc_match_formal_arglist (entry
, 0, 0);
7129 if (gfc_match_eos () == MATCH_YES
)
7131 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
7132 || !gfc_add_function (&entry
->attr
, entry
->name
, NULL
))
7135 entry
->result
= entry
;
7139 m
= gfc_match_suffix (entry
, &result
);
7141 gfc_syntax_error (ST_ENTRY
);
7147 if (!gfc_add_result (&result
->attr
, result
->name
, NULL
)
7148 || !gfc_add_entry (&entry
->attr
, result
->name
, NULL
)
7149 || !gfc_add_function (&entry
->attr
, result
->name
, NULL
))
7151 entry
->result
= result
;
7155 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
7156 || !gfc_add_function (&entry
->attr
, entry
->name
, NULL
))
7158 entry
->result
= entry
;
7162 if (!gfc_current_ns
->parent
7163 && !add_global_entry (name
, entry
->binding_label
, false,
7168 if (gfc_match_eos () != MATCH_YES
)
7170 gfc_syntax_error (ST_ENTRY
);
7174 entry
->attr
.recursive
= proc
->attr
.recursive
;
7175 entry
->attr
.elemental
= proc
->attr
.elemental
;
7176 entry
->attr
.pure
= proc
->attr
.pure
;
7178 el
= gfc_get_entry_list ();
7180 el
->next
= gfc_current_ns
->entries
;
7181 gfc_current_ns
->entries
= el
;
7183 el
->id
= el
->next
->id
+ 1;
7187 new_st
.op
= EXEC_ENTRY
;
7188 new_st
.ext
.entry
= el
;
7194 /* Match a subroutine statement, including optional prefixes. */
7197 gfc_match_subroutine (void)
7199 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7204 bool allow_binding_name
;
7206 if (gfc_current_state () != COMP_NONE
7207 && gfc_current_state () != COMP_INTERFACE
7208 && gfc_current_state () != COMP_CONTAINS
)
7211 m
= gfc_match_prefix (NULL
);
7215 m
= gfc_match ("subroutine% %n", name
);
7219 if (get_proc_name (name
, &sym
, false))
7222 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
7223 the symbol existed before. */
7224 sym
->declared_at
= gfc_current_locus
;
7226 if (current_attr
.module_procedure
)
7227 sym
->attr
.module_procedure
= 1;
7229 if (add_hidden_procptr_result (sym
))
7232 gfc_new_block
= sym
;
7234 /* Check what next non-whitespace character is so we can tell if there
7235 is the required parens if we have a BIND(C). */
7236 gfc_gobble_whitespace ();
7237 peek_char
= gfc_peek_ascii_char ();
7239 if (!gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
))
7242 if (gfc_match_formal_arglist (sym
, 0, 1) != MATCH_YES
)
7245 /* Make sure that it isn't already declared as BIND(C). If it is, it
7246 must have been marked BIND(C) with a BIND(C) attribute and that is
7247 not allowed for procedures. */
7248 if (sym
->attr
.is_bind_c
== 1)
7250 sym
->attr
.is_bind_c
= 0;
7251 if (sym
->old_symbol
!= NULL
)
7252 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7253 "variables or common blocks",
7254 &(sym
->old_symbol
->declared_at
));
7256 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7257 "variables or common blocks", &gfc_current_locus
);
7260 /* C binding names are not allowed for internal procedures. */
7261 if (gfc_current_state () == COMP_CONTAINS
7262 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
7263 allow_binding_name
= false;
7265 allow_binding_name
= true;
7267 /* Here, we are just checking if it has the bind(c) attribute, and if
7268 so, then we need to make sure it's all correct. If it doesn't,
7269 we still need to continue matching the rest of the subroutine line. */
7270 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
7271 if (is_bind_c
== MATCH_ERROR
)
7273 /* There was an attempt at the bind(c), but it was wrong. An
7274 error message should have been printed w/in the gfc_match_bind_c
7275 so here we'll just return the MATCH_ERROR. */
7279 if (is_bind_c
== MATCH_YES
)
7281 /* The following is allowed in the Fortran 2008 draft. */
7282 if (gfc_current_state () == COMP_CONTAINS
7283 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
7284 && !gfc_notify_std (GFC_STD_F2008
, "BIND(C) attribute "
7285 "at %L may not be specified for an internal "
7286 "procedure", &gfc_current_locus
))
7289 if (peek_char
!= '(')
7291 gfc_error ("Missing required parentheses before BIND(C) at %C");
7294 if (!gfc_add_is_bind_c (&(sym
->attr
), sym
->name
,
7295 &(sym
->declared_at
), 1))
7299 if (gfc_match_eos () != MATCH_YES
)
7301 gfc_syntax_error (ST_SUBROUTINE
);
7305 if (!copy_prefix (&sym
->attr
, &sym
->declared_at
))
7307 if(!sym
->attr
.module_procedure
)
7313 /* Warn if it has the same name as an intrinsic. */
7314 do_warn_intrinsic_shadow (sym
, false);
7320 /* Check that the NAME identifier in a BIND attribute or statement
7321 is conform to C identifier rules. */
7324 check_bind_name_identifier (char **name
)
7326 char *n
= *name
, *p
;
7328 /* Remove leading spaces. */
7332 /* On an empty string, free memory and set name to NULL. */
7340 /* Remove trailing spaces. */
7341 p
= n
+ strlen(n
) - 1;
7345 /* Insert the identifier into the symbol table. */
7350 /* Now check that identifier is valid under C rules. */
7353 gfc_error ("Invalid C identifier in NAME= specifier at %C");
7358 if (!(ISALNUM (*p
) || *p
== '_' || *p
== '$'))
7360 gfc_error ("Invalid C identifier in NAME= specifier at %C");
7368 /* Match a BIND(C) specifier, with the optional 'name=' specifier if
7369 given, and set the binding label in either the given symbol (if not
7370 NULL), or in the current_ts. The symbol may be NULL because we may
7371 encounter the BIND(C) before the declaration itself. Return
7372 MATCH_NO if what we're looking at isn't a BIND(C) specifier,
7373 MATCH_ERROR if it is a BIND(C) clause but an error was encountered,
7374 or MATCH_YES if the specifier was correct and the binding label and
7375 bind(c) fields were set correctly for the given symbol or the
7376 current_ts. If allow_binding_name is false, no binding name may be
7380 gfc_match_bind_c (gfc_symbol
*sym
, bool allow_binding_name
)
7382 char *binding_label
= NULL
;
7385 /* Initialize the flag that specifies whether we encountered a NAME=
7386 specifier or not. */
7387 has_name_equals
= 0;
7389 /* This much we have to be able to match, in this order, if
7390 there is a bind(c) label. */
7391 if (gfc_match (" bind ( c ") != MATCH_YES
)
7394 /* Now see if there is a binding label, or if we've reached the
7395 end of the bind(c) attribute without one. */
7396 if (gfc_match_char (',') == MATCH_YES
)
7398 if (gfc_match (" name = ") != MATCH_YES
)
7400 gfc_error ("Syntax error in NAME= specifier for binding label "
7402 /* should give an error message here */
7406 has_name_equals
= 1;
7408 if (gfc_match_init_expr (&e
) != MATCH_YES
)
7414 if (!gfc_simplify_expr(e
, 0))
7416 gfc_error ("NAME= specifier at %C should be a constant expression");
7421 if (e
->expr_type
!= EXPR_CONSTANT
|| e
->ts
.type
!= BT_CHARACTER
7422 || e
->ts
.kind
!= gfc_default_character_kind
|| e
->rank
!= 0)
7424 gfc_error ("NAME= specifier at %C should be a scalar of "
7425 "default character kind");
7430 // Get a C string from the Fortran string constant
7431 binding_label
= gfc_widechar_to_char (e
->value
.character
.string
,
7432 e
->value
.character
.length
);
7435 // Check that it is valid (old gfc_match_name_C)
7436 if (check_bind_name_identifier (&binding_label
) != MATCH_YES
)
7440 /* Get the required right paren. */
7441 if (gfc_match_char (')') != MATCH_YES
)
7443 gfc_error ("Missing closing paren for binding label at %C");
7447 if (has_name_equals
&& !allow_binding_name
)
7449 gfc_error ("No binding name is allowed in BIND(C) at %C");
7453 if (has_name_equals
&& sym
!= NULL
&& sym
->attr
.dummy
)
7455 gfc_error ("For dummy procedure %s, no binding name is "
7456 "allowed in BIND(C) at %C", sym
->name
);
7461 /* Save the binding label to the symbol. If sym is null, we're
7462 probably matching the typespec attributes of a declaration and
7463 haven't gotten the name yet, and therefore, no symbol yet. */
7467 sym
->binding_label
= binding_label
;
7469 curr_binding_label
= binding_label
;
7471 else if (allow_binding_name
)
7473 /* No binding label, but if symbol isn't null, we
7474 can set the label for it here.
7475 If name="" or allow_binding_name is false, no C binding name is
7477 if (sym
!= NULL
&& sym
->name
!= NULL
&& has_name_equals
== 0)
7478 sym
->binding_label
= IDENTIFIER_POINTER (get_identifier (sym
->name
));
7481 if (has_name_equals
&& gfc_current_state () == COMP_INTERFACE
7482 && current_interface
.type
== INTERFACE_ABSTRACT
)
7484 gfc_error ("NAME not allowed on BIND(C) for ABSTRACT INTERFACE at %C");
7492 /* Return nonzero if we're currently compiling a contained procedure. */
7495 contained_procedure (void)
7497 gfc_state_data
*s
= gfc_state_stack
;
7499 if ((s
->state
== COMP_SUBROUTINE
|| s
->state
== COMP_FUNCTION
)
7500 && s
->previous
!= NULL
&& s
->previous
->state
== COMP_CONTAINS
)
7506 /* Set the kind of each enumerator. The kind is selected such that it is
7507 interoperable with the corresponding C enumeration type, making
7508 sure that -fshort-enums is honored. */
7513 enumerator_history
*current_history
= NULL
;
7517 if (max_enum
== NULL
|| enum_history
== NULL
)
7520 if (!flag_short_enums
)
7526 kind
= gfc_integer_kinds
[i
++].kind
;
7528 while (kind
< gfc_c_int_kind
7529 && gfc_check_integer_range (max_enum
->initializer
->value
.integer
,
7532 current_history
= enum_history
;
7533 while (current_history
!= NULL
)
7535 current_history
->sym
->ts
.kind
= kind
;
7536 current_history
= current_history
->next
;
7541 /* Match any of the various end-block statements. Returns the type of
7542 END to the caller. The END INTERFACE, END IF, END DO, END SELECT
7543 and END BLOCK statements cannot be replaced by a single END statement. */
7546 gfc_match_end (gfc_statement
*st
)
7548 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7549 gfc_compile_state state
;
7551 const char *block_name
;
7555 gfc_namespace
*parent_ns
, *ns
, *prev_ns
;
7556 gfc_namespace
**nsp
;
7557 bool abreviated_modproc_decl
= false;
7558 bool got_matching_end
= false;
7560 old_loc
= gfc_current_locus
;
7561 if (gfc_match ("end") != MATCH_YES
)
7564 state
= gfc_current_state ();
7565 block_name
= gfc_current_block () == NULL
7566 ? NULL
: gfc_current_block ()->name
;
7570 case COMP_ASSOCIATE
:
7572 if (!strncmp (block_name
, "block@", strlen("block@")))
7577 case COMP_DERIVED_CONTAINS
:
7578 state
= gfc_state_stack
->previous
->state
;
7579 block_name
= gfc_state_stack
->previous
->sym
== NULL
7580 ? NULL
: gfc_state_stack
->previous
->sym
->name
;
7581 abreviated_modproc_decl
= gfc_state_stack
->previous
->sym
7582 && gfc_state_stack
->previous
->sym
->abr_modproc_decl
;
7589 if (!abreviated_modproc_decl
)
7590 abreviated_modproc_decl
= gfc_current_block ()
7591 && gfc_current_block ()->abr_modproc_decl
;
7597 *st
= ST_END_PROGRAM
;
7598 target
= " program";
7602 case COMP_SUBROUTINE
:
7603 *st
= ST_END_SUBROUTINE
;
7604 if (!abreviated_modproc_decl
)
7605 target
= " subroutine";
7607 target
= " procedure";
7608 eos_ok
= !contained_procedure ();
7612 *st
= ST_END_FUNCTION
;
7613 if (!abreviated_modproc_decl
)
7614 target
= " function";
7616 target
= " procedure";
7617 eos_ok
= !contained_procedure ();
7620 case COMP_BLOCK_DATA
:
7621 *st
= ST_END_BLOCK_DATA
;
7622 target
= " block data";
7627 *st
= ST_END_MODULE
;
7632 case COMP_SUBMODULE
:
7633 *st
= ST_END_SUBMODULE
;
7634 target
= " submodule";
7638 case COMP_INTERFACE
:
7639 *st
= ST_END_INTERFACE
;
7640 target
= " interface";
7656 case COMP_STRUCTURE
:
7657 *st
= ST_END_STRUCTURE
;
7658 target
= " structure";
7663 case COMP_DERIVED_CONTAINS
:
7669 case COMP_ASSOCIATE
:
7670 *st
= ST_END_ASSOCIATE
;
7671 target
= " associate";
7688 case COMP_DO_CONCURRENT
:
7695 *st
= ST_END_CRITICAL
;
7696 target
= " critical";
7701 case COMP_SELECT_TYPE
:
7702 *st
= ST_END_SELECT
;
7708 *st
= ST_END_FORALL
;
7723 last_initializer
= NULL
;
7725 gfc_free_enum_history ();
7729 gfc_error ("Unexpected END statement at %C");
7733 old_loc
= gfc_current_locus
;
7734 if (gfc_match_eos () == MATCH_YES
)
7736 if (!eos_ok
&& (*st
== ST_END_SUBROUTINE
|| *st
== ST_END_FUNCTION
))
7738 if (!gfc_notify_std (GFC_STD_F2008
, "END statement "
7739 "instead of %s statement at %L",
7740 abreviated_modproc_decl
? "END PROCEDURE"
7741 : gfc_ascii_statement(*st
), &old_loc
))
7746 /* We would have required END [something]. */
7747 gfc_error ("%s statement expected at %L",
7748 gfc_ascii_statement (*st
), &old_loc
);
7755 /* Verify that we've got the sort of end-block that we're expecting. */
7756 if (gfc_match (target
) != MATCH_YES
)
7758 gfc_error ("Expecting %s statement at %L", abreviated_modproc_decl
7759 ? "END PROCEDURE" : gfc_ascii_statement(*st
), &old_loc
);
7763 got_matching_end
= true;
7765 old_loc
= gfc_current_locus
;
7766 /* If we're at the end, make sure a block name wasn't required. */
7767 if (gfc_match_eos () == MATCH_YES
)
7770 if (*st
!= ST_ENDDO
&& *st
!= ST_ENDIF
&& *st
!= ST_END_SELECT
7771 && *st
!= ST_END_FORALL
&& *st
!= ST_END_WHERE
&& *st
!= ST_END_BLOCK
7772 && *st
!= ST_END_ASSOCIATE
&& *st
!= ST_END_CRITICAL
)
7778 gfc_error ("Expected block name of %qs in %s statement at %L",
7779 block_name
, gfc_ascii_statement (*st
), &old_loc
);
7784 /* END INTERFACE has a special handler for its several possible endings. */
7785 if (*st
== ST_END_INTERFACE
)
7786 return gfc_match_end_interface ();
7788 /* We haven't hit the end of statement, so what is left must be an
7790 m
= gfc_match_space ();
7792 m
= gfc_match_name (name
);
7795 gfc_error ("Expected terminating name at %C");
7799 if (block_name
== NULL
)
7802 /* We have to pick out the declared submodule name from the composite
7803 required by F2008:11.2.3 para 2, which ends in the declared name. */
7804 if (state
== COMP_SUBMODULE
)
7805 block_name
= strchr (block_name
, '.') + 1;
7807 if (strcmp (name
, block_name
) != 0 && strcmp (block_name
, "ppr@") != 0)
7809 gfc_error ("Expected label %qs for %s statement at %C", block_name
,
7810 gfc_ascii_statement (*st
));
7813 /* Procedure pointer as function result. */
7814 else if (strcmp (block_name
, "ppr@") == 0
7815 && strcmp (name
, gfc_current_block ()->ns
->proc_name
->name
) != 0)
7817 gfc_error ("Expected label %qs for %s statement at %C",
7818 gfc_current_block ()->ns
->proc_name
->name
,
7819 gfc_ascii_statement (*st
));
7823 if (gfc_match_eos () == MATCH_YES
)
7827 gfc_syntax_error (*st
);
7830 gfc_current_locus
= old_loc
;
7832 /* If we are missing an END BLOCK, we created a half-ready namespace.
7833 Remove it from the parent namespace's sibling list. */
7835 while (state
== COMP_BLOCK
&& !got_matching_end
)
7837 parent_ns
= gfc_current_ns
->parent
;
7839 nsp
= &(gfc_state_stack
->previous
->tail
->ext
.block
.ns
);
7845 if (ns
== gfc_current_ns
)
7847 if (prev_ns
== NULL
)
7850 prev_ns
->sibling
= ns
->sibling
;
7856 gfc_free_namespace (gfc_current_ns
);
7857 gfc_current_ns
= parent_ns
;
7858 gfc_state_stack
= gfc_state_stack
->previous
;
7859 state
= gfc_current_state ();
7867 /***************** Attribute declaration statements ****************/
7869 /* Set the attribute of a single variable. */
7874 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7877 /* Workaround -Wmaybe-uninitialized false positive during
7878 profiledbootstrap by initializing them. */
7879 gfc_symbol
*sym
= NULL
;
7885 m
= gfc_match_name (name
);
7889 if (find_special (name
, &sym
, false))
7892 if (!check_function_name (name
))
7898 var_locus
= gfc_current_locus
;
7900 /* Deal with possible array specification for certain attributes. */
7901 if (current_attr
.dimension
7902 || current_attr
.codimension
7903 || current_attr
.allocatable
7904 || current_attr
.pointer
7905 || current_attr
.target
)
7907 m
= gfc_match_array_spec (&as
, !current_attr
.codimension
,
7908 !current_attr
.dimension
7909 && !current_attr
.pointer
7910 && !current_attr
.target
);
7911 if (m
== MATCH_ERROR
)
7914 if (current_attr
.dimension
&& m
== MATCH_NO
)
7916 gfc_error ("Missing array specification at %L in DIMENSION "
7917 "statement", &var_locus
);
7922 if (current_attr
.dimension
&& sym
->value
)
7924 gfc_error ("Dimensions specified for %s at %L after its "
7925 "initialization", sym
->name
, &var_locus
);
7930 if (current_attr
.codimension
&& m
== MATCH_NO
)
7932 gfc_error ("Missing array specification at %L in CODIMENSION "
7933 "statement", &var_locus
);
7938 if ((current_attr
.allocatable
|| current_attr
.pointer
)
7939 && (m
== MATCH_YES
) && (as
->type
!= AS_DEFERRED
))
7941 gfc_error ("Array specification must be deferred at %L", &var_locus
);
7947 /* Update symbol table. DIMENSION attribute is set in
7948 gfc_set_array_spec(). For CLASS variables, this must be applied
7949 to the first component, or '_data' field. */
7950 if (sym
->ts
.type
== BT_CLASS
&& sym
->ts
.u
.derived
->attr
.is_class
)
7952 if (!gfc_copy_attr (&CLASS_DATA(sym
)->attr
, ¤t_attr
, &var_locus
))
7960 if (current_attr
.dimension
== 0 && current_attr
.codimension
== 0
7961 && !gfc_copy_attr (&sym
->attr
, ¤t_attr
, &var_locus
))
7968 if (sym
->ts
.type
== BT_CLASS
7969 && !gfc_build_class_symbol (&sym
->ts
, &sym
->attr
, &sym
->as
))
7975 if (!gfc_set_array_spec (sym
, as
, &var_locus
))
7981 if (sym
->attr
.cray_pointee
&& sym
->as
!= NULL
)
7983 /* Fix the array spec. */
7984 m
= gfc_mod_pointee_as (sym
->as
);
7985 if (m
== MATCH_ERROR
)
7989 if (!gfc_add_attribute (&sym
->attr
, &var_locus
))
7995 if ((current_attr
.external
|| current_attr
.intrinsic
)
7996 && sym
->attr
.flavor
!= FL_PROCEDURE
7997 && !gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, NULL
))
8003 add_hidden_procptr_result (sym
);
8008 gfc_free_array_spec (as
);
8013 /* Generic attribute declaration subroutine. Used for attributes that
8014 just have a list of names. */
8021 /* Gobble the optional double colon, by simply ignoring the result
8031 if (gfc_match_eos () == MATCH_YES
)
8037 if (gfc_match_char (',') != MATCH_YES
)
8039 gfc_error ("Unexpected character in variable list at %C");
8049 /* This routine matches Cray Pointer declarations of the form:
8050 pointer ( <pointer>, <pointee> )
8052 pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...
8053 The pointer, if already declared, should be an integer. Otherwise, we
8054 set it as BT_INTEGER with kind gfc_index_integer_kind. The pointee may
8055 be either a scalar, or an array declaration. No space is allocated for
8056 the pointee. For the statement
8057 pointer (ipt, ar(10))
8058 any subsequent uses of ar will be translated (in C-notation) as
8059 ar(i) => ((<type> *) ipt)(i)
8060 After gimplification, pointee variable will disappear in the code. */
8063 cray_pointer_decl (void)
8066 gfc_array_spec
*as
= NULL
;
8067 gfc_symbol
*cptr
; /* Pointer symbol. */
8068 gfc_symbol
*cpte
; /* Pointee symbol. */
8074 if (gfc_match_char ('(') != MATCH_YES
)
8076 gfc_error ("Expected %<(%> at %C");
8080 /* Match pointer. */
8081 var_locus
= gfc_current_locus
;
8082 gfc_clear_attr (¤t_attr
);
8083 gfc_add_cray_pointer (¤t_attr
, &var_locus
);
8084 current_ts
.type
= BT_INTEGER
;
8085 current_ts
.kind
= gfc_index_integer_kind
;
8087 m
= gfc_match_symbol (&cptr
, 0);
8090 gfc_error ("Expected variable name at %C");
8094 if (!gfc_add_cray_pointer (&cptr
->attr
, &var_locus
))
8097 gfc_set_sym_referenced (cptr
);
8099 if (cptr
->ts
.type
== BT_UNKNOWN
) /* Override the type, if necessary. */
8101 cptr
->ts
.type
= BT_INTEGER
;
8102 cptr
->ts
.kind
= gfc_index_integer_kind
;
8104 else if (cptr
->ts
.type
!= BT_INTEGER
)
8106 gfc_error ("Cray pointer at %C must be an integer");
8109 else if (cptr
->ts
.kind
< gfc_index_integer_kind
)
8110 gfc_warning (0, "Cray pointer at %C has %d bytes of precision;"
8111 " memory addresses require %d bytes",
8112 cptr
->ts
.kind
, gfc_index_integer_kind
);
8114 if (gfc_match_char (',') != MATCH_YES
)
8116 gfc_error ("Expected \",\" at %C");
8120 /* Match Pointee. */
8121 var_locus
= gfc_current_locus
;
8122 gfc_clear_attr (¤t_attr
);
8123 gfc_add_cray_pointee (¤t_attr
, &var_locus
);
8124 current_ts
.type
= BT_UNKNOWN
;
8125 current_ts
.kind
= 0;
8127 m
= gfc_match_symbol (&cpte
, 0);
8130 gfc_error ("Expected variable name at %C");
8134 /* Check for an optional array spec. */
8135 m
= gfc_match_array_spec (&as
, true, false);
8136 if (m
== MATCH_ERROR
)
8138 gfc_free_array_spec (as
);
8141 else if (m
== MATCH_NO
)
8143 gfc_free_array_spec (as
);
8147 if (!gfc_add_cray_pointee (&cpte
->attr
, &var_locus
))
8150 gfc_set_sym_referenced (cpte
);
8152 if (cpte
->as
== NULL
)
8154 if (!gfc_set_array_spec (cpte
, as
, &var_locus
))
8155 gfc_internal_error ("Couldn't set Cray pointee array spec.");
8157 else if (as
!= NULL
)
8159 gfc_error ("Duplicate array spec for Cray pointee at %C");
8160 gfc_free_array_spec (as
);
8166 if (cpte
->as
!= NULL
)
8168 /* Fix array spec. */
8169 m
= gfc_mod_pointee_as (cpte
->as
);
8170 if (m
== MATCH_ERROR
)
8174 /* Point the Pointee at the Pointer. */
8175 cpte
->cp_pointer
= cptr
;
8177 if (gfc_match_char (')') != MATCH_YES
)
8179 gfc_error ("Expected \")\" at %C");
8182 m
= gfc_match_char (',');
8184 done
= true; /* Stop searching for more declarations. */
8188 if (m
== MATCH_ERROR
/* Failed when trying to find ',' above. */
8189 || gfc_match_eos () != MATCH_YES
)
8191 gfc_error ("Expected %<,%> or end of statement at %C");
8199 gfc_match_external (void)
8202 gfc_clear_attr (¤t_attr
);
8203 current_attr
.external
= 1;
8205 return attr_decl ();
8210 gfc_match_intent (void)
8214 /* This is not allowed within a BLOCK construct! */
8215 if (gfc_current_state () == COMP_BLOCK
)
8217 gfc_error ("INTENT is not allowed inside of BLOCK at %C");
8221 intent
= match_intent_spec ();
8222 if (intent
== INTENT_UNKNOWN
)
8225 gfc_clear_attr (¤t_attr
);
8226 current_attr
.intent
= intent
;
8228 return attr_decl ();
8233 gfc_match_intrinsic (void)
8236 gfc_clear_attr (¤t_attr
);
8237 current_attr
.intrinsic
= 1;
8239 return attr_decl ();
8244 gfc_match_optional (void)
8246 /* This is not allowed within a BLOCK construct! */
8247 if (gfc_current_state () == COMP_BLOCK
)
8249 gfc_error ("OPTIONAL is not allowed inside of BLOCK at %C");
8253 gfc_clear_attr (¤t_attr
);
8254 current_attr
.optional
= 1;
8256 return attr_decl ();
8261 gfc_match_pointer (void)
8263 gfc_gobble_whitespace ();
8264 if (gfc_peek_ascii_char () == '(')
8266 if (!flag_cray_pointer
)
8268 gfc_error ("Cray pointer declaration at %C requires -fcray-pointer "
8272 return cray_pointer_decl ();
8276 gfc_clear_attr (¤t_attr
);
8277 current_attr
.pointer
= 1;
8279 return attr_decl ();
8285 gfc_match_allocatable (void)
8287 gfc_clear_attr (¤t_attr
);
8288 current_attr
.allocatable
= 1;
8290 return attr_decl ();
8295 gfc_match_codimension (void)
8297 gfc_clear_attr (¤t_attr
);
8298 current_attr
.codimension
= 1;
8300 return attr_decl ();
8305 gfc_match_contiguous (void)
8307 if (!gfc_notify_std (GFC_STD_F2008
, "CONTIGUOUS statement at %C"))
8310 gfc_clear_attr (¤t_attr
);
8311 current_attr
.contiguous
= 1;
8313 return attr_decl ();
8318 gfc_match_dimension (void)
8320 gfc_clear_attr (¤t_attr
);
8321 current_attr
.dimension
= 1;
8323 return attr_decl ();
8328 gfc_match_target (void)
8330 gfc_clear_attr (¤t_attr
);
8331 current_attr
.target
= 1;
8333 return attr_decl ();
8337 /* Match the list of entities being specified in a PUBLIC or PRIVATE
8341 access_attr_decl (gfc_statement st
)
8343 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8344 interface_type type
;
8346 gfc_symbol
*sym
, *dt_sym
;
8347 gfc_intrinsic_op op
;
8350 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
8355 m
= gfc_match_generic_spec (&type
, name
, &op
);
8358 if (m
== MATCH_ERROR
)
8363 case INTERFACE_NAMELESS
:
8364 case INTERFACE_ABSTRACT
:
8367 case INTERFACE_GENERIC
:
8368 case INTERFACE_DTIO
:
8370 if (gfc_get_symbol (name
, NULL
, &sym
))
8373 if (type
== INTERFACE_DTIO
8374 && gfc_current_ns
->proc_name
8375 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
8376 && sym
->attr
.flavor
== FL_UNKNOWN
)
8377 sym
->attr
.flavor
= FL_PROCEDURE
;
8379 if (!gfc_add_access (&sym
->attr
,
8381 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
,
8385 if (sym
->attr
.generic
&& (dt_sym
= gfc_find_dt_in_generic (sym
))
8386 && !gfc_add_access (&dt_sym
->attr
,
8388 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
,
8394 case INTERFACE_INTRINSIC_OP
:
8395 if (gfc_current_ns
->operator_access
[op
] == ACCESS_UNKNOWN
)
8397 gfc_intrinsic_op other_op
;
8399 gfc_current_ns
->operator_access
[op
] =
8400 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
8402 /* Handle the case if there is another op with the same
8403 function, for INTRINSIC_EQ vs. INTRINSIC_EQ_OS and so on. */
8404 other_op
= gfc_equivalent_op (op
);
8406 if (other_op
!= INTRINSIC_NONE
)
8407 gfc_current_ns
->operator_access
[other_op
] =
8408 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
8413 gfc_error ("Access specification of the %s operator at %C has "
8414 "already been specified", gfc_op2string (op
));
8420 case INTERFACE_USER_OP
:
8421 uop
= gfc_get_uop (name
);
8423 if (uop
->access
== ACCESS_UNKNOWN
)
8425 uop
->access
= (st
== ST_PUBLIC
)
8426 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
8430 gfc_error ("Access specification of the .%s. operator at %C "
8431 "has already been specified", sym
->name
);
8438 if (gfc_match_char (',') == MATCH_NO
)
8442 if (gfc_match_eos () != MATCH_YES
)
8447 gfc_syntax_error (st
);
8455 gfc_match_protected (void)
8460 if (!gfc_current_ns
->proc_name
8461 || gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
8463 gfc_error ("PROTECTED at %C only allowed in specification "
8464 "part of a module");
8469 if (!gfc_notify_std (GFC_STD_F2003
, "PROTECTED statement at %C"))
8472 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
8477 if (gfc_match_eos () == MATCH_YES
)
8482 m
= gfc_match_symbol (&sym
, 0);
8486 if (!gfc_add_protected (&sym
->attr
, sym
->name
, &gfc_current_locus
))
8498 if (gfc_match_eos () == MATCH_YES
)
8500 if (gfc_match_char (',') != MATCH_YES
)
8507 gfc_error ("Syntax error in PROTECTED statement at %C");
8512 /* The PRIVATE statement is a bit weird in that it can be an attribute
8513 declaration, but also works as a standalone statement inside of a
8514 type declaration or a module. */
8517 gfc_match_private (gfc_statement
*st
)
8520 if (gfc_match ("private") != MATCH_YES
)
8523 if (gfc_current_state () != COMP_MODULE
8524 && !(gfc_current_state () == COMP_DERIVED
8525 && gfc_state_stack
->previous
8526 && gfc_state_stack
->previous
->state
== COMP_MODULE
)
8527 && !(gfc_current_state () == COMP_DERIVED_CONTAINS
8528 && gfc_state_stack
->previous
&& gfc_state_stack
->previous
->previous
8529 && gfc_state_stack
->previous
->previous
->state
== COMP_MODULE
))
8531 gfc_error ("PRIVATE statement at %C is only allowed in the "
8532 "specification part of a module");
8536 if (gfc_current_state () == COMP_DERIVED
)
8538 if (gfc_match_eos () == MATCH_YES
)
8544 gfc_syntax_error (ST_PRIVATE
);
8548 if (gfc_match_eos () == MATCH_YES
)
8555 return access_attr_decl (ST_PRIVATE
);
8560 gfc_match_public (gfc_statement
*st
)
8563 if (gfc_match ("public") != MATCH_YES
)
8566 if (gfc_current_state () != COMP_MODULE
)
8568 gfc_error ("PUBLIC statement at %C is only allowed in the "
8569 "specification part of a module");
8573 if (gfc_match_eos () == MATCH_YES
)
8580 return access_attr_decl (ST_PUBLIC
);
8584 /* Workhorse for gfc_match_parameter. */
8594 m
= gfc_match_symbol (&sym
, 0);
8596 gfc_error ("Expected variable name at %C in PARAMETER statement");
8601 if (gfc_match_char ('=') == MATCH_NO
)
8603 gfc_error ("Expected = sign in PARAMETER statement at %C");
8607 m
= gfc_match_init_expr (&init
);
8609 gfc_error ("Expected expression at %C in PARAMETER statement");
8613 if (sym
->ts
.type
== BT_UNKNOWN
8614 && !gfc_set_default_type (sym
, 1, NULL
))
8620 if (!gfc_check_assign_symbol (sym
, NULL
, init
)
8621 || !gfc_add_flavor (&sym
->attr
, FL_PARAMETER
, sym
->name
, NULL
))
8629 gfc_error ("Initializing already initialized variable at %C");
8634 t
= add_init_expr_to_sym (sym
->name
, &init
, &gfc_current_locus
);
8635 return (t
) ? MATCH_YES
: MATCH_ERROR
;
8638 gfc_free_expr (init
);
8643 /* Match a parameter statement, with the weird syntax that these have. */
8646 gfc_match_parameter (void)
8648 const char *term
= " )%t";
8651 if (gfc_match_char ('(') == MATCH_NO
)
8653 /* With legacy PARAMETER statements, don't expect a terminating ')'. */
8654 if (!gfc_notify_std (GFC_STD_LEGACY
, "PARAMETER without '()' at %C"))
8665 if (gfc_match (term
) == MATCH_YES
)
8668 if (gfc_match_char (',') != MATCH_YES
)
8670 gfc_error ("Unexpected characters in PARAMETER statement at %C");
8681 gfc_match_automatic (void)
8685 bool seen_symbol
= false;
8687 if (!flag_dec_static
)
8689 gfc_error ("%s at %C is a DEC extension, enable with "
8700 m
= gfc_match_symbol (&sym
, 0);
8710 if (!gfc_add_automatic (&sym
->attr
, sym
->name
, &gfc_current_locus
))
8716 if (gfc_match_eos () == MATCH_YES
)
8718 if (gfc_match_char (',') != MATCH_YES
)
8724 gfc_error ("Expected entity-list in AUTOMATIC statement at %C");
8731 gfc_error ("Syntax error in AUTOMATIC statement at %C");
8737 gfc_match_static (void)
8741 bool seen_symbol
= false;
8743 if (!flag_dec_static
)
8745 gfc_error ("%s at %C is a DEC extension, enable with "
8755 m
= gfc_match_symbol (&sym
, 0);
8765 if (!gfc_add_save (&sym
->attr
, SAVE_EXPLICIT
, sym
->name
,
8766 &gfc_current_locus
))
8772 if (gfc_match_eos () == MATCH_YES
)
8774 if (gfc_match_char (',') != MATCH_YES
)
8780 gfc_error ("Expected entity-list in STATIC statement at %C");
8787 gfc_error ("Syntax error in STATIC statement at %C");
8792 /* Save statements have a special syntax. */
8795 gfc_match_save (void)
8797 char n
[GFC_MAX_SYMBOL_LEN
+1];
8802 if (gfc_match_eos () == MATCH_YES
)
8804 if (gfc_current_ns
->seen_save
)
8806 if (!gfc_notify_std (GFC_STD_LEGACY
, "Blanket SAVE statement at %C "
8807 "follows previous SAVE statement"))
8811 gfc_current_ns
->save_all
= gfc_current_ns
->seen_save
= 1;
8815 if (gfc_current_ns
->save_all
)
8817 if (!gfc_notify_std (GFC_STD_LEGACY
, "SAVE statement at %C follows "
8818 "blanket SAVE statement"))
8826 m
= gfc_match_symbol (&sym
, 0);
8830 if (!gfc_add_save (&sym
->attr
, SAVE_EXPLICIT
, sym
->name
,
8831 &gfc_current_locus
))
8842 m
= gfc_match (" / %n /", &n
);
8843 if (m
== MATCH_ERROR
)
8848 c
= gfc_get_common (n
, 0);
8851 gfc_current_ns
->seen_save
= 1;
8854 if (gfc_match_eos () == MATCH_YES
)
8856 if (gfc_match_char (',') != MATCH_YES
)
8863 gfc_error ("Syntax error in SAVE statement at %C");
8869 gfc_match_value (void)
8874 /* This is not allowed within a BLOCK construct! */
8875 if (gfc_current_state () == COMP_BLOCK
)
8877 gfc_error ("VALUE is not allowed inside of BLOCK at %C");
8881 if (!gfc_notify_std (GFC_STD_F2003
, "VALUE statement at %C"))
8884 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
8889 if (gfc_match_eos () == MATCH_YES
)
8894 m
= gfc_match_symbol (&sym
, 0);
8898 if (!gfc_add_value (&sym
->attr
, sym
->name
, &gfc_current_locus
))
8910 if (gfc_match_eos () == MATCH_YES
)
8912 if (gfc_match_char (',') != MATCH_YES
)
8919 gfc_error ("Syntax error in VALUE statement at %C");
8925 gfc_match_volatile (void)
8930 if (!gfc_notify_std (GFC_STD_F2003
, "VOLATILE statement at %C"))
8933 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
8938 if (gfc_match_eos () == MATCH_YES
)
8943 /* VOLATILE is special because it can be added to host-associated
8944 symbols locally. Except for coarrays. */
8945 m
= gfc_match_symbol (&sym
, 1);
8949 /* F2008, C560+C561. VOLATILE for host-/use-associated variable or
8950 for variable in a BLOCK which is defined outside of the BLOCK. */
8951 if (sym
->ns
!= gfc_current_ns
&& sym
->attr
.codimension
)
8953 gfc_error ("Specifying VOLATILE for coarray variable %qs at "
8954 "%C, which is use-/host-associated", sym
->name
);
8957 if (!gfc_add_volatile (&sym
->attr
, sym
->name
, &gfc_current_locus
))
8969 if (gfc_match_eos () == MATCH_YES
)
8971 if (gfc_match_char (',') != MATCH_YES
)
8978 gfc_error ("Syntax error in VOLATILE statement at %C");
8984 gfc_match_asynchronous (void)
8989 if (!gfc_notify_std (GFC_STD_F2003
, "ASYNCHRONOUS statement at %C"))
8992 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
8997 if (gfc_match_eos () == MATCH_YES
)
9002 /* ASYNCHRONOUS is special because it can be added to host-associated
9004 m
= gfc_match_symbol (&sym
, 1);
9008 if (!gfc_add_asynchronous (&sym
->attr
, sym
->name
, &gfc_current_locus
))
9020 if (gfc_match_eos () == MATCH_YES
)
9022 if (gfc_match_char (',') != MATCH_YES
)
9029 gfc_error ("Syntax error in ASYNCHRONOUS statement at %C");
9034 /* Match a module procedure statement in a submodule. */
9037 gfc_match_submod_proc (void)
9039 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9040 gfc_symbol
*sym
, *fsym
;
9042 gfc_formal_arglist
*formal
, *head
, *tail
;
9044 if (gfc_current_state () != COMP_CONTAINS
9045 || !(gfc_state_stack
->previous
9046 && (gfc_state_stack
->previous
->state
== COMP_SUBMODULE
9047 || gfc_state_stack
->previous
->state
== COMP_MODULE
)))
9050 m
= gfc_match (" module% procedure% %n", name
);
9054 if (!gfc_notify_std (GFC_STD_F2008
, "MODULE PROCEDURE declaration "
9058 if (get_proc_name (name
, &sym
, false))
9061 /* Make sure that the result field is appropriately filled, even though
9062 the result symbol will be replaced later on. */
9063 if (sym
->tlink
&& sym
->tlink
->attr
.function
)
9065 if (sym
->tlink
->result
9066 && sym
->tlink
->result
!= sym
->tlink
)
9067 sym
->result
= sym
->tlink
->result
;
9072 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
9073 the symbol existed before. */
9074 sym
->declared_at
= gfc_current_locus
;
9076 if (!sym
->attr
.module_procedure
)
9079 /* Signal match_end to expect "end procedure". */
9080 sym
->abr_modproc_decl
= 1;
9082 /* Change from IFSRC_IFBODY coming from the interface declaration. */
9083 sym
->attr
.if_source
= IFSRC_DECL
;
9085 gfc_new_block
= sym
;
9087 /* Make a new formal arglist with the symbols in the procedure
9090 for (formal
= sym
->formal
; formal
&& formal
->sym
; formal
= formal
->next
)
9092 if (formal
== sym
->formal
)
9093 head
= tail
= gfc_get_formal_arglist ();
9096 tail
->next
= gfc_get_formal_arglist ();
9100 if (gfc_copy_dummy_sym (&fsym
, formal
->sym
, 0))
9104 gfc_set_sym_referenced (fsym
);
9107 /* The dummy symbols get cleaned up, when the formal_namespace of the
9108 interface declaration is cleared. This allows us to add the
9109 explicit interface as is done for other type of procedure. */
9110 if (!gfc_add_explicit_interface (sym
, IFSRC_DECL
, head
,
9111 &gfc_current_locus
))
9114 if (gfc_match_eos () != MATCH_YES
)
9116 gfc_syntax_error (ST_MODULE_PROC
);
9123 gfc_free_formal_arglist (head
);
9128 /* Match a module procedure statement. Note that we have to modify
9129 symbols in the parent's namespace because the current one was there
9130 to receive symbols that are in an interface's formal argument list. */
9133 gfc_match_modproc (void)
9135 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9139 gfc_namespace
*module_ns
;
9140 gfc_interface
*old_interface_head
, *interface
;
9142 if (gfc_state_stack
->state
!= COMP_INTERFACE
9143 || gfc_state_stack
->previous
== NULL
9144 || current_interface
.type
== INTERFACE_NAMELESS
9145 || current_interface
.type
== INTERFACE_ABSTRACT
)
9147 gfc_error ("MODULE PROCEDURE at %C must be in a generic module "
9152 module_ns
= gfc_current_ns
->parent
;
9153 for (; module_ns
; module_ns
= module_ns
->parent
)
9154 if (module_ns
->proc_name
->attr
.flavor
== FL_MODULE
9155 || module_ns
->proc_name
->attr
.flavor
== FL_PROGRAM
9156 || (module_ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
9157 && !module_ns
->proc_name
->attr
.contained
))
9160 if (module_ns
== NULL
)
9163 /* Store the current state of the interface. We will need it if we
9164 end up with a syntax error and need to recover. */
9165 old_interface_head
= gfc_current_interface_head ();
9167 /* Check if the F2008 optional double colon appears. */
9168 gfc_gobble_whitespace ();
9169 old_locus
= gfc_current_locus
;
9170 if (gfc_match ("::") == MATCH_YES
)
9172 if (!gfc_notify_std (GFC_STD_F2008
, "double colon in "
9173 "MODULE PROCEDURE statement at %L", &old_locus
))
9177 gfc_current_locus
= old_locus
;
9182 old_locus
= gfc_current_locus
;
9184 m
= gfc_match_name (name
);
9190 /* Check for syntax error before starting to add symbols to the
9191 current namespace. */
9192 if (gfc_match_eos () == MATCH_YES
)
9195 if (!last
&& gfc_match_char (',') != MATCH_YES
)
9198 /* Now we're sure the syntax is valid, we process this item
9200 if (gfc_get_symbol (name
, module_ns
, &sym
))
9203 if (sym
->attr
.intrinsic
)
9205 gfc_error ("Intrinsic procedure at %L cannot be a MODULE "
9206 "PROCEDURE", &old_locus
);
9210 if (sym
->attr
.proc
!= PROC_MODULE
9211 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
9214 if (!gfc_add_interface (sym
))
9217 sym
->attr
.mod_proc
= 1;
9218 sym
->declared_at
= old_locus
;
9227 /* Restore the previous state of the interface. */
9228 interface
= gfc_current_interface_head ();
9229 gfc_set_current_interface_head (old_interface_head
);
9231 /* Free the new interfaces. */
9232 while (interface
!= old_interface_head
)
9234 gfc_interface
*i
= interface
->next
;
9239 /* And issue a syntax error. */
9240 gfc_syntax_error (ST_MODULE_PROC
);
9245 /* Check a derived type that is being extended. */
9248 check_extended_derived_type (char *name
)
9250 gfc_symbol
*extended
;
9252 if (gfc_find_symbol (name
, gfc_current_ns
, 1, &extended
))
9254 gfc_error ("Ambiguous symbol in TYPE definition at %C");
9258 extended
= gfc_find_dt_in_generic (extended
);
9263 gfc_error ("Symbol %qs at %C has not been previously defined", name
);
9267 if (extended
->attr
.flavor
!= FL_DERIVED
)
9269 gfc_error ("%qs in EXTENDS expression at %C is not a "
9270 "derived type", name
);
9274 if (extended
->attr
.is_bind_c
)
9276 gfc_error ("%qs cannot be extended at %C because it "
9277 "is BIND(C)", extended
->name
);
9281 if (extended
->attr
.sequence
)
9283 gfc_error ("%qs cannot be extended at %C because it "
9284 "is a SEQUENCE type", extended
->name
);
9292 /* Match the optional attribute specifiers for a type declaration.
9293 Return MATCH_ERROR if an error is encountered in one of the handled
9294 attributes (public, private, bind(c)), MATCH_NO if what's found is
9295 not a handled attribute, and MATCH_YES otherwise. TODO: More error
9296 checking on attribute conflicts needs to be done. */
9299 gfc_get_type_attr_spec (symbol_attribute
*attr
, char *name
)
9301 /* See if the derived type is marked as private. */
9302 if (gfc_match (" , private") == MATCH_YES
)
9304 if (gfc_current_state () != COMP_MODULE
)
9306 gfc_error ("Derived type at %C can only be PRIVATE in the "
9307 "specification part of a module");
9311 if (!gfc_add_access (attr
, ACCESS_PRIVATE
, NULL
, NULL
))
9314 else if (gfc_match (" , public") == MATCH_YES
)
9316 if (gfc_current_state () != COMP_MODULE
)
9318 gfc_error ("Derived type at %C can only be PUBLIC in the "
9319 "specification part of a module");
9323 if (!gfc_add_access (attr
, ACCESS_PUBLIC
, NULL
, NULL
))
9326 else if (gfc_match (" , bind ( c )") == MATCH_YES
)
9328 /* If the type is defined to be bind(c) it then needs to make
9329 sure that all fields are interoperable. This will
9330 need to be a semantic check on the finished derived type.
9331 See 15.2.3 (lines 9-12) of F2003 draft. */
9332 if (!gfc_add_is_bind_c (attr
, NULL
, &gfc_current_locus
, 0))
9335 /* TODO: attr conflicts need to be checked, probably in symbol.c. */
9337 else if (gfc_match (" , abstract") == MATCH_YES
)
9339 if (!gfc_notify_std (GFC_STD_F2003
, "ABSTRACT type at %C"))
9342 if (!gfc_add_abstract (attr
, &gfc_current_locus
))
9345 else if (name
&& gfc_match (" , extends ( %n )", name
) == MATCH_YES
)
9347 if (!gfc_add_extension (attr
, &gfc_current_locus
))
9353 /* If we get here, something matched. */
9358 /* Common function for type declaration blocks similar to derived types, such
9359 as STRUCTURES and MAPs. Unlike derived types, a structure type
9360 does NOT have a generic symbol matching the name given by the user.
9361 STRUCTUREs can share names with variables and PARAMETERs so we must allow
9362 for the creation of an independent symbol.
9363 Other parameters are a message to prefix errors with, the name of the new
9364 type to be created, and the flavor to add to the resulting symbol. */
9367 get_struct_decl (const char *name
, sym_flavor fl
, locus
*decl
,
9368 gfc_symbol
**result
)
9373 gcc_assert (name
[0] == (char) TOUPPER (name
[0]));
9378 where
= gfc_current_locus
;
9380 if (gfc_get_symbol (name
, NULL
, &sym
))
9385 gfc_internal_error ("Failed to create structure type '%s' at %C", name
);
9389 if (sym
->components
!= NULL
|| sym
->attr
.zero_comp
)
9391 gfc_error ("Type definition of %qs at %C was already defined at %L",
9392 sym
->name
, &sym
->declared_at
);
9396 sym
->declared_at
= where
;
9398 if (sym
->attr
.flavor
!= fl
9399 && !gfc_add_flavor (&sym
->attr
, fl
, sym
->name
, NULL
))
9402 if (!sym
->hash_value
)
9403 /* Set the hash for the compound name for this type. */
9404 sym
->hash_value
= gfc_hash_value (sym
);
9406 /* Normally the type is expected to have been completely parsed by the time
9407 a field declaration with this type is seen. For unions, maps, and nested
9408 structure declarations, we need to indicate that it is okay that we
9409 haven't seen any components yet. This will be updated after the structure
9411 sym
->attr
.zero_comp
= 0;
9413 /* Structures always act like derived-types with the SEQUENCE attribute */
9414 gfc_add_sequence (&sym
->attr
, sym
->name
, NULL
);
9416 if (result
) *result
= sym
;
9422 /* Match the opening of a MAP block. Like a struct within a union in C;
9423 behaves identical to STRUCTURE blocks. */
9426 gfc_match_map (void)
9428 /* Counter used to give unique internal names to map structures. */
9429 static unsigned int gfc_map_id
= 0;
9430 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9434 old_loc
= gfc_current_locus
;
9436 if (gfc_match_eos () != MATCH_YES
)
9438 gfc_error ("Junk after MAP statement at %C");
9439 gfc_current_locus
= old_loc
;
9443 /* Map blocks are anonymous so we make up unique names for the symbol table
9444 which are invalid Fortran identifiers. */
9445 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "MM$%u", gfc_map_id
++);
9447 if (!get_struct_decl (name
, FL_STRUCT
, &old_loc
, &sym
))
9450 gfc_new_block
= sym
;
9456 /* Match the opening of a UNION block. */
9459 gfc_match_union (void)
9461 /* Counter used to give unique internal names to union types. */
9462 static unsigned int gfc_union_id
= 0;
9463 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9467 old_loc
= gfc_current_locus
;
9469 if (gfc_match_eos () != MATCH_YES
)
9471 gfc_error ("Junk after UNION statement at %C");
9472 gfc_current_locus
= old_loc
;
9476 /* Unions are anonymous so we make up unique names for the symbol table
9477 which are invalid Fortran identifiers. */
9478 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "UU$%u", gfc_union_id
++);
9480 if (!get_struct_decl (name
, FL_UNION
, &old_loc
, &sym
))
9483 gfc_new_block
= sym
;
9489 /* Match the beginning of a STRUCTURE declaration. This is similar to
9490 matching the beginning of a derived type declaration with a few
9491 twists. The resulting type symbol has no access control or other
9492 interesting attributes. */
9495 gfc_match_structure_decl (void)
9497 /* Counter used to give unique internal names to anonymous structures. */
9498 static unsigned int gfc_structure_id
= 0;
9499 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9504 if (!flag_dec_structure
)
9506 gfc_error ("%s at %C is a DEC extension, enable with "
9507 "%<-fdec-structure%>",
9514 m
= gfc_match (" /%n/", name
);
9517 /* Non-nested structure declarations require a structure name. */
9518 if (!gfc_comp_struct (gfc_current_state ()))
9520 gfc_error ("Structure name expected in non-nested structure "
9521 "declaration at %C");
9524 /* This is an anonymous structure; make up a unique name for it
9525 (upper-case letters never make it to symbol names from the source).
9526 The important thing is initializing the type variable
9527 and setting gfc_new_symbol, which is immediately used by
9528 parse_structure () and variable_decl () to add components of
9530 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "SS$%u", gfc_structure_id
++);
9533 where
= gfc_current_locus
;
9534 /* No field list allowed after non-nested structure declaration. */
9535 if (!gfc_comp_struct (gfc_current_state ())
9536 && gfc_match_eos () != MATCH_YES
)
9538 gfc_error ("Junk after non-nested STRUCTURE statement at %C");
9542 /* Make sure the name is not the name of an intrinsic type. */
9543 if (gfc_is_intrinsic_typename (name
))
9545 gfc_error ("Structure name %qs at %C cannot be the same as an"
9546 " intrinsic type", name
);
9550 /* Store the actual type symbol for the structure with an upper-case first
9551 letter (an invalid Fortran identifier). */
9553 if (!get_struct_decl (gfc_dt_upper_string (name
), FL_STRUCT
, &where
, &sym
))
9556 gfc_new_block
= sym
;
9561 /* This function does some work to determine which matcher should be used to
9562 * match a statement beginning with "TYPE". This is used to disambiguate TYPE
9563 * as an alias for PRINT from derived type declarations, TYPE IS statements,
9564 * and derived type data declarations. */
9567 gfc_match_type (gfc_statement
*st
)
9569 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9573 /* Requires -fdec. */
9577 m
= gfc_match ("type");
9580 /* If we already have an error in the buffer, it is probably from failing to
9581 * match a derived type data declaration. Let it happen. */
9582 else if (gfc_error_flag_test ())
9585 old_loc
= gfc_current_locus
;
9588 /* If we see an attribute list before anything else it's definitely a derived
9589 * type declaration. */
9590 if (gfc_match (" ,") == MATCH_YES
|| gfc_match (" ::") == MATCH_YES
)
9592 gfc_current_locus
= old_loc
;
9593 *st
= ST_DERIVED_DECL
;
9594 return gfc_match_derived_decl ();
9597 /* By now "TYPE" has already been matched. If we do not see a name, this may
9598 * be something like "TYPE *" or "TYPE <fmt>". */
9599 m
= gfc_match_name (name
);
9602 /* Let print match if it can, otherwise throw an error from
9603 * gfc_match_derived_decl. */
9604 gfc_current_locus
= old_loc
;
9605 if (gfc_match_print () == MATCH_YES
)
9610 gfc_current_locus
= old_loc
;
9611 *st
= ST_DERIVED_DECL
;
9612 return gfc_match_derived_decl ();
9615 /* A derived type declaration requires an EOS. Without it, assume print. */
9616 m
= gfc_match_eos ();
9619 /* Check manually for TYPE IS (... - this is invalid print syntax. */
9620 if (strncmp ("is", name
, 3) == 0
9621 && gfc_match (" (", name
) == MATCH_YES
)
9623 gfc_current_locus
= old_loc
;
9624 gcc_assert (gfc_match (" is") == MATCH_YES
);
9626 return gfc_match_type_is ();
9628 gfc_current_locus
= old_loc
;
9630 return gfc_match_print ();
9634 /* By now we have "TYPE <name> <EOS>". Check first if the name is an
9635 * intrinsic typename - if so let gfc_match_derived_decl dump an error.
9636 * Otherwise if gfc_match_derived_decl fails it's probably an existing
9637 * symbol which can be printed. */
9638 gfc_current_locus
= old_loc
;
9639 m
= gfc_match_derived_decl ();
9640 if (gfc_is_intrinsic_typename (name
) || m
== MATCH_YES
)
9642 *st
= ST_DERIVED_DECL
;
9645 gfc_current_locus
= old_loc
;
9647 return gfc_match_print ();
9654 /* Match the beginning of a derived type declaration. If a type name
9655 was the result of a function, then it is possible to have a symbol
9656 already to be known as a derived type yet have no components. */
9659 gfc_match_derived_decl (void)
9661 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9662 char parent
[GFC_MAX_SYMBOL_LEN
+ 1];
9663 symbol_attribute attr
;
9664 gfc_symbol
*sym
, *gensym
;
9665 gfc_symbol
*extended
;
9667 match is_type_attr_spec
= MATCH_NO
;
9668 bool seen_attr
= false;
9669 gfc_interface
*intr
= NULL
, *head
;
9670 bool parameterized_type
= false;
9671 bool seen_colons
= false;
9673 if (gfc_comp_struct (gfc_current_state ()))
9678 gfc_clear_attr (&attr
);
9683 is_type_attr_spec
= gfc_get_type_attr_spec (&attr
, parent
);
9684 if (is_type_attr_spec
== MATCH_ERROR
)
9686 if (is_type_attr_spec
== MATCH_YES
)
9688 } while (is_type_attr_spec
== MATCH_YES
);
9690 /* Deal with derived type extensions. The extension attribute has
9691 been added to 'attr' but now the parent type must be found and
9694 extended
= check_extended_derived_type (parent
);
9696 if (parent
[0] && !extended
)
9699 m
= gfc_match (" ::");
9706 gfc_error ("Expected :: in TYPE definition at %C");
9710 m
= gfc_match (" %n ", name
);
9714 /* Make sure that we don't identify TYPE IS (...) as a parameterized
9715 derived type named 'is'.
9716 TODO Expand the check, when 'name' = "is" by matching " (tname) "
9717 and checking if this is a(n intrinsic) typename. his picks up
9718 misplaced TYPE IS statements such as in select_type_1.f03. */
9719 if (gfc_peek_ascii_char () == '(')
9721 if (gfc_current_state () == COMP_SELECT_TYPE
9722 || (!seen_colons
&& !strcmp (name
, "is")))
9724 parameterized_type
= true;
9727 m
= gfc_match_eos ();
9728 if (m
!= MATCH_YES
&& !parameterized_type
)
9731 /* Make sure the name is not the name of an intrinsic type. */
9732 if (gfc_is_intrinsic_typename (name
))
9734 gfc_error ("Type name %qs at %C cannot be the same as an intrinsic "
9739 if (gfc_get_symbol (name
, NULL
, &gensym
))
9742 if (!gensym
->attr
.generic
&& gensym
->ts
.type
!= BT_UNKNOWN
)
9744 gfc_error ("Derived type name %qs at %C already has a basic type "
9745 "of %s", gensym
->name
, gfc_typename (&gensym
->ts
));
9749 if (!gensym
->attr
.generic
9750 && !gfc_add_generic (&gensym
->attr
, gensym
->name
, NULL
))
9753 if (!gensym
->attr
.function
9754 && !gfc_add_function (&gensym
->attr
, gensym
->name
, NULL
))
9757 sym
= gfc_find_dt_in_generic (gensym
);
9759 if (sym
&& (sym
->components
!= NULL
|| sym
->attr
.zero_comp
))
9761 gfc_error ("Derived type definition of %qs at %C has already been "
9762 "defined", sym
->name
);
9768 /* Use upper case to save the actual derived-type symbol. */
9769 gfc_get_symbol (gfc_dt_upper_string (gensym
->name
), NULL
, &sym
);
9770 sym
->name
= gfc_get_string ("%s", gensym
->name
);
9771 head
= gensym
->generic
;
9772 intr
= gfc_get_interface ();
9774 intr
->where
= gfc_current_locus
;
9775 intr
->sym
->declared_at
= gfc_current_locus
;
9777 gensym
->generic
= intr
;
9778 gensym
->attr
.if_source
= IFSRC_DECL
;
9781 /* The symbol may already have the derived attribute without the
9782 components. The ways this can happen is via a function
9783 definition, an INTRINSIC statement or a subtype in another
9784 derived type that is a pointer. The first part of the AND clause
9785 is true if the symbol is not the return value of a function. */
9786 if (sym
->attr
.flavor
!= FL_DERIVED
9787 && !gfc_add_flavor (&sym
->attr
, FL_DERIVED
, sym
->name
, NULL
))
9790 if (attr
.access
!= ACCESS_UNKNOWN
9791 && !gfc_add_access (&sym
->attr
, attr
.access
, sym
->name
, NULL
))
9793 else if (sym
->attr
.access
== ACCESS_UNKNOWN
9794 && gensym
->attr
.access
!= ACCESS_UNKNOWN
9795 && !gfc_add_access (&sym
->attr
, gensym
->attr
.access
,
9799 if (sym
->attr
.access
!= ACCESS_UNKNOWN
9800 && gensym
->attr
.access
== ACCESS_UNKNOWN
)
9801 gensym
->attr
.access
= sym
->attr
.access
;
9803 /* See if the derived type was labeled as bind(c). */
9804 if (attr
.is_bind_c
!= 0)
9805 sym
->attr
.is_bind_c
= attr
.is_bind_c
;
9807 /* Construct the f2k_derived namespace if it is not yet there. */
9808 if (!sym
->f2k_derived
)
9809 sym
->f2k_derived
= gfc_get_namespace (NULL
, 0);
9811 if (parameterized_type
)
9813 m
= gfc_match_formal_arglist (sym
, 0, 0, true);
9816 m
= gfc_match_eos ();
9819 sym
->attr
.pdt_template
= 1;
9822 if (extended
&& !sym
->components
)
9825 gfc_formal_arglist
*f
, *g
, *h
;
9827 /* Add the extended derived type as the first component. */
9828 gfc_add_component (sym
, parent
, &p
);
9830 gfc_set_sym_referenced (extended
);
9832 p
->ts
.type
= BT_DERIVED
;
9833 p
->ts
.u
.derived
= extended
;
9834 p
->initializer
= gfc_default_initializer (&p
->ts
);
9836 /* Set extension level. */
9837 if (extended
->attr
.extension
== 255)
9839 /* Since the extension field is 8 bit wide, we can only have
9840 up to 255 extension levels. */
9841 gfc_error ("Maximum extension level reached with type %qs at %L",
9842 extended
->name
, &extended
->declared_at
);
9845 sym
->attr
.extension
= extended
->attr
.extension
+ 1;
9847 /* Provide the links between the extended type and its extension. */
9848 if (!extended
->f2k_derived
)
9849 extended
->f2k_derived
= gfc_get_namespace (NULL
, 0);
9851 /* Copy the extended type-param-name-list from the extended type,
9852 append those of the extension and add the whole lot to the
9854 if (extended
->attr
.pdt_template
)
9857 sym
->attr
.pdt_template
= 1;
9858 for (f
= extended
->formal
; f
; f
= f
->next
)
9860 if (f
== extended
->formal
)
9862 g
= gfc_get_formal_arglist ();
9867 g
->next
= gfc_get_formal_arglist ();
9872 g
->next
= sym
->formal
;
9877 if (!sym
->hash_value
)
9878 /* Set the hash for the compound name for this type. */
9879 sym
->hash_value
= gfc_hash_value (sym
);
9881 /* Take over the ABSTRACT attribute. */
9882 sym
->attr
.abstract
= attr
.abstract
;
9884 gfc_new_block
= sym
;
9890 /* Cray Pointees can be declared as:
9891 pointer (ipt, a (n,m,...,*)) */
9894 gfc_mod_pointee_as (gfc_array_spec
*as
)
9896 as
->cray_pointee
= true; /* This will be useful to know later. */
9897 if (as
->type
== AS_ASSUMED_SIZE
)
9898 as
->cp_was_assumed
= true;
9899 else if (as
->type
== AS_ASSUMED_SHAPE
)
9901 gfc_error ("Cray Pointee at %C cannot be assumed shape array");
9908 /* Match the enum definition statement, here we are trying to match
9909 the first line of enum definition statement.
9910 Returns MATCH_YES if match is found. */
9913 gfc_match_enum (void)
9917 m
= gfc_match_eos ();
9921 if (!gfc_notify_std (GFC_STD_F2003
, "ENUM and ENUMERATOR at %C"))
9928 /* Returns an initializer whose value is one higher than the value of the
9929 LAST_INITIALIZER argument. If the argument is NULL, the
9930 initializers value will be set to zero. The initializer's kind
9931 will be set to gfc_c_int_kind.
9933 If -fshort-enums is given, the appropriate kind will be selected
9934 later after all enumerators have been parsed. A warning is issued
9935 here if an initializer exceeds gfc_c_int_kind. */
9938 enum_initializer (gfc_expr
*last_initializer
, locus where
)
9941 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_c_int_kind
, &where
);
9943 mpz_init (result
->value
.integer
);
9945 if (last_initializer
!= NULL
)
9947 mpz_add_ui (result
->value
.integer
, last_initializer
->value
.integer
, 1);
9948 result
->where
= last_initializer
->where
;
9950 if (gfc_check_integer_range (result
->value
.integer
,
9951 gfc_c_int_kind
) != ARITH_OK
)
9953 gfc_error ("Enumerator exceeds the C integer type at %C");
9959 /* Control comes here, if it's the very first enumerator and no
9960 initializer has been given. It will be initialized to zero. */
9961 mpz_set_si (result
->value
.integer
, 0);
9968 /* Match a variable name with an optional initializer. When this
9969 subroutine is called, a variable is expected to be parsed next.
9970 Depending on what is happening at the moment, updates either the
9971 symbol table or the current interface. */
9974 enumerator_decl (void)
9976 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9977 gfc_expr
*initializer
;
9978 gfc_array_spec
*as
= NULL
;
9986 old_locus
= gfc_current_locus
;
9988 /* When we get here, we've just matched a list of attributes and
9989 maybe a type and a double colon. The next thing we expect to see
9990 is the name of the symbol. */
9991 m
= gfc_match_name (name
);
9995 var_locus
= gfc_current_locus
;
9997 /* OK, we've successfully matched the declaration. Now put the
9998 symbol in the current namespace. If we fail to create the symbol,
10000 if (!build_sym (name
, NULL
, false, &as
, &var_locus
))
10006 /* The double colon must be present in order to have initializers.
10007 Otherwise the statement is ambiguous with an assignment statement. */
10010 if (gfc_match_char ('=') == MATCH_YES
)
10012 m
= gfc_match_init_expr (&initializer
);
10015 gfc_error ("Expected an initialization expression at %C");
10019 if (m
!= MATCH_YES
)
10024 /* If we do not have an initializer, the initialization value of the
10025 previous enumerator (stored in last_initializer) is incremented
10026 by 1 and is used to initialize the current enumerator. */
10027 if (initializer
== NULL
)
10028 initializer
= enum_initializer (last_initializer
, old_locus
);
10030 if (initializer
== NULL
|| initializer
->ts
.type
!= BT_INTEGER
)
10032 gfc_error ("ENUMERATOR %L not initialized with integer expression",
10038 /* Store this current initializer, for the next enumerator variable
10039 to be parsed. add_init_expr_to_sym() zeros initializer, so we
10040 use last_initializer below. */
10041 last_initializer
= initializer
;
10042 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
10044 /* Maintain enumerator history. */
10045 gfc_find_symbol (name
, NULL
, 0, &sym
);
10046 create_enum_history (sym
, last_initializer
);
10048 return (t
) ? MATCH_YES
: MATCH_ERROR
;
10051 /* Free stuff up and return. */
10052 gfc_free_expr (initializer
);
10058 /* Match the enumerator definition statement. */
10061 gfc_match_enumerator_def (void)
10066 gfc_clear_ts (¤t_ts
);
10068 m
= gfc_match (" enumerator");
10069 if (m
!= MATCH_YES
)
10072 m
= gfc_match (" :: ");
10073 if (m
== MATCH_ERROR
)
10076 colon_seen
= (m
== MATCH_YES
);
10078 if (gfc_current_state () != COMP_ENUM
)
10080 gfc_error ("ENUM definition statement expected before %C");
10081 gfc_free_enum_history ();
10082 return MATCH_ERROR
;
10085 (¤t_ts
)->type
= BT_INTEGER
;
10086 (¤t_ts
)->kind
= gfc_c_int_kind
;
10088 gfc_clear_attr (¤t_attr
);
10089 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, NULL
);
10098 m
= enumerator_decl ();
10099 if (m
== MATCH_ERROR
)
10101 gfc_free_enum_history ();
10107 if (gfc_match_eos () == MATCH_YES
)
10109 if (gfc_match_char (',') != MATCH_YES
)
10113 if (gfc_current_state () == COMP_ENUM
)
10115 gfc_free_enum_history ();
10116 gfc_error ("Syntax error in ENUMERATOR definition at %C");
10121 gfc_free_array_spec (current_as
);
10128 /* Match binding attributes. */
10131 match_binding_attributes (gfc_typebound_proc
* ba
, bool generic
, bool ppc
)
10133 bool found_passing
= false;
10134 bool seen_ptr
= false;
10135 match m
= MATCH_YES
;
10137 /* Initialize to defaults. Do so even before the MATCH_NO check so that in
10138 this case the defaults are in there. */
10139 ba
->access
= ACCESS_UNKNOWN
;
10140 ba
->pass_arg
= NULL
;
10141 ba
->pass_arg_num
= 0;
10143 ba
->non_overridable
= 0;
10147 /* If we find a comma, we believe there are binding attributes. */
10148 m
= gfc_match_char (',');
10154 /* Access specifier. */
10156 m
= gfc_match (" public");
10157 if (m
== MATCH_ERROR
)
10159 if (m
== MATCH_YES
)
10161 if (ba
->access
!= ACCESS_UNKNOWN
)
10163 gfc_error ("Duplicate access-specifier at %C");
10167 ba
->access
= ACCESS_PUBLIC
;
10171 m
= gfc_match (" private");
10172 if (m
== MATCH_ERROR
)
10174 if (m
== MATCH_YES
)
10176 if (ba
->access
!= ACCESS_UNKNOWN
)
10178 gfc_error ("Duplicate access-specifier at %C");
10182 ba
->access
= ACCESS_PRIVATE
;
10186 /* If inside GENERIC, the following is not allowed. */
10191 m
= gfc_match (" nopass");
10192 if (m
== MATCH_ERROR
)
10194 if (m
== MATCH_YES
)
10198 gfc_error ("Binding attributes already specify passing,"
10199 " illegal NOPASS at %C");
10203 found_passing
= true;
10208 /* PASS possibly including argument. */
10209 m
= gfc_match (" pass");
10210 if (m
== MATCH_ERROR
)
10212 if (m
== MATCH_YES
)
10214 char arg
[GFC_MAX_SYMBOL_LEN
+ 1];
10218 gfc_error ("Binding attributes already specify passing,"
10219 " illegal PASS at %C");
10223 m
= gfc_match (" ( %n )", arg
);
10224 if (m
== MATCH_ERROR
)
10226 if (m
== MATCH_YES
)
10227 ba
->pass_arg
= gfc_get_string ("%s", arg
);
10228 gcc_assert ((m
== MATCH_YES
) == (ba
->pass_arg
!= NULL
));
10230 found_passing
= true;
10237 /* POINTER flag. */
10238 m
= gfc_match (" pointer");
10239 if (m
== MATCH_ERROR
)
10241 if (m
== MATCH_YES
)
10245 gfc_error ("Duplicate POINTER attribute at %C");
10255 /* NON_OVERRIDABLE flag. */
10256 m
= gfc_match (" non_overridable");
10257 if (m
== MATCH_ERROR
)
10259 if (m
== MATCH_YES
)
10261 if (ba
->non_overridable
)
10263 gfc_error ("Duplicate NON_OVERRIDABLE at %C");
10267 ba
->non_overridable
= 1;
10271 /* DEFERRED flag. */
10272 m
= gfc_match (" deferred");
10273 if (m
== MATCH_ERROR
)
10275 if (m
== MATCH_YES
)
10279 gfc_error ("Duplicate DEFERRED at %C");
10290 /* Nothing matching found. */
10292 gfc_error ("Expected access-specifier at %C");
10294 gfc_error ("Expected binding attribute at %C");
10297 while (gfc_match_char (',') == MATCH_YES
);
10299 /* NON_OVERRIDABLE and DEFERRED exclude themselves. */
10300 if (ba
->non_overridable
&& ba
->deferred
)
10302 gfc_error ("NON_OVERRIDABLE and DEFERRED can't both appear at %C");
10309 if (ba
->access
== ACCESS_UNKNOWN
)
10310 ba
->access
= gfc_typebound_default_access
;
10312 if (ppc
&& !seen_ptr
)
10314 gfc_error ("POINTER attribute is required for procedure pointer component"
10322 return MATCH_ERROR
;
10326 /* Match a PROCEDURE specific binding inside a derived type. */
10329 match_procedure_in_type (void)
10331 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10332 char target_buf
[GFC_MAX_SYMBOL_LEN
+ 1];
10333 char* target
= NULL
, *ifc
= NULL
;
10334 gfc_typebound_proc tb
;
10338 gfc_symtree
* stree
;
10343 /* Check current state. */
10344 gcc_assert (gfc_state_stack
->state
== COMP_DERIVED_CONTAINS
);
10345 block
= gfc_state_stack
->previous
->sym
;
10346 gcc_assert (block
);
10348 /* Try to match PROCEDURE(interface). */
10349 if (gfc_match (" (") == MATCH_YES
)
10351 m
= gfc_match_name (target_buf
);
10352 if (m
== MATCH_ERROR
)
10354 if (m
!= MATCH_YES
)
10356 gfc_error ("Interface-name expected after %<(%> at %C");
10357 return MATCH_ERROR
;
10360 if (gfc_match (" )") != MATCH_YES
)
10362 gfc_error ("%<)%> expected at %C");
10363 return MATCH_ERROR
;
10369 /* Construct the data structure. */
10370 memset (&tb
, 0, sizeof (tb
));
10371 tb
.where
= gfc_current_locus
;
10373 /* Match binding attributes. */
10374 m
= match_binding_attributes (&tb
, false, false);
10375 if (m
== MATCH_ERROR
)
10377 seen_attrs
= (m
== MATCH_YES
);
10379 /* Check that attribute DEFERRED is given if an interface is specified. */
10380 if (tb
.deferred
&& !ifc
)
10382 gfc_error ("Interface must be specified for DEFERRED binding at %C");
10383 return MATCH_ERROR
;
10385 if (ifc
&& !tb
.deferred
)
10387 gfc_error ("PROCEDURE(interface) at %C should be declared DEFERRED");
10388 return MATCH_ERROR
;
10391 /* Match the colons. */
10392 m
= gfc_match (" ::");
10393 if (m
== MATCH_ERROR
)
10395 seen_colons
= (m
== MATCH_YES
);
10396 if (seen_attrs
&& !seen_colons
)
10398 gfc_error ("Expected %<::%> after binding-attributes at %C");
10399 return MATCH_ERROR
;
10402 /* Match the binding names. */
10405 m
= gfc_match_name (name
);
10406 if (m
== MATCH_ERROR
)
10410 gfc_error ("Expected binding name at %C");
10411 return MATCH_ERROR
;
10414 if (num
>1 && !gfc_notify_std (GFC_STD_F2008
, "PROCEDURE list at %C"))
10415 return MATCH_ERROR
;
10417 /* Try to match the '=> target', if it's there. */
10419 m
= gfc_match (" =>");
10420 if (m
== MATCH_ERROR
)
10422 if (m
== MATCH_YES
)
10426 gfc_error ("%<=> target%> is invalid for DEFERRED binding at %C");
10427 return MATCH_ERROR
;
10432 gfc_error ("%<::%> needed in PROCEDURE binding with explicit target"
10434 return MATCH_ERROR
;
10437 m
= gfc_match_name (target_buf
);
10438 if (m
== MATCH_ERROR
)
10442 gfc_error ("Expected binding target after %<=>%> at %C");
10443 return MATCH_ERROR
;
10445 target
= target_buf
;
10448 /* If no target was found, it has the same name as the binding. */
10452 /* Get the namespace to insert the symbols into. */
10453 ns
= block
->f2k_derived
;
10456 /* If the binding is DEFERRED, check that the containing type is ABSTRACT. */
10457 if (tb
.deferred
&& !block
->attr
.abstract
)
10459 gfc_error ("Type %qs containing DEFERRED binding at %C "
10460 "is not ABSTRACT", block
->name
);
10461 return MATCH_ERROR
;
10464 /* See if we already have a binding with this name in the symtree which
10465 would be an error. If a GENERIC already targeted this binding, it may
10466 be already there but then typebound is still NULL. */
10467 stree
= gfc_find_symtree (ns
->tb_sym_root
, name
);
10468 if (stree
&& stree
->n
.tb
)
10470 gfc_error ("There is already a procedure with binding name %qs for "
10471 "the derived type %qs at %C", name
, block
->name
);
10472 return MATCH_ERROR
;
10475 /* Insert it and set attributes. */
10479 stree
= gfc_new_symtree (&ns
->tb_sym_root
, name
);
10480 gcc_assert (stree
);
10482 stree
->n
.tb
= gfc_get_typebound_proc (&tb
);
10484 if (gfc_get_sym_tree (target
, gfc_current_ns
, &stree
->n
.tb
->u
.specific
,
10486 return MATCH_ERROR
;
10487 gfc_set_sym_referenced (stree
->n
.tb
->u
.specific
->n
.sym
);
10488 gfc_add_flavor(&stree
->n
.tb
->u
.specific
->n
.sym
->attr
, FL_PROCEDURE
,
10489 target
, &stree
->n
.tb
->u
.specific
->n
.sym
->declared_at
);
10491 if (gfc_match_eos () == MATCH_YES
)
10493 if (gfc_match_char (',') != MATCH_YES
)
10498 gfc_error ("Syntax error in PROCEDURE statement at %C");
10499 return MATCH_ERROR
;
10503 /* Match a GENERIC procedure binding inside a derived type. */
10506 gfc_match_generic (void)
10508 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10509 char bind_name
[GFC_MAX_SYMBOL_LEN
+ 16]; /* Allow space for OPERATOR(...). */
10511 gfc_typebound_proc tbattr
; /* Used for match_binding_attributes. */
10512 gfc_typebound_proc
* tb
;
10514 interface_type op_type
;
10515 gfc_intrinsic_op op
;
10518 /* Check current state. */
10519 if (gfc_current_state () == COMP_DERIVED
)
10521 gfc_error ("GENERIC at %C must be inside a derived-type CONTAINS");
10522 return MATCH_ERROR
;
10524 if (gfc_current_state () != COMP_DERIVED_CONTAINS
)
10526 block
= gfc_state_stack
->previous
->sym
;
10527 ns
= block
->f2k_derived
;
10528 gcc_assert (block
&& ns
);
10530 memset (&tbattr
, 0, sizeof (tbattr
));
10531 tbattr
.where
= gfc_current_locus
;
10533 /* See if we get an access-specifier. */
10534 m
= match_binding_attributes (&tbattr
, true, false);
10535 if (m
== MATCH_ERROR
)
10538 /* Now the colons, those are required. */
10539 if (gfc_match (" ::") != MATCH_YES
)
10541 gfc_error ("Expected %<::%> at %C");
10545 /* Match the binding name; depending on type (operator / generic) format
10546 it for future error messages into bind_name. */
10548 m
= gfc_match_generic_spec (&op_type
, name
, &op
);
10549 if (m
== MATCH_ERROR
)
10550 return MATCH_ERROR
;
10553 gfc_error ("Expected generic name or operator descriptor at %C");
10559 case INTERFACE_GENERIC
:
10560 case INTERFACE_DTIO
:
10561 snprintf (bind_name
, sizeof (bind_name
), "%s", name
);
10564 case INTERFACE_USER_OP
:
10565 snprintf (bind_name
, sizeof (bind_name
), "OPERATOR(.%s.)", name
);
10568 case INTERFACE_INTRINSIC_OP
:
10569 snprintf (bind_name
, sizeof (bind_name
), "OPERATOR(%s)",
10570 gfc_op2string (op
));
10573 case INTERFACE_NAMELESS
:
10574 gfc_error ("Malformed GENERIC statement at %C");
10579 gcc_unreachable ();
10582 /* Match the required =>. */
10583 if (gfc_match (" =>") != MATCH_YES
)
10585 gfc_error ("Expected %<=>%> at %C");
10589 /* Try to find existing GENERIC binding with this name / for this operator;
10590 if there is something, check that it is another GENERIC and then extend
10591 it rather than building a new node. Otherwise, create it and put it
10592 at the right position. */
10596 case INTERFACE_DTIO
:
10597 case INTERFACE_USER_OP
:
10598 case INTERFACE_GENERIC
:
10600 const bool is_op
= (op_type
== INTERFACE_USER_OP
);
10603 st
= gfc_find_symtree (is_op
? ns
->tb_uop_root
: ns
->tb_sym_root
, name
);
10604 tb
= st
? st
->n
.tb
: NULL
;
10608 case INTERFACE_INTRINSIC_OP
:
10609 tb
= ns
->tb_op
[op
];
10613 gcc_unreachable ();
10618 if (!tb
->is_generic
)
10620 gcc_assert (op_type
== INTERFACE_GENERIC
);
10621 gfc_error ("There's already a non-generic procedure with binding name"
10622 " %qs for the derived type %qs at %C",
10623 bind_name
, block
->name
);
10627 if (tb
->access
!= tbattr
.access
)
10629 gfc_error ("Binding at %C must have the same access as already"
10630 " defined binding %qs", bind_name
);
10636 tb
= gfc_get_typebound_proc (NULL
);
10637 tb
->where
= gfc_current_locus
;
10638 tb
->access
= tbattr
.access
;
10639 tb
->is_generic
= 1;
10640 tb
->u
.generic
= NULL
;
10644 case INTERFACE_DTIO
:
10645 case INTERFACE_GENERIC
:
10646 case INTERFACE_USER_OP
:
10648 const bool is_op
= (op_type
== INTERFACE_USER_OP
);
10649 gfc_symtree
* st
= gfc_get_tbp_symtree (is_op
? &ns
->tb_uop_root
:
10650 &ns
->tb_sym_root
, name
);
10657 case INTERFACE_INTRINSIC_OP
:
10658 ns
->tb_op
[op
] = tb
;
10662 gcc_unreachable ();
10666 /* Now, match all following names as specific targets. */
10669 gfc_symtree
* target_st
;
10670 gfc_tbp_generic
* target
;
10672 m
= gfc_match_name (name
);
10673 if (m
== MATCH_ERROR
)
10677 gfc_error ("Expected specific binding name at %C");
10681 target_st
= gfc_get_tbp_symtree (&ns
->tb_sym_root
, name
);
10683 /* See if this is a duplicate specification. */
10684 for (target
= tb
->u
.generic
; target
; target
= target
->next
)
10685 if (target_st
== target
->specific_st
)
10687 gfc_error ("%qs already defined as specific binding for the"
10688 " generic %qs at %C", name
, bind_name
);
10692 target
= gfc_get_tbp_generic ();
10693 target
->specific_st
= target_st
;
10694 target
->specific
= NULL
;
10695 target
->next
= tb
->u
.generic
;
10696 target
->is_operator
= ((op_type
== INTERFACE_USER_OP
)
10697 || (op_type
== INTERFACE_INTRINSIC_OP
));
10698 tb
->u
.generic
= target
;
10700 while (gfc_match (" ,") == MATCH_YES
);
10702 /* Here should be the end. */
10703 if (gfc_match_eos () != MATCH_YES
)
10705 gfc_error ("Junk after GENERIC binding at %C");
10712 return MATCH_ERROR
;
10716 /* Match a FINAL declaration inside a derived type. */
10719 gfc_match_final_decl (void)
10721 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10724 gfc_namespace
* module_ns
;
10728 if (gfc_current_form
== FORM_FREE
)
10730 char c
= gfc_peek_ascii_char ();
10731 if (!gfc_is_whitespace (c
) && c
!= ':')
10735 if (gfc_state_stack
->state
!= COMP_DERIVED_CONTAINS
)
10737 if (gfc_current_form
== FORM_FIXED
)
10740 gfc_error ("FINAL declaration at %C must be inside a derived type "
10741 "CONTAINS section");
10742 return MATCH_ERROR
;
10745 block
= gfc_state_stack
->previous
->sym
;
10746 gcc_assert (block
);
10748 if (!gfc_state_stack
->previous
|| !gfc_state_stack
->previous
->previous
10749 || gfc_state_stack
->previous
->previous
->state
!= COMP_MODULE
)
10751 gfc_error ("Derived type declaration with FINAL at %C must be in the"
10752 " specification part of a MODULE");
10753 return MATCH_ERROR
;
10756 module_ns
= gfc_current_ns
;
10757 gcc_assert (module_ns
);
10758 gcc_assert (module_ns
->proc_name
->attr
.flavor
== FL_MODULE
);
10760 /* Match optional ::, don't care about MATCH_YES or MATCH_NO. */
10761 if (gfc_match (" ::") == MATCH_ERROR
)
10762 return MATCH_ERROR
;
10764 /* Match the sequence of procedure names. */
10771 if (first
&& gfc_match_eos () == MATCH_YES
)
10773 gfc_error ("Empty FINAL at %C");
10774 return MATCH_ERROR
;
10777 m
= gfc_match_name (name
);
10780 gfc_error ("Expected module procedure name at %C");
10781 return MATCH_ERROR
;
10783 else if (m
!= MATCH_YES
)
10784 return MATCH_ERROR
;
10786 if (gfc_match_eos () == MATCH_YES
)
10788 if (!last
&& gfc_match_char (',') != MATCH_YES
)
10790 gfc_error ("Expected %<,%> at %C");
10791 return MATCH_ERROR
;
10794 if (gfc_get_symbol (name
, module_ns
, &sym
))
10796 gfc_error ("Unknown procedure name %qs at %C", name
);
10797 return MATCH_ERROR
;
10800 /* Mark the symbol as module procedure. */
10801 if (sym
->attr
.proc
!= PROC_MODULE
10802 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
10803 return MATCH_ERROR
;
10805 /* Check if we already have this symbol in the list, this is an error. */
10806 for (f
= block
->f2k_derived
->finalizers
; f
; f
= f
->next
)
10807 if (f
->proc_sym
== sym
)
10809 gfc_error ("%qs at %C is already defined as FINAL procedure",
10811 return MATCH_ERROR
;
10814 /* Add this symbol to the list of finalizers. */
10815 gcc_assert (block
->f2k_derived
);
10817 f
= XCNEW (gfc_finalizer
);
10819 f
->proc_tree
= NULL
;
10820 f
->where
= gfc_current_locus
;
10821 f
->next
= block
->f2k_derived
->finalizers
;
10822 block
->f2k_derived
->finalizers
= f
;
10832 const ext_attr_t ext_attr_list
[] = {
10833 { "dllimport", EXT_ATTR_DLLIMPORT
, "dllimport" },
10834 { "dllexport", EXT_ATTR_DLLEXPORT
, "dllexport" },
10835 { "cdecl", EXT_ATTR_CDECL
, "cdecl" },
10836 { "stdcall", EXT_ATTR_STDCALL
, "stdcall" },
10837 { "fastcall", EXT_ATTR_FASTCALL
, "fastcall" },
10838 { "no_arg_check", EXT_ATTR_NO_ARG_CHECK
, NULL
},
10839 { NULL
, EXT_ATTR_LAST
, NULL
}
10842 /* Match a !GCC$ ATTRIBUTES statement of the form:
10843 !GCC$ ATTRIBUTES attribute-list :: var-name [, var-name] ...
10844 When we come here, we have already matched the !GCC$ ATTRIBUTES string.
10846 TODO: We should support all GCC attributes using the same syntax for
10847 the attribute list, i.e. the list in C
10848 __attributes(( attribute-list ))
10850 !GCC$ ATTRIBUTES attribute-list ::
10851 Cf. c-parser.c's c_parser_attributes; the data can then directly be
10854 As there is absolutely no risk of confusion, we should never return
10857 gfc_match_gcc_attributes (void)
10859 symbol_attribute attr
;
10860 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10865 gfc_clear_attr (&attr
);
10870 if (gfc_match_name (name
) != MATCH_YES
)
10871 return MATCH_ERROR
;
10873 for (id
= 0; id
< EXT_ATTR_LAST
; id
++)
10874 if (strcmp (name
, ext_attr_list
[id
].name
) == 0)
10877 if (id
== EXT_ATTR_LAST
)
10879 gfc_error ("Unknown attribute in !GCC$ ATTRIBUTES statement at %C");
10880 return MATCH_ERROR
;
10883 if (!gfc_add_ext_attribute (&attr
, (ext_attr_id_t
)id
, &gfc_current_locus
))
10884 return MATCH_ERROR
;
10886 gfc_gobble_whitespace ();
10887 ch
= gfc_next_ascii_char ();
10890 /* This is the successful exit condition for the loop. */
10891 if (gfc_next_ascii_char () == ':')
10901 if (gfc_match_eos () == MATCH_YES
)
10906 m
= gfc_match_name (name
);
10907 if (m
!= MATCH_YES
)
10910 if (find_special (name
, &sym
, true))
10911 return MATCH_ERROR
;
10913 sym
->attr
.ext_attr
|= attr
.ext_attr
;
10915 if (gfc_match_eos () == MATCH_YES
)
10918 if (gfc_match_char (',') != MATCH_YES
)
10925 gfc_error ("Syntax error in !GCC$ ATTRIBUTES statement at %C");
10926 return MATCH_ERROR
;