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 /* Set upon parsing a !GCC$ unroll n directive for use in the next loop. */
99 int directive_unroll
= -1;
101 /* If a kind expression of a component of a parameterized derived type is
102 parameterized, temporarily store the expression here. */
103 static gfc_expr
*saved_kind_expr
= NULL
;
105 /* Used to store the parameter list arising in a PDT declaration and
106 in the typespec of a PDT variable or component. */
107 static gfc_actual_arglist
*decl_type_param_list
;
108 static gfc_actual_arglist
*type_param_spec_list
;
110 /********************* DATA statement subroutines *********************/
112 static bool in_match_data
= false;
115 gfc_in_match_data (void)
117 return in_match_data
;
121 set_in_match_data (bool set_value
)
123 in_match_data
= set_value
;
126 /* Free a gfc_data_variable structure and everything beneath it. */
129 free_variable (gfc_data_variable
*p
)
131 gfc_data_variable
*q
;
136 gfc_free_expr (p
->expr
);
137 gfc_free_iterator (&p
->iter
, 0);
138 free_variable (p
->list
);
144 /* Free a gfc_data_value structure and everything beneath it. */
147 free_value (gfc_data_value
*p
)
154 mpz_clear (p
->repeat
);
155 gfc_free_expr (p
->expr
);
161 /* Free a list of gfc_data structures. */
164 gfc_free_data (gfc_data
*p
)
171 free_variable (p
->var
);
172 free_value (p
->value
);
178 /* Free all data in a namespace. */
181 gfc_free_data_all (gfc_namespace
*ns
)
193 /* Reject data parsed since the last restore point was marked. */
196 gfc_reject_data (gfc_namespace
*ns
)
200 while (ns
->data
&& ns
->data
!= ns
->old_data
)
208 static match
var_element (gfc_data_variable
*);
210 /* Match a list of variables terminated by an iterator and a right
214 var_list (gfc_data_variable
*parent
)
216 gfc_data_variable
*tail
, var
;
219 m
= var_element (&var
);
220 if (m
== MATCH_ERROR
)
225 tail
= gfc_get_data_variable ();
232 if (gfc_match_char (',') != MATCH_YES
)
235 m
= gfc_match_iterator (&parent
->iter
, 1);
238 if (m
== MATCH_ERROR
)
241 m
= var_element (&var
);
242 if (m
== MATCH_ERROR
)
247 tail
->next
= gfc_get_data_variable ();
253 if (gfc_match_char (')') != MATCH_YES
)
258 gfc_syntax_error (ST_DATA
);
263 /* Match a single element in a data variable list, which can be a
264 variable-iterator list. */
267 var_element (gfc_data_variable
*new_var
)
272 memset (new_var
, 0, sizeof (gfc_data_variable
));
274 if (gfc_match_char ('(') == MATCH_YES
)
275 return var_list (new_var
);
277 m
= gfc_match_variable (&new_var
->expr
, 0);
281 sym
= new_var
->expr
->symtree
->n
.sym
;
283 /* Symbol should already have an associated type. */
284 if (!gfc_check_symbol_typed (sym
, gfc_current_ns
, false, gfc_current_locus
))
287 if (!sym
->attr
.function
&& gfc_current_ns
->parent
288 && gfc_current_ns
->parent
== sym
->ns
)
290 gfc_error ("Host associated variable %qs may not be in the DATA "
291 "statement at %C", sym
->name
);
295 if (gfc_current_state () != COMP_BLOCK_DATA
296 && sym
->attr
.in_common
297 && !gfc_notify_std (GFC_STD_GNU
, "initialization of "
298 "common block variable %qs in DATA statement at %C",
302 if (!gfc_add_data (&sym
->attr
, sym
->name
, &new_var
->expr
->where
))
309 /* Match the top-level list of data variables. */
312 top_var_list (gfc_data
*d
)
314 gfc_data_variable var
, *tail
, *new_var
;
321 m
= var_element (&var
);
324 if (m
== MATCH_ERROR
)
327 new_var
= gfc_get_data_variable ();
333 tail
->next
= new_var
;
337 if (gfc_match_char ('/') == MATCH_YES
)
339 if (gfc_match_char (',') != MATCH_YES
)
346 gfc_syntax_error (ST_DATA
);
347 gfc_free_data_all (gfc_current_ns
);
353 match_data_constant (gfc_expr
**result
)
355 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
356 gfc_symbol
*sym
, *dt_sym
= NULL
;
361 m
= gfc_match_literal_constant (&expr
, 1);
368 if (m
== MATCH_ERROR
)
371 m
= gfc_match_null (result
);
375 old_loc
= gfc_current_locus
;
377 /* Should this be a structure component, try to match it
378 before matching a name. */
379 m
= gfc_match_rvalue (result
);
380 if (m
== MATCH_ERROR
)
383 if (m
== MATCH_YES
&& (*result
)->expr_type
== EXPR_STRUCTURE
)
385 if (!gfc_simplify_expr (*result
, 0))
389 else if (m
== MATCH_YES
)
390 gfc_free_expr (*result
);
392 gfc_current_locus
= old_loc
;
394 m
= gfc_match_name (name
);
398 if (gfc_find_symbol (name
, NULL
, 1, &sym
))
401 if (sym
&& sym
->attr
.generic
)
402 dt_sym
= gfc_find_dt_in_generic (sym
);
405 || (sym
->attr
.flavor
!= FL_PARAMETER
406 && (!dt_sym
|| !gfc_fl_struct (dt_sym
->attr
.flavor
))))
408 gfc_error ("Symbol %qs must be a PARAMETER in DATA statement at %C",
413 else if (dt_sym
&& gfc_fl_struct (dt_sym
->attr
.flavor
))
414 return gfc_match_structure_constructor (dt_sym
, result
);
416 /* Check to see if the value is an initialization array expression. */
417 if (sym
->value
->expr_type
== EXPR_ARRAY
)
419 gfc_current_locus
= old_loc
;
421 m
= gfc_match_init_expr (result
);
422 if (m
== MATCH_ERROR
)
427 if (!gfc_simplify_expr (*result
, 0))
430 if ((*result
)->expr_type
== EXPR_CONSTANT
)
434 gfc_error ("Invalid initializer %s in Data statement at %C", name
);
440 *result
= gfc_copy_expr (sym
->value
);
445 /* Match a list of values in a DATA statement. The leading '/' has
446 already been seen at this point. */
449 top_val_list (gfc_data
*data
)
451 gfc_data_value
*new_val
, *tail
;
459 m
= match_data_constant (&expr
);
462 if (m
== MATCH_ERROR
)
465 new_val
= gfc_get_data_value ();
466 mpz_init (new_val
->repeat
);
469 data
->value
= new_val
;
471 tail
->next
= new_val
;
475 if (expr
->ts
.type
!= BT_INTEGER
|| gfc_match_char ('*') != MATCH_YES
)
478 mpz_set_ui (tail
->repeat
, 1);
482 mpz_set (tail
->repeat
, expr
->value
.integer
);
483 gfc_free_expr (expr
);
485 m
= match_data_constant (&tail
->expr
);
488 if (m
== MATCH_ERROR
)
492 if (gfc_match_char ('/') == MATCH_YES
)
494 if (gfc_match_char (',') == MATCH_NO
)
501 gfc_syntax_error (ST_DATA
);
502 gfc_free_data_all (gfc_current_ns
);
507 /* Matches an old style initialization. */
510 match_old_style_init (const char *name
)
517 /* Set up data structure to hold initializers. */
518 gfc_find_sym_tree (name
, NULL
, 0, &st
);
521 newdata
= gfc_get_data ();
522 newdata
->var
= gfc_get_data_variable ();
523 newdata
->var
->expr
= gfc_get_variable_expr (st
);
524 newdata
->where
= gfc_current_locus
;
526 /* Match initial value list. This also eats the terminal '/'. */
527 m
= top_val_list (newdata
);
536 gfc_error ("Initialization at %C is not allowed in a PURE procedure");
540 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
542 /* Mark the variable as having appeared in a data statement. */
543 if (!gfc_add_data (&sym
->attr
, sym
->name
, &sym
->declared_at
))
549 /* Chain in namespace list of DATA initializers. */
550 newdata
->next
= gfc_current_ns
->data
;
551 gfc_current_ns
->data
= newdata
;
557 /* Match the stuff following a DATA statement. If ERROR_FLAG is set,
558 we are matching a DATA statement and are therefore issuing an error
559 if we encounter something unexpected, if not, we're trying to match
560 an old-style initialization expression of the form INTEGER I /2/. */
563 gfc_match_data (void)
568 /* Before parsing the rest of a DATA statement, check F2008:c1206. */
569 if ((gfc_current_state () == COMP_FUNCTION
570 || gfc_current_state () == COMP_SUBROUTINE
)
571 && gfc_state_stack
->previous
->state
== COMP_INTERFACE
)
573 gfc_error ("DATA statement at %C cannot appear within an INTERFACE");
577 set_in_match_data (true);
581 new_data
= gfc_get_data ();
582 new_data
->where
= gfc_current_locus
;
584 m
= top_var_list (new_data
);
588 m
= top_val_list (new_data
);
592 new_data
->next
= gfc_current_ns
->data
;
593 gfc_current_ns
->data
= new_data
;
595 if (gfc_match_eos () == MATCH_YES
)
598 gfc_match_char (','); /* Optional comma */
601 set_in_match_data (false);
605 gfc_error ("DATA statement at %C is not allowed in a PURE procedure");
608 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
613 set_in_match_data (false);
614 gfc_free_data (new_data
);
619 /************************ Declaration statements *********************/
622 /* Like gfc_match_init_expr, but matches a 'clist' (old-style initialization
623 list). The difference here is the expression is a list of constants
624 and is surrounded by '/'.
625 The typespec ts must match the typespec of the variable which the
626 clist is initializing.
627 The arrayspec tells whether this should match a list of constants
628 corresponding to array elements or a scalar (as == NULL). */
631 match_clist_expr (gfc_expr
**result
, gfc_typespec
*ts
, gfc_array_spec
*as
)
633 gfc_constructor_base array_head
= NULL
;
634 gfc_expr
*expr
= NULL
;
637 mpz_t repeat
, cons_size
, as_size
;
643 mpz_init_set_ui (repeat
, 0);
644 scalar
= !as
|| !as
->rank
;
646 /* We have already matched '/' - now look for a constant list, as with
647 top_val_list from decl.c, but append the result to an array. */
648 if (gfc_match ("/") == MATCH_YES
)
650 gfc_error ("Empty old style initializer list at %C");
654 where
= gfc_current_locus
;
657 m
= match_data_constant (&expr
);
659 expr
= NULL
; /* match_data_constant may set expr to garbage */
662 if (m
== MATCH_ERROR
)
665 /* Found r in repeat spec r*c; look for the constant to repeat. */
666 if ( gfc_match_char ('*') == MATCH_YES
)
670 gfc_error ("Repeat spec invalid in scalar initializer at %C");
673 if (expr
->ts
.type
!= BT_INTEGER
)
675 gfc_error ("Repeat spec must be an integer at %C");
678 mpz_set (repeat
, expr
->value
.integer
);
679 gfc_free_expr (expr
);
682 m
= match_data_constant (&expr
);
684 gfc_error ("Expected data constant after repeat spec at %C");
688 /* No repeat spec, we matched the data constant itself. */
690 mpz_set_ui (repeat
, 1);
694 /* Add the constant initializer as many times as repeated. */
695 for (; mpz_cmp_ui (repeat
, 0) > 0; mpz_sub_ui (repeat
, repeat
, 1))
697 /* Make sure types of elements match */
698 if(ts
&& !gfc_compare_types (&expr
->ts
, ts
)
699 && !gfc_convert_type (expr
, ts
, 1))
702 gfc_constructor_append_expr (&array_head
,
703 gfc_copy_expr (expr
), &gfc_current_locus
);
706 gfc_free_expr (expr
);
710 /* For scalar initializers quit after one element. */
713 if(gfc_match_char ('/') != MATCH_YES
)
715 gfc_error ("End of scalar initializer expected at %C");
721 if (gfc_match_char ('/') == MATCH_YES
)
723 if (gfc_match_char (',') == MATCH_NO
)
727 /* Set up expr as an array constructor. */
730 expr
= gfc_get_array_expr (ts
->type
, ts
->kind
, &where
);
732 expr
->value
.constructor
= array_head
;
734 expr
->rank
= as
->rank
;
735 expr
->shape
= gfc_get_shape (expr
->rank
);
737 /* Validate sizes. We built expr ourselves, so cons_size will be
738 constant (we fail above for non-constant expressions).
739 We still need to verify that the array-spec has constant size. */
741 gcc_assert (gfc_array_size (expr
, &cons_size
));
742 if (!spec_size (as
, &as_size
))
744 gfc_error ("Expected constant array-spec in initializer list at %L",
745 as
->type
== AS_EXPLICIT
? &as
->upper
[0]->where
: &where
);
750 /* Make sure the specs are of the same size. */
751 cmp
= mpz_cmp (cons_size
, as_size
);
753 gfc_error ("Not enough elements in array initializer at %C");
755 gfc_error ("Too many elements in array initializer at %C");
758 mpz_clear (cons_size
);
763 /* Make sure scalar types match. */
764 else if (!gfc_compare_types (&expr
->ts
, ts
)
765 && !gfc_convert_type (expr
, ts
, 1))
769 expr
->ts
.u
.cl
->length_from_typespec
= 1;
776 gfc_error ("Syntax error in old style initializer list at %C");
780 expr
->value
.constructor
= NULL
;
781 gfc_free_expr (expr
);
782 gfc_constructor_free (array_head
);
788 /* Auxiliary function to merge DIMENSION and CODIMENSION array specs. */
791 merge_array_spec (gfc_array_spec
*from
, gfc_array_spec
*to
, bool copy
)
795 if ((from
->type
== AS_ASSUMED_RANK
&& to
->corank
)
796 || (to
->type
== AS_ASSUMED_RANK
&& from
->corank
))
798 gfc_error ("The assumed-rank array at %C shall not have a codimension");
802 if (to
->rank
== 0 && from
->rank
> 0)
804 to
->rank
= from
->rank
;
805 to
->type
= from
->type
;
806 to
->cray_pointee
= from
->cray_pointee
;
807 to
->cp_was_assumed
= from
->cp_was_assumed
;
809 for (i
= 0; i
< to
->corank
; i
++)
811 to
->lower
[from
->rank
+ i
] = to
->lower
[i
];
812 to
->upper
[from
->rank
+ i
] = to
->upper
[i
];
814 for (i
= 0; i
< from
->rank
; i
++)
818 to
->lower
[i
] = gfc_copy_expr (from
->lower
[i
]);
819 to
->upper
[i
] = gfc_copy_expr (from
->upper
[i
]);
823 to
->lower
[i
] = from
->lower
[i
];
824 to
->upper
[i
] = from
->upper
[i
];
828 else if (to
->corank
== 0 && from
->corank
> 0)
830 to
->corank
= from
->corank
;
831 to
->cotype
= from
->cotype
;
833 for (i
= 0; i
< from
->corank
; i
++)
837 to
->lower
[to
->rank
+ i
] = gfc_copy_expr (from
->lower
[i
]);
838 to
->upper
[to
->rank
+ i
] = gfc_copy_expr (from
->upper
[i
]);
842 to
->lower
[to
->rank
+ i
] = from
->lower
[i
];
843 to
->upper
[to
->rank
+ i
] = from
->upper
[i
];
852 /* Match an intent specification. Since this can only happen after an
853 INTENT word, a legal intent-spec must follow. */
856 match_intent_spec (void)
859 if (gfc_match (" ( in out )") == MATCH_YES
)
861 if (gfc_match (" ( in )") == MATCH_YES
)
863 if (gfc_match (" ( out )") == MATCH_YES
)
866 gfc_error ("Bad INTENT specification at %C");
867 return INTENT_UNKNOWN
;
871 /* Matches a character length specification, which is either a
872 specification expression, '*', or ':'. */
875 char_len_param_value (gfc_expr
**expr
, bool *deferred
)
882 if (gfc_match_char ('*') == MATCH_YES
)
885 if (gfc_match_char (':') == MATCH_YES
)
887 if (!gfc_notify_std (GFC_STD_F2003
, "deferred type parameter at %C"))
895 m
= gfc_match_expr (expr
);
897 if (m
== MATCH_NO
|| m
== MATCH_ERROR
)
900 if (!gfc_expr_check_typed (*expr
, gfc_current_ns
, false))
903 if ((*expr
)->expr_type
== EXPR_FUNCTION
)
905 if ((*expr
)->ts
.type
== BT_INTEGER
906 || ((*expr
)->ts
.type
== BT_UNKNOWN
907 && strcmp((*expr
)->symtree
->name
, "null") != 0))
912 else if ((*expr
)->expr_type
== EXPR_CONSTANT
)
914 /* F2008, 4.4.3.1: The length is a type parameter; its kind is
915 processor dependent and its value is greater than or equal to zero.
916 F2008, 4.4.3.2: If the character length parameter value evaluates
917 to a negative value, the length of character entities declared
920 if ((*expr
)->ts
.type
== BT_INTEGER
)
922 if (mpz_cmp_si ((*expr
)->value
.integer
, 0) < 0)
923 mpz_set_si ((*expr
)->value
.integer
, 0);
928 else if ((*expr
)->expr_type
== EXPR_ARRAY
)
930 else if ((*expr
)->expr_type
== EXPR_VARIABLE
)
935 e
= gfc_copy_expr (*expr
);
937 /* This catches the invalid code "[character(m(2:3)) :: 'x', 'y']",
938 which causes an ICE if gfc_reduce_init_expr() is called. */
939 if (e
->ref
&& e
->ref
->type
== REF_ARRAY
940 && e
->ref
->u
.ar
.type
== AR_UNKNOWN
941 && e
->ref
->u
.ar
.dimen_type
[0] == DIMEN_RANGE
)
944 t
= gfc_reduce_init_expr (e
);
946 if (!t
&& e
->ts
.type
== BT_UNKNOWN
947 && e
->symtree
->n
.sym
->attr
.untyped
== 1
948 && (flag_implicit_none
949 || e
->symtree
->n
.sym
->ns
->seen_implicit_none
== 1
950 || e
->symtree
->n
.sym
->ns
->parent
->seen_implicit_none
== 1))
956 if ((e
->ref
&& e
->ref
->type
== REF_ARRAY
957 && e
->ref
->u
.ar
.type
!= AR_ELEMENT
)
958 || (!e
->ref
&& e
->expr_type
== EXPR_ARRAY
))
970 gfc_error ("Scalar INTEGER expression expected at %L", &(*expr
)->where
);
975 /* A character length is a '*' followed by a literal integer or a
976 char_len_param_value in parenthesis. */
979 match_char_length (gfc_expr
**expr
, bool *deferred
, bool obsolescent_check
)
985 m
= gfc_match_char ('*');
989 m
= gfc_match_small_literal_int (&length
, NULL
);
990 if (m
== MATCH_ERROR
)
995 if (obsolescent_check
996 && !gfc_notify_std (GFC_STD_F95_OBS
, "Old-style character length at %C"))
998 *expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, length
);
1002 if (gfc_match_char ('(') == MATCH_NO
)
1005 m
= char_len_param_value (expr
, deferred
);
1006 if (m
!= MATCH_YES
&& gfc_matching_function
)
1008 gfc_undo_symbols ();
1012 if (m
== MATCH_ERROR
)
1017 if (gfc_match_char (')') == MATCH_NO
)
1019 gfc_free_expr (*expr
);
1027 gfc_error ("Syntax error in character length specification at %C");
1032 /* Special subroutine for finding a symbol. Check if the name is found
1033 in the current name space. If not, and we're compiling a function or
1034 subroutine and the parent compilation unit is an interface, then check
1035 to see if the name we've been given is the name of the interface
1036 (located in another namespace). */
1039 find_special (const char *name
, gfc_symbol
**result
, bool allow_subroutine
)
1045 i
= gfc_get_sym_tree (name
, NULL
, &st
, allow_subroutine
);
1048 *result
= st
? st
->n
.sym
: NULL
;
1052 if (gfc_current_state () != COMP_SUBROUTINE
1053 && gfc_current_state () != COMP_FUNCTION
)
1056 s
= gfc_state_stack
->previous
;
1060 if (s
->state
!= COMP_INTERFACE
)
1063 goto end
; /* Nameless interface. */
1065 if (strcmp (name
, s
->sym
->name
) == 0)
1076 /* Special subroutine for getting a symbol node associated with a
1077 procedure name, used in SUBROUTINE and FUNCTION statements. The
1078 symbol is created in the parent using with symtree node in the
1079 child unit pointing to the symbol. If the current namespace has no
1080 parent, then the symbol is just created in the current unit. */
1083 get_proc_name (const char *name
, gfc_symbol
**result
, bool module_fcn_entry
)
1089 /* Module functions have to be left in their own namespace because
1090 they have potentially (almost certainly!) already been referenced.
1091 In this sense, they are rather like external functions. This is
1092 fixed up in resolve.c(resolve_entries), where the symbol name-
1093 space is set to point to the master function, so that the fake
1094 result mechanism can work. */
1095 if (module_fcn_entry
)
1097 /* Present if entry is declared to be a module procedure. */
1098 rc
= gfc_find_symbol (name
, gfc_current_ns
->parent
, 0, result
);
1100 if (*result
== NULL
)
1101 rc
= gfc_get_symbol (name
, NULL
, result
);
1102 else if (!gfc_get_symbol (name
, NULL
, &sym
) && sym
1103 && (*result
)->ts
.type
== BT_UNKNOWN
1104 && sym
->attr
.flavor
== FL_UNKNOWN
)
1105 /* Pick up the typespec for the entry, if declared in the function
1106 body. Note that this symbol is FL_UNKNOWN because it will
1107 only have appeared in a type declaration. The local symtree
1108 is set to point to the module symbol and a unique symtree
1109 to the local version. This latter ensures a correct clearing
1112 /* If the ENTRY proceeds its specification, we need to ensure
1113 that this does not raise a "has no IMPLICIT type" error. */
1114 if (sym
->ts
.type
== BT_UNKNOWN
)
1115 sym
->attr
.untyped
= 1;
1117 (*result
)->ts
= sym
->ts
;
1119 /* Put the symbol in the procedure namespace so that, should
1120 the ENTRY precede its specification, the specification
1122 (*result
)->ns
= gfc_current_ns
;
1124 gfc_find_sym_tree (name
, gfc_current_ns
, 0, &st
);
1125 st
->n
.sym
= *result
;
1126 st
= gfc_get_unique_symtree (gfc_current_ns
);
1132 rc
= gfc_get_symbol (name
, gfc_current_ns
->parent
, result
);
1138 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
1141 if (sym
->attr
.module_procedure
1142 && sym
->attr
.if_source
== IFSRC_IFBODY
)
1144 /* Create a partially populated interface symbol to carry the
1145 characteristics of the procedure and the result. */
1146 sym
->tlink
= gfc_new_symbol (name
, sym
->ns
);
1147 gfc_add_type (sym
->tlink
, &(sym
->ts
),
1148 &gfc_current_locus
);
1149 gfc_copy_attr (&sym
->tlink
->attr
, &sym
->attr
, NULL
);
1150 if (sym
->attr
.dimension
)
1151 sym
->tlink
->as
= gfc_copy_array_spec (sym
->as
);
1153 /* Ideally, at this point, a copy would be made of the formal
1154 arguments and their namespace. However, this does not appear
1155 to be necessary, albeit at the expense of not being able to
1156 use gfc_compare_interfaces directly. */
1158 if (sym
->result
&& sym
->result
!= sym
)
1160 sym
->tlink
->result
= sym
->result
;
1163 else if (sym
->result
)
1165 sym
->tlink
->result
= sym
->tlink
;
1168 else if (sym
&& !sym
->gfc_new
1169 && gfc_current_state () != COMP_INTERFACE
)
1171 /* Trap another encompassed procedure with the same name. All
1172 these conditions are necessary to avoid picking up an entry
1173 whose name clashes with that of the encompassing procedure;
1174 this is handled using gsymbols to register unique, globally
1175 accessible names. */
1176 if (sym
->attr
.flavor
!= 0
1177 && sym
->attr
.proc
!= 0
1178 && (sym
->attr
.subroutine
|| sym
->attr
.function
)
1179 && sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
1180 gfc_error_now ("Procedure %qs at %C is already defined at %L",
1181 name
, &sym
->declared_at
);
1183 /* Trap a procedure with a name the same as interface in the
1184 encompassing scope. */
1185 if (sym
->attr
.generic
!= 0
1186 && (sym
->attr
.subroutine
|| sym
->attr
.function
)
1187 && !sym
->attr
.mod_proc
)
1188 gfc_error_now ("Name %qs at %C is already defined"
1189 " as a generic interface at %L",
1190 name
, &sym
->declared_at
);
1192 /* Trap declarations of attributes in encompassing scope. The
1193 signature for this is that ts.kind is set. Legitimate
1194 references only set ts.type. */
1195 if (sym
->ts
.kind
!= 0
1196 && !sym
->attr
.implicit_type
1197 && sym
->attr
.proc
== 0
1198 && gfc_current_ns
->parent
!= NULL
1199 && sym
->attr
.access
== 0
1200 && !module_fcn_entry
)
1201 gfc_error_now ("Procedure %qs at %C has an explicit interface "
1202 "and must not have attributes declared at %L",
1203 name
, &sym
->declared_at
);
1206 if (gfc_current_ns
->parent
== NULL
|| *result
== NULL
)
1209 /* Module function entries will already have a symtree in
1210 the current namespace but will need one at module level. */
1211 if (module_fcn_entry
)
1213 /* Present if entry is declared to be a module procedure. */
1214 rc
= gfc_find_sym_tree (name
, gfc_current_ns
->parent
, 0, &st
);
1216 st
= gfc_new_symtree (&gfc_current_ns
->parent
->sym_root
, name
);
1219 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, name
);
1224 /* See if the procedure should be a module procedure. */
1226 if (((sym
->ns
->proc_name
!= NULL
1227 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
1228 && sym
->attr
.proc
!= PROC_MODULE
)
1229 || (module_fcn_entry
&& sym
->attr
.proc
!= PROC_MODULE
))
1230 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
1237 /* Verify that the given symbol representing a parameter is C
1238 interoperable, by checking to see if it was marked as such after
1239 its declaration. If the given symbol is not interoperable, a
1240 warning is reported, thus removing the need to return the status to
1241 the calling function. The standard does not require the user use
1242 one of the iso_c_binding named constants to declare an
1243 interoperable parameter, but we can't be sure if the param is C
1244 interop or not if the user doesn't. For example, integer(4) may be
1245 legal Fortran, but doesn't have meaning in C. It may interop with
1246 a number of the C types, which causes a problem because the
1247 compiler can't know which one. This code is almost certainly not
1248 portable, and the user will get what they deserve if the C type
1249 across platforms isn't always interoperable with integer(4). If
1250 the user had used something like integer(c_int) or integer(c_long),
1251 the compiler could have automatically handled the varying sizes
1252 across platforms. */
1255 gfc_verify_c_interop_param (gfc_symbol
*sym
)
1257 int is_c_interop
= 0;
1260 /* We check implicitly typed variables in symbol.c:gfc_set_default_type().
1261 Don't repeat the checks here. */
1262 if (sym
->attr
.implicit_type
)
1265 /* For subroutines or functions that are passed to a BIND(C) procedure,
1266 they're interoperable if they're BIND(C) and their params are all
1268 if (sym
->attr
.flavor
== FL_PROCEDURE
)
1270 if (sym
->attr
.is_bind_c
== 0)
1272 gfc_error_now ("Procedure %qs at %L must have the BIND(C) "
1273 "attribute to be C interoperable", sym
->name
,
1274 &(sym
->declared_at
));
1279 if (sym
->attr
.is_c_interop
== 1)
1280 /* We've already checked this procedure; don't check it again. */
1283 return verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
1288 /* See if we've stored a reference to a procedure that owns sym. */
1289 if (sym
->ns
!= NULL
&& sym
->ns
->proc_name
!= NULL
)
1291 if (sym
->ns
->proc_name
->attr
.is_bind_c
== 1)
1293 is_c_interop
= (gfc_verify_c_interop(&(sym
->ts
)) ? 1 : 0);
1295 if (is_c_interop
!= 1)
1297 /* Make personalized messages to give better feedback. */
1298 if (sym
->ts
.type
== BT_DERIVED
)
1299 gfc_error ("Variable %qs at %L is a dummy argument to the "
1300 "BIND(C) procedure %qs but is not C interoperable "
1301 "because derived type %qs is not C interoperable",
1302 sym
->name
, &(sym
->declared_at
),
1303 sym
->ns
->proc_name
->name
,
1304 sym
->ts
.u
.derived
->name
);
1305 else if (sym
->ts
.type
== BT_CLASS
)
1306 gfc_error ("Variable %qs at %L is a dummy argument to the "
1307 "BIND(C) procedure %qs but is not C interoperable "
1308 "because it is polymorphic",
1309 sym
->name
, &(sym
->declared_at
),
1310 sym
->ns
->proc_name
->name
);
1311 else if (warn_c_binding_type
)
1312 gfc_warning (OPT_Wc_binding_type
,
1313 "Variable %qs at %L is a dummy argument of the "
1314 "BIND(C) procedure %qs but may not be C "
1316 sym
->name
, &(sym
->declared_at
),
1317 sym
->ns
->proc_name
->name
);
1320 /* Character strings are only C interoperable if they have a
1322 if (sym
->ts
.type
== BT_CHARACTER
)
1324 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
1325 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
1326 || mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
1328 gfc_error ("Character argument %qs at %L "
1329 "must be length 1 because "
1330 "procedure %qs is BIND(C)",
1331 sym
->name
, &sym
->declared_at
,
1332 sym
->ns
->proc_name
->name
);
1337 /* We have to make sure that any param to a bind(c) routine does
1338 not have the allocatable, pointer, or optional attributes,
1339 according to J3/04-007, section 5.1. */
1340 if (sym
->attr
.allocatable
== 1
1341 && !gfc_notify_std (GFC_STD_F2008_TS
, "Variable %qs at %L with "
1342 "ALLOCATABLE attribute in procedure %qs "
1343 "with BIND(C)", sym
->name
,
1344 &(sym
->declared_at
),
1345 sym
->ns
->proc_name
->name
))
1348 if (sym
->attr
.pointer
== 1
1349 && !gfc_notify_std (GFC_STD_F2008_TS
, "Variable %qs at %L with "
1350 "POINTER attribute in procedure %qs "
1351 "with BIND(C)", sym
->name
,
1352 &(sym
->declared_at
),
1353 sym
->ns
->proc_name
->name
))
1356 if ((sym
->attr
.allocatable
|| sym
->attr
.pointer
) && !sym
->as
)
1358 gfc_error ("Scalar variable %qs at %L with POINTER or "
1359 "ALLOCATABLE in procedure %qs with BIND(C) is not yet"
1360 " supported", sym
->name
, &(sym
->declared_at
),
1361 sym
->ns
->proc_name
->name
);
1365 if (sym
->attr
.optional
== 1 && sym
->attr
.value
)
1367 gfc_error ("Variable %qs at %L cannot have both the OPTIONAL "
1368 "and the VALUE attribute because procedure %qs "
1369 "is BIND(C)", sym
->name
, &(sym
->declared_at
),
1370 sym
->ns
->proc_name
->name
);
1373 else if (sym
->attr
.optional
== 1
1374 && !gfc_notify_std (GFC_STD_F2008_TS
, "Variable %qs "
1375 "at %L with OPTIONAL attribute in "
1376 "procedure %qs which is BIND(C)",
1377 sym
->name
, &(sym
->declared_at
),
1378 sym
->ns
->proc_name
->name
))
1381 /* Make sure that if it has the dimension attribute, that it is
1382 either assumed size or explicit shape. Deferred shape is already
1383 covered by the pointer/allocatable attribute. */
1384 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SHAPE
1385 && !gfc_notify_std (GFC_STD_F2008_TS
, "Assumed-shape array %qs "
1386 "at %L as dummy argument to the BIND(C) "
1387 "procedure %qs at %L", sym
->name
,
1388 &(sym
->declared_at
),
1389 sym
->ns
->proc_name
->name
,
1390 &(sym
->ns
->proc_name
->declared_at
)))
1400 /* Function called by variable_decl() that adds a name to the symbol table. */
1403 build_sym (const char *name
, gfc_charlen
*cl
, bool cl_deferred
,
1404 gfc_array_spec
**as
, locus
*var_locus
)
1406 symbol_attribute attr
;
1411 /* Symbols in a submodule are host associated from the parent module or
1412 submodules. Therefore, they can be overridden by declarations in the
1413 submodule scope. Deal with this by attaching the existing symbol to
1414 a new symtree and recycling the old symtree with a new symbol... */
1415 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
1416 if (st
!= NULL
&& gfc_state_stack
->state
== COMP_SUBMODULE
1417 && st
->n
.sym
!= NULL
1418 && st
->n
.sym
->attr
.host_assoc
&& st
->n
.sym
->attr
.used_in_submodule
)
1420 gfc_symtree
*s
= gfc_get_unique_symtree (gfc_current_ns
);
1421 s
->n
.sym
= st
->n
.sym
;
1422 sym
= gfc_new_symbol (name
, gfc_current_ns
);
1427 gfc_set_sym_referenced (sym
);
1429 /* ...Otherwise generate a new symtree and new symbol. */
1430 else if (gfc_get_symbol (name
, NULL
, &sym
))
1433 /* Check if the name has already been defined as a type. The
1434 first letter of the symtree will be in upper case then. Of
1435 course, this is only necessary if the upper case letter is
1436 actually different. */
1438 upper
= TOUPPER(name
[0]);
1439 if (upper
!= name
[0])
1441 char u_name
[GFC_MAX_SYMBOL_LEN
+ 1];
1444 gcc_assert (strlen(name
) <= GFC_MAX_SYMBOL_LEN
);
1445 strcpy (u_name
, name
);
1448 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, u_name
);
1450 /* STRUCTURE types can alias symbol names */
1451 if (st
!= 0 && st
->n
.sym
->attr
.flavor
!= FL_STRUCT
)
1453 gfc_error ("Symbol %qs at %C also declared as a type at %L", name
,
1454 &st
->n
.sym
->declared_at
);
1459 /* Start updating the symbol table. Add basic type attribute if present. */
1460 if (current_ts
.type
!= BT_UNKNOWN
1461 && (sym
->attr
.implicit_type
== 0
1462 || !gfc_compare_types (&sym
->ts
, ¤t_ts
))
1463 && !gfc_add_type (sym
, ¤t_ts
, var_locus
))
1466 if (sym
->ts
.type
== BT_CHARACTER
)
1469 sym
->ts
.deferred
= cl_deferred
;
1472 /* Add dimension attribute if present. */
1473 if (!gfc_set_array_spec (sym
, *as
, var_locus
))
1477 /* Add attribute to symbol. The copy is so that we can reset the
1478 dimension attribute. */
1479 attr
= current_attr
;
1481 attr
.codimension
= 0;
1483 if (!gfc_copy_attr (&sym
->attr
, &attr
, var_locus
))
1486 /* Finish any work that may need to be done for the binding label,
1487 if it's a bind(c). The bind(c) attr is found before the symbol
1488 is made, and before the symbol name (for data decls), so the
1489 current_ts is holding the binding label, or nothing if the
1490 name= attr wasn't given. Therefore, test here if we're dealing
1491 with a bind(c) and make sure the binding label is set correctly. */
1492 if (sym
->attr
.is_bind_c
== 1)
1494 if (!sym
->binding_label
)
1496 /* Set the binding label and verify that if a NAME= was specified
1497 then only one identifier was in the entity-decl-list. */
1498 if (!set_binding_label (&sym
->binding_label
, sym
->name
,
1499 num_idents_on_line
))
1504 /* See if we know we're in a common block, and if it's a bind(c)
1505 common then we need to make sure we're an interoperable type. */
1506 if (sym
->attr
.in_common
== 1)
1508 /* Test the common block object. */
1509 if (sym
->common_block
!= NULL
&& sym
->common_block
->is_bind_c
== 1
1510 && sym
->ts
.is_c_interop
!= 1)
1512 gfc_error_now ("Variable %qs in common block %qs at %C "
1513 "must be declared with a C interoperable "
1514 "kind since common block %qs is BIND(C)",
1515 sym
->name
, sym
->common_block
->name
,
1516 sym
->common_block
->name
);
1521 sym
->attr
.implied_index
= 0;
1523 /* Use the parameter expressions for a parameterized derived type. */
1524 if ((sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
1525 && sym
->ts
.u
.derived
->attr
.pdt_type
&& type_param_spec_list
)
1526 sym
->param_list
= gfc_copy_actual_arglist (type_param_spec_list
);
1528 if (sym
->ts
.type
== BT_CLASS
)
1529 return gfc_build_class_symbol (&sym
->ts
, &sym
->attr
, &sym
->as
);
1535 /* Set character constant to the given length. The constant will be padded or
1536 truncated. If we're inside an array constructor without a typespec, we
1537 additionally check that all elements have the same length; check_len -1
1538 means no checking. */
1541 gfc_set_constant_character_len (int len
, gfc_expr
*expr
, int check_len
)
1546 if (expr
->ts
.type
!= BT_CHARACTER
)
1549 if (expr
->expr_type
!= EXPR_CONSTANT
)
1551 gfc_error_now ("CHARACTER length must be a constant at %L", &expr
->where
);
1555 slen
= expr
->value
.character
.length
;
1558 s
= gfc_get_wide_string (len
+ 1);
1559 memcpy (s
, expr
->value
.character
.string
,
1560 MIN (len
, slen
) * sizeof (gfc_char_t
));
1562 gfc_wide_memset (&s
[slen
], ' ', len
- slen
);
1564 if (warn_character_truncation
&& slen
> len
)
1565 gfc_warning_now (OPT_Wcharacter_truncation
,
1566 "CHARACTER expression at %L is being truncated "
1567 "(%d/%d)", &expr
->where
, slen
, len
);
1569 /* Apply the standard by 'hand' otherwise it gets cleared for
1571 if (check_len
!= -1 && slen
!= check_len
1572 && !(gfc_option
.allow_std
& GFC_STD_GNU
))
1573 gfc_error_now ("The CHARACTER elements of the array constructor "
1574 "at %L must have the same length (%d/%d)",
1575 &expr
->where
, slen
, check_len
);
1578 free (expr
->value
.character
.string
);
1579 expr
->value
.character
.string
= s
;
1580 expr
->value
.character
.length
= len
;
1585 /* Function to create and update the enumerator history
1586 using the information passed as arguments.
1587 Pointer "max_enum" is also updated, to point to
1588 enum history node containing largest initializer.
1590 SYM points to the symbol node of enumerator.
1591 INIT points to its enumerator value. */
1594 create_enum_history (gfc_symbol
*sym
, gfc_expr
*init
)
1596 enumerator_history
*new_enum_history
;
1597 gcc_assert (sym
!= NULL
&& init
!= NULL
);
1599 new_enum_history
= XCNEW (enumerator_history
);
1601 new_enum_history
->sym
= sym
;
1602 new_enum_history
->initializer
= init
;
1603 new_enum_history
->next
= NULL
;
1605 if (enum_history
== NULL
)
1607 enum_history
= new_enum_history
;
1608 max_enum
= enum_history
;
1612 new_enum_history
->next
= enum_history
;
1613 enum_history
= new_enum_history
;
1615 if (mpz_cmp (max_enum
->initializer
->value
.integer
,
1616 new_enum_history
->initializer
->value
.integer
) < 0)
1617 max_enum
= new_enum_history
;
1622 /* Function to free enum kind history. */
1625 gfc_free_enum_history (void)
1627 enumerator_history
*current
= enum_history
;
1628 enumerator_history
*next
;
1630 while (current
!= NULL
)
1632 next
= current
->next
;
1637 enum_history
= NULL
;
1641 /* Function called by variable_decl() that adds an initialization
1642 expression to a symbol. */
1645 add_init_expr_to_sym (const char *name
, gfc_expr
**initp
, locus
*var_locus
)
1647 symbol_attribute attr
;
1652 if (find_special (name
, &sym
, false))
1657 /* If this symbol is confirming an implicit parameter type,
1658 then an initialization expression is not allowed. */
1659 if (attr
.flavor
== FL_PARAMETER
1660 && sym
->value
!= NULL
1663 gfc_error ("Initializer not allowed for PARAMETER %qs at %C",
1670 /* An initializer is required for PARAMETER declarations. */
1671 if (attr
.flavor
== FL_PARAMETER
)
1673 gfc_error ("PARAMETER at %L is missing an initializer", var_locus
);
1679 /* If a variable appears in a DATA block, it cannot have an
1683 gfc_error ("Variable %qs at %C with an initializer already "
1684 "appears in a DATA statement", sym
->name
);
1688 /* Check if the assignment can happen. This has to be put off
1689 until later for derived type variables and procedure pointers. */
1690 if (!gfc_bt_struct (sym
->ts
.type
) && !gfc_bt_struct (init
->ts
.type
)
1691 && sym
->ts
.type
!= BT_CLASS
&& init
->ts
.type
!= BT_CLASS
1692 && !sym
->attr
.proc_pointer
1693 && !gfc_check_assign_symbol (sym
, NULL
, init
))
1696 if (sym
->ts
.type
== BT_CHARACTER
&& sym
->ts
.u
.cl
1697 && init
->ts
.type
== BT_CHARACTER
)
1699 /* Update symbol character length according initializer. */
1700 if (!gfc_check_assign_symbol (sym
, NULL
, init
))
1703 if (sym
->ts
.u
.cl
->length
== NULL
)
1706 /* If there are multiple CHARACTER variables declared on the
1707 same line, we don't want them to share the same length. */
1708 sym
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1710 if (sym
->attr
.flavor
== FL_PARAMETER
)
1712 if (init
->expr_type
== EXPR_CONSTANT
)
1714 clen
= init
->value
.character
.length
;
1715 sym
->ts
.u
.cl
->length
1716 = gfc_get_int_expr (gfc_default_integer_kind
,
1719 else if (init
->expr_type
== EXPR_ARRAY
)
1723 const gfc_expr
*length
= init
->ts
.u
.cl
->length
;
1724 if (length
->expr_type
!= EXPR_CONSTANT
)
1726 gfc_error ("Cannot initialize parameter array "
1728 "with variable length elements",
1732 clen
= mpz_get_si (length
->value
.integer
);
1734 else if (init
->value
.constructor
)
1737 c
= gfc_constructor_first (init
->value
.constructor
);
1738 clen
= c
->expr
->value
.character
.length
;
1742 sym
->ts
.u
.cl
->length
1743 = gfc_get_int_expr (gfc_default_integer_kind
,
1746 else if (init
->ts
.u
.cl
&& init
->ts
.u
.cl
->length
)
1747 sym
->ts
.u
.cl
->length
=
1748 gfc_copy_expr (sym
->value
->ts
.u
.cl
->length
);
1751 /* Update initializer character length according symbol. */
1752 else if (sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1756 if (!gfc_specification_expr (sym
->ts
.u
.cl
->length
))
1759 len
= mpz_get_si (sym
->ts
.u
.cl
->length
->value
.integer
);
1761 if (init
->expr_type
== EXPR_CONSTANT
)
1762 gfc_set_constant_character_len (len
, init
, -1);
1763 else if (init
->expr_type
== EXPR_ARRAY
)
1767 /* Build a new charlen to prevent simplification from
1768 deleting the length before it is resolved. */
1769 init
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1770 init
->ts
.u
.cl
->length
= gfc_copy_expr (sym
->ts
.u
.cl
->length
);
1772 for (c
= gfc_constructor_first (init
->value
.constructor
);
1773 c
; c
= gfc_constructor_next (c
))
1774 gfc_set_constant_character_len (len
, c
->expr
, -1);
1779 /* If sym is implied-shape, set its upper bounds from init. */
1780 if (sym
->attr
.flavor
== FL_PARAMETER
&& sym
->attr
.dimension
1781 && sym
->as
->type
== AS_IMPLIED_SHAPE
)
1785 if (init
->rank
== 0)
1787 gfc_error ("Can't initialize implied-shape array at %L"
1788 " with scalar", &sym
->declared_at
);
1792 /* Shape should be present, we get an initialization expression. */
1793 gcc_assert (init
->shape
);
1795 for (dim
= 0; dim
< sym
->as
->rank
; ++dim
)
1798 gfc_expr
*e
, *lower
;
1800 lower
= sym
->as
->lower
[dim
];
1802 /* If the lower bound is an array element from another
1803 parameterized array, then it is marked with EXPR_VARIABLE and
1804 is an initialization expression. Try to reduce it. */
1805 if (lower
->expr_type
== EXPR_VARIABLE
)
1806 gfc_reduce_init_expr (lower
);
1808 if (lower
->expr_type
== EXPR_CONSTANT
)
1810 /* All dimensions must be without upper bound. */
1811 gcc_assert (!sym
->as
->upper
[dim
]);
1814 e
= gfc_get_constant_expr (BT_INTEGER
, k
, &sym
->declared_at
);
1815 mpz_add (e
->value
.integer
, lower
->value
.integer
,
1817 mpz_sub_ui (e
->value
.integer
, e
->value
.integer
, 1);
1818 sym
->as
->upper
[dim
] = e
;
1822 gfc_error ("Non-constant lower bound in implied-shape"
1823 " declaration at %L", &lower
->where
);
1828 sym
->as
->type
= AS_EXPLICIT
;
1831 /* Need to check if the expression we initialized this
1832 to was one of the iso_c_binding named constants. If so,
1833 and we're a parameter (constant), let it be iso_c.
1835 integer(c_int), parameter :: my_int = c_int
1836 integer(my_int) :: my_int_2
1837 If we mark my_int as iso_c (since we can see it's value
1838 is equal to one of the named constants), then my_int_2
1839 will be considered C interoperable. */
1840 if (sym
->ts
.type
!= BT_CHARACTER
&& !gfc_bt_struct (sym
->ts
.type
))
1842 sym
->ts
.is_iso_c
|= init
->ts
.is_iso_c
;
1843 sym
->ts
.is_c_interop
|= init
->ts
.is_c_interop
;
1844 /* attr bits needed for module files. */
1845 sym
->attr
.is_iso_c
|= init
->ts
.is_iso_c
;
1846 sym
->attr
.is_c_interop
|= init
->ts
.is_c_interop
;
1847 if (init
->ts
.is_iso_c
)
1848 sym
->ts
.f90_type
= init
->ts
.f90_type
;
1851 /* Add initializer. Make sure we keep the ranks sane. */
1852 if (sym
->attr
.dimension
&& init
->rank
== 0)
1857 if (sym
->attr
.flavor
== FL_PARAMETER
1858 && init
->expr_type
== EXPR_CONSTANT
1859 && spec_size (sym
->as
, &size
)
1860 && mpz_cmp_si (size
, 0) > 0)
1862 array
= gfc_get_array_expr (init
->ts
.type
, init
->ts
.kind
,
1864 for (n
= 0; n
< (int)mpz_get_si (size
); n
++)
1865 gfc_constructor_append_expr (&array
->value
.constructor
,
1868 : gfc_copy_expr (init
),
1871 array
->shape
= gfc_get_shape (sym
->as
->rank
);
1872 for (n
= 0; n
< sym
->as
->rank
; n
++)
1873 spec_dimen_size (sym
->as
, n
, &array
->shape
[n
]);
1878 init
->rank
= sym
->as
->rank
;
1882 if (sym
->attr
.save
== SAVE_NONE
)
1883 sym
->attr
.save
= SAVE_IMPLICIT
;
1891 /* Function called by variable_decl() that adds a name to a structure
1895 build_struct (const char *name
, gfc_charlen
*cl
, gfc_expr
**init
,
1896 gfc_array_spec
**as
)
1901 /* F03:C438/C439. If the current symbol is of the same derived type that we're
1902 constructing, it must have the pointer attribute. */
1903 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
1904 && current_ts
.u
.derived
== gfc_current_block ()
1905 && current_attr
.pointer
== 0)
1907 if (current_attr
.allocatable
1908 && !gfc_notify_std(GFC_STD_F2008
, "Component at %C "
1909 "must have the POINTER attribute"))
1913 else if (current_attr
.allocatable
== 0)
1915 gfc_error ("Component at %C must have the POINTER attribute");
1921 if (current_ts
.type
== BT_CLASS
1922 && !(current_attr
.pointer
|| current_attr
.allocatable
))
1924 gfc_error ("Component %qs with CLASS at %C must be allocatable "
1925 "or pointer", name
);
1929 if (gfc_current_block ()->attr
.pointer
&& (*as
)->rank
!= 0)
1931 if ((*as
)->type
!= AS_DEFERRED
&& (*as
)->type
!= AS_EXPLICIT
)
1933 gfc_error ("Array component of structure at %C must have explicit "
1934 "or deferred shape");
1939 /* If we are in a nested union/map definition, gfc_add_component will not
1940 properly find repeated components because:
1941 (i) gfc_add_component does a flat search, where components of unions
1942 and maps are implicity chained so nested components may conflict.
1943 (ii) Unions and maps are not linked as components of their parent
1944 structures until after they are parsed.
1945 For (i) we use gfc_find_component which searches recursively, and for (ii)
1946 we search each block directly from the parse stack until we find the top
1949 s
= gfc_state_stack
;
1950 if (s
->state
== COMP_UNION
|| s
->state
== COMP_MAP
)
1952 while (s
->state
== COMP_UNION
|| gfc_comp_struct (s
->state
))
1954 c
= gfc_find_component (s
->sym
, name
, true, true, NULL
);
1957 gfc_error_now ("Component %qs at %C already declared at %L",
1961 /* Break after we've searched the entire chain. */
1962 if (s
->state
== COMP_DERIVED
|| s
->state
== COMP_STRUCTURE
)
1968 if (!gfc_add_component (gfc_current_block(), name
, &c
))
1972 if (c
->ts
.type
== BT_CHARACTER
)
1975 if (c
->ts
.type
!= BT_CLASS
&& c
->ts
.type
!= BT_DERIVED
1976 && (c
->ts
.kind
== 0 || c
->ts
.type
== BT_CHARACTER
)
1977 && saved_kind_expr
!= NULL
)
1978 c
->kind_expr
= gfc_copy_expr (saved_kind_expr
);
1980 c
->attr
= current_attr
;
1982 c
->initializer
= *init
;
1989 c
->attr
.codimension
= 1;
1991 c
->attr
.dimension
= 1;
1995 gfc_apply_init (&c
->ts
, &c
->attr
, c
->initializer
);
1997 /* Check array components. */
1998 if (!c
->attr
.dimension
)
2001 if (c
->attr
.pointer
)
2003 if (c
->as
->type
!= AS_DEFERRED
)
2005 gfc_error ("Pointer array component of structure at %C must have a "
2010 else if (c
->attr
.allocatable
)
2012 if (c
->as
->type
!= AS_DEFERRED
)
2014 gfc_error ("Allocatable component of structure at %C must have a "
2021 if (c
->as
->type
!= AS_EXPLICIT
)
2023 gfc_error ("Array component of structure at %C must have an "
2030 if (c
->ts
.type
== BT_CLASS
)
2031 return gfc_build_class_symbol (&c
->ts
, &c
->attr
, &c
->as
);
2033 if (c
->attr
.pdt_kind
|| c
->attr
.pdt_len
)
2036 gfc_find_symbol (c
->name
, gfc_current_block ()->f2k_derived
,
2040 gfc_error ("Type parameter %qs at %C has no corresponding entry "
2041 "in the type parameter name list at %L",
2042 c
->name
, &gfc_current_block ()->declared_at
);
2046 sym
->attr
.pdt_kind
= c
->attr
.pdt_kind
;
2047 sym
->attr
.pdt_len
= c
->attr
.pdt_len
;
2049 sym
->value
= gfc_copy_expr (c
->initializer
);
2050 sym
->attr
.flavor
= FL_VARIABLE
;
2053 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
2054 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_template
2055 && decl_type_param_list
)
2056 c
->param_list
= gfc_copy_actual_arglist (decl_type_param_list
);
2062 /* Match a 'NULL()', and possibly take care of some side effects. */
2065 gfc_match_null (gfc_expr
**result
)
2068 match m
, m2
= MATCH_NO
;
2070 if ((m
= gfc_match (" null ( )")) == MATCH_ERROR
)
2076 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2078 if ((m2
= gfc_match (" null (")) != MATCH_YES
)
2081 old_loc
= gfc_current_locus
;
2082 if ((m2
= gfc_match (" %n ) ", name
)) == MATCH_ERROR
)
2085 && ((m2
= gfc_match (" mold = %n )", name
)) == MATCH_ERROR
))
2089 gfc_current_locus
= old_loc
;
2094 /* The NULL symbol now has to be/become an intrinsic function. */
2095 if (gfc_get_symbol ("null", NULL
, &sym
))
2097 gfc_error ("NULL() initialization at %C is ambiguous");
2101 gfc_intrinsic_symbol (sym
);
2103 if (sym
->attr
.proc
!= PROC_INTRINSIC
2104 && !(sym
->attr
.use_assoc
&& sym
->attr
.intrinsic
)
2105 && (!gfc_add_procedure(&sym
->attr
, PROC_INTRINSIC
, sym
->name
, NULL
)
2106 || !gfc_add_function (&sym
->attr
, sym
->name
, NULL
)))
2109 *result
= gfc_get_null_expr (&gfc_current_locus
);
2111 /* Invalid per F2008, C512. */
2112 if (m2
== MATCH_YES
)
2114 gfc_error ("NULL() initialization at %C may not have MOLD");
2122 /* Match the initialization expr for a data pointer or procedure pointer. */
2125 match_pointer_init (gfc_expr
**init
, int procptr
)
2129 if (gfc_pure (NULL
) && !gfc_comp_struct (gfc_state_stack
->state
))
2131 gfc_error ("Initialization of pointer at %C is not allowed in "
2132 "a PURE procedure");
2135 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
2137 /* Match NULL() initialization. */
2138 m
= gfc_match_null (init
);
2142 /* Match non-NULL initialization. */
2143 gfc_matching_ptr_assignment
= !procptr
;
2144 gfc_matching_procptr_assignment
= procptr
;
2145 m
= gfc_match_rvalue (init
);
2146 gfc_matching_ptr_assignment
= 0;
2147 gfc_matching_procptr_assignment
= 0;
2148 if (m
== MATCH_ERROR
)
2150 else if (m
== MATCH_NO
)
2152 gfc_error ("Error in pointer initialization at %C");
2156 if (!procptr
&& !gfc_resolve_expr (*init
))
2159 if (!gfc_notify_std (GFC_STD_F2008
, "non-NULL pointer "
2160 "initialization at %C"))
2168 check_function_name (char *name
)
2170 /* In functions that have a RESULT variable defined, the function name always
2171 refers to function calls. Therefore, the name is not allowed to appear in
2172 specification statements. When checking this, be careful about
2173 'hidden' procedure pointer results ('ppr@'). */
2175 if (gfc_current_state () == COMP_FUNCTION
)
2177 gfc_symbol
*block
= gfc_current_block ();
2178 if (block
&& block
->result
&& block
->result
!= block
2179 && strcmp (block
->result
->name
, "ppr@") != 0
2180 && strcmp (block
->name
, name
) == 0)
2182 gfc_error ("Function name %qs not allowed at %C", name
);
2191 /* Match a variable name with an optional initializer. When this
2192 subroutine is called, a variable is expected to be parsed next.
2193 Depending on what is happening at the moment, updates either the
2194 symbol table or the current interface. */
2197 variable_decl (int elem
)
2199 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2200 static unsigned int fill_id
= 0;
2201 gfc_expr
*initializer
, *char_len
;
2203 gfc_array_spec
*cp_as
; /* Extra copy for Cray Pointees. */
2215 /* When we get here, we've just matched a list of attributes and
2216 maybe a type and a double colon. The next thing we expect to see
2217 is the name of the symbol. */
2219 /* If we are parsing a structure with legacy support, we allow the symbol
2220 name to be '%FILL' which gives it an anonymous (inaccessible) name. */
2222 gfc_gobble_whitespace ();
2223 if (gfc_peek_ascii_char () == '%')
2225 gfc_next_ascii_char ();
2226 m
= gfc_match ("fill");
2231 m
= gfc_match_name (name
);
2239 if (gfc_current_state () != COMP_STRUCTURE
)
2241 if (flag_dec_structure
)
2242 gfc_error ("%qs not allowed outside STRUCTURE at %C", "%FILL");
2244 gfc_error ("%qs at %C is a DEC extension, enable with "
2245 "%<-fdec-structure%>", "%FILL");
2251 gfc_error ("%qs entity cannot have attributes at %C", "%FILL");
2255 /* %FILL components are given invalid fortran names. */
2256 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "%%FILL%u", fill_id
++);
2260 var_locus
= gfc_current_locus
;
2262 /* Now we could see the optional array spec. or character length. */
2263 m
= gfc_match_array_spec (&as
, true, true);
2264 if (m
== MATCH_ERROR
)
2268 as
= gfc_copy_array_spec (current_as
);
2270 && !merge_array_spec (current_as
, as
, true))
2276 if (flag_cray_pointer
)
2277 cp_as
= gfc_copy_array_spec (as
);
2279 /* At this point, we know for sure if the symbol is PARAMETER and can thus
2280 determine (and check) whether it can be implied-shape. If it
2281 was parsed as assumed-size, change it because PARAMETERs can not
2285 if (as
->type
== AS_IMPLIED_SHAPE
&& current_attr
.flavor
!= FL_PARAMETER
)
2288 gfc_error ("Non-PARAMETER symbol %qs at %L can't be implied-shape",
2293 if (as
->type
== AS_ASSUMED_SIZE
&& as
->rank
== 1
2294 && current_attr
.flavor
== FL_PARAMETER
)
2295 as
->type
= AS_IMPLIED_SHAPE
;
2297 if (as
->type
== AS_IMPLIED_SHAPE
2298 && !gfc_notify_std (GFC_STD_F2008
, "Implied-shape array at %L",
2308 cl_deferred
= false;
2310 if (current_ts
.type
== BT_CHARACTER
)
2312 switch (match_char_length (&char_len
, &cl_deferred
, false))
2315 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2317 cl
->length
= char_len
;
2320 /* Non-constant lengths need to be copied after the first
2321 element. Also copy assumed lengths. */
2324 && (current_ts
.u
.cl
->length
== NULL
2325 || current_ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
2327 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2328 cl
->length
= gfc_copy_expr (current_ts
.u
.cl
->length
);
2331 cl
= current_ts
.u
.cl
;
2333 cl_deferred
= current_ts
.deferred
;
2342 /* The dummy arguments and result of the abreviated form of MODULE
2343 PROCEDUREs, used in SUBMODULES should not be redefined. */
2344 if (gfc_current_ns
->proc_name
2345 && gfc_current_ns
->proc_name
->abr_modproc_decl
)
2347 gfc_find_symbol (name
, gfc_current_ns
, 1, &sym
);
2348 if (sym
!= NULL
&& (sym
->attr
.dummy
|| sym
->attr
.result
))
2351 gfc_error ("%qs at %C is a redefinition of the declaration "
2352 "in the corresponding interface for MODULE "
2353 "PROCEDURE %qs", sym
->name
,
2354 gfc_current_ns
->proc_name
->name
);
2359 /* %FILL components may not have initializers. */
2360 if (strncmp (name
, "%FILL", 5) == 0 && gfc_match_eos () != MATCH_YES
)
2362 gfc_error ("%qs entity cannot have an initializer at %C", "%FILL");
2367 /* If this symbol has already shown up in a Cray Pointer declaration,
2368 and this is not a component declaration,
2369 then we want to set the type & bail out. */
2370 if (flag_cray_pointer
&& !gfc_comp_struct (gfc_current_state ()))
2372 gfc_find_symbol (name
, gfc_current_ns
, 1, &sym
);
2373 if (sym
!= NULL
&& sym
->attr
.cray_pointee
)
2375 sym
->ts
.type
= current_ts
.type
;
2376 sym
->ts
.kind
= current_ts
.kind
;
2378 sym
->ts
.u
.derived
= current_ts
.u
.derived
;
2379 sym
->ts
.is_c_interop
= current_ts
.is_c_interop
;
2380 sym
->ts
.is_iso_c
= current_ts
.is_iso_c
;
2383 /* Check to see if we have an array specification. */
2386 if (sym
->as
!= NULL
)
2388 gfc_error ("Duplicate array spec for Cray pointee at %C");
2389 gfc_free_array_spec (cp_as
);
2395 if (!gfc_set_array_spec (sym
, cp_as
, &var_locus
))
2396 gfc_internal_error ("Couldn't set pointee array spec.");
2398 /* Fix the array spec. */
2399 m
= gfc_mod_pointee_as (sym
->as
);
2400 if (m
== MATCH_ERROR
)
2408 gfc_free_array_spec (cp_as
);
2412 /* Procedure pointer as function result. */
2413 if (gfc_current_state () == COMP_FUNCTION
2414 && strcmp ("ppr@", gfc_current_block ()->name
) == 0
2415 && strcmp (name
, gfc_current_block ()->ns
->proc_name
->name
) == 0)
2416 strcpy (name
, "ppr@");
2418 if (gfc_current_state () == COMP_FUNCTION
2419 && strcmp (name
, gfc_current_block ()->name
) == 0
2420 && gfc_current_block ()->result
2421 && strcmp ("ppr@", gfc_current_block ()->result
->name
) == 0)
2422 strcpy (name
, "ppr@");
2424 /* OK, we've successfully matched the declaration. Now put the
2425 symbol in the current namespace, because it might be used in the
2426 optional initialization expression for this symbol, e.g. this is
2429 integer, parameter :: i = huge(i)
2431 This is only true for parameters or variables of a basic type.
2432 For components of derived types, it is not true, so we don't
2433 create a symbol for those yet. If we fail to create the symbol,
2435 if (!gfc_comp_struct (gfc_current_state ())
2436 && !build_sym (name
, cl
, cl_deferred
, &as
, &var_locus
))
2442 if (!check_function_name (name
))
2448 /* We allow old-style initializations of the form
2449 integer i /2/, j(4) /3*3, 1/
2450 (if no colon has been seen). These are different from data
2451 statements in that initializers are only allowed to apply to the
2452 variable immediately preceding, i.e.
2454 is not allowed. Therefore we have to do some work manually, that
2455 could otherwise be left to the matchers for DATA statements. */
2457 if (!colon_seen
&& gfc_match (" /") == MATCH_YES
)
2459 if (!gfc_notify_std (GFC_STD_GNU
, "Old-style "
2460 "initialization at %C"))
2463 /* Allow old style initializations for components of STRUCTUREs and MAPs
2464 but not components of derived types. */
2465 else if (gfc_current_state () == COMP_DERIVED
)
2467 gfc_error ("Invalid old style initialization for derived type "
2473 /* For structure components, read the initializer as a special
2474 expression and let the rest of this function apply the initializer
2476 else if (gfc_comp_struct (gfc_current_state ()))
2478 m
= match_clist_expr (&initializer
, ¤t_ts
, as
);
2480 gfc_error ("Syntax error in old style initialization of %s at %C",
2486 /* Otherwise we treat the old style initialization just like a
2487 DATA declaration for the current variable. */
2489 return match_old_style_init (name
);
2492 /* The double colon must be present in order to have initializers.
2493 Otherwise the statement is ambiguous with an assignment statement. */
2496 if (gfc_match (" =>") == MATCH_YES
)
2498 if (!current_attr
.pointer
)
2500 gfc_error ("Initialization at %C isn't for a pointer variable");
2505 m
= match_pointer_init (&initializer
, 0);
2509 else if (gfc_match_char ('=') == MATCH_YES
)
2511 if (current_attr
.pointer
)
2513 gfc_error ("Pointer initialization at %C requires %<=>%>, "
2519 m
= gfc_match_init_expr (&initializer
);
2522 gfc_error ("Expected an initialization expression at %C");
2526 if (current_attr
.flavor
!= FL_PARAMETER
&& gfc_pure (NULL
)
2527 && !gfc_comp_struct (gfc_state_stack
->state
))
2529 gfc_error ("Initialization of variable at %C is not allowed in "
2530 "a PURE procedure");
2534 if (current_attr
.flavor
!= FL_PARAMETER
2535 && !gfc_comp_struct (gfc_state_stack
->state
))
2536 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
2543 if (initializer
!= NULL
&& current_attr
.allocatable
2544 && gfc_comp_struct (gfc_current_state ()))
2546 gfc_error ("Initialization of allocatable component at %C is not "
2552 if (gfc_current_state () == COMP_DERIVED
2553 && gfc_current_block ()->attr
.pdt_template
)
2556 gfc_find_symbol (name
, gfc_current_block ()->f2k_derived
,
2558 if (!param
&& (current_attr
.pdt_kind
|| current_attr
.pdt_len
))
2560 gfc_error ("The component with KIND or LEN attribute at %C does not "
2561 "not appear in the type parameter list at %L",
2562 &gfc_current_block ()->declared_at
);
2566 else if (param
&& !(current_attr
.pdt_kind
|| current_attr
.pdt_len
))
2568 gfc_error ("The component at %C that appears in the type parameter "
2569 "list at %L has neither the KIND nor LEN attribute",
2570 &gfc_current_block ()->declared_at
);
2574 else if (as
&& (current_attr
.pdt_kind
|| current_attr
.pdt_len
))
2576 gfc_error ("The component at %C which is a type parameter must be "
2581 else if (param
&& initializer
)
2582 param
->value
= gfc_copy_expr (initializer
);
2585 /* Add the initializer. Note that it is fine if initializer is
2586 NULL here, because we sometimes also need to check if a
2587 declaration *must* have an initialization expression. */
2588 if (!gfc_comp_struct (gfc_current_state ()))
2589 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
2592 if (current_ts
.type
== BT_DERIVED
2593 && !current_attr
.pointer
&& !initializer
)
2594 initializer
= gfc_default_initializer (¤t_ts
);
2595 t
= build_struct (name
, cl
, &initializer
, &as
);
2597 /* If we match a nested structure definition we expect to see the
2598 * body even if the variable declarations blow up, so we need to keep
2599 * the structure declaration around. */
2600 if (gfc_new_block
&& gfc_new_block
->attr
.flavor
== FL_STRUCT
)
2601 gfc_commit_symbol (gfc_new_block
);
2604 m
= (t
) ? MATCH_YES
: MATCH_ERROR
;
2607 /* Free stuff up and return. */
2608 gfc_free_expr (initializer
);
2609 gfc_free_array_spec (as
);
2615 /* Match an extended-f77 "TYPESPEC*bytesize"-style kind specification.
2616 This assumes that the byte size is equal to the kind number for
2617 non-COMPLEX types, and equal to twice the kind number for COMPLEX. */
2620 gfc_match_old_kind_spec (gfc_typespec
*ts
)
2625 if (gfc_match_char ('*') != MATCH_YES
)
2628 m
= gfc_match_small_literal_int (&ts
->kind
, NULL
);
2632 original_kind
= ts
->kind
;
2634 /* Massage the kind numbers for complex types. */
2635 if (ts
->type
== BT_COMPLEX
)
2639 gfc_error ("Old-style type declaration %s*%d not supported at %C",
2640 gfc_basic_typename (ts
->type
), original_kind
);
2647 if (ts
->type
== BT_INTEGER
&& ts
->kind
== 4 && flag_integer4_kind
== 8)
2650 if (ts
->type
== BT_REAL
|| ts
->type
== BT_COMPLEX
)
2654 if (flag_real4_kind
== 8)
2656 if (flag_real4_kind
== 10)
2658 if (flag_real4_kind
== 16)
2664 if (flag_real8_kind
== 4)
2666 if (flag_real8_kind
== 10)
2668 if (flag_real8_kind
== 16)
2673 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
2675 gfc_error ("Old-style type declaration %s*%d not supported at %C",
2676 gfc_basic_typename (ts
->type
), original_kind
);
2680 if (!gfc_notify_std (GFC_STD_GNU
,
2681 "Nonstandard type declaration %s*%d at %C",
2682 gfc_basic_typename(ts
->type
), original_kind
))
2689 /* Match a kind specification. Since kinds are generally optional, we
2690 usually return MATCH_NO if something goes wrong. If a "kind="
2691 string is found, then we know we have an error. */
2694 gfc_match_kind_spec (gfc_typespec
*ts
, bool kind_expr_only
)
2704 saved_kind_expr
= NULL
;
2706 where
= loc
= gfc_current_locus
;
2711 if (gfc_match_char ('(') == MATCH_NO
)
2714 /* Also gobbles optional text. */
2715 if (gfc_match (" kind = ") == MATCH_YES
)
2718 loc
= gfc_current_locus
;
2722 n
= gfc_match_init_expr (&e
);
2724 if (gfc_derived_parameter_expr (e
))
2727 saved_kind_expr
= gfc_copy_expr (e
);
2728 goto close_brackets
;
2733 if (gfc_matching_function
)
2735 /* The function kind expression might include use associated or
2736 imported parameters and try again after the specification
2738 if (gfc_match_char (')') != MATCH_YES
)
2740 gfc_error ("Missing right parenthesis at %C");
2746 gfc_undo_symbols ();
2751 /* ....or else, the match is real. */
2753 gfc_error ("Expected initialization expression at %C");
2761 gfc_error ("Expected scalar initialization expression at %C");
2766 if (gfc_extract_int (e
, &ts
->kind
, 1))
2772 /* Before throwing away the expression, let's see if we had a
2773 C interoperable kind (and store the fact). */
2774 if (e
->ts
.is_c_interop
== 1)
2776 /* Mark this as C interoperable if being declared with one
2777 of the named constants from iso_c_binding. */
2778 ts
->is_c_interop
= e
->ts
.is_iso_c
;
2779 ts
->f90_type
= e
->ts
.f90_type
;
2781 ts
->interop_kind
= e
->symtree
->n
.sym
;
2787 /* Ignore errors to this point, if we've gotten here. This means
2788 we ignore the m=MATCH_ERROR from above. */
2789 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
2791 gfc_error ("Kind %d not supported for type %s at %C", ts
->kind
,
2792 gfc_basic_typename (ts
->type
));
2793 gfc_current_locus
= where
;
2797 /* Warn if, e.g., c_int is used for a REAL variable, but not
2798 if, e.g., c_double is used for COMPLEX as the standard
2799 explicitly says that the kind type parameter for complex and real
2800 variable is the same, i.e. c_float == c_float_complex. */
2801 if (ts
->f90_type
!= BT_UNKNOWN
&& ts
->f90_type
!= ts
->type
2802 && !((ts
->f90_type
== BT_REAL
&& ts
->type
== BT_COMPLEX
)
2803 || (ts
->f90_type
== BT_COMPLEX
&& ts
->type
== BT_REAL
)))
2804 gfc_warning_now (0, "C kind type parameter is for type %s but type at %L "
2805 "is %s", gfc_basic_typename (ts
->f90_type
), &where
,
2806 gfc_basic_typename (ts
->type
));
2810 gfc_gobble_whitespace ();
2811 if ((c
= gfc_next_ascii_char ()) != ')'
2812 && (ts
->type
!= BT_CHARACTER
|| c
!= ','))
2814 if (ts
->type
== BT_CHARACTER
)
2815 gfc_error ("Missing right parenthesis or comma at %C");
2817 gfc_error ("Missing right parenthesis at %C");
2821 /* All tests passed. */
2824 if(m
== MATCH_ERROR
)
2825 gfc_current_locus
= where
;
2827 if (ts
->type
== BT_INTEGER
&& ts
->kind
== 4 && flag_integer4_kind
== 8)
2830 if (ts
->type
== BT_REAL
|| ts
->type
== BT_COMPLEX
)
2834 if (flag_real4_kind
== 8)
2836 if (flag_real4_kind
== 10)
2838 if (flag_real4_kind
== 16)
2844 if (flag_real8_kind
== 4)
2846 if (flag_real8_kind
== 10)
2848 if (flag_real8_kind
== 16)
2853 /* Return what we know from the test(s). */
2858 gfc_current_locus
= where
;
2864 match_char_kind (int * kind
, int * is_iso_c
)
2873 where
= gfc_current_locus
;
2875 n
= gfc_match_init_expr (&e
);
2877 if (n
!= MATCH_YES
&& gfc_matching_function
)
2879 /* The expression might include use-associated or imported
2880 parameters and try again after the specification
2883 gfc_undo_symbols ();
2888 gfc_error ("Expected initialization expression at %C");
2894 gfc_error ("Expected scalar initialization expression at %C");
2899 if (gfc_derived_parameter_expr (e
))
2901 saved_kind_expr
= e
;
2906 fail
= gfc_extract_int (e
, kind
, 1);
2907 *is_iso_c
= e
->ts
.is_iso_c
;
2916 /* Ignore errors to this point, if we've gotten here. This means
2917 we ignore the m=MATCH_ERROR from above. */
2918 if (gfc_validate_kind (BT_CHARACTER
, *kind
, true) < 0)
2920 gfc_error ("Kind %d is not supported for CHARACTER at %C", *kind
);
2924 /* All tests passed. */
2927 if (m
== MATCH_ERROR
)
2928 gfc_current_locus
= where
;
2930 /* Return what we know from the test(s). */
2935 gfc_current_locus
= where
;
2940 /* Match the various kind/length specifications in a CHARACTER
2941 declaration. We don't return MATCH_NO. */
2944 gfc_match_char_spec (gfc_typespec
*ts
)
2946 int kind
, seen_length
, is_iso_c
;
2958 /* Try the old-style specification first. */
2959 old_char_selector
= 0;
2961 m
= match_char_length (&len
, &deferred
, true);
2965 old_char_selector
= 1;
2970 m
= gfc_match_char ('(');
2973 m
= MATCH_YES
; /* Character without length is a single char. */
2977 /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ). */
2978 if (gfc_match (" kind =") == MATCH_YES
)
2980 m
= match_char_kind (&kind
, &is_iso_c
);
2982 if (m
== MATCH_ERROR
)
2987 if (gfc_match (" , len =") == MATCH_NO
)
2990 m
= char_len_param_value (&len
, &deferred
);
2993 if (m
== MATCH_ERROR
)
3000 /* Try to match "LEN = <len-param>" or "LEN = <len-param>, KIND = <int>". */
3001 if (gfc_match (" len =") == MATCH_YES
)
3003 m
= char_len_param_value (&len
, &deferred
);
3006 if (m
== MATCH_ERROR
)
3010 if (gfc_match_char (')') == MATCH_YES
)
3013 if (gfc_match (" , kind =") != MATCH_YES
)
3016 if (match_char_kind (&kind
, &is_iso_c
) == MATCH_ERROR
)
3022 /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ). */
3023 m
= char_len_param_value (&len
, &deferred
);
3026 if (m
== MATCH_ERROR
)
3030 m
= gfc_match_char (')');
3034 if (gfc_match_char (',') != MATCH_YES
)
3037 gfc_match (" kind ="); /* Gobble optional text. */
3039 m
= match_char_kind (&kind
, &is_iso_c
);
3040 if (m
== MATCH_ERROR
)
3046 /* Require a right-paren at this point. */
3047 m
= gfc_match_char (')');
3052 gfc_error ("Syntax error in CHARACTER declaration at %C");
3054 gfc_free_expr (len
);
3058 /* Deal with character functions after USE and IMPORT statements. */
3059 if (gfc_matching_function
)
3061 gfc_free_expr (len
);
3062 gfc_undo_symbols ();
3068 gfc_free_expr (len
);
3072 /* Do some final massaging of the length values. */
3073 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
3075 if (seen_length
== 0)
3076 cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
3081 ts
->kind
= kind
== 0 ? gfc_default_character_kind
: kind
;
3082 ts
->deferred
= deferred
;
3084 /* We have to know if it was a C interoperable kind so we can
3085 do accurate type checking of bind(c) procs, etc. */
3087 /* Mark this as C interoperable if being declared with one
3088 of the named constants from iso_c_binding. */
3089 ts
->is_c_interop
= is_iso_c
;
3090 else if (len
!= NULL
)
3091 /* Here, we might have parsed something such as: character(c_char)
3092 In this case, the parsing code above grabs the c_char when
3093 looking for the length (line 1690, roughly). it's the last
3094 testcase for parsing the kind params of a character variable.
3095 However, it's not actually the length. this seems like it
3097 To see if the user used a C interop kind, test the expr
3098 of the so called length, and see if it's C interoperable. */
3099 ts
->is_c_interop
= len
->ts
.is_iso_c
;
3105 /* Matches a RECORD declaration. */
3108 match_record_decl (char *name
)
3111 old_loc
= gfc_current_locus
;
3114 m
= gfc_match (" record /");
3117 if (!flag_dec_structure
)
3119 gfc_current_locus
= old_loc
;
3120 gfc_error ("RECORD at %C is an extension, enable it with "
3124 m
= gfc_match (" %n/", name
);
3129 gfc_current_locus
= old_loc
;
3130 if (flag_dec_structure
3131 && (gfc_match (" record% ") == MATCH_YES
3132 || gfc_match (" record%t") == MATCH_YES
))
3133 gfc_error ("Structure name expected after RECORD at %C");
3141 /* This function uses the gfc_actual_arglist 'type_param_spec_list' as a source
3142 of expressions to substitute into the possibly parameterized expression
3143 'e'. Using a list is inefficient but should not be too bad since the
3144 number of type parameters is not likely to be large. */
3146 insert_parameter_exprs (gfc_expr
* e
, gfc_symbol
* sym ATTRIBUTE_UNUSED
,
3149 gfc_actual_arglist
*param
;
3152 if (e
->expr_type
!= EXPR_VARIABLE
)
3155 gcc_assert (e
->symtree
);
3156 if (e
->symtree
->n
.sym
->attr
.pdt_kind
3157 || (*f
!= 0 && e
->symtree
->n
.sym
->attr
.pdt_len
))
3159 for (param
= type_param_spec_list
; param
; param
= param
->next
)
3160 if (strcmp (e
->symtree
->n
.sym
->name
, param
->name
) == 0)
3165 copy
= gfc_copy_expr (param
->expr
);
3176 gfc_insert_kind_parameter_exprs (gfc_expr
*e
)
3178 return gfc_traverse_expr (e
, NULL
, &insert_parameter_exprs
, 0);
3183 gfc_insert_parameter_exprs (gfc_expr
*e
, gfc_actual_arglist
*param_list
)
3185 gfc_actual_arglist
*old_param_spec_list
= type_param_spec_list
;
3186 type_param_spec_list
= param_list
;
3187 return gfc_traverse_expr (e
, NULL
, &insert_parameter_exprs
, 1);
3188 type_param_spec_list
= NULL
;
3189 type_param_spec_list
= old_param_spec_list
;
3192 /* Determines the instance of a parameterized derived type to be used by
3193 matching determining the values of the kind parameters and using them
3194 in the name of the instance. If the instance exists, it is used, otherwise
3195 a new derived type is created. */
3197 gfc_get_pdt_instance (gfc_actual_arglist
*param_list
, gfc_symbol
**sym
,
3198 gfc_actual_arglist
**ext_param_list
)
3200 /* The PDT template symbol. */
3201 gfc_symbol
*pdt
= *sym
;
3202 /* The symbol for the parameter in the template f2k_namespace. */
3204 /* The hoped for instance of the PDT. */
3205 gfc_symbol
*instance
;
3206 /* The list of parameters appearing in the PDT declaration. */
3207 gfc_formal_arglist
*type_param_name_list
;
3208 /* Used to store the parameter specification list during recursive calls. */
3209 gfc_actual_arglist
*old_param_spec_list
;
3210 /* Pointers to the parameter specification being used. */
3211 gfc_actual_arglist
*actual_param
;
3212 gfc_actual_arglist
*tail
= NULL
;
3213 /* Used to build up the name of the PDT instance. The prefix uses 4
3214 characters and each KIND parameter 2 more. Allow 8 of the latter. */
3215 char name
[GFC_MAX_SYMBOL_LEN
+ 21];
3217 bool name_seen
= (param_list
== NULL
);
3218 bool assumed_seen
= false;
3219 bool deferred_seen
= false;
3220 bool spec_error
= false;
3222 gfc_expr
*kind_expr
;
3223 gfc_component
*c1
, *c2
;
3226 type_param_spec_list
= NULL
;
3228 type_param_name_list
= pdt
->formal
;
3229 actual_param
= param_list
;
3230 sprintf (name
, "Pdt%s", pdt
->name
);
3232 /* Run through the parameter name list and pick up the actual
3233 parameter values or use the default values in the PDT declaration. */
3234 for (; type_param_name_list
;
3235 type_param_name_list
= type_param_name_list
->next
)
3237 if (actual_param
&& actual_param
->spec_type
!= SPEC_EXPLICIT
)
3239 if (actual_param
->spec_type
== SPEC_ASSUMED
)
3240 spec_error
= deferred_seen
;
3242 spec_error
= assumed_seen
;
3246 gfc_error ("The type parameter spec list at %C cannot contain "
3247 "both ASSUMED and DEFERRED parameters");
3252 if (actual_param
&& actual_param
->name
)
3254 param
= type_param_name_list
->sym
;
3256 if (!param
|| !param
->name
)
3259 c1
= gfc_find_component (pdt
, param
->name
, false, true, NULL
);
3260 /* An error should already have been thrown in resolve.c
3261 (resolve_fl_derived0). */
3262 if (!pdt
->attr
.use_assoc
&& !c1
)
3268 if (!actual_param
&& !(c1
&& c1
->initializer
))
3270 gfc_error ("The type parameter spec list at %C does not contain "
3271 "enough parameter expressions");
3274 else if (!actual_param
&& c1
&& c1
->initializer
)
3275 kind_expr
= gfc_copy_expr (c1
->initializer
);
3276 else if (actual_param
&& actual_param
->spec_type
== SPEC_EXPLICIT
)
3277 kind_expr
= gfc_copy_expr (actual_param
->expr
);
3281 actual_param
= param_list
;
3282 for (;actual_param
; actual_param
= actual_param
->next
)
3283 if (actual_param
->name
3284 && strcmp (actual_param
->name
, param
->name
) == 0)
3286 if (actual_param
&& actual_param
->spec_type
== SPEC_EXPLICIT
)
3287 kind_expr
= gfc_copy_expr (actual_param
->expr
);
3290 if (c1
->initializer
)
3291 kind_expr
= gfc_copy_expr (c1
->initializer
);
3292 else if (!(actual_param
&& param
->attr
.pdt_len
))
3294 gfc_error ("The derived parameter '%qs' at %C does not "
3295 "have a default value", param
->name
);
3301 /* Store the current parameter expressions in a temporary actual
3302 arglist 'list' so that they can be substituted in the corresponding
3303 expressions in the PDT instance. */
3304 if (type_param_spec_list
== NULL
)
3306 type_param_spec_list
= gfc_get_actual_arglist ();
3307 tail
= type_param_spec_list
;
3311 tail
->next
= gfc_get_actual_arglist ();
3314 tail
->name
= param
->name
;
3318 /* Try simplification even for LEN expressions. */
3319 gfc_resolve_expr (kind_expr
);
3320 gfc_simplify_expr (kind_expr
, 1);
3321 /* Variable expressions seem to default to BT_PROCEDURE.
3322 TODO find out why this is and fix it. */
3323 if (kind_expr
->ts
.type
!= BT_INTEGER
3324 && kind_expr
->ts
.type
!= BT_PROCEDURE
)
3326 gfc_error ("The parameter expression at %C must be of "
3327 "INTEGER type and not %s type",
3328 gfc_basic_typename (kind_expr
->ts
.type
));
3332 tail
->expr
= gfc_copy_expr (kind_expr
);
3336 tail
->spec_type
= actual_param
->spec_type
;
3338 if (!param
->attr
.pdt_kind
)
3340 if (!name_seen
&& actual_param
)
3341 actual_param
= actual_param
->next
;
3344 gfc_free_expr (kind_expr
);
3351 && (actual_param
->spec_type
== SPEC_ASSUMED
3352 || actual_param
->spec_type
== SPEC_DEFERRED
))
3354 gfc_error ("The KIND parameter '%qs' at %C cannot either be "
3355 "ASSUMED or DEFERRED", param
->name
);
3359 if (!kind_expr
|| !gfc_is_constant_expr (kind_expr
))
3361 gfc_error ("The value for the KIND parameter '%qs' at %C does not "
3362 "reduce to a constant expression", param
->name
);
3366 gfc_extract_int (kind_expr
, &kind_value
);
3367 sprintf (name
+ strlen (name
), "_%d", kind_value
);
3369 if (!name_seen
&& actual_param
)
3370 actual_param
= actual_param
->next
;
3371 gfc_free_expr (kind_expr
);
3374 if (!name_seen
&& actual_param
)
3376 gfc_error ("The type parameter spec list at %C contains too many "
3377 "parameter expressions");
3381 /* Now we search for the PDT instance 'name'. If it doesn't exist, we
3382 build it, using 'pdt' as a template. */
3383 if (gfc_get_symbol (name
, pdt
->ns
, &instance
))
3385 gfc_error ("Parameterized derived type at %C is ambiguous");
3391 if (instance
->attr
.flavor
== FL_DERIVED
3392 && instance
->attr
.pdt_type
)
3396 *ext_param_list
= type_param_spec_list
;
3398 gfc_commit_symbols ();
3402 /* Start building the new instance of the parameterized type. */
3403 gfc_copy_attr (&instance
->attr
, &pdt
->attr
, &pdt
->declared_at
);
3404 instance
->attr
.pdt_template
= 0;
3405 instance
->attr
.pdt_type
= 1;
3406 instance
->declared_at
= gfc_current_locus
;
3408 /* Add the components, replacing the parameters in all expressions
3409 with the expressions for their values in 'type_param_spec_list'. */
3410 c1
= pdt
->components
;
3411 tail
= type_param_spec_list
;
3412 for (; c1
; c1
= c1
->next
)
3414 gfc_add_component (instance
, c1
->name
, &c2
);
3417 c2
->attr
= c1
->attr
;
3419 /* The order of declaration of the type_specs might not be the
3420 same as that of the components. */
3421 if (c1
->attr
.pdt_kind
|| c1
->attr
.pdt_len
)
3423 for (tail
= type_param_spec_list
; tail
; tail
= tail
->next
)
3424 if (strcmp (c1
->name
, tail
->name
) == 0)
3428 /* Deal with type extension by recursively calling this function
3429 to obtain the instance of the extended type. */
3430 if (gfc_current_state () != COMP_DERIVED
3431 && c1
== pdt
->components
3432 && (c1
->ts
.type
== BT_DERIVED
|| c1
->ts
.type
== BT_CLASS
)
3433 && c1
->ts
.u
.derived
&& c1
->ts
.u
.derived
->attr
.pdt_template
3434 && gfc_get_derived_super_type (*sym
) == c2
->ts
.u
.derived
)
3436 gfc_formal_arglist
*f
;
3438 old_param_spec_list
= type_param_spec_list
;
3440 /* Obtain a spec list appropriate to the extended type..*/
3441 actual_param
= gfc_copy_actual_arglist (type_param_spec_list
);
3442 type_param_spec_list
= actual_param
;
3443 for (f
= c1
->ts
.u
.derived
->formal
; f
&& f
->next
; f
= f
->next
)
3444 actual_param
= actual_param
->next
;
3447 gfc_free_actual_arglist (actual_param
->next
);
3448 actual_param
->next
= NULL
;
3451 /* Now obtain the PDT instance for the extended type. */
3452 c2
->param_list
= type_param_spec_list
;
3453 m
= gfc_get_pdt_instance (type_param_spec_list
, &c2
->ts
.u
.derived
,
3455 type_param_spec_list
= old_param_spec_list
;
3457 c2
->ts
.u
.derived
->refs
++;
3458 gfc_set_sym_referenced (c2
->ts
.u
.derived
);
3460 /* Set extension level. */
3461 if (c2
->ts
.u
.derived
->attr
.extension
== 255)
3463 /* Since the extension field is 8 bit wide, we can only have
3464 up to 255 extension levels. */
3465 gfc_error ("Maximum extension level reached with type %qs at %L",
3466 c2
->ts
.u
.derived
->name
,
3467 &c2
->ts
.u
.derived
->declared_at
);
3470 instance
->attr
.extension
= c2
->ts
.u
.derived
->attr
.extension
+ 1;
3475 /* Set the component kind using the parameterized expression. */
3476 if ((c1
->ts
.kind
== 0 || c1
->ts
.type
== BT_CHARACTER
)
3477 && c1
->kind_expr
!= NULL
)
3479 gfc_expr
*e
= gfc_copy_expr (c1
->kind_expr
);
3480 gfc_insert_kind_parameter_exprs (e
);
3481 gfc_simplify_expr (e
, 1);
3482 gfc_extract_int (e
, &c2
->ts
.kind
);
3484 if (gfc_validate_kind (c2
->ts
.type
, c2
->ts
.kind
, true) < 0)
3486 gfc_error ("Kind %d not supported for type %s at %C",
3487 c2
->ts
.kind
, gfc_basic_typename (c2
->ts
.type
));
3492 /* Similarly, set the string length if parameterized. */
3493 if (c1
->ts
.type
== BT_CHARACTER
3494 && c1
->ts
.u
.cl
->length
3495 && gfc_derived_parameter_expr (c1
->ts
.u
.cl
->length
))
3498 e
= gfc_copy_expr (c1
->ts
.u
.cl
->length
);
3499 gfc_insert_kind_parameter_exprs (e
);
3500 gfc_simplify_expr (e
, 1);
3501 c2
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
3502 c2
->ts
.u
.cl
->length
= e
;
3503 c2
->attr
.pdt_string
= 1;
3506 /* Set up either the KIND/LEN initializer, if constant,
3507 or the parameterized expression. Use the template
3508 initializer if one is not already set in this instance. */
3509 if (c2
->attr
.pdt_kind
|| c2
->attr
.pdt_len
)
3511 if (tail
&& tail
->expr
&& gfc_is_constant_expr (tail
->expr
))
3512 c2
->initializer
= gfc_copy_expr (tail
->expr
);
3513 else if (tail
&& tail
->expr
)
3515 c2
->param_list
= gfc_get_actual_arglist ();
3516 c2
->param_list
->name
= tail
->name
;
3517 c2
->param_list
->expr
= gfc_copy_expr (tail
->expr
);
3518 c2
->param_list
->next
= NULL
;
3521 if (!c2
->initializer
&& c1
->initializer
)
3522 c2
->initializer
= gfc_copy_expr (c1
->initializer
);
3525 /* Copy the array spec. */
3526 c2
->as
= gfc_copy_array_spec (c1
->as
);
3527 if (c1
->ts
.type
== BT_CLASS
)
3528 CLASS_DATA (c2
)->as
= gfc_copy_array_spec (CLASS_DATA (c1
)->as
);
3530 /* Determine if an array spec is parameterized. If so, substitute
3531 in the parameter expressions for the bounds and set the pdt_array
3532 attribute. Notice that this attribute must be unconditionally set
3533 if this is an array of parameterized character length. */
3534 if (c1
->as
&& c1
->as
->type
== AS_EXPLICIT
)
3536 bool pdt_array
= false;
3538 /* Are the bounds of the array parameterized? */
3539 for (i
= 0; i
< c1
->as
->rank
; i
++)
3541 if (gfc_derived_parameter_expr (c1
->as
->lower
[i
]))
3543 if (gfc_derived_parameter_expr (c1
->as
->upper
[i
]))
3547 /* If they are, free the expressions for the bounds and
3548 replace them with the template expressions with substitute
3550 for (i
= 0; pdt_array
&& i
< c1
->as
->rank
; i
++)
3553 e
= gfc_copy_expr (c1
->as
->lower
[i
]);
3554 gfc_insert_kind_parameter_exprs (e
);
3555 gfc_simplify_expr (e
, 1);
3556 gfc_free_expr (c2
->as
->lower
[i
]);
3557 c2
->as
->lower
[i
] = e
;
3558 e
= gfc_copy_expr (c1
->as
->upper
[i
]);
3559 gfc_insert_kind_parameter_exprs (e
);
3560 gfc_simplify_expr (e
, 1);
3561 gfc_free_expr (c2
->as
->upper
[i
]);
3562 c2
->as
->upper
[i
] = e
;
3564 c2
->attr
.pdt_array
= pdt_array
? 1 : c2
->attr
.pdt_string
;
3567 /* Recurse into this function for PDT components. */
3568 if ((c1
->ts
.type
== BT_DERIVED
|| c1
->ts
.type
== BT_CLASS
)
3569 && c1
->ts
.u
.derived
&& c1
->ts
.u
.derived
->attr
.pdt_template
)
3571 gfc_actual_arglist
*params
;
3572 /* The component in the template has a list of specification
3573 expressions derived from its declaration. */
3574 params
= gfc_copy_actual_arglist (c1
->param_list
);
3575 actual_param
= params
;
3576 /* Substitute the template parameters with the expressions
3577 from the specification list. */
3578 for (;actual_param
; actual_param
= actual_param
->next
)
3579 gfc_insert_parameter_exprs (actual_param
->expr
,
3580 type_param_spec_list
);
3582 /* Now obtain the PDT instance for the component. */
3583 old_param_spec_list
= type_param_spec_list
;
3584 m
= gfc_get_pdt_instance (params
, &c2
->ts
.u
.derived
, NULL
);
3585 type_param_spec_list
= old_param_spec_list
;
3587 c2
->param_list
= params
;
3588 if (!(c2
->attr
.pointer
|| c2
->attr
.allocatable
))
3589 c2
->initializer
= gfc_default_initializer (&c2
->ts
);
3591 if (c2
->attr
.allocatable
)
3592 instance
->attr
.alloc_comp
= 1;
3596 gfc_commit_symbol (instance
);
3598 *ext_param_list
= type_param_spec_list
;
3603 gfc_free_actual_arglist (type_param_spec_list
);
3608 /* Matches a declaration-type-spec (F03:R502). If successful, sets the ts
3609 structure to the matched specification. This is necessary for FUNCTION and
3610 IMPLICIT statements.
3612 If implicit_flag is nonzero, then we don't check for the optional
3613 kind specification. Not doing so is needed for matching an IMPLICIT
3614 statement correctly. */
3617 gfc_match_decl_type_spec (gfc_typespec
*ts
, int implicit_flag
)
3619 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3620 gfc_symbol
*sym
, *dt_sym
;
3623 bool seen_deferred_kind
, matched_type
;
3624 const char *dt_name
;
3626 decl_type_param_list
= NULL
;
3628 /* A belt and braces check that the typespec is correctly being treated
3629 as a deferred characteristic association. */
3630 seen_deferred_kind
= (gfc_current_state () == COMP_FUNCTION
)
3631 && (gfc_current_block ()->result
->ts
.kind
== -1)
3632 && (ts
->kind
== -1);
3634 if (seen_deferred_kind
)
3637 /* Clear the current binding label, in case one is given. */
3638 curr_binding_label
= NULL
;
3640 if (gfc_match (" byte") == MATCH_YES
)
3642 if (!gfc_notify_std (GFC_STD_GNU
, "BYTE type at %C"))
3645 if (gfc_validate_kind (BT_INTEGER
, 1, true) < 0)
3647 gfc_error ("BYTE type used at %C "
3648 "is not available on the target machine");
3652 ts
->type
= BT_INTEGER
;
3658 m
= gfc_match (" type (");
3659 matched_type
= (m
== MATCH_YES
);
3662 gfc_gobble_whitespace ();
3663 if (gfc_peek_ascii_char () == '*')
3665 if ((m
= gfc_match ("*)")) != MATCH_YES
)
3667 if (gfc_comp_struct (gfc_current_state ()))
3669 gfc_error ("Assumed type at %C is not allowed for components");
3672 if (!gfc_notify_std (GFC_STD_F2008_TS
, "Assumed type "
3675 ts
->type
= BT_ASSUMED
;
3679 m
= gfc_match ("%n", name
);
3680 matched_type
= (m
== MATCH_YES
);
3683 if ((matched_type
&& strcmp ("integer", name
) == 0)
3684 || (!matched_type
&& gfc_match (" integer") == MATCH_YES
))
3686 ts
->type
= BT_INTEGER
;
3687 ts
->kind
= gfc_default_integer_kind
;
3691 if ((matched_type
&& strcmp ("character", name
) == 0)
3692 || (!matched_type
&& gfc_match (" character") == MATCH_YES
))
3695 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
3696 "intrinsic-type-spec at %C"))
3699 ts
->type
= BT_CHARACTER
;
3700 if (implicit_flag
== 0)
3701 m
= gfc_match_char_spec (ts
);
3705 if (matched_type
&& m
== MATCH_YES
&& gfc_match_char (')') != MATCH_YES
)
3711 if ((matched_type
&& strcmp ("real", name
) == 0)
3712 || (!matched_type
&& gfc_match (" real") == MATCH_YES
))
3715 ts
->kind
= gfc_default_real_kind
;
3720 && (strcmp ("doubleprecision", name
) == 0
3721 || (strcmp ("double", name
) == 0
3722 && gfc_match (" precision") == MATCH_YES
)))
3723 || (!matched_type
&& gfc_match (" double precision") == MATCH_YES
))
3726 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
3727 "intrinsic-type-spec at %C"))
3729 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
3733 ts
->kind
= gfc_default_double_kind
;
3737 if ((matched_type
&& strcmp ("complex", name
) == 0)
3738 || (!matched_type
&& gfc_match (" complex") == MATCH_YES
))
3740 ts
->type
= BT_COMPLEX
;
3741 ts
->kind
= gfc_default_complex_kind
;
3746 && (strcmp ("doublecomplex", name
) == 0
3747 || (strcmp ("double", name
) == 0
3748 && gfc_match (" complex") == MATCH_YES
)))
3749 || (!matched_type
&& gfc_match (" double complex") == MATCH_YES
))
3751 if (!gfc_notify_std (GFC_STD_GNU
, "DOUBLE COMPLEX at %C"))
3755 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
3756 "intrinsic-type-spec at %C"))
3759 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
3762 ts
->type
= BT_COMPLEX
;
3763 ts
->kind
= gfc_default_double_kind
;
3767 if ((matched_type
&& strcmp ("logical", name
) == 0)
3768 || (!matched_type
&& gfc_match (" logical") == MATCH_YES
))
3770 ts
->type
= BT_LOGICAL
;
3771 ts
->kind
= gfc_default_logical_kind
;
3777 m
= gfc_match_actual_arglist (1, &decl_type_param_list
, true);
3778 if (m
== MATCH_ERROR
)
3781 m
= gfc_match_char (')');
3785 m
= match_record_decl (name
);
3787 if (matched_type
|| m
== MATCH_YES
)
3789 ts
->type
= BT_DERIVED
;
3790 /* We accept record/s/ or type(s) where s is a structure, but we
3791 * don't need all the extra derived-type stuff for structures. */
3792 if (gfc_find_symbol (gfc_dt_upper_string (name
), NULL
, 1, &sym
))
3794 gfc_error ("Type name %qs at %C is ambiguous", name
);
3798 if (sym
&& sym
->attr
.flavor
== FL_DERIVED
3799 && sym
->attr
.pdt_template
3800 && gfc_current_state () != COMP_DERIVED
)
3802 m
= gfc_get_pdt_instance (decl_type_param_list
, &sym
, NULL
);
3805 gcc_assert (!sym
->attr
.pdt_template
&& sym
->attr
.pdt_type
);
3806 ts
->u
.derived
= sym
;
3807 strcpy (name
, gfc_dt_lower_string (sym
->name
));
3810 if (sym
&& sym
->attr
.flavor
== FL_STRUCT
)
3812 ts
->u
.derived
= sym
;
3815 /* Actually a derived type. */
3820 /* Match nested STRUCTURE declarations; only valid within another
3821 structure declaration. */
3822 if (flag_dec_structure
3823 && (gfc_current_state () == COMP_STRUCTURE
3824 || gfc_current_state () == COMP_MAP
))
3826 m
= gfc_match (" structure");
3829 m
= gfc_match_structure_decl ();
3832 /* gfc_new_block is updated by match_structure_decl. */
3833 ts
->type
= BT_DERIVED
;
3834 ts
->u
.derived
= gfc_new_block
;
3838 if (m
== MATCH_ERROR
)
3842 /* Match CLASS declarations. */
3843 m
= gfc_match (" class ( * )");
3844 if (m
== MATCH_ERROR
)
3846 else if (m
== MATCH_YES
)
3850 ts
->type
= BT_CLASS
;
3851 gfc_find_symbol ("STAR", gfc_current_ns
, 1, &upe
);
3854 upe
= gfc_new_symbol ("STAR", gfc_current_ns
);
3855 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "STAR");
3857 gfc_set_sym_referenced (upe
);
3859 upe
->ts
.type
= BT_VOID
;
3860 upe
->attr
.unlimited_polymorphic
= 1;
3861 /* This is essential to force the construction of
3862 unlimited polymorphic component class containers. */
3863 upe
->attr
.zero_comp
= 1;
3864 if (!gfc_add_flavor (&upe
->attr
, FL_DERIVED
, NULL
,
3865 &gfc_current_locus
))
3870 st
= gfc_get_tbp_symtree (&gfc_current_ns
->sym_root
, "STAR");
3874 ts
->u
.derived
= upe
;
3878 m
= gfc_match (" class (");
3881 m
= gfc_match ("%n", name
);
3887 ts
->type
= BT_CLASS
;
3889 if (!gfc_notify_std (GFC_STD_F2003
, "CLASS statement at %C"))
3892 m
= gfc_match_actual_arglist (1, &decl_type_param_list
, true);
3893 if (m
== MATCH_ERROR
)
3896 m
= gfc_match_char (')');
3901 /* Defer association of the derived type until the end of the
3902 specification block. However, if the derived type can be
3903 found, add it to the typespec. */
3904 if (gfc_matching_function
)
3906 ts
->u
.derived
= NULL
;
3907 if (gfc_current_state () != COMP_INTERFACE
3908 && !gfc_find_symbol (name
, NULL
, 1, &sym
) && sym
)
3910 sym
= gfc_find_dt_in_generic (sym
);
3911 ts
->u
.derived
= sym
;
3916 /* Search for the name but allow the components to be defined later. If
3917 type = -1, this typespec has been seen in a function declaration but
3918 the type could not be accessed at that point. The actual derived type is
3919 stored in a symtree with the first letter of the name capitalized; the
3920 symtree with the all lower-case name contains the associated
3921 generic function. */
3922 dt_name
= gfc_dt_upper_string (name
);
3927 gfc_get_ha_symbol (name
, &sym
);
3928 if (sym
->generic
&& gfc_find_symbol (dt_name
, NULL
, 0, &dt_sym
))
3930 gfc_error ("Type name %qs at %C is ambiguous", name
);
3933 if (sym
->generic
&& !dt_sym
)
3934 dt_sym
= gfc_find_dt_in_generic (sym
);
3936 /* Host associated PDTs can get confused with their constructors
3937 because they ar instantiated in the template's namespace. */
3940 if (gfc_find_symbol (dt_name
, NULL
, 1, &dt_sym
))
3942 gfc_error ("Type name %qs at %C is ambiguous", name
);
3945 if (dt_sym
&& !dt_sym
->attr
.pdt_type
)
3949 else if (ts
->kind
== -1)
3951 int iface
= gfc_state_stack
->previous
->state
!= COMP_INTERFACE
3952 || gfc_current_ns
->has_import_set
;
3953 gfc_find_symbol (name
, NULL
, iface
, &sym
);
3954 if (sym
&& sym
->generic
&& gfc_find_symbol (dt_name
, NULL
, 1, &dt_sym
))
3956 gfc_error ("Type name %qs at %C is ambiguous", name
);
3959 if (sym
&& sym
->generic
&& !dt_sym
)
3960 dt_sym
= gfc_find_dt_in_generic (sym
);
3967 if ((sym
->attr
.flavor
!= FL_UNKNOWN
&& sym
->attr
.flavor
!= FL_STRUCT
3968 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.generic
))
3969 || sym
->attr
.subroutine
)
3971 gfc_error ("Type name %qs at %C conflicts with previously declared "
3972 "entity at %L, which has the same name", name
,
3977 if (sym
&& sym
->attr
.flavor
== FL_DERIVED
3978 && sym
->attr
.pdt_template
3979 && gfc_current_state () != COMP_DERIVED
)
3981 m
= gfc_get_pdt_instance (decl_type_param_list
, &sym
, NULL
);
3984 gcc_assert (!sym
->attr
.pdt_template
&& sym
->attr
.pdt_type
);
3985 ts
->u
.derived
= sym
;
3986 strcpy (name
, gfc_dt_lower_string (sym
->name
));
3989 gfc_save_symbol_data (sym
);
3990 gfc_set_sym_referenced (sym
);
3991 if (!sym
->attr
.generic
3992 && !gfc_add_generic (&sym
->attr
, sym
->name
, NULL
))
3995 if (!sym
->attr
.function
3996 && !gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
3999 if (dt_sym
&& dt_sym
->attr
.flavor
== FL_DERIVED
4000 && dt_sym
->attr
.pdt_template
4001 && gfc_current_state () != COMP_DERIVED
)
4003 m
= gfc_get_pdt_instance (decl_type_param_list
, &dt_sym
, NULL
);
4006 gcc_assert (!dt_sym
->attr
.pdt_template
&& dt_sym
->attr
.pdt_type
);
4011 gfc_interface
*intr
, *head
;
4013 /* Use upper case to save the actual derived-type symbol. */
4014 gfc_get_symbol (dt_name
, NULL
, &dt_sym
);
4015 dt_sym
->name
= gfc_get_string ("%s", sym
->name
);
4016 head
= sym
->generic
;
4017 intr
= gfc_get_interface ();
4019 intr
->where
= gfc_current_locus
;
4021 sym
->generic
= intr
;
4022 sym
->attr
.if_source
= IFSRC_DECL
;
4025 gfc_save_symbol_data (dt_sym
);
4027 gfc_set_sym_referenced (dt_sym
);
4029 if (dt_sym
->attr
.flavor
!= FL_DERIVED
&& dt_sym
->attr
.flavor
!= FL_STRUCT
4030 && !gfc_add_flavor (&dt_sym
->attr
, FL_DERIVED
, sym
->name
, NULL
))
4033 ts
->u
.derived
= dt_sym
;
4039 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
4040 "intrinsic-type-spec at %C"))
4043 /* For all types except double, derived and character, look for an
4044 optional kind specifier. MATCH_NO is actually OK at this point. */
4045 if (implicit_flag
== 1)
4047 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
4053 if (gfc_current_form
== FORM_FREE
)
4055 c
= gfc_peek_ascii_char ();
4056 if (!gfc_is_whitespace (c
) && c
!= '*' && c
!= '('
4057 && c
!= ':' && c
!= ',')
4059 if (matched_type
&& c
== ')')
4061 gfc_next_ascii_char ();
4068 m
= gfc_match_kind_spec (ts
, false);
4069 if (m
== MATCH_NO
&& ts
->type
!= BT_CHARACTER
)
4071 m
= gfc_match_old_kind_spec (ts
);
4072 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) == -1)
4076 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
4079 /* Defer association of the KIND expression of function results
4080 until after USE and IMPORT statements. */
4081 if ((gfc_current_state () == COMP_NONE
&& gfc_error_flag_test ())
4082 || gfc_matching_function
)
4086 m
= MATCH_YES
; /* No kind specifier found. */
4092 /* Match an IMPLICIT NONE statement. Actually, this statement is
4093 already matched in parse.c, or we would not end up here in the
4094 first place. So the only thing we need to check, is if there is
4095 trailing garbage. If not, the match is successful. */
4098 gfc_match_implicit_none (void)
4102 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4104 bool external
= false;
4105 locus cur_loc
= gfc_current_locus
;
4107 if (gfc_current_ns
->seen_implicit_none
4108 || gfc_current_ns
->has_implicit_none_export
)
4110 gfc_error ("Duplicate IMPLICIT NONE statement at %C");
4114 gfc_gobble_whitespace ();
4115 c
= gfc_peek_ascii_char ();
4118 (void) gfc_next_ascii_char ();
4119 if (!gfc_notify_std (GFC_STD_F2018
, "IMPORT NONE with spec list at %C"))
4122 gfc_gobble_whitespace ();
4123 if (gfc_peek_ascii_char () == ')')
4125 (void) gfc_next_ascii_char ();
4131 m
= gfc_match (" %n", name
);
4135 if (strcmp (name
, "type") == 0)
4137 else if (strcmp (name
, "external") == 0)
4142 gfc_gobble_whitespace ();
4143 c
= gfc_next_ascii_char ();
4154 if (gfc_match_eos () != MATCH_YES
)
4157 gfc_set_implicit_none (type
, external
, &cur_loc
);
4163 /* Match the letter range(s) of an IMPLICIT statement. */
4166 match_implicit_range (void)
4172 cur_loc
= gfc_current_locus
;
4174 gfc_gobble_whitespace ();
4175 c
= gfc_next_ascii_char ();
4178 gfc_error ("Missing character range in IMPLICIT at %C");
4185 gfc_gobble_whitespace ();
4186 c1
= gfc_next_ascii_char ();
4190 gfc_gobble_whitespace ();
4191 c
= gfc_next_ascii_char ();
4196 inner
= 0; /* Fall through. */
4203 gfc_gobble_whitespace ();
4204 c2
= gfc_next_ascii_char ();
4208 gfc_gobble_whitespace ();
4209 c
= gfc_next_ascii_char ();
4211 if ((c
!= ',') && (c
!= ')'))
4224 gfc_error ("Letters must be in alphabetic order in "
4225 "IMPLICIT statement at %C");
4229 /* See if we can add the newly matched range to the pending
4230 implicits from this IMPLICIT statement. We do not check for
4231 conflicts with whatever earlier IMPLICIT statements may have
4232 set. This is done when we've successfully finished matching
4234 if (!gfc_add_new_implicit_range (c1
, c2
))
4241 gfc_syntax_error (ST_IMPLICIT
);
4243 gfc_current_locus
= cur_loc
;
4248 /* Match an IMPLICIT statement, storing the types for
4249 gfc_set_implicit() if the statement is accepted by the parser.
4250 There is a strange looking, but legal syntactic construction
4251 possible. It looks like:
4253 IMPLICIT INTEGER (a-b) (c-d)
4255 This is legal if "a-b" is a constant expression that happens to
4256 equal one of the legal kinds for integers. The real problem
4257 happens with an implicit specification that looks like:
4259 IMPLICIT INTEGER (a-b)
4261 In this case, a typespec matcher that is "greedy" (as most of the
4262 matchers are) gobbles the character range as a kindspec, leaving
4263 nothing left. We therefore have to go a bit more slowly in the
4264 matching process by inhibiting the kindspec checking during
4265 typespec matching and checking for a kind later. */
4268 gfc_match_implicit (void)
4275 if (gfc_current_ns
->seen_implicit_none
)
4277 gfc_error ("IMPLICIT statement at %C following an IMPLICIT NONE (type) "
4284 /* We don't allow empty implicit statements. */
4285 if (gfc_match_eos () == MATCH_YES
)
4287 gfc_error ("Empty IMPLICIT statement at %C");
4293 /* First cleanup. */
4294 gfc_clear_new_implicit ();
4296 /* A basic type is mandatory here. */
4297 m
= gfc_match_decl_type_spec (&ts
, 1);
4298 if (m
== MATCH_ERROR
)
4303 cur_loc
= gfc_current_locus
;
4304 m
= match_implicit_range ();
4308 /* We may have <TYPE> (<RANGE>). */
4309 gfc_gobble_whitespace ();
4310 c
= gfc_peek_ascii_char ();
4311 if (c
== ',' || c
== '\n' || c
== ';' || c
== '!')
4313 /* Check for CHARACTER with no length parameter. */
4314 if (ts
.type
== BT_CHARACTER
&& !ts
.u
.cl
)
4316 ts
.kind
= gfc_default_character_kind
;
4317 ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4318 ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
,
4322 /* Record the Successful match. */
4323 if (!gfc_merge_new_implicit (&ts
))
4326 c
= gfc_next_ascii_char ();
4327 else if (gfc_match_eos () == MATCH_ERROR
)
4332 gfc_current_locus
= cur_loc
;
4335 /* Discard the (incorrectly) matched range. */
4336 gfc_clear_new_implicit ();
4338 /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
4339 if (ts
.type
== BT_CHARACTER
)
4340 m
= gfc_match_char_spec (&ts
);
4343 m
= gfc_match_kind_spec (&ts
, false);
4346 m
= gfc_match_old_kind_spec (&ts
);
4347 if (m
== MATCH_ERROR
)
4353 if (m
== MATCH_ERROR
)
4356 m
= match_implicit_range ();
4357 if (m
== MATCH_ERROR
)
4362 gfc_gobble_whitespace ();
4363 c
= gfc_next_ascii_char ();
4364 if (c
!= ',' && gfc_match_eos () != MATCH_YES
)
4367 if (!gfc_merge_new_implicit (&ts
))
4375 gfc_syntax_error (ST_IMPLICIT
);
4383 gfc_match_import (void)
4385 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4390 if (gfc_current_ns
->proc_name
== NULL
4391 || gfc_current_ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
4393 gfc_error ("IMPORT statement at %C only permitted in "
4394 "an INTERFACE body");
4398 if (gfc_current_ns
->proc_name
->attr
.module_procedure
)
4400 gfc_error ("F2008: C1210 IMPORT statement at %C is not permitted "
4401 "in a module procedure interface body");
4405 if (!gfc_notify_std (GFC_STD_F2003
, "IMPORT statement at %C"))
4408 if (gfc_match_eos () == MATCH_YES
)
4410 /* All host variables should be imported. */
4411 gfc_current_ns
->has_import_set
= 1;
4415 if (gfc_match (" ::") == MATCH_YES
)
4417 if (gfc_match_eos () == MATCH_YES
)
4419 gfc_error ("Expecting list of named entities at %C");
4427 m
= gfc_match (" %n", name
);
4431 if (gfc_current_ns
->parent
!= NULL
4432 && gfc_find_symbol (name
, gfc_current_ns
->parent
, 1, &sym
))
4434 gfc_error ("Type name %qs at %C is ambiguous", name
);
4437 else if (!sym
&& gfc_current_ns
->proc_name
->ns
->parent
!= NULL
4438 && gfc_find_symbol (name
,
4439 gfc_current_ns
->proc_name
->ns
->parent
,
4442 gfc_error ("Type name %qs at %C is ambiguous", name
);
4448 gfc_error ("Cannot IMPORT %qs from host scoping unit "
4449 "at %C - does not exist.", name
);
4453 if (gfc_find_symtree (gfc_current_ns
->sym_root
, name
))
4455 gfc_warning (0, "%qs is already IMPORTed from host scoping unit "
4460 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, name
);
4463 sym
->attr
.imported
= 1;
4465 if (sym
->attr
.generic
&& (sym
= gfc_find_dt_in_generic (sym
)))
4467 /* The actual derived type is stored in a symtree with the first
4468 letter of the name capitalized; the symtree with the all
4469 lower-case name contains the associated generic function. */
4470 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
,
4471 gfc_dt_upper_string (name
));
4474 sym
->attr
.imported
= 1;
4487 if (gfc_match_eos () == MATCH_YES
)
4489 if (gfc_match_char (',') != MATCH_YES
)
4496 gfc_error ("Syntax error in IMPORT statement at %C");
4501 /* A minimal implementation of gfc_match without whitespace, escape
4502 characters or variable arguments. Returns true if the next
4503 characters match the TARGET template exactly. */
4506 match_string_p (const char *target
)
4510 for (p
= target
; *p
; p
++)
4511 if ((char) gfc_next_ascii_char () != *p
)
4516 /* Matches an attribute specification including array specs. If
4517 successful, leaves the variables current_attr and current_as
4518 holding the specification. Also sets the colon_seen variable for
4519 later use by matchers associated with initializations.
4521 This subroutine is a little tricky in the sense that we don't know
4522 if we really have an attr-spec until we hit the double colon.
4523 Until that time, we can only return MATCH_NO. This forces us to
4524 check for duplicate specification at this level. */
4527 match_attr_spec (void)
4529 /* Modifiers that can exist in a type statement. */
4531 { GFC_DECL_BEGIN
= 0,
4532 DECL_ALLOCATABLE
= GFC_DECL_BEGIN
, DECL_DIMENSION
, DECL_EXTERNAL
,
4533 DECL_IN
, DECL_OUT
, DECL_INOUT
, DECL_INTRINSIC
, DECL_OPTIONAL
,
4534 DECL_PARAMETER
, DECL_POINTER
, DECL_PROTECTED
, DECL_PRIVATE
,
4535 DECL_STATIC
, DECL_AUTOMATIC
,
4536 DECL_PUBLIC
, DECL_SAVE
, DECL_TARGET
, DECL_VALUE
, DECL_VOLATILE
,
4537 DECL_IS_BIND_C
, DECL_CODIMENSION
, DECL_ASYNCHRONOUS
, DECL_CONTIGUOUS
,
4538 DECL_LEN
, DECL_KIND
, DECL_NONE
, GFC_DECL_END
/* Sentinel */
4541 /* GFC_DECL_END is the sentinel, index starts at 0. */
4542 #define NUM_DECL GFC_DECL_END
4544 locus start
, seen_at
[NUM_DECL
];
4551 gfc_clear_attr (¤t_attr
);
4552 start
= gfc_current_locus
;
4558 /* See if we get all of the keywords up to the final double colon. */
4559 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
4567 gfc_gobble_whitespace ();
4569 ch
= gfc_next_ascii_char ();
4572 /* This is the successful exit condition for the loop. */
4573 if (gfc_next_ascii_char () == ':')
4578 gfc_gobble_whitespace ();
4579 switch (gfc_peek_ascii_char ())
4582 gfc_next_ascii_char ();
4583 switch (gfc_next_ascii_char ())
4586 if (match_string_p ("locatable"))
4588 /* Matched "allocatable". */
4589 d
= DECL_ALLOCATABLE
;
4594 if (match_string_p ("ynchronous"))
4596 /* Matched "asynchronous". */
4597 d
= DECL_ASYNCHRONOUS
;
4602 if (match_string_p ("tomatic"))
4604 /* Matched "automatic". */
4612 /* Try and match the bind(c). */
4613 m
= gfc_match_bind_c (NULL
, true);
4616 else if (m
== MATCH_ERROR
)
4621 gfc_next_ascii_char ();
4622 if ('o' != gfc_next_ascii_char ())
4624 switch (gfc_next_ascii_char ())
4627 if (match_string_p ("imension"))
4629 d
= DECL_CODIMENSION
;
4634 if (match_string_p ("tiguous"))
4636 d
= DECL_CONTIGUOUS
;
4643 if (match_string_p ("dimension"))
4648 if (match_string_p ("external"))
4653 if (match_string_p ("int"))
4655 ch
= gfc_next_ascii_char ();
4658 if (match_string_p ("nt"))
4660 /* Matched "intent". */
4661 /* TODO: Call match_intent_spec from here. */
4662 if (gfc_match (" ( in out )") == MATCH_YES
)
4664 else if (gfc_match (" ( in )") == MATCH_YES
)
4666 else if (gfc_match (" ( out )") == MATCH_YES
)
4672 if (match_string_p ("insic"))
4674 /* Matched "intrinsic". */
4682 if (match_string_p ("kind"))
4687 if (match_string_p ("len"))
4692 if (match_string_p ("optional"))
4697 gfc_next_ascii_char ();
4698 switch (gfc_next_ascii_char ())
4701 if (match_string_p ("rameter"))
4703 /* Matched "parameter". */
4709 if (match_string_p ("inter"))
4711 /* Matched "pointer". */
4717 ch
= gfc_next_ascii_char ();
4720 if (match_string_p ("vate"))
4722 /* Matched "private". */
4728 if (match_string_p ("tected"))
4730 /* Matched "protected". */
4737 if (match_string_p ("blic"))
4739 /* Matched "public". */
4747 gfc_next_ascii_char ();
4748 switch (gfc_next_ascii_char ())
4751 if (match_string_p ("ve"))
4753 /* Matched "save". */
4759 if (match_string_p ("atic"))
4761 /* Matched "static". */
4769 if (match_string_p ("target"))
4774 gfc_next_ascii_char ();
4775 ch
= gfc_next_ascii_char ();
4778 if (match_string_p ("lue"))
4780 /* Matched "value". */
4786 if (match_string_p ("latile"))
4788 /* Matched "volatile". */
4796 /* No double colon and no recognizable decl_type, so assume that
4797 we've been looking at something else the whole time. */
4804 /* Check to make sure any parens are paired up correctly. */
4805 if (gfc_match_parens () == MATCH_ERROR
)
4812 seen_at
[d
] = gfc_current_locus
;
4814 if (d
== DECL_DIMENSION
|| d
== DECL_CODIMENSION
)
4816 gfc_array_spec
*as
= NULL
;
4818 m
= gfc_match_array_spec (&as
, d
== DECL_DIMENSION
,
4819 d
== DECL_CODIMENSION
);
4821 if (current_as
== NULL
)
4823 else if (m
== MATCH_YES
)
4825 if (!merge_array_spec (as
, current_as
, false))
4832 if (d
== DECL_CODIMENSION
)
4833 gfc_error ("Missing codimension specification at %C");
4835 gfc_error ("Missing dimension specification at %C");
4839 if (m
== MATCH_ERROR
)
4844 /* Since we've seen a double colon, we have to be looking at an
4845 attr-spec. This means that we can now issue errors. */
4846 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
4851 case DECL_ALLOCATABLE
:
4852 attr
= "ALLOCATABLE";
4854 case DECL_ASYNCHRONOUS
:
4855 attr
= "ASYNCHRONOUS";
4857 case DECL_CODIMENSION
:
4858 attr
= "CODIMENSION";
4860 case DECL_CONTIGUOUS
:
4861 attr
= "CONTIGUOUS";
4863 case DECL_DIMENSION
:
4870 attr
= "INTENT (IN)";
4873 attr
= "INTENT (OUT)";
4876 attr
= "INTENT (IN OUT)";
4878 case DECL_INTRINSIC
:
4890 case DECL_PARAMETER
:
4896 case DECL_PROTECTED
:
4911 case DECL_AUTOMATIC
:
4917 case DECL_IS_BIND_C
:
4927 attr
= NULL
; /* This shouldn't happen. */
4930 gfc_error ("Duplicate %s attribute at %L", attr
, &seen_at
[d
]);
4935 /* Now that we've dealt with duplicate attributes, add the attributes
4936 to the current attribute. */
4937 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
4944 if ((d
== DECL_STATIC
|| d
== DECL_AUTOMATIC
)
4945 && !flag_dec_static
)
4947 gfc_error ("%s at %L is a DEC extension, enable with "
4949 d
== DECL_STATIC
? "STATIC" : "AUTOMATIC", &seen_at
[d
]);
4953 /* Allow SAVE with STATIC, but don't complain. */
4954 if (d
== DECL_STATIC
&& seen
[DECL_SAVE
])
4957 if (gfc_current_state () == COMP_DERIVED
4958 && d
!= DECL_DIMENSION
&& d
!= DECL_CODIMENSION
4959 && d
!= DECL_POINTER
&& d
!= DECL_PRIVATE
4960 && d
!= DECL_PUBLIC
&& d
!= DECL_CONTIGUOUS
&& d
!= DECL_NONE
)
4962 if (d
== DECL_ALLOCATABLE
)
4964 if (!gfc_notify_std (GFC_STD_F2003
, "ALLOCATABLE "
4965 "attribute at %C in a TYPE definition"))
4971 else if (d
== DECL_KIND
)
4973 if (!gfc_notify_std (GFC_STD_F2003
, "KIND "
4974 "attribute at %C in a TYPE definition"))
4979 if (current_ts
.type
!= BT_INTEGER
)
4981 gfc_error ("Component with KIND attribute at %C must be "
4986 if (current_ts
.kind
!= gfc_default_integer_kind
)
4988 gfc_error ("Component with KIND attribute at %C must be "
4989 "default integer kind (%d)",
4990 gfc_default_integer_kind
);
4995 else if (d
== DECL_LEN
)
4997 if (!gfc_notify_std (GFC_STD_F2003
, "LEN "
4998 "attribute at %C in a TYPE definition"))
5003 if (current_ts
.type
!= BT_INTEGER
)
5005 gfc_error ("Component with LEN attribute at %C must be "
5010 if (current_ts
.kind
!= gfc_default_integer_kind
)
5012 gfc_error ("Component with LEN attribute at %C must be "
5013 "default integer kind (%d)",
5014 gfc_default_integer_kind
);
5021 gfc_error ("Attribute at %L is not allowed in a TYPE definition",
5028 if ((d
== DECL_PRIVATE
|| d
== DECL_PUBLIC
)
5029 && gfc_current_state () != COMP_MODULE
)
5031 if (d
== DECL_PRIVATE
)
5035 if (gfc_current_state () == COMP_DERIVED
5036 && gfc_state_stack
->previous
5037 && gfc_state_stack
->previous
->state
== COMP_MODULE
)
5039 if (!gfc_notify_std (GFC_STD_F2003
, "Attribute %s "
5040 "at %L in a TYPE definition", attr
,
5049 gfc_error ("%s attribute at %L is not allowed outside of the "
5050 "specification part of a module", attr
, &seen_at
[d
]);
5056 if (gfc_current_state () != COMP_DERIVED
5057 && (d
== DECL_KIND
|| d
== DECL_LEN
))
5059 gfc_error ("Attribute at %L is not allowed outside a TYPE "
5060 "definition", &seen_at
[d
]);
5067 case DECL_ALLOCATABLE
:
5068 t
= gfc_add_allocatable (¤t_attr
, &seen_at
[d
]);
5071 case DECL_ASYNCHRONOUS
:
5072 if (!gfc_notify_std (GFC_STD_F2003
, "ASYNCHRONOUS attribute at %C"))
5075 t
= gfc_add_asynchronous (¤t_attr
, NULL
, &seen_at
[d
]);
5078 case DECL_CODIMENSION
:
5079 t
= gfc_add_codimension (¤t_attr
, NULL
, &seen_at
[d
]);
5082 case DECL_CONTIGUOUS
:
5083 if (!gfc_notify_std (GFC_STD_F2008
, "CONTIGUOUS attribute at %C"))
5086 t
= gfc_add_contiguous (¤t_attr
, NULL
, &seen_at
[d
]);
5089 case DECL_DIMENSION
:
5090 t
= gfc_add_dimension (¤t_attr
, NULL
, &seen_at
[d
]);
5094 t
= gfc_add_external (¤t_attr
, &seen_at
[d
]);
5098 t
= gfc_add_intent (¤t_attr
, INTENT_IN
, &seen_at
[d
]);
5102 t
= gfc_add_intent (¤t_attr
, INTENT_OUT
, &seen_at
[d
]);
5106 t
= gfc_add_intent (¤t_attr
, INTENT_INOUT
, &seen_at
[d
]);
5109 case DECL_INTRINSIC
:
5110 t
= gfc_add_intrinsic (¤t_attr
, &seen_at
[d
]);
5114 t
= gfc_add_optional (¤t_attr
, &seen_at
[d
]);
5118 t
= gfc_add_kind (¤t_attr
, &seen_at
[d
]);
5122 t
= gfc_add_len (¤t_attr
, &seen_at
[d
]);
5125 case DECL_PARAMETER
:
5126 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, &seen_at
[d
]);
5130 t
= gfc_add_pointer (¤t_attr
, &seen_at
[d
]);
5133 case DECL_PROTECTED
:
5134 if (gfc_current_state () != COMP_MODULE
5135 || (gfc_current_ns
->proc_name
5136 && gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
))
5138 gfc_error ("PROTECTED at %C only allowed in specification "
5139 "part of a module");
5144 if (!gfc_notify_std (GFC_STD_F2003
, "PROTECTED attribute at %C"))
5147 t
= gfc_add_protected (¤t_attr
, NULL
, &seen_at
[d
]);
5151 t
= gfc_add_access (¤t_attr
, ACCESS_PRIVATE
, NULL
,
5156 t
= gfc_add_access (¤t_attr
, ACCESS_PUBLIC
, NULL
,
5162 t
= gfc_add_save (¤t_attr
, SAVE_EXPLICIT
, NULL
, &seen_at
[d
]);
5165 case DECL_AUTOMATIC
:
5166 t
= gfc_add_automatic (¤t_attr
, NULL
, &seen_at
[d
]);
5170 t
= gfc_add_target (¤t_attr
, &seen_at
[d
]);
5173 case DECL_IS_BIND_C
:
5174 t
= gfc_add_is_bind_c(¤t_attr
, NULL
, &seen_at
[d
], 0);
5178 if (!gfc_notify_std (GFC_STD_F2003
, "VALUE attribute at %C"))
5181 t
= gfc_add_value (¤t_attr
, NULL
, &seen_at
[d
]);
5185 if (!gfc_notify_std (GFC_STD_F2003
, "VOLATILE attribute at %C"))
5188 t
= gfc_add_volatile (¤t_attr
, NULL
, &seen_at
[d
]);
5192 gfc_internal_error ("match_attr_spec(): Bad attribute");
5202 /* Since Fortran 2008 module variables implicitly have the SAVE attribute. */
5203 if ((gfc_current_state () == COMP_MODULE
5204 || gfc_current_state () == COMP_SUBMODULE
)
5205 && !current_attr
.save
5206 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
5207 current_attr
.save
= SAVE_IMPLICIT
;
5213 gfc_current_locus
= start
;
5214 gfc_free_array_spec (current_as
);
5221 /* Set the binding label, dest_label, either with the binding label
5222 stored in the given gfc_typespec, ts, or if none was provided, it
5223 will be the symbol name in all lower case, as required by the draft
5224 (J3/04-007, section 15.4.1). If a binding label was given and
5225 there is more than one argument (num_idents), it is an error. */
5228 set_binding_label (const char **dest_label
, const char *sym_name
,
5231 if (num_idents
> 1 && has_name_equals
)
5233 gfc_error ("Multiple identifiers provided with "
5234 "single NAME= specifier at %C");
5238 if (curr_binding_label
)
5239 /* Binding label given; store in temp holder till have sym. */
5240 *dest_label
= curr_binding_label
;
5243 /* No binding label given, and the NAME= specifier did not exist,
5244 which means there was no NAME="". */
5245 if (sym_name
!= NULL
&& has_name_equals
== 0)
5246 *dest_label
= IDENTIFIER_POINTER (get_identifier (sym_name
));
5253 /* Set the status of the given common block as being BIND(C) or not,
5254 depending on the given parameter, is_bind_c. */
5257 set_com_block_bind_c (gfc_common_head
*com_block
, int is_bind_c
)
5259 com_block
->is_bind_c
= is_bind_c
;
5264 /* Verify that the given gfc_typespec is for a C interoperable type. */
5267 gfc_verify_c_interop (gfc_typespec
*ts
)
5269 if (ts
->type
== BT_DERIVED
&& ts
->u
.derived
!= NULL
)
5270 return (ts
->u
.derived
->ts
.is_c_interop
|| ts
->u
.derived
->attr
.is_bind_c
)
5272 else if (ts
->type
== BT_CLASS
)
5274 else if (ts
->is_c_interop
!= 1 && ts
->type
!= BT_ASSUMED
)
5281 /* Verify that the variables of a given common block, which has been
5282 defined with the attribute specifier bind(c), to be of a C
5283 interoperable type. Errors will be reported here, if
5287 verify_com_block_vars_c_interop (gfc_common_head
*com_block
)
5289 gfc_symbol
*curr_sym
= NULL
;
5292 curr_sym
= com_block
->head
;
5294 /* Make sure we have at least one symbol. */
5295 if (curr_sym
== NULL
)
5298 /* Here we know we have a symbol, so we'll execute this loop
5302 /* The second to last param, 1, says this is in a common block. */
5303 retval
= verify_bind_c_sym (curr_sym
, &(curr_sym
->ts
), 1, com_block
);
5304 curr_sym
= curr_sym
->common_next
;
5305 } while (curr_sym
!= NULL
);
5311 /* Verify that a given BIND(C) symbol is C interoperable. If it is not,
5312 an appropriate error message is reported. */
5315 verify_bind_c_sym (gfc_symbol
*tmp_sym
, gfc_typespec
*ts
,
5316 int is_in_common
, gfc_common_head
*com_block
)
5318 bool bind_c_function
= false;
5321 if (tmp_sym
->attr
.function
&& tmp_sym
->attr
.is_bind_c
)
5322 bind_c_function
= true;
5324 if (tmp_sym
->attr
.function
&& tmp_sym
->result
!= NULL
)
5326 tmp_sym
= tmp_sym
->result
;
5327 /* Make sure it wasn't an implicitly typed result. */
5328 if (tmp_sym
->attr
.implicit_type
&& warn_c_binding_type
)
5330 gfc_warning (OPT_Wc_binding_type
,
5331 "Implicitly declared BIND(C) function %qs at "
5332 "%L may not be C interoperable", tmp_sym
->name
,
5333 &tmp_sym
->declared_at
);
5334 tmp_sym
->ts
.f90_type
= tmp_sym
->ts
.type
;
5335 /* Mark it as C interoperable to prevent duplicate warnings. */
5336 tmp_sym
->ts
.is_c_interop
= 1;
5337 tmp_sym
->attr
.is_c_interop
= 1;
5341 /* Here, we know we have the bind(c) attribute, so if we have
5342 enough type info, then verify that it's a C interop kind.
5343 The info could be in the symbol already, or possibly still in
5344 the given ts (current_ts), so look in both. */
5345 if (tmp_sym
->ts
.type
!= BT_UNKNOWN
|| ts
->type
!= BT_UNKNOWN
)
5347 if (!gfc_verify_c_interop (&(tmp_sym
->ts
)))
5349 /* See if we're dealing with a sym in a common block or not. */
5350 if (is_in_common
== 1 && warn_c_binding_type
)
5352 gfc_warning (OPT_Wc_binding_type
,
5353 "Variable %qs in common block %qs at %L "
5354 "may not be a C interoperable "
5355 "kind though common block %qs is BIND(C)",
5356 tmp_sym
->name
, com_block
->name
,
5357 &(tmp_sym
->declared_at
), com_block
->name
);
5361 if (tmp_sym
->ts
.type
== BT_DERIVED
|| ts
->type
== BT_DERIVED
)
5362 gfc_error ("Type declaration %qs at %L is not C "
5363 "interoperable but it is BIND(C)",
5364 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5365 else if (warn_c_binding_type
)
5366 gfc_warning (OPT_Wc_binding_type
, "Variable %qs at %L "
5367 "may not be a C interoperable "
5368 "kind but it is BIND(C)",
5369 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5373 /* Variables declared w/in a common block can't be bind(c)
5374 since there's no way for C to see these variables, so there's
5375 semantically no reason for the attribute. */
5376 if (is_in_common
== 1 && tmp_sym
->attr
.is_bind_c
== 1)
5378 gfc_error ("Variable %qs in common block %qs at "
5379 "%L cannot be declared with BIND(C) "
5380 "since it is not a global",
5381 tmp_sym
->name
, com_block
->name
,
5382 &(tmp_sym
->declared_at
));
5386 /* Scalar variables that are bind(c) can not have the pointer
5387 or allocatable attributes. */
5388 if (tmp_sym
->attr
.is_bind_c
== 1)
5390 if (tmp_sym
->attr
.pointer
== 1)
5392 gfc_error ("Variable %qs at %L cannot have both the "
5393 "POINTER and BIND(C) attributes",
5394 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5398 if (tmp_sym
->attr
.allocatable
== 1)
5400 gfc_error ("Variable %qs at %L cannot have both the "
5401 "ALLOCATABLE and BIND(C) attributes",
5402 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5408 /* If it is a BIND(C) function, make sure the return value is a
5409 scalar value. The previous tests in this function made sure
5410 the type is interoperable. */
5411 if (bind_c_function
&& tmp_sym
->as
!= NULL
)
5412 gfc_error ("Return type of BIND(C) function %qs at %L cannot "
5413 "be an array", tmp_sym
->name
, &(tmp_sym
->declared_at
));
5415 /* BIND(C) functions can not return a character string. */
5416 if (bind_c_function
&& tmp_sym
->ts
.type
== BT_CHARACTER
)
5417 if (tmp_sym
->ts
.u
.cl
== NULL
|| tmp_sym
->ts
.u
.cl
->length
== NULL
5418 || tmp_sym
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
5419 || mpz_cmp_si (tmp_sym
->ts
.u
.cl
->length
->value
.integer
, 1) != 0)
5420 gfc_error ("Return type of BIND(C) function %qs at %L cannot "
5421 "be a character string", tmp_sym
->name
,
5422 &(tmp_sym
->declared_at
));
5425 /* See if the symbol has been marked as private. If it has, make sure
5426 there is no binding label and warn the user if there is one. */
5427 if (tmp_sym
->attr
.access
== ACCESS_PRIVATE
5428 && tmp_sym
->binding_label
)
5429 /* Use gfc_warning_now because we won't say that the symbol fails
5430 just because of this. */
5431 gfc_warning_now (0, "Symbol %qs at %L is marked PRIVATE but has been "
5432 "given the binding label %qs", tmp_sym
->name
,
5433 &(tmp_sym
->declared_at
), tmp_sym
->binding_label
);
5439 /* Set the appropriate fields for a symbol that's been declared as
5440 BIND(C) (the is_bind_c flag and the binding label), and verify that
5441 the type is C interoperable. Errors are reported by the functions
5442 used to set/test these fields. */
5445 set_verify_bind_c_sym (gfc_symbol
*tmp_sym
, int num_idents
)
5449 /* TODO: Do we need to make sure the vars aren't marked private? */
5451 /* Set the is_bind_c bit in symbol_attribute. */
5452 gfc_add_is_bind_c (&(tmp_sym
->attr
), tmp_sym
->name
, &gfc_current_locus
, 0);
5454 if (!set_binding_label (&tmp_sym
->binding_label
, tmp_sym
->name
, num_idents
))
5461 /* Set the fields marking the given common block as BIND(C), including
5462 a binding label, and report any errors encountered. */
5465 set_verify_bind_c_com_block (gfc_common_head
*com_block
, int num_idents
)
5469 /* destLabel, common name, typespec (which may have binding label). */
5470 if (!set_binding_label (&com_block
->binding_label
, com_block
->name
,
5474 /* Set the given common block (com_block) to being bind(c) (1). */
5475 set_com_block_bind_c (com_block
, 1);
5481 /* Retrieve the list of one or more identifiers that the given bind(c)
5482 attribute applies to. */
5485 get_bind_c_idents (void)
5487 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5489 gfc_symbol
*tmp_sym
= NULL
;
5491 gfc_common_head
*com_block
= NULL
;
5493 if (gfc_match_name (name
) == MATCH_YES
)
5495 found_id
= MATCH_YES
;
5496 gfc_get_ha_symbol (name
, &tmp_sym
);
5498 else if (match_common_name (name
) == MATCH_YES
)
5500 found_id
= MATCH_YES
;
5501 com_block
= gfc_get_common (name
, 0);
5505 gfc_error ("Need either entity or common block name for "
5506 "attribute specification statement at %C");
5510 /* Save the current identifier and look for more. */
5513 /* Increment the number of identifiers found for this spec stmt. */
5516 /* Make sure we have a sym or com block, and verify that it can
5517 be bind(c). Set the appropriate field(s) and look for more
5519 if (tmp_sym
!= NULL
|| com_block
!= NULL
)
5521 if (tmp_sym
!= NULL
)
5523 if (!set_verify_bind_c_sym (tmp_sym
, num_idents
))
5528 if (!set_verify_bind_c_com_block (com_block
, num_idents
))
5532 /* Look to see if we have another identifier. */
5534 if (gfc_match_eos () == MATCH_YES
)
5535 found_id
= MATCH_NO
;
5536 else if (gfc_match_char (',') != MATCH_YES
)
5537 found_id
= MATCH_NO
;
5538 else if (gfc_match_name (name
) == MATCH_YES
)
5540 found_id
= MATCH_YES
;
5541 gfc_get_ha_symbol (name
, &tmp_sym
);
5543 else if (match_common_name (name
) == MATCH_YES
)
5545 found_id
= MATCH_YES
;
5546 com_block
= gfc_get_common (name
, 0);
5550 gfc_error ("Missing entity or common block name for "
5551 "attribute specification statement at %C");
5557 gfc_internal_error ("Missing symbol");
5559 } while (found_id
== MATCH_YES
);
5561 /* if we get here we were successful */
5566 /* Try and match a BIND(C) attribute specification statement. */
5569 gfc_match_bind_c_stmt (void)
5571 match found_match
= MATCH_NO
;
5576 /* This may not be necessary. */
5578 /* Clear the temporary binding label holder. */
5579 curr_binding_label
= NULL
;
5581 /* Look for the bind(c). */
5582 found_match
= gfc_match_bind_c (NULL
, true);
5584 if (found_match
== MATCH_YES
)
5586 if (!gfc_notify_std (GFC_STD_F2003
, "BIND(C) statement at %C"))
5589 /* Look for the :: now, but it is not required. */
5592 /* Get the identifier(s) that needs to be updated. This may need to
5593 change to hand the flag(s) for the attr specified so all identifiers
5594 found can have all appropriate parts updated (assuming that the same
5595 spec stmt can have multiple attrs, such as both bind(c) and
5597 if (!get_bind_c_idents ())
5598 /* Error message should have printed already. */
5606 /* Match a data declaration statement. */
5609 gfc_match_data_decl (void)
5615 type_param_spec_list
= NULL
;
5616 decl_type_param_list
= NULL
;
5618 num_idents_on_line
= 0;
5620 m
= gfc_match_decl_type_spec (¤t_ts
, 0);
5624 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
5625 && !gfc_comp_struct (gfc_current_state ()))
5627 sym
= gfc_use_derived (current_ts
.u
.derived
);
5635 current_ts
.u
.derived
= sym
;
5638 m
= match_attr_spec ();
5639 if (m
== MATCH_ERROR
)
5645 if (current_ts
.type
== BT_CLASS
5646 && current_ts
.u
.derived
->attr
.unlimited_polymorphic
)
5649 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
5650 && current_ts
.u
.derived
->components
== NULL
5651 && !current_ts
.u
.derived
->attr
.zero_comp
)
5654 if (current_attr
.pointer
&& gfc_comp_struct (gfc_current_state ()))
5657 if (current_attr
.allocatable
&& gfc_current_state () == COMP_DERIVED
5658 && current_ts
.u
.derived
== gfc_current_block ())
5661 gfc_find_symbol (current_ts
.u
.derived
->name
,
5662 current_ts
.u
.derived
->ns
, 1, &sym
);
5664 /* Any symbol that we find had better be a type definition
5665 which has its components defined, or be a structure definition
5666 actively being parsed. */
5667 if (sym
!= NULL
&& gfc_fl_struct (sym
->attr
.flavor
)
5668 && (current_ts
.u
.derived
->components
!= NULL
5669 || current_ts
.u
.derived
->attr
.zero_comp
5670 || current_ts
.u
.derived
== gfc_new_block
))
5673 gfc_error ("Derived type at %C has not been previously defined "
5674 "and so cannot appear in a derived type definition");
5680 /* If we have an old-style character declaration, and no new-style
5681 attribute specifications, then there a comma is optional between
5682 the type specification and the variable list. */
5683 if (m
== MATCH_NO
&& current_ts
.type
== BT_CHARACTER
&& old_char_selector
)
5684 gfc_match_char (',');
5686 /* Give the types/attributes to symbols that follow. Give the element
5687 a number so that repeat character length expressions can be copied. */
5691 num_idents_on_line
++;
5692 m
= variable_decl (elem
++);
5693 if (m
== MATCH_ERROR
)
5698 if (gfc_match_eos () == MATCH_YES
)
5700 if (gfc_match_char (',') != MATCH_YES
)
5704 if (!gfc_error_flag_test ())
5706 /* An anonymous structure declaration is unambiguous; if we matched one
5707 according to gfc_match_structure_decl, we need to return MATCH_YES
5708 here to avoid confusing the remaining matchers, even if there was an
5709 error during variable_decl. We must flush any such errors. Note this
5710 causes the parser to gracefully continue parsing the remaining input
5711 as a structure body, which likely follows. */
5712 if (current_ts
.type
== BT_DERIVED
&& current_ts
.u
.derived
5713 && gfc_fl_struct (current_ts
.u
.derived
->attr
.flavor
))
5715 gfc_error_now ("Syntax error in anonymous structure declaration"
5717 /* Skip the bad variable_decl and line up for the start of the
5719 gfc_error_recovery ();
5724 gfc_error ("Syntax error in data declaration at %C");
5729 gfc_free_data_all (gfc_current_ns
);
5732 if (saved_kind_expr
)
5733 gfc_free_expr (saved_kind_expr
);
5734 if (type_param_spec_list
)
5735 gfc_free_actual_arglist (type_param_spec_list
);
5736 if (decl_type_param_list
)
5737 gfc_free_actual_arglist (decl_type_param_list
);
5738 saved_kind_expr
= NULL
;
5739 gfc_free_array_spec (current_as
);
5745 /* Match a prefix associated with a function or subroutine
5746 declaration. If the typespec pointer is nonnull, then a typespec
5747 can be matched. Note that if nothing matches, MATCH_YES is
5748 returned (the null string was matched). */
5751 gfc_match_prefix (gfc_typespec
*ts
)
5757 gfc_clear_attr (¤t_attr
);
5759 seen_impure
= false;
5761 gcc_assert (!gfc_matching_prefix
);
5762 gfc_matching_prefix
= true;
5766 found_prefix
= false;
5768 /* MODULE is a prefix like PURE, ELEMENTAL, etc., having a
5769 corresponding attribute seems natural and distinguishes these
5770 procedures from procedure types of PROC_MODULE, which these are
5772 if (gfc_match ("module% ") == MATCH_YES
)
5774 if (!gfc_notify_std (GFC_STD_F2008
, "MODULE prefix at %C"))
5777 current_attr
.module_procedure
= 1;
5778 found_prefix
= true;
5781 if (!seen_type
&& ts
!= NULL
5782 && gfc_match_decl_type_spec (ts
, 0) == MATCH_YES
5783 && gfc_match_space () == MATCH_YES
)
5787 found_prefix
= true;
5790 if (gfc_match ("elemental% ") == MATCH_YES
)
5792 if (!gfc_add_elemental (¤t_attr
, NULL
))
5795 found_prefix
= true;
5798 if (gfc_match ("pure% ") == MATCH_YES
)
5800 if (!gfc_add_pure (¤t_attr
, NULL
))
5803 found_prefix
= true;
5806 if (gfc_match ("recursive% ") == MATCH_YES
)
5808 if (!gfc_add_recursive (¤t_attr
, NULL
))
5811 found_prefix
= true;
5814 /* IMPURE is a somewhat special case, as it needs not set an actual
5815 attribute but rather only prevents ELEMENTAL routines from being
5816 automatically PURE. */
5817 if (gfc_match ("impure% ") == MATCH_YES
)
5819 if (!gfc_notify_std (GFC_STD_F2008
, "IMPURE procedure at %C"))
5823 found_prefix
= true;
5826 while (found_prefix
);
5828 /* IMPURE and PURE must not both appear, of course. */
5829 if (seen_impure
&& current_attr
.pure
)
5831 gfc_error ("PURE and IMPURE must not appear both at %C");
5835 /* If IMPURE it not seen but the procedure is ELEMENTAL, mark it as PURE. */
5836 if (!seen_impure
&& current_attr
.elemental
&& !current_attr
.pure
)
5838 if (!gfc_add_pure (¤t_attr
, NULL
))
5842 /* At this point, the next item is not a prefix. */
5843 gcc_assert (gfc_matching_prefix
);
5845 gfc_matching_prefix
= false;
5849 gcc_assert (gfc_matching_prefix
);
5850 gfc_matching_prefix
= false;
5855 /* Copy attributes matched by gfc_match_prefix() to attributes on a symbol. */
5858 copy_prefix (symbol_attribute
*dest
, locus
*where
)
5860 if (dest
->module_procedure
)
5862 if (current_attr
.elemental
)
5863 dest
->elemental
= 1;
5865 if (current_attr
.pure
)
5868 if (current_attr
.recursive
)
5869 dest
->recursive
= 1;
5871 /* Module procedures are unusual in that the 'dest' is copied from
5872 the interface declaration. However, this is an oportunity to
5873 check that the submodule declaration is compliant with the
5875 if (dest
->elemental
&& !current_attr
.elemental
)
5877 gfc_error ("ELEMENTAL prefix in MODULE PROCEDURE interface is "
5878 "missing at %L", where
);
5882 if (dest
->pure
&& !current_attr
.pure
)
5884 gfc_error ("PURE prefix in MODULE PROCEDURE interface is "
5885 "missing at %L", where
);
5889 if (dest
->recursive
&& !current_attr
.recursive
)
5891 gfc_error ("RECURSIVE prefix in MODULE PROCEDURE interface is "
5892 "missing at %L", where
);
5899 if (current_attr
.elemental
&& !gfc_add_elemental (dest
, where
))
5902 if (current_attr
.pure
&& !gfc_add_pure (dest
, where
))
5905 if (current_attr
.recursive
&& !gfc_add_recursive (dest
, where
))
5912 /* Match a formal argument list or, if typeparam is true, a
5913 type_param_name_list. */
5916 gfc_match_formal_arglist (gfc_symbol
*progname
, int st_flag
,
5917 int null_flag
, bool typeparam
)
5919 gfc_formal_arglist
*head
, *tail
, *p
, *q
;
5920 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5923 gfc_formal_arglist
*formal
= NULL
;
5927 /* Keep the interface formal argument list and null it so that the
5928 matching for the new declaration can be done. The numbers and
5929 names of the arguments are checked here. The interface formal
5930 arguments are retained in formal_arglist and the characteristics
5931 are compared in resolve.c(resolve_fl_procedure). See the remark
5932 in get_proc_name about the eventual need to copy the formal_arglist
5933 and populate the formal namespace of the interface symbol. */
5934 if (progname
->attr
.module_procedure
5935 && progname
->attr
.host_assoc
)
5937 formal
= progname
->formal
;
5938 progname
->formal
= NULL
;
5941 if (gfc_match_char ('(') != MATCH_YES
)
5948 if (gfc_match_char (')') == MATCH_YES
)
5953 if (gfc_match_char ('*') == MATCH_YES
)
5956 if (!typeparam
&& !gfc_notify_std (GFC_STD_F95_OBS
,
5957 "Alternate-return argument at %C"))
5963 gfc_error_now ("A parameter name is required at %C");
5967 m
= gfc_match_name (name
);
5971 gfc_error_now ("A parameter name is required at %C");
5975 if (!typeparam
&& gfc_get_symbol (name
, NULL
, &sym
))
5978 && gfc_get_symbol (name
, progname
->f2k_derived
, &sym
))
5982 p
= gfc_get_formal_arglist ();
5994 /* We don't add the VARIABLE flavor because the name could be a
5995 dummy procedure. We don't apply these attributes to formal
5996 arguments of statement functions. */
5997 if (sym
!= NULL
&& !st_flag
5998 && (!gfc_add_dummy(&sym
->attr
, sym
->name
, NULL
)
5999 || !gfc_missing_attr (&sym
->attr
, NULL
)))
6005 /* The name of a program unit can be in a different namespace,
6006 so check for it explicitly. After the statement is accepted,
6007 the name is checked for especially in gfc_get_symbol(). */
6008 if (gfc_new_block
!= NULL
&& sym
!= NULL
&& !typeparam
6009 && strcmp (sym
->name
, gfc_new_block
->name
) == 0)
6011 gfc_error ("Name %qs at %C is the name of the procedure",
6017 if (gfc_match_char (')') == MATCH_YES
)
6020 m
= gfc_match_char (',');
6024 gfc_error_now ("Expected parameter list in type declaration "
6027 gfc_error ("Unexpected junk in formal argument list at %C");
6033 /* Check for duplicate symbols in the formal argument list. */
6036 for (p
= head
; p
->next
; p
= p
->next
)
6041 for (q
= p
->next
; q
; q
= q
->next
)
6042 if (p
->sym
== q
->sym
)
6045 gfc_error_now ("Duplicate name %qs in parameter "
6046 "list at %C", p
->sym
->name
);
6048 gfc_error ("Duplicate symbol %qs in formal argument "
6049 "list at %C", p
->sym
->name
);
6057 if (!gfc_add_explicit_interface (progname
, IFSRC_DECL
, head
, NULL
))
6063 /* gfc_error_now used in following and return with MATCH_YES because
6064 doing otherwise results in a cascade of extraneous errors and in
6065 some cases an ICE in symbol.c(gfc_release_symbol). */
6066 if (progname
->attr
.module_procedure
&& progname
->attr
.host_assoc
)
6068 bool arg_count_mismatch
= false;
6070 if (!formal
&& head
)
6071 arg_count_mismatch
= true;
6073 /* Abbreviated module procedure declaration is not meant to have any
6074 formal arguments! */
6075 if (!progname
->abr_modproc_decl
&& formal
&& !head
)
6076 arg_count_mismatch
= true;
6078 for (p
= formal
, q
= head
; p
&& q
; p
= p
->next
, q
= q
->next
)
6080 if ((p
->next
!= NULL
&& q
->next
== NULL
)
6081 || (p
->next
== NULL
&& q
->next
!= NULL
))
6082 arg_count_mismatch
= true;
6083 else if ((p
->sym
== NULL
&& q
->sym
== NULL
)
6084 || strcmp (p
->sym
->name
, q
->sym
->name
) == 0)
6087 gfc_error_now ("Mismatch in MODULE PROCEDURE formal "
6088 "argument names (%s/%s) at %C",
6089 p
->sym
->name
, q
->sym
->name
);
6092 if (arg_count_mismatch
)
6093 gfc_error_now ("Mismatch in number of MODULE PROCEDURE "
6094 "formal arguments at %C");
6100 gfc_free_formal_arglist (head
);
6105 /* Match a RESULT specification following a function declaration or
6106 ENTRY statement. Also matches the end-of-statement. */
6109 match_result (gfc_symbol
*function
, gfc_symbol
**result
)
6111 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6115 if (gfc_match (" result (") != MATCH_YES
)
6118 m
= gfc_match_name (name
);
6122 /* Get the right paren, and that's it because there could be the
6123 bind(c) attribute after the result clause. */
6124 if (gfc_match_char (')') != MATCH_YES
)
6126 /* TODO: should report the missing right paren here. */
6130 if (strcmp (function
->name
, name
) == 0)
6132 gfc_error ("RESULT variable at %C must be different than function name");
6136 if (gfc_get_symbol (name
, NULL
, &r
))
6139 if (!gfc_add_result (&r
->attr
, r
->name
, NULL
))
6148 /* Match a function suffix, which could be a combination of a result
6149 clause and BIND(C), either one, or neither. The draft does not
6150 require them to come in a specific order. */
6153 gfc_match_suffix (gfc_symbol
*sym
, gfc_symbol
**result
)
6155 match is_bind_c
; /* Found bind(c). */
6156 match is_result
; /* Found result clause. */
6157 match found_match
; /* Status of whether we've found a good match. */
6158 char peek_char
; /* Character we're going to peek at. */
6159 bool allow_binding_name
;
6161 /* Initialize to having found nothing. */
6162 found_match
= MATCH_NO
;
6163 is_bind_c
= MATCH_NO
;
6164 is_result
= MATCH_NO
;
6166 /* Get the next char to narrow between result and bind(c). */
6167 gfc_gobble_whitespace ();
6168 peek_char
= gfc_peek_ascii_char ();
6170 /* C binding names are not allowed for internal procedures. */
6171 if (gfc_current_state () == COMP_CONTAINS
6172 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
6173 allow_binding_name
= false;
6175 allow_binding_name
= true;
6180 /* Look for result clause. */
6181 is_result
= match_result (sym
, result
);
6182 if (is_result
== MATCH_YES
)
6184 /* Now see if there is a bind(c) after it. */
6185 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
6186 /* We've found the result clause and possibly bind(c). */
6187 found_match
= MATCH_YES
;
6190 /* This should only be MATCH_ERROR. */
6191 found_match
= is_result
;
6194 /* Look for bind(c) first. */
6195 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
6196 if (is_bind_c
== MATCH_YES
)
6198 /* Now see if a result clause followed it. */
6199 is_result
= match_result (sym
, result
);
6200 found_match
= MATCH_YES
;
6204 /* Should only be a MATCH_ERROR if we get here after seeing 'b'. */
6205 found_match
= MATCH_ERROR
;
6209 gfc_error ("Unexpected junk after function declaration at %C");
6210 found_match
= MATCH_ERROR
;
6214 if (is_bind_c
== MATCH_YES
)
6216 /* Fortran 2008 draft allows BIND(C) for internal procedures. */
6217 if (gfc_current_state () == COMP_CONTAINS
6218 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
6219 && !gfc_notify_std (GFC_STD_F2008
, "BIND(C) attribute "
6220 "at %L may not be specified for an internal "
6221 "procedure", &gfc_current_locus
))
6224 if (!gfc_add_is_bind_c (&(sym
->attr
), sym
->name
, &gfc_current_locus
, 1))
6232 /* Procedure pointer return value without RESULT statement:
6233 Add "hidden" result variable named "ppr@". */
6236 add_hidden_procptr_result (gfc_symbol
*sym
)
6240 if (gfc_notification_std (GFC_STD_F2003
) == ERROR
)
6243 /* First usage case: PROCEDURE and EXTERNAL statements. */
6244 case1
= gfc_current_state () == COMP_FUNCTION
&& gfc_current_block ()
6245 && strcmp (gfc_current_block ()->name
, sym
->name
) == 0
6246 && sym
->attr
.external
;
6247 /* Second usage case: INTERFACE statements. */
6248 case2
= gfc_current_state () == COMP_INTERFACE
&& gfc_state_stack
->previous
6249 && gfc_state_stack
->previous
->state
== COMP_FUNCTION
6250 && strcmp (gfc_state_stack
->previous
->sym
->name
, sym
->name
) == 0;
6256 gfc_get_sym_tree ("ppr@", gfc_current_ns
, &stree
, false);
6260 gfc_get_sym_tree ("ppr@", gfc_current_ns
->parent
, &stree
, false);
6261 st2
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "ppr@");
6262 st2
->n
.sym
= stree
->n
.sym
;
6263 stree
->n
.sym
->refs
++;
6265 sym
->result
= stree
->n
.sym
;
6267 sym
->result
->attr
.proc_pointer
= sym
->attr
.proc_pointer
;
6268 sym
->result
->attr
.pointer
= sym
->attr
.pointer
;
6269 sym
->result
->attr
.external
= sym
->attr
.external
;
6270 sym
->result
->attr
.referenced
= sym
->attr
.referenced
;
6271 sym
->result
->ts
= sym
->ts
;
6272 sym
->attr
.proc_pointer
= 0;
6273 sym
->attr
.pointer
= 0;
6274 sym
->attr
.external
= 0;
6275 if (sym
->result
->attr
.external
&& sym
->result
->attr
.pointer
)
6277 sym
->result
->attr
.pointer
= 0;
6278 sym
->result
->attr
.proc_pointer
= 1;
6281 return gfc_add_result (&sym
->result
->attr
, sym
->result
->name
, NULL
);
6283 /* POINTER after PROCEDURE/EXTERNAL/INTERFACE statement. */
6284 else if (sym
->attr
.function
&& !sym
->attr
.external
&& sym
->attr
.pointer
6285 && sym
->result
&& sym
->result
!= sym
&& sym
->result
->attr
.external
6286 && sym
== gfc_current_ns
->proc_name
6287 && sym
== sym
->result
->ns
->proc_name
6288 && strcmp ("ppr@", sym
->result
->name
) == 0)
6290 sym
->result
->attr
.proc_pointer
= 1;
6291 sym
->attr
.pointer
= 0;
6299 /* Match the interface for a PROCEDURE declaration,
6300 including brackets (R1212). */
6303 match_procedure_interface (gfc_symbol
**proc_if
)
6307 locus old_loc
, entry_loc
;
6308 gfc_namespace
*old_ns
= gfc_current_ns
;
6309 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6311 old_loc
= entry_loc
= gfc_current_locus
;
6312 gfc_clear_ts (¤t_ts
);
6314 if (gfc_match (" (") != MATCH_YES
)
6316 gfc_current_locus
= entry_loc
;
6320 /* Get the type spec. for the procedure interface. */
6321 old_loc
= gfc_current_locus
;
6322 m
= gfc_match_decl_type_spec (¤t_ts
, 0);
6323 gfc_gobble_whitespace ();
6324 if (m
== MATCH_YES
|| (m
== MATCH_NO
&& gfc_peek_ascii_char () == ')'))
6327 if (m
== MATCH_ERROR
)
6330 /* Procedure interface is itself a procedure. */
6331 gfc_current_locus
= old_loc
;
6332 m
= gfc_match_name (name
);
6334 /* First look to see if it is already accessible in the current
6335 namespace because it is use associated or contained. */
6337 if (gfc_find_sym_tree (name
, NULL
, 0, &st
))
6340 /* If it is still not found, then try the parent namespace, if it
6341 exists and create the symbol there if it is still not found. */
6342 if (gfc_current_ns
->parent
)
6343 gfc_current_ns
= gfc_current_ns
->parent
;
6344 if (st
== NULL
&& gfc_get_ha_sym_tree (name
, &st
))
6347 gfc_current_ns
= old_ns
;
6348 *proc_if
= st
->n
.sym
;
6353 /* Resolve interface if possible. That way, attr.procedure is only set
6354 if it is declared by a later procedure-declaration-stmt, which is
6355 invalid per F08:C1216 (cf. resolve_procedure_interface). */
6356 while ((*proc_if
)->ts
.interface
6357 && *proc_if
!= (*proc_if
)->ts
.interface
)
6358 *proc_if
= (*proc_if
)->ts
.interface
;
6360 if ((*proc_if
)->attr
.flavor
== FL_UNKNOWN
6361 && (*proc_if
)->ts
.type
== BT_UNKNOWN
6362 && !gfc_add_flavor (&(*proc_if
)->attr
, FL_PROCEDURE
,
6363 (*proc_if
)->name
, NULL
))
6368 if (gfc_match (" )") != MATCH_YES
)
6370 gfc_current_locus
= entry_loc
;
6378 /* Match a PROCEDURE declaration (R1211). */
6381 match_procedure_decl (void)
6384 gfc_symbol
*sym
, *proc_if
= NULL
;
6386 gfc_expr
*initializer
= NULL
;
6388 /* Parse interface (with brackets). */
6389 m
= match_procedure_interface (&proc_if
);
6393 /* Parse attributes (with colons). */
6394 m
= match_attr_spec();
6395 if (m
== MATCH_ERROR
)
6398 if (proc_if
&& proc_if
->attr
.is_bind_c
&& !current_attr
.is_bind_c
)
6400 current_attr
.is_bind_c
= 1;
6401 has_name_equals
= 0;
6402 curr_binding_label
= NULL
;
6405 /* Get procedure symbols. */
6408 m
= gfc_match_symbol (&sym
, 0);
6411 else if (m
== MATCH_ERROR
)
6414 /* Add current_attr to the symbol attributes. */
6415 if (!gfc_copy_attr (&sym
->attr
, ¤t_attr
, NULL
))
6418 if (sym
->attr
.is_bind_c
)
6420 /* Check for C1218. */
6421 if (!proc_if
|| !proc_if
->attr
.is_bind_c
)
6423 gfc_error ("BIND(C) attribute at %C requires "
6424 "an interface with BIND(C)");
6427 /* Check for C1217. */
6428 if (has_name_equals
&& sym
->attr
.pointer
)
6430 gfc_error ("BIND(C) procedure with NAME may not have "
6431 "POINTER attribute at %C");
6434 if (has_name_equals
&& sym
->attr
.dummy
)
6436 gfc_error ("Dummy procedure at %C may not have "
6437 "BIND(C) attribute with NAME");
6440 /* Set binding label for BIND(C). */
6441 if (!set_binding_label (&sym
->binding_label
, sym
->name
, num
))
6445 if (!gfc_add_external (&sym
->attr
, NULL
))
6448 if (add_hidden_procptr_result (sym
))
6451 if (!gfc_add_proc (&sym
->attr
, sym
->name
, NULL
))
6454 /* Set interface. */
6455 if (proc_if
!= NULL
)
6457 if (sym
->ts
.type
!= BT_UNKNOWN
)
6459 gfc_error ("Procedure %qs at %L already has basic type of %s",
6460 sym
->name
, &gfc_current_locus
,
6461 gfc_basic_typename (sym
->ts
.type
));
6464 sym
->ts
.interface
= proc_if
;
6465 sym
->attr
.untyped
= 1;
6466 sym
->attr
.if_source
= IFSRC_IFBODY
;
6468 else if (current_ts
.type
!= BT_UNKNOWN
)
6470 if (!gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
6472 sym
->ts
.interface
= gfc_new_symbol ("", gfc_current_ns
);
6473 sym
->ts
.interface
->ts
= current_ts
;
6474 sym
->ts
.interface
->attr
.flavor
= FL_PROCEDURE
;
6475 sym
->ts
.interface
->attr
.function
= 1;
6476 sym
->attr
.function
= 1;
6477 sym
->attr
.if_source
= IFSRC_UNKNOWN
;
6480 if (gfc_match (" =>") == MATCH_YES
)
6482 if (!current_attr
.pointer
)
6484 gfc_error ("Initialization at %C isn't for a pointer variable");
6489 m
= match_pointer_init (&initializer
, 1);
6493 if (!add_init_expr_to_sym (sym
->name
, &initializer
, &gfc_current_locus
))
6498 if (gfc_match_eos () == MATCH_YES
)
6500 if (gfc_match_char (',') != MATCH_YES
)
6505 gfc_error ("Syntax error in PROCEDURE statement at %C");
6509 /* Free stuff up and return. */
6510 gfc_free_expr (initializer
);
6516 match_binding_attributes (gfc_typebound_proc
* ba
, bool generic
, bool ppc
);
6519 /* Match a procedure pointer component declaration (R445). */
6522 match_ppc_decl (void)
6525 gfc_symbol
*proc_if
= NULL
;
6529 gfc_expr
*initializer
= NULL
;
6530 gfc_typebound_proc
* tb
;
6531 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6533 /* Parse interface (with brackets). */
6534 m
= match_procedure_interface (&proc_if
);
6538 /* Parse attributes. */
6539 tb
= XCNEW (gfc_typebound_proc
);
6540 tb
->where
= gfc_current_locus
;
6541 m
= match_binding_attributes (tb
, false, true);
6542 if (m
== MATCH_ERROR
)
6545 gfc_clear_attr (¤t_attr
);
6546 current_attr
.procedure
= 1;
6547 current_attr
.proc_pointer
= 1;
6548 current_attr
.access
= tb
->access
;
6549 current_attr
.flavor
= FL_PROCEDURE
;
6551 /* Match the colons (required). */
6552 if (gfc_match (" ::") != MATCH_YES
)
6554 gfc_error ("Expected %<::%> after binding-attributes at %C");
6558 /* Check for C450. */
6559 if (!tb
->nopass
&& proc_if
== NULL
)
6561 gfc_error("NOPASS or explicit interface required at %C");
6565 if (!gfc_notify_std (GFC_STD_F2003
, "Procedure pointer component at %C"))
6568 /* Match PPC names. */
6572 m
= gfc_match_name (name
);
6575 else if (m
== MATCH_ERROR
)
6578 if (!gfc_add_component (gfc_current_block(), name
, &c
))
6581 /* Add current_attr to the symbol attributes. */
6582 if (!gfc_copy_attr (&c
->attr
, ¤t_attr
, NULL
))
6585 if (!gfc_add_external (&c
->attr
, NULL
))
6588 if (!gfc_add_proc (&c
->attr
, name
, NULL
))
6595 c
->tb
= XCNEW (gfc_typebound_proc
);
6596 c
->tb
->where
= gfc_current_locus
;
6600 /* Set interface. */
6601 if (proc_if
!= NULL
)
6603 c
->ts
.interface
= proc_if
;
6604 c
->attr
.untyped
= 1;
6605 c
->attr
.if_source
= IFSRC_IFBODY
;
6607 else if (ts
.type
!= BT_UNKNOWN
)
6610 c
->ts
.interface
= gfc_new_symbol ("", gfc_current_ns
);
6611 c
->ts
.interface
->result
= c
->ts
.interface
;
6612 c
->ts
.interface
->ts
= ts
;
6613 c
->ts
.interface
->attr
.flavor
= FL_PROCEDURE
;
6614 c
->ts
.interface
->attr
.function
= 1;
6615 c
->attr
.function
= 1;
6616 c
->attr
.if_source
= IFSRC_UNKNOWN
;
6619 if (gfc_match (" =>") == MATCH_YES
)
6621 m
= match_pointer_init (&initializer
, 1);
6624 gfc_free_expr (initializer
);
6627 c
->initializer
= initializer
;
6630 if (gfc_match_eos () == MATCH_YES
)
6632 if (gfc_match_char (',') != MATCH_YES
)
6637 gfc_error ("Syntax error in procedure pointer component at %C");
6642 /* Match a PROCEDURE declaration inside an interface (R1206). */
6645 match_procedure_in_interface (void)
6649 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6652 if (current_interface
.type
== INTERFACE_NAMELESS
6653 || current_interface
.type
== INTERFACE_ABSTRACT
)
6655 gfc_error ("PROCEDURE at %C must be in a generic interface");
6659 /* Check if the F2008 optional double colon appears. */
6660 gfc_gobble_whitespace ();
6661 old_locus
= gfc_current_locus
;
6662 if (gfc_match ("::") == MATCH_YES
)
6664 if (!gfc_notify_std (GFC_STD_F2008
, "double colon in "
6665 "MODULE PROCEDURE statement at %L", &old_locus
))
6669 gfc_current_locus
= old_locus
;
6673 m
= gfc_match_name (name
);
6676 else if (m
== MATCH_ERROR
)
6678 if (gfc_get_symbol (name
, gfc_current_ns
->parent
, &sym
))
6681 if (!gfc_add_interface (sym
))
6684 if (gfc_match_eos () == MATCH_YES
)
6686 if (gfc_match_char (',') != MATCH_YES
)
6693 gfc_error ("Syntax error in PROCEDURE statement at %C");
6698 /* General matcher for PROCEDURE declarations. */
6700 static match
match_procedure_in_type (void);
6703 gfc_match_procedure (void)
6707 switch (gfc_current_state ())
6712 case COMP_SUBMODULE
:
6713 case COMP_SUBROUTINE
:
6716 m
= match_procedure_decl ();
6718 case COMP_INTERFACE
:
6719 m
= match_procedure_in_interface ();
6722 m
= match_ppc_decl ();
6724 case COMP_DERIVED_CONTAINS
:
6725 m
= match_procedure_in_type ();
6734 if (!gfc_notify_std (GFC_STD_F2003
, "PROCEDURE statement at %C"))
6741 /* Warn if a matched procedure has the same name as an intrinsic; this is
6742 simply a wrapper around gfc_warn_intrinsic_shadow that interprets the current
6743 parser-state-stack to find out whether we're in a module. */
6746 do_warn_intrinsic_shadow (const gfc_symbol
* sym
, bool func
)
6750 in_module
= (gfc_state_stack
->previous
6751 && (gfc_state_stack
->previous
->state
== COMP_MODULE
6752 || gfc_state_stack
->previous
->state
== COMP_SUBMODULE
));
6754 gfc_warn_intrinsic_shadow (sym
, in_module
, func
);
6758 /* Match a function declaration. */
6761 gfc_match_function_decl (void)
6763 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6764 gfc_symbol
*sym
, *result
;
6768 match found_match
; /* Status returned by match func. */
6770 if (gfc_current_state () != COMP_NONE
6771 && gfc_current_state () != COMP_INTERFACE
6772 && gfc_current_state () != COMP_CONTAINS
)
6775 gfc_clear_ts (¤t_ts
);
6777 old_loc
= gfc_current_locus
;
6779 m
= gfc_match_prefix (¤t_ts
);
6782 gfc_current_locus
= old_loc
;
6786 if (gfc_match ("function% %n", name
) != MATCH_YES
)
6788 gfc_current_locus
= old_loc
;
6792 if (get_proc_name (name
, &sym
, false))
6795 if (add_hidden_procptr_result (sym
))
6798 if (current_attr
.module_procedure
)
6799 sym
->attr
.module_procedure
= 1;
6801 gfc_new_block
= sym
;
6803 m
= gfc_match_formal_arglist (sym
, 0, 0);
6806 gfc_error ("Expected formal argument list in function "
6807 "definition at %C");
6811 else if (m
== MATCH_ERROR
)
6816 /* According to the draft, the bind(c) and result clause can
6817 come in either order after the formal_arg_list (i.e., either
6818 can be first, both can exist together or by themselves or neither
6819 one). Therefore, the match_result can't match the end of the
6820 string, and check for the bind(c) or result clause in either order. */
6821 found_match
= gfc_match_eos ();
6823 /* Make sure that it isn't already declared as BIND(C). If it is, it
6824 must have been marked BIND(C) with a BIND(C) attribute and that is
6825 not allowed for procedures. */
6826 if (sym
->attr
.is_bind_c
== 1)
6828 sym
->attr
.is_bind_c
= 0;
6829 if (sym
->old_symbol
!= NULL
)
6830 gfc_error_now ("BIND(C) attribute at %L can only be used for "
6831 "variables or common blocks",
6832 &(sym
->old_symbol
->declared_at
));
6834 gfc_error_now ("BIND(C) attribute at %L can only be used for "
6835 "variables or common blocks", &gfc_current_locus
);
6838 if (found_match
!= MATCH_YES
)
6840 /* If we haven't found the end-of-statement, look for a suffix. */
6841 suffix_match
= gfc_match_suffix (sym
, &result
);
6842 if (suffix_match
== MATCH_YES
)
6843 /* Need to get the eos now. */
6844 found_match
= gfc_match_eos ();
6846 found_match
= suffix_match
;
6849 if(found_match
!= MATCH_YES
)
6853 /* Make changes to the symbol. */
6856 if (!gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
6859 if (!gfc_missing_attr (&sym
->attr
, NULL
))
6862 if (!copy_prefix (&sym
->attr
, &sym
->declared_at
))
6864 if(!sym
->attr
.module_procedure
)
6870 /* Delay matching the function characteristics until after the
6871 specification block by signalling kind=-1. */
6872 sym
->declared_at
= old_loc
;
6873 if (current_ts
.type
!= BT_UNKNOWN
)
6874 current_ts
.kind
= -1;
6876 current_ts
.kind
= 0;
6880 if (current_ts
.type
!= BT_UNKNOWN
6881 && !gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
6887 if (current_ts
.type
!= BT_UNKNOWN
6888 && !gfc_add_type (result
, ¤t_ts
, &gfc_current_locus
))
6890 sym
->result
= result
;
6893 /* Warn if this procedure has the same name as an intrinsic. */
6894 do_warn_intrinsic_shadow (sym
, true);
6900 gfc_current_locus
= old_loc
;
6905 /* This is mostly a copy of parse.c(add_global_procedure) but modified to
6906 pass the name of the entry, rather than the gfc_current_block name, and
6907 to return false upon finding an existing global entry. */
6910 add_global_entry (const char *name
, const char *binding_label
, bool sub
,
6914 enum gfc_symbol_type type
;
6916 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
6918 /* Only in Fortran 2003: For procedures with a binding label also the Fortran
6919 name is a global identifier. */
6920 if (!binding_label
|| gfc_notification_std (GFC_STD_F2008
))
6922 s
= gfc_get_gsymbol (name
);
6924 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= type
))
6926 gfc_global_used (s
, where
);
6935 s
->ns
= gfc_current_ns
;
6939 /* Don't add the symbol multiple times. */
6941 && (!gfc_notification_std (GFC_STD_F2008
)
6942 || strcmp (name
, binding_label
) != 0))
6944 s
= gfc_get_gsymbol (binding_label
);
6946 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= type
))
6948 gfc_global_used (s
, where
);
6955 s
->binding_label
= binding_label
;
6958 s
->ns
= gfc_current_ns
;
6966 /* Match an ENTRY statement. */
6969 gfc_match_entry (void)
6974 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6975 gfc_compile_state state
;
6979 bool module_procedure
;
6983 m
= gfc_match_name (name
);
6987 if (!gfc_notify_std (GFC_STD_F2008_OBS
, "ENTRY statement at %C"))
6990 state
= gfc_current_state ();
6991 if (state
!= COMP_SUBROUTINE
&& state
!= COMP_FUNCTION
)
6996 gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
6999 gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
7001 case COMP_SUBMODULE
:
7002 gfc_error ("ENTRY statement at %C cannot appear within a SUBMODULE");
7004 case COMP_BLOCK_DATA
:
7005 gfc_error ("ENTRY statement at %C cannot appear within "
7008 case COMP_INTERFACE
:
7009 gfc_error ("ENTRY statement at %C cannot appear within "
7012 case COMP_STRUCTURE
:
7013 gfc_error ("ENTRY statement at %C cannot appear within "
7014 "a STRUCTURE block");
7017 gfc_error ("ENTRY statement at %C cannot appear within "
7018 "a DERIVED TYPE block");
7021 gfc_error ("ENTRY statement at %C cannot appear within "
7022 "an IF-THEN block");
7025 case COMP_DO_CONCURRENT
:
7026 gfc_error ("ENTRY statement at %C cannot appear within "
7030 gfc_error ("ENTRY statement at %C cannot appear within "
7034 gfc_error ("ENTRY statement at %C cannot appear within "
7038 gfc_error ("ENTRY statement at %C cannot appear within "
7042 gfc_error ("ENTRY statement at %C cannot appear within "
7043 "a contained subprogram");
7046 gfc_error ("Unexpected ENTRY statement at %C");
7051 if ((state
== COMP_SUBROUTINE
|| state
== COMP_FUNCTION
)
7052 && gfc_state_stack
->previous
->state
== COMP_INTERFACE
)
7054 gfc_error ("ENTRY statement at %C cannot appear within an INTERFACE");
7058 module_procedure
= gfc_current_ns
->parent
!= NULL
7059 && gfc_current_ns
->parent
->proc_name
7060 && gfc_current_ns
->parent
->proc_name
->attr
.flavor
7063 if (gfc_current_ns
->parent
!= NULL
7064 && gfc_current_ns
->parent
->proc_name
7065 && !module_procedure
)
7067 gfc_error("ENTRY statement at %C cannot appear in a "
7068 "contained procedure");
7072 /* Module function entries need special care in get_proc_name
7073 because previous references within the function will have
7074 created symbols attached to the current namespace. */
7075 if (get_proc_name (name
, &entry
,
7076 gfc_current_ns
->parent
!= NULL
7077 && module_procedure
))
7080 proc
= gfc_current_block ();
7082 /* Make sure that it isn't already declared as BIND(C). If it is, it
7083 must have been marked BIND(C) with a BIND(C) attribute and that is
7084 not allowed for procedures. */
7085 if (entry
->attr
.is_bind_c
== 1)
7087 entry
->attr
.is_bind_c
= 0;
7088 if (entry
->old_symbol
!= NULL
)
7089 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7090 "variables or common blocks",
7091 &(entry
->old_symbol
->declared_at
));
7093 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7094 "variables or common blocks", &gfc_current_locus
);
7097 /* Check what next non-whitespace character is so we can tell if there
7098 is the required parens if we have a BIND(C). */
7099 old_loc
= gfc_current_locus
;
7100 gfc_gobble_whitespace ();
7101 peek_char
= gfc_peek_ascii_char ();
7103 if (state
== COMP_SUBROUTINE
)
7105 m
= gfc_match_formal_arglist (entry
, 0, 1);
7109 /* Call gfc_match_bind_c with allow_binding_name = true as ENTRY can
7110 never be an internal procedure. */
7111 is_bind_c
= gfc_match_bind_c (entry
, true);
7112 if (is_bind_c
== MATCH_ERROR
)
7114 if (is_bind_c
== MATCH_YES
)
7116 if (peek_char
!= '(')
7118 gfc_error ("Missing required parentheses before BIND(C) at %C");
7121 if (!gfc_add_is_bind_c (&(entry
->attr
), entry
->name
,
7122 &(entry
->declared_at
), 1))
7126 if (!gfc_current_ns
->parent
7127 && !add_global_entry (name
, entry
->binding_label
, true,
7131 /* An entry in a subroutine. */
7132 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
7133 || !gfc_add_subroutine (&entry
->attr
, entry
->name
, NULL
))
7138 /* An entry in a function.
7139 We need to take special care because writing
7144 ENTRY f() RESULT (r)
7146 ENTRY f RESULT (r). */
7147 if (gfc_match_eos () == MATCH_YES
)
7149 gfc_current_locus
= old_loc
;
7150 /* Match the empty argument list, and add the interface to
7152 m
= gfc_match_formal_arglist (entry
, 0, 1);
7155 m
= gfc_match_formal_arglist (entry
, 0, 0);
7162 if (gfc_match_eos () == MATCH_YES
)
7164 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
7165 || !gfc_add_function (&entry
->attr
, entry
->name
, NULL
))
7168 entry
->result
= entry
;
7172 m
= gfc_match_suffix (entry
, &result
);
7174 gfc_syntax_error (ST_ENTRY
);
7180 if (!gfc_add_result (&result
->attr
, result
->name
, NULL
)
7181 || !gfc_add_entry (&entry
->attr
, result
->name
, NULL
)
7182 || !gfc_add_function (&entry
->attr
, result
->name
, NULL
))
7184 entry
->result
= result
;
7188 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
7189 || !gfc_add_function (&entry
->attr
, entry
->name
, NULL
))
7191 entry
->result
= entry
;
7195 if (!gfc_current_ns
->parent
7196 && !add_global_entry (name
, entry
->binding_label
, false,
7201 if (gfc_match_eos () != MATCH_YES
)
7203 gfc_syntax_error (ST_ENTRY
);
7207 entry
->attr
.recursive
= proc
->attr
.recursive
;
7208 entry
->attr
.elemental
= proc
->attr
.elemental
;
7209 entry
->attr
.pure
= proc
->attr
.pure
;
7211 el
= gfc_get_entry_list ();
7213 el
->next
= gfc_current_ns
->entries
;
7214 gfc_current_ns
->entries
= el
;
7216 el
->id
= el
->next
->id
+ 1;
7220 new_st
.op
= EXEC_ENTRY
;
7221 new_st
.ext
.entry
= el
;
7227 /* Match a subroutine statement, including optional prefixes. */
7230 gfc_match_subroutine (void)
7232 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7237 bool allow_binding_name
;
7239 if (gfc_current_state () != COMP_NONE
7240 && gfc_current_state () != COMP_INTERFACE
7241 && gfc_current_state () != COMP_CONTAINS
)
7244 m
= gfc_match_prefix (NULL
);
7248 m
= gfc_match ("subroutine% %n", name
);
7252 if (get_proc_name (name
, &sym
, false))
7255 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
7256 the symbol existed before. */
7257 sym
->declared_at
= gfc_current_locus
;
7259 if (current_attr
.module_procedure
)
7260 sym
->attr
.module_procedure
= 1;
7262 if (add_hidden_procptr_result (sym
))
7265 gfc_new_block
= sym
;
7267 /* Check what next non-whitespace character is so we can tell if there
7268 is the required parens if we have a BIND(C). */
7269 gfc_gobble_whitespace ();
7270 peek_char
= gfc_peek_ascii_char ();
7272 if (!gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
))
7275 if (gfc_match_formal_arglist (sym
, 0, 1) != MATCH_YES
)
7278 /* Make sure that it isn't already declared as BIND(C). If it is, it
7279 must have been marked BIND(C) with a BIND(C) attribute and that is
7280 not allowed for procedures. */
7281 if (sym
->attr
.is_bind_c
== 1)
7283 sym
->attr
.is_bind_c
= 0;
7284 if (sym
->old_symbol
!= NULL
)
7285 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7286 "variables or common blocks",
7287 &(sym
->old_symbol
->declared_at
));
7289 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7290 "variables or common blocks", &gfc_current_locus
);
7293 /* C binding names are not allowed for internal procedures. */
7294 if (gfc_current_state () == COMP_CONTAINS
7295 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
7296 allow_binding_name
= false;
7298 allow_binding_name
= true;
7300 /* Here, we are just checking if it has the bind(c) attribute, and if
7301 so, then we need to make sure it's all correct. If it doesn't,
7302 we still need to continue matching the rest of the subroutine line. */
7303 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
7304 if (is_bind_c
== MATCH_ERROR
)
7306 /* There was an attempt at the bind(c), but it was wrong. An
7307 error message should have been printed w/in the gfc_match_bind_c
7308 so here we'll just return the MATCH_ERROR. */
7312 if (is_bind_c
== MATCH_YES
)
7314 /* The following is allowed in the Fortran 2008 draft. */
7315 if (gfc_current_state () == COMP_CONTAINS
7316 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
7317 && !gfc_notify_std (GFC_STD_F2008
, "BIND(C) attribute "
7318 "at %L may not be specified for an internal "
7319 "procedure", &gfc_current_locus
))
7322 if (peek_char
!= '(')
7324 gfc_error ("Missing required parentheses before BIND(C) at %C");
7327 if (!gfc_add_is_bind_c (&(sym
->attr
), sym
->name
,
7328 &(sym
->declared_at
), 1))
7332 if (gfc_match_eos () != MATCH_YES
)
7334 gfc_syntax_error (ST_SUBROUTINE
);
7338 if (!copy_prefix (&sym
->attr
, &sym
->declared_at
))
7340 if(!sym
->attr
.module_procedure
)
7346 /* Warn if it has the same name as an intrinsic. */
7347 do_warn_intrinsic_shadow (sym
, false);
7353 /* Check that the NAME identifier in a BIND attribute or statement
7354 is conform to C identifier rules. */
7357 check_bind_name_identifier (char **name
)
7359 char *n
= *name
, *p
;
7361 /* Remove leading spaces. */
7365 /* On an empty string, free memory and set name to NULL. */
7373 /* Remove trailing spaces. */
7374 p
= n
+ strlen(n
) - 1;
7378 /* Insert the identifier into the symbol table. */
7383 /* Now check that identifier is valid under C rules. */
7386 gfc_error ("Invalid C identifier in NAME= specifier at %C");
7391 if (!(ISALNUM (*p
) || *p
== '_' || *p
== '$'))
7393 gfc_error ("Invalid C identifier in NAME= specifier at %C");
7401 /* Match a BIND(C) specifier, with the optional 'name=' specifier if
7402 given, and set the binding label in either the given symbol (if not
7403 NULL), or in the current_ts. The symbol may be NULL because we may
7404 encounter the BIND(C) before the declaration itself. Return
7405 MATCH_NO if what we're looking at isn't a BIND(C) specifier,
7406 MATCH_ERROR if it is a BIND(C) clause but an error was encountered,
7407 or MATCH_YES if the specifier was correct and the binding label and
7408 bind(c) fields were set correctly for the given symbol or the
7409 current_ts. If allow_binding_name is false, no binding name may be
7413 gfc_match_bind_c (gfc_symbol
*sym
, bool allow_binding_name
)
7415 char *binding_label
= NULL
;
7418 /* Initialize the flag that specifies whether we encountered a NAME=
7419 specifier or not. */
7420 has_name_equals
= 0;
7422 /* This much we have to be able to match, in this order, if
7423 there is a bind(c) label. */
7424 if (gfc_match (" bind ( c ") != MATCH_YES
)
7427 /* Now see if there is a binding label, or if we've reached the
7428 end of the bind(c) attribute without one. */
7429 if (gfc_match_char (',') == MATCH_YES
)
7431 if (gfc_match (" name = ") != MATCH_YES
)
7433 gfc_error ("Syntax error in NAME= specifier for binding label "
7435 /* should give an error message here */
7439 has_name_equals
= 1;
7441 if (gfc_match_init_expr (&e
) != MATCH_YES
)
7447 if (!gfc_simplify_expr(e
, 0))
7449 gfc_error ("NAME= specifier at %C should be a constant expression");
7454 if (e
->expr_type
!= EXPR_CONSTANT
|| e
->ts
.type
!= BT_CHARACTER
7455 || e
->ts
.kind
!= gfc_default_character_kind
|| e
->rank
!= 0)
7457 gfc_error ("NAME= specifier at %C should be a scalar of "
7458 "default character kind");
7463 // Get a C string from the Fortran string constant
7464 binding_label
= gfc_widechar_to_char (e
->value
.character
.string
,
7465 e
->value
.character
.length
);
7468 // Check that it is valid (old gfc_match_name_C)
7469 if (check_bind_name_identifier (&binding_label
) != MATCH_YES
)
7473 /* Get the required right paren. */
7474 if (gfc_match_char (')') != MATCH_YES
)
7476 gfc_error ("Missing closing paren for binding label at %C");
7480 if (has_name_equals
&& !allow_binding_name
)
7482 gfc_error ("No binding name is allowed in BIND(C) at %C");
7486 if (has_name_equals
&& sym
!= NULL
&& sym
->attr
.dummy
)
7488 gfc_error ("For dummy procedure %s, no binding name is "
7489 "allowed in BIND(C) at %C", sym
->name
);
7494 /* Save the binding label to the symbol. If sym is null, we're
7495 probably matching the typespec attributes of a declaration and
7496 haven't gotten the name yet, and therefore, no symbol yet. */
7500 sym
->binding_label
= binding_label
;
7502 curr_binding_label
= binding_label
;
7504 else if (allow_binding_name
)
7506 /* No binding label, but if symbol isn't null, we
7507 can set the label for it here.
7508 If name="" or allow_binding_name is false, no C binding name is
7510 if (sym
!= NULL
&& sym
->name
!= NULL
&& has_name_equals
== 0)
7511 sym
->binding_label
= IDENTIFIER_POINTER (get_identifier (sym
->name
));
7514 if (has_name_equals
&& gfc_current_state () == COMP_INTERFACE
7515 && current_interface
.type
== INTERFACE_ABSTRACT
)
7517 gfc_error ("NAME not allowed on BIND(C) for ABSTRACT INTERFACE at %C");
7525 /* Return nonzero if we're currently compiling a contained procedure. */
7528 contained_procedure (void)
7530 gfc_state_data
*s
= gfc_state_stack
;
7532 if ((s
->state
== COMP_SUBROUTINE
|| s
->state
== COMP_FUNCTION
)
7533 && s
->previous
!= NULL
&& s
->previous
->state
== COMP_CONTAINS
)
7539 /* Set the kind of each enumerator. The kind is selected such that it is
7540 interoperable with the corresponding C enumeration type, making
7541 sure that -fshort-enums is honored. */
7546 enumerator_history
*current_history
= NULL
;
7550 if (max_enum
== NULL
|| enum_history
== NULL
)
7553 if (!flag_short_enums
)
7559 kind
= gfc_integer_kinds
[i
++].kind
;
7561 while (kind
< gfc_c_int_kind
7562 && gfc_check_integer_range (max_enum
->initializer
->value
.integer
,
7565 current_history
= enum_history
;
7566 while (current_history
!= NULL
)
7568 current_history
->sym
->ts
.kind
= kind
;
7569 current_history
= current_history
->next
;
7574 /* Match any of the various end-block statements. Returns the type of
7575 END to the caller. The END INTERFACE, END IF, END DO, END SELECT
7576 and END BLOCK statements cannot be replaced by a single END statement. */
7579 gfc_match_end (gfc_statement
*st
)
7581 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7582 gfc_compile_state state
;
7584 const char *block_name
;
7588 gfc_namespace
*parent_ns
, *ns
, *prev_ns
;
7589 gfc_namespace
**nsp
;
7590 bool abreviated_modproc_decl
= false;
7591 bool got_matching_end
= false;
7593 old_loc
= gfc_current_locus
;
7594 if (gfc_match ("end") != MATCH_YES
)
7597 state
= gfc_current_state ();
7598 block_name
= gfc_current_block () == NULL
7599 ? NULL
: gfc_current_block ()->name
;
7603 case COMP_ASSOCIATE
:
7605 if (!strncmp (block_name
, "block@", strlen("block@")))
7610 case COMP_DERIVED_CONTAINS
:
7611 state
= gfc_state_stack
->previous
->state
;
7612 block_name
= gfc_state_stack
->previous
->sym
== NULL
7613 ? NULL
: gfc_state_stack
->previous
->sym
->name
;
7614 abreviated_modproc_decl
= gfc_state_stack
->previous
->sym
7615 && gfc_state_stack
->previous
->sym
->abr_modproc_decl
;
7622 if (!abreviated_modproc_decl
)
7623 abreviated_modproc_decl
= gfc_current_block ()
7624 && gfc_current_block ()->abr_modproc_decl
;
7630 *st
= ST_END_PROGRAM
;
7631 target
= " program";
7635 case COMP_SUBROUTINE
:
7636 *st
= ST_END_SUBROUTINE
;
7637 if (!abreviated_modproc_decl
)
7638 target
= " subroutine";
7640 target
= " procedure";
7641 eos_ok
= !contained_procedure ();
7645 *st
= ST_END_FUNCTION
;
7646 if (!abreviated_modproc_decl
)
7647 target
= " function";
7649 target
= " procedure";
7650 eos_ok
= !contained_procedure ();
7653 case COMP_BLOCK_DATA
:
7654 *st
= ST_END_BLOCK_DATA
;
7655 target
= " block data";
7660 *st
= ST_END_MODULE
;
7665 case COMP_SUBMODULE
:
7666 *st
= ST_END_SUBMODULE
;
7667 target
= " submodule";
7671 case COMP_INTERFACE
:
7672 *st
= ST_END_INTERFACE
;
7673 target
= " interface";
7689 case COMP_STRUCTURE
:
7690 *st
= ST_END_STRUCTURE
;
7691 target
= " structure";
7696 case COMP_DERIVED_CONTAINS
:
7702 case COMP_ASSOCIATE
:
7703 *st
= ST_END_ASSOCIATE
;
7704 target
= " associate";
7721 case COMP_DO_CONCURRENT
:
7728 *st
= ST_END_CRITICAL
;
7729 target
= " critical";
7734 case COMP_SELECT_TYPE
:
7735 *st
= ST_END_SELECT
;
7741 *st
= ST_END_FORALL
;
7756 last_initializer
= NULL
;
7758 gfc_free_enum_history ();
7762 gfc_error ("Unexpected END statement at %C");
7766 old_loc
= gfc_current_locus
;
7767 if (gfc_match_eos () == MATCH_YES
)
7769 if (!eos_ok
&& (*st
== ST_END_SUBROUTINE
|| *st
== ST_END_FUNCTION
))
7771 if (!gfc_notify_std (GFC_STD_F2008
, "END statement "
7772 "instead of %s statement at %L",
7773 abreviated_modproc_decl
? "END PROCEDURE"
7774 : gfc_ascii_statement(*st
), &old_loc
))
7779 /* We would have required END [something]. */
7780 gfc_error ("%s statement expected at %L",
7781 gfc_ascii_statement (*st
), &old_loc
);
7788 /* Verify that we've got the sort of end-block that we're expecting. */
7789 if (gfc_match (target
) != MATCH_YES
)
7791 gfc_error ("Expecting %s statement at %L", abreviated_modproc_decl
7792 ? "END PROCEDURE" : gfc_ascii_statement(*st
), &old_loc
);
7796 got_matching_end
= true;
7798 old_loc
= gfc_current_locus
;
7799 /* If we're at the end, make sure a block name wasn't required. */
7800 if (gfc_match_eos () == MATCH_YES
)
7803 if (*st
!= ST_ENDDO
&& *st
!= ST_ENDIF
&& *st
!= ST_END_SELECT
7804 && *st
!= ST_END_FORALL
&& *st
!= ST_END_WHERE
&& *st
!= ST_END_BLOCK
7805 && *st
!= ST_END_ASSOCIATE
&& *st
!= ST_END_CRITICAL
)
7811 gfc_error ("Expected block name of %qs in %s statement at %L",
7812 block_name
, gfc_ascii_statement (*st
), &old_loc
);
7817 /* END INTERFACE has a special handler for its several possible endings. */
7818 if (*st
== ST_END_INTERFACE
)
7819 return gfc_match_end_interface ();
7821 /* We haven't hit the end of statement, so what is left must be an
7823 m
= gfc_match_space ();
7825 m
= gfc_match_name (name
);
7828 gfc_error ("Expected terminating name at %C");
7832 if (block_name
== NULL
)
7835 /* We have to pick out the declared submodule name from the composite
7836 required by F2008:11.2.3 para 2, which ends in the declared name. */
7837 if (state
== COMP_SUBMODULE
)
7838 block_name
= strchr (block_name
, '.') + 1;
7840 if (strcmp (name
, block_name
) != 0 && strcmp (block_name
, "ppr@") != 0)
7842 gfc_error ("Expected label %qs for %s statement at %C", block_name
,
7843 gfc_ascii_statement (*st
));
7846 /* Procedure pointer as function result. */
7847 else if (strcmp (block_name
, "ppr@") == 0
7848 && strcmp (name
, gfc_current_block ()->ns
->proc_name
->name
) != 0)
7850 gfc_error ("Expected label %qs for %s statement at %C",
7851 gfc_current_block ()->ns
->proc_name
->name
,
7852 gfc_ascii_statement (*st
));
7856 if (gfc_match_eos () == MATCH_YES
)
7860 gfc_syntax_error (*st
);
7863 gfc_current_locus
= old_loc
;
7865 /* If we are missing an END BLOCK, we created a half-ready namespace.
7866 Remove it from the parent namespace's sibling list. */
7868 while (state
== COMP_BLOCK
&& !got_matching_end
)
7870 parent_ns
= gfc_current_ns
->parent
;
7872 nsp
= &(gfc_state_stack
->previous
->tail
->ext
.block
.ns
);
7878 if (ns
== gfc_current_ns
)
7880 if (prev_ns
== NULL
)
7883 prev_ns
->sibling
= ns
->sibling
;
7889 gfc_free_namespace (gfc_current_ns
);
7890 gfc_current_ns
= parent_ns
;
7891 gfc_state_stack
= gfc_state_stack
->previous
;
7892 state
= gfc_current_state ();
7900 /***************** Attribute declaration statements ****************/
7902 /* Set the attribute of a single variable. */
7907 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7910 /* Workaround -Wmaybe-uninitialized false positive during
7911 profiledbootstrap by initializing them. */
7912 gfc_symbol
*sym
= NULL
;
7918 m
= gfc_match_name (name
);
7922 if (find_special (name
, &sym
, false))
7925 if (!check_function_name (name
))
7931 var_locus
= gfc_current_locus
;
7933 /* Deal with possible array specification for certain attributes. */
7934 if (current_attr
.dimension
7935 || current_attr
.codimension
7936 || current_attr
.allocatable
7937 || current_attr
.pointer
7938 || current_attr
.target
)
7940 m
= gfc_match_array_spec (&as
, !current_attr
.codimension
,
7941 !current_attr
.dimension
7942 && !current_attr
.pointer
7943 && !current_attr
.target
);
7944 if (m
== MATCH_ERROR
)
7947 if (current_attr
.dimension
&& m
== MATCH_NO
)
7949 gfc_error ("Missing array specification at %L in DIMENSION "
7950 "statement", &var_locus
);
7955 if (current_attr
.dimension
&& sym
->value
)
7957 gfc_error ("Dimensions specified for %s at %L after its "
7958 "initialization", sym
->name
, &var_locus
);
7963 if (current_attr
.codimension
&& m
== MATCH_NO
)
7965 gfc_error ("Missing array specification at %L in CODIMENSION "
7966 "statement", &var_locus
);
7971 if ((current_attr
.allocatable
|| current_attr
.pointer
)
7972 && (m
== MATCH_YES
) && (as
->type
!= AS_DEFERRED
))
7974 gfc_error ("Array specification must be deferred at %L", &var_locus
);
7980 /* Update symbol table. DIMENSION attribute is set in
7981 gfc_set_array_spec(). For CLASS variables, this must be applied
7982 to the first component, or '_data' field. */
7983 if (sym
->ts
.type
== BT_CLASS
&& sym
->ts
.u
.derived
->attr
.is_class
)
7985 if (!gfc_copy_attr (&CLASS_DATA(sym
)->attr
, ¤t_attr
, &var_locus
))
7993 if (current_attr
.dimension
== 0 && current_attr
.codimension
== 0
7994 && !gfc_copy_attr (&sym
->attr
, ¤t_attr
, &var_locus
))
8001 if (sym
->ts
.type
== BT_CLASS
8002 && !gfc_build_class_symbol (&sym
->ts
, &sym
->attr
, &sym
->as
))
8008 if (!gfc_set_array_spec (sym
, as
, &var_locus
))
8014 if (sym
->attr
.cray_pointee
&& sym
->as
!= NULL
)
8016 /* Fix the array spec. */
8017 m
= gfc_mod_pointee_as (sym
->as
);
8018 if (m
== MATCH_ERROR
)
8022 if (!gfc_add_attribute (&sym
->attr
, &var_locus
))
8028 if ((current_attr
.external
|| current_attr
.intrinsic
)
8029 && sym
->attr
.flavor
!= FL_PROCEDURE
8030 && !gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, NULL
))
8036 add_hidden_procptr_result (sym
);
8041 gfc_free_array_spec (as
);
8046 /* Generic attribute declaration subroutine. Used for attributes that
8047 just have a list of names. */
8054 /* Gobble the optional double colon, by simply ignoring the result
8064 if (gfc_match_eos () == MATCH_YES
)
8070 if (gfc_match_char (',') != MATCH_YES
)
8072 gfc_error ("Unexpected character in variable list at %C");
8082 /* This routine matches Cray Pointer declarations of the form:
8083 pointer ( <pointer>, <pointee> )
8085 pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...
8086 The pointer, if already declared, should be an integer. Otherwise, we
8087 set it as BT_INTEGER with kind gfc_index_integer_kind. The pointee may
8088 be either a scalar, or an array declaration. No space is allocated for
8089 the pointee. For the statement
8090 pointer (ipt, ar(10))
8091 any subsequent uses of ar will be translated (in C-notation) as
8092 ar(i) => ((<type> *) ipt)(i)
8093 After gimplification, pointee variable will disappear in the code. */
8096 cray_pointer_decl (void)
8099 gfc_array_spec
*as
= NULL
;
8100 gfc_symbol
*cptr
; /* Pointer symbol. */
8101 gfc_symbol
*cpte
; /* Pointee symbol. */
8107 if (gfc_match_char ('(') != MATCH_YES
)
8109 gfc_error ("Expected %<(%> at %C");
8113 /* Match pointer. */
8114 var_locus
= gfc_current_locus
;
8115 gfc_clear_attr (¤t_attr
);
8116 gfc_add_cray_pointer (¤t_attr
, &var_locus
);
8117 current_ts
.type
= BT_INTEGER
;
8118 current_ts
.kind
= gfc_index_integer_kind
;
8120 m
= gfc_match_symbol (&cptr
, 0);
8123 gfc_error ("Expected variable name at %C");
8127 if (!gfc_add_cray_pointer (&cptr
->attr
, &var_locus
))
8130 gfc_set_sym_referenced (cptr
);
8132 if (cptr
->ts
.type
== BT_UNKNOWN
) /* Override the type, if necessary. */
8134 cptr
->ts
.type
= BT_INTEGER
;
8135 cptr
->ts
.kind
= gfc_index_integer_kind
;
8137 else if (cptr
->ts
.type
!= BT_INTEGER
)
8139 gfc_error ("Cray pointer at %C must be an integer");
8142 else if (cptr
->ts
.kind
< gfc_index_integer_kind
)
8143 gfc_warning (0, "Cray pointer at %C has %d bytes of precision;"
8144 " memory addresses require %d bytes",
8145 cptr
->ts
.kind
, gfc_index_integer_kind
);
8147 if (gfc_match_char (',') != MATCH_YES
)
8149 gfc_error ("Expected \",\" at %C");
8153 /* Match Pointee. */
8154 var_locus
= gfc_current_locus
;
8155 gfc_clear_attr (¤t_attr
);
8156 gfc_add_cray_pointee (¤t_attr
, &var_locus
);
8157 current_ts
.type
= BT_UNKNOWN
;
8158 current_ts
.kind
= 0;
8160 m
= gfc_match_symbol (&cpte
, 0);
8163 gfc_error ("Expected variable name at %C");
8167 /* Check for an optional array spec. */
8168 m
= gfc_match_array_spec (&as
, true, false);
8169 if (m
== MATCH_ERROR
)
8171 gfc_free_array_spec (as
);
8174 else if (m
== MATCH_NO
)
8176 gfc_free_array_spec (as
);
8180 if (!gfc_add_cray_pointee (&cpte
->attr
, &var_locus
))
8183 gfc_set_sym_referenced (cpte
);
8185 if (cpte
->as
== NULL
)
8187 if (!gfc_set_array_spec (cpte
, as
, &var_locus
))
8188 gfc_internal_error ("Couldn't set Cray pointee array spec.");
8190 else if (as
!= NULL
)
8192 gfc_error ("Duplicate array spec for Cray pointee at %C");
8193 gfc_free_array_spec (as
);
8199 if (cpte
->as
!= NULL
)
8201 /* Fix array spec. */
8202 m
= gfc_mod_pointee_as (cpte
->as
);
8203 if (m
== MATCH_ERROR
)
8207 /* Point the Pointee at the Pointer. */
8208 cpte
->cp_pointer
= cptr
;
8210 if (gfc_match_char (')') != MATCH_YES
)
8212 gfc_error ("Expected \")\" at %C");
8215 m
= gfc_match_char (',');
8217 done
= true; /* Stop searching for more declarations. */
8221 if (m
== MATCH_ERROR
/* Failed when trying to find ',' above. */
8222 || gfc_match_eos () != MATCH_YES
)
8224 gfc_error ("Expected %<,%> or end of statement at %C");
8232 gfc_match_external (void)
8235 gfc_clear_attr (¤t_attr
);
8236 current_attr
.external
= 1;
8238 return attr_decl ();
8243 gfc_match_intent (void)
8247 /* This is not allowed within a BLOCK construct! */
8248 if (gfc_current_state () == COMP_BLOCK
)
8250 gfc_error ("INTENT is not allowed inside of BLOCK at %C");
8254 intent
= match_intent_spec ();
8255 if (intent
== INTENT_UNKNOWN
)
8258 gfc_clear_attr (¤t_attr
);
8259 current_attr
.intent
= intent
;
8261 return attr_decl ();
8266 gfc_match_intrinsic (void)
8269 gfc_clear_attr (¤t_attr
);
8270 current_attr
.intrinsic
= 1;
8272 return attr_decl ();
8277 gfc_match_optional (void)
8279 /* This is not allowed within a BLOCK construct! */
8280 if (gfc_current_state () == COMP_BLOCK
)
8282 gfc_error ("OPTIONAL is not allowed inside of BLOCK at %C");
8286 gfc_clear_attr (¤t_attr
);
8287 current_attr
.optional
= 1;
8289 return attr_decl ();
8294 gfc_match_pointer (void)
8296 gfc_gobble_whitespace ();
8297 if (gfc_peek_ascii_char () == '(')
8299 if (!flag_cray_pointer
)
8301 gfc_error ("Cray pointer declaration at %C requires -fcray-pointer "
8305 return cray_pointer_decl ();
8309 gfc_clear_attr (¤t_attr
);
8310 current_attr
.pointer
= 1;
8312 return attr_decl ();
8318 gfc_match_allocatable (void)
8320 gfc_clear_attr (¤t_attr
);
8321 current_attr
.allocatable
= 1;
8323 return attr_decl ();
8328 gfc_match_codimension (void)
8330 gfc_clear_attr (¤t_attr
);
8331 current_attr
.codimension
= 1;
8333 return attr_decl ();
8338 gfc_match_contiguous (void)
8340 if (!gfc_notify_std (GFC_STD_F2008
, "CONTIGUOUS statement at %C"))
8343 gfc_clear_attr (¤t_attr
);
8344 current_attr
.contiguous
= 1;
8346 return attr_decl ();
8351 gfc_match_dimension (void)
8353 gfc_clear_attr (¤t_attr
);
8354 current_attr
.dimension
= 1;
8356 return attr_decl ();
8361 gfc_match_target (void)
8363 gfc_clear_attr (¤t_attr
);
8364 current_attr
.target
= 1;
8366 return attr_decl ();
8370 /* Match the list of entities being specified in a PUBLIC or PRIVATE
8374 access_attr_decl (gfc_statement st
)
8376 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8377 interface_type type
;
8379 gfc_symbol
*sym
, *dt_sym
;
8380 gfc_intrinsic_op op
;
8383 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
8388 m
= gfc_match_generic_spec (&type
, name
, &op
);
8391 if (m
== MATCH_ERROR
)
8396 case INTERFACE_NAMELESS
:
8397 case INTERFACE_ABSTRACT
:
8400 case INTERFACE_GENERIC
:
8401 case INTERFACE_DTIO
:
8403 if (gfc_get_symbol (name
, NULL
, &sym
))
8406 if (type
== INTERFACE_DTIO
8407 && gfc_current_ns
->proc_name
8408 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
8409 && sym
->attr
.flavor
== FL_UNKNOWN
)
8410 sym
->attr
.flavor
= FL_PROCEDURE
;
8412 if (!gfc_add_access (&sym
->attr
,
8414 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
,
8418 if (sym
->attr
.generic
&& (dt_sym
= gfc_find_dt_in_generic (sym
))
8419 && !gfc_add_access (&dt_sym
->attr
,
8421 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
,
8427 case INTERFACE_INTRINSIC_OP
:
8428 if (gfc_current_ns
->operator_access
[op
] == ACCESS_UNKNOWN
)
8430 gfc_intrinsic_op other_op
;
8432 gfc_current_ns
->operator_access
[op
] =
8433 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
8435 /* Handle the case if there is another op with the same
8436 function, for INTRINSIC_EQ vs. INTRINSIC_EQ_OS and so on. */
8437 other_op
= gfc_equivalent_op (op
);
8439 if (other_op
!= INTRINSIC_NONE
)
8440 gfc_current_ns
->operator_access
[other_op
] =
8441 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
8446 gfc_error ("Access specification of the %s operator at %C has "
8447 "already been specified", gfc_op2string (op
));
8453 case INTERFACE_USER_OP
:
8454 uop
= gfc_get_uop (name
);
8456 if (uop
->access
== ACCESS_UNKNOWN
)
8458 uop
->access
= (st
== ST_PUBLIC
)
8459 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
8463 gfc_error ("Access specification of the .%s. operator at %C "
8464 "has already been specified", sym
->name
);
8471 if (gfc_match_char (',') == MATCH_NO
)
8475 if (gfc_match_eos () != MATCH_YES
)
8480 gfc_syntax_error (st
);
8488 gfc_match_protected (void)
8493 if (!gfc_current_ns
->proc_name
8494 || gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
8496 gfc_error ("PROTECTED at %C only allowed in specification "
8497 "part of a module");
8502 if (!gfc_notify_std (GFC_STD_F2003
, "PROTECTED statement at %C"))
8505 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
8510 if (gfc_match_eos () == MATCH_YES
)
8515 m
= gfc_match_symbol (&sym
, 0);
8519 if (!gfc_add_protected (&sym
->attr
, sym
->name
, &gfc_current_locus
))
8531 if (gfc_match_eos () == MATCH_YES
)
8533 if (gfc_match_char (',') != MATCH_YES
)
8540 gfc_error ("Syntax error in PROTECTED statement at %C");
8545 /* The PRIVATE statement is a bit weird in that it can be an attribute
8546 declaration, but also works as a standalone statement inside of a
8547 type declaration or a module. */
8550 gfc_match_private (gfc_statement
*st
)
8553 if (gfc_match ("private") != MATCH_YES
)
8556 if (gfc_current_state () != COMP_MODULE
8557 && !(gfc_current_state () == COMP_DERIVED
8558 && gfc_state_stack
->previous
8559 && gfc_state_stack
->previous
->state
== COMP_MODULE
)
8560 && !(gfc_current_state () == COMP_DERIVED_CONTAINS
8561 && gfc_state_stack
->previous
&& gfc_state_stack
->previous
->previous
8562 && gfc_state_stack
->previous
->previous
->state
== COMP_MODULE
))
8564 gfc_error ("PRIVATE statement at %C is only allowed in the "
8565 "specification part of a module");
8569 if (gfc_current_state () == COMP_DERIVED
)
8571 if (gfc_match_eos () == MATCH_YES
)
8577 gfc_syntax_error (ST_PRIVATE
);
8581 if (gfc_match_eos () == MATCH_YES
)
8588 return access_attr_decl (ST_PRIVATE
);
8593 gfc_match_public (gfc_statement
*st
)
8596 if (gfc_match ("public") != MATCH_YES
)
8599 if (gfc_current_state () != COMP_MODULE
)
8601 gfc_error ("PUBLIC statement at %C is only allowed in the "
8602 "specification part of a module");
8606 if (gfc_match_eos () == MATCH_YES
)
8613 return access_attr_decl (ST_PUBLIC
);
8617 /* Workhorse for gfc_match_parameter. */
8627 m
= gfc_match_symbol (&sym
, 0);
8629 gfc_error ("Expected variable name at %C in PARAMETER statement");
8634 if (gfc_match_char ('=') == MATCH_NO
)
8636 gfc_error ("Expected = sign in PARAMETER statement at %C");
8640 m
= gfc_match_init_expr (&init
);
8642 gfc_error ("Expected expression at %C in PARAMETER statement");
8646 if (sym
->ts
.type
== BT_UNKNOWN
8647 && !gfc_set_default_type (sym
, 1, NULL
))
8653 if (!gfc_check_assign_symbol (sym
, NULL
, init
)
8654 || !gfc_add_flavor (&sym
->attr
, FL_PARAMETER
, sym
->name
, NULL
))
8662 gfc_error ("Initializing already initialized variable at %C");
8667 t
= add_init_expr_to_sym (sym
->name
, &init
, &gfc_current_locus
);
8668 return (t
) ? MATCH_YES
: MATCH_ERROR
;
8671 gfc_free_expr (init
);
8676 /* Match a parameter statement, with the weird syntax that these have. */
8679 gfc_match_parameter (void)
8681 const char *term
= " )%t";
8684 if (gfc_match_char ('(') == MATCH_NO
)
8686 /* With legacy PARAMETER statements, don't expect a terminating ')'. */
8687 if (!gfc_notify_std (GFC_STD_LEGACY
, "PARAMETER without '()' at %C"))
8698 if (gfc_match (term
) == MATCH_YES
)
8701 if (gfc_match_char (',') != MATCH_YES
)
8703 gfc_error ("Unexpected characters in PARAMETER statement at %C");
8714 gfc_match_automatic (void)
8718 bool seen_symbol
= false;
8720 if (!flag_dec_static
)
8722 gfc_error ("%s at %C is a DEC extension, enable with "
8733 m
= gfc_match_symbol (&sym
, 0);
8743 if (!gfc_add_automatic (&sym
->attr
, sym
->name
, &gfc_current_locus
))
8749 if (gfc_match_eos () == MATCH_YES
)
8751 if (gfc_match_char (',') != MATCH_YES
)
8757 gfc_error ("Expected entity-list in AUTOMATIC statement at %C");
8764 gfc_error ("Syntax error in AUTOMATIC statement at %C");
8770 gfc_match_static (void)
8774 bool seen_symbol
= false;
8776 if (!flag_dec_static
)
8778 gfc_error ("%s at %C is a DEC extension, enable with "
8788 m
= gfc_match_symbol (&sym
, 0);
8798 if (!gfc_add_save (&sym
->attr
, SAVE_EXPLICIT
, sym
->name
,
8799 &gfc_current_locus
))
8805 if (gfc_match_eos () == MATCH_YES
)
8807 if (gfc_match_char (',') != MATCH_YES
)
8813 gfc_error ("Expected entity-list in STATIC statement at %C");
8820 gfc_error ("Syntax error in STATIC statement at %C");
8825 /* Save statements have a special syntax. */
8828 gfc_match_save (void)
8830 char n
[GFC_MAX_SYMBOL_LEN
+1];
8835 if (gfc_match_eos () == MATCH_YES
)
8837 if (gfc_current_ns
->seen_save
)
8839 if (!gfc_notify_std (GFC_STD_LEGACY
, "Blanket SAVE statement at %C "
8840 "follows previous SAVE statement"))
8844 gfc_current_ns
->save_all
= gfc_current_ns
->seen_save
= 1;
8848 if (gfc_current_ns
->save_all
)
8850 if (!gfc_notify_std (GFC_STD_LEGACY
, "SAVE statement at %C follows "
8851 "blanket SAVE statement"))
8859 m
= gfc_match_symbol (&sym
, 0);
8863 if (!gfc_add_save (&sym
->attr
, SAVE_EXPLICIT
, sym
->name
,
8864 &gfc_current_locus
))
8875 m
= gfc_match (" / %n /", &n
);
8876 if (m
== MATCH_ERROR
)
8881 c
= gfc_get_common (n
, 0);
8884 gfc_current_ns
->seen_save
= 1;
8887 if (gfc_match_eos () == MATCH_YES
)
8889 if (gfc_match_char (',') != MATCH_YES
)
8896 gfc_error ("Syntax error in SAVE statement at %C");
8902 gfc_match_value (void)
8907 /* This is not allowed within a BLOCK construct! */
8908 if (gfc_current_state () == COMP_BLOCK
)
8910 gfc_error ("VALUE is not allowed inside of BLOCK at %C");
8914 if (!gfc_notify_std (GFC_STD_F2003
, "VALUE statement at %C"))
8917 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
8922 if (gfc_match_eos () == MATCH_YES
)
8927 m
= gfc_match_symbol (&sym
, 0);
8931 if (!gfc_add_value (&sym
->attr
, sym
->name
, &gfc_current_locus
))
8943 if (gfc_match_eos () == MATCH_YES
)
8945 if (gfc_match_char (',') != MATCH_YES
)
8952 gfc_error ("Syntax error in VALUE statement at %C");
8958 gfc_match_volatile (void)
8963 if (!gfc_notify_std (GFC_STD_F2003
, "VOLATILE statement at %C"))
8966 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
8971 if (gfc_match_eos () == MATCH_YES
)
8976 /* VOLATILE is special because it can be added to host-associated
8977 symbols locally. Except for coarrays. */
8978 m
= gfc_match_symbol (&sym
, 1);
8982 /* F2008, C560+C561. VOLATILE for host-/use-associated variable or
8983 for variable in a BLOCK which is defined outside of the BLOCK. */
8984 if (sym
->ns
!= gfc_current_ns
&& sym
->attr
.codimension
)
8986 gfc_error ("Specifying VOLATILE for coarray variable %qs at "
8987 "%C, which is use-/host-associated", sym
->name
);
8990 if (!gfc_add_volatile (&sym
->attr
, sym
->name
, &gfc_current_locus
))
9002 if (gfc_match_eos () == MATCH_YES
)
9004 if (gfc_match_char (',') != MATCH_YES
)
9011 gfc_error ("Syntax error in VOLATILE statement at %C");
9017 gfc_match_asynchronous (void)
9022 if (!gfc_notify_std (GFC_STD_F2003
, "ASYNCHRONOUS statement at %C"))
9025 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
9030 if (gfc_match_eos () == MATCH_YES
)
9035 /* ASYNCHRONOUS is special because it can be added to host-associated
9037 m
= gfc_match_symbol (&sym
, 1);
9041 if (!gfc_add_asynchronous (&sym
->attr
, sym
->name
, &gfc_current_locus
))
9053 if (gfc_match_eos () == MATCH_YES
)
9055 if (gfc_match_char (',') != MATCH_YES
)
9062 gfc_error ("Syntax error in ASYNCHRONOUS statement at %C");
9067 /* Match a module procedure statement in a submodule. */
9070 gfc_match_submod_proc (void)
9072 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9073 gfc_symbol
*sym
, *fsym
;
9075 gfc_formal_arglist
*formal
, *head
, *tail
;
9077 if (gfc_current_state () != COMP_CONTAINS
9078 || !(gfc_state_stack
->previous
9079 && (gfc_state_stack
->previous
->state
== COMP_SUBMODULE
9080 || gfc_state_stack
->previous
->state
== COMP_MODULE
)))
9083 m
= gfc_match (" module% procedure% %n", name
);
9087 if (!gfc_notify_std (GFC_STD_F2008
, "MODULE PROCEDURE declaration "
9091 if (get_proc_name (name
, &sym
, false))
9094 /* Make sure that the result field is appropriately filled, even though
9095 the result symbol will be replaced later on. */
9096 if (sym
->tlink
&& sym
->tlink
->attr
.function
)
9098 if (sym
->tlink
->result
9099 && sym
->tlink
->result
!= sym
->tlink
)
9100 sym
->result
= sym
->tlink
->result
;
9105 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
9106 the symbol existed before. */
9107 sym
->declared_at
= gfc_current_locus
;
9109 if (!sym
->attr
.module_procedure
)
9112 /* Signal match_end to expect "end procedure". */
9113 sym
->abr_modproc_decl
= 1;
9115 /* Change from IFSRC_IFBODY coming from the interface declaration. */
9116 sym
->attr
.if_source
= IFSRC_DECL
;
9118 gfc_new_block
= sym
;
9120 /* Make a new formal arglist with the symbols in the procedure
9123 for (formal
= sym
->formal
; formal
&& formal
->sym
; formal
= formal
->next
)
9125 if (formal
== sym
->formal
)
9126 head
= tail
= gfc_get_formal_arglist ();
9129 tail
->next
= gfc_get_formal_arglist ();
9133 if (gfc_copy_dummy_sym (&fsym
, formal
->sym
, 0))
9137 gfc_set_sym_referenced (fsym
);
9140 /* The dummy symbols get cleaned up, when the formal_namespace of the
9141 interface declaration is cleared. This allows us to add the
9142 explicit interface as is done for other type of procedure. */
9143 if (!gfc_add_explicit_interface (sym
, IFSRC_DECL
, head
,
9144 &gfc_current_locus
))
9147 if (gfc_match_eos () != MATCH_YES
)
9149 gfc_syntax_error (ST_MODULE_PROC
);
9156 gfc_free_formal_arglist (head
);
9161 /* Match a module procedure statement. Note that we have to modify
9162 symbols in the parent's namespace because the current one was there
9163 to receive symbols that are in an interface's formal argument list. */
9166 gfc_match_modproc (void)
9168 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9172 gfc_namespace
*module_ns
;
9173 gfc_interface
*old_interface_head
, *interface
;
9175 if (gfc_state_stack
->state
!= COMP_INTERFACE
9176 || gfc_state_stack
->previous
== NULL
9177 || current_interface
.type
== INTERFACE_NAMELESS
9178 || current_interface
.type
== INTERFACE_ABSTRACT
)
9180 gfc_error ("MODULE PROCEDURE at %C must be in a generic module "
9185 module_ns
= gfc_current_ns
->parent
;
9186 for (; module_ns
; module_ns
= module_ns
->parent
)
9187 if (module_ns
->proc_name
->attr
.flavor
== FL_MODULE
9188 || module_ns
->proc_name
->attr
.flavor
== FL_PROGRAM
9189 || (module_ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
9190 && !module_ns
->proc_name
->attr
.contained
))
9193 if (module_ns
== NULL
)
9196 /* Store the current state of the interface. We will need it if we
9197 end up with a syntax error and need to recover. */
9198 old_interface_head
= gfc_current_interface_head ();
9200 /* Check if the F2008 optional double colon appears. */
9201 gfc_gobble_whitespace ();
9202 old_locus
= gfc_current_locus
;
9203 if (gfc_match ("::") == MATCH_YES
)
9205 if (!gfc_notify_std (GFC_STD_F2008
, "double colon in "
9206 "MODULE PROCEDURE statement at %L", &old_locus
))
9210 gfc_current_locus
= old_locus
;
9215 old_locus
= gfc_current_locus
;
9217 m
= gfc_match_name (name
);
9223 /* Check for syntax error before starting to add symbols to the
9224 current namespace. */
9225 if (gfc_match_eos () == MATCH_YES
)
9228 if (!last
&& gfc_match_char (',') != MATCH_YES
)
9231 /* Now we're sure the syntax is valid, we process this item
9233 if (gfc_get_symbol (name
, module_ns
, &sym
))
9236 if (sym
->attr
.intrinsic
)
9238 gfc_error ("Intrinsic procedure at %L cannot be a MODULE "
9239 "PROCEDURE", &old_locus
);
9243 if (sym
->attr
.proc
!= PROC_MODULE
9244 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
9247 if (!gfc_add_interface (sym
))
9250 sym
->attr
.mod_proc
= 1;
9251 sym
->declared_at
= old_locus
;
9260 /* Restore the previous state of the interface. */
9261 interface
= gfc_current_interface_head ();
9262 gfc_set_current_interface_head (old_interface_head
);
9264 /* Free the new interfaces. */
9265 while (interface
!= old_interface_head
)
9267 gfc_interface
*i
= interface
->next
;
9272 /* And issue a syntax error. */
9273 gfc_syntax_error (ST_MODULE_PROC
);
9278 /* Check a derived type that is being extended. */
9281 check_extended_derived_type (char *name
)
9283 gfc_symbol
*extended
;
9285 if (gfc_find_symbol (name
, gfc_current_ns
, 1, &extended
))
9287 gfc_error ("Ambiguous symbol in TYPE definition at %C");
9291 extended
= gfc_find_dt_in_generic (extended
);
9296 gfc_error ("Symbol %qs at %C has not been previously defined", name
);
9300 if (extended
->attr
.flavor
!= FL_DERIVED
)
9302 gfc_error ("%qs in EXTENDS expression at %C is not a "
9303 "derived type", name
);
9307 if (extended
->attr
.is_bind_c
)
9309 gfc_error ("%qs cannot be extended at %C because it "
9310 "is BIND(C)", extended
->name
);
9314 if (extended
->attr
.sequence
)
9316 gfc_error ("%qs cannot be extended at %C because it "
9317 "is a SEQUENCE type", extended
->name
);
9325 /* Match the optional attribute specifiers for a type declaration.
9326 Return MATCH_ERROR if an error is encountered in one of the handled
9327 attributes (public, private, bind(c)), MATCH_NO if what's found is
9328 not a handled attribute, and MATCH_YES otherwise. TODO: More error
9329 checking on attribute conflicts needs to be done. */
9332 gfc_get_type_attr_spec (symbol_attribute
*attr
, char *name
)
9334 /* See if the derived type is marked as private. */
9335 if (gfc_match (" , private") == MATCH_YES
)
9337 if (gfc_current_state () != COMP_MODULE
)
9339 gfc_error ("Derived type at %C can only be PRIVATE in the "
9340 "specification part of a module");
9344 if (!gfc_add_access (attr
, ACCESS_PRIVATE
, NULL
, NULL
))
9347 else if (gfc_match (" , public") == MATCH_YES
)
9349 if (gfc_current_state () != COMP_MODULE
)
9351 gfc_error ("Derived type at %C can only be PUBLIC in the "
9352 "specification part of a module");
9356 if (!gfc_add_access (attr
, ACCESS_PUBLIC
, NULL
, NULL
))
9359 else if (gfc_match (" , bind ( c )") == MATCH_YES
)
9361 /* If the type is defined to be bind(c) it then needs to make
9362 sure that all fields are interoperable. This will
9363 need to be a semantic check on the finished derived type.
9364 See 15.2.3 (lines 9-12) of F2003 draft. */
9365 if (!gfc_add_is_bind_c (attr
, NULL
, &gfc_current_locus
, 0))
9368 /* TODO: attr conflicts need to be checked, probably in symbol.c. */
9370 else if (gfc_match (" , abstract") == MATCH_YES
)
9372 if (!gfc_notify_std (GFC_STD_F2003
, "ABSTRACT type at %C"))
9375 if (!gfc_add_abstract (attr
, &gfc_current_locus
))
9378 else if (name
&& gfc_match (" , extends ( %n )", name
) == MATCH_YES
)
9380 if (!gfc_add_extension (attr
, &gfc_current_locus
))
9386 /* If we get here, something matched. */
9391 /* Common function for type declaration blocks similar to derived types, such
9392 as STRUCTURES and MAPs. Unlike derived types, a structure type
9393 does NOT have a generic symbol matching the name given by the user.
9394 STRUCTUREs can share names with variables and PARAMETERs so we must allow
9395 for the creation of an independent symbol.
9396 Other parameters are a message to prefix errors with, the name of the new
9397 type to be created, and the flavor to add to the resulting symbol. */
9400 get_struct_decl (const char *name
, sym_flavor fl
, locus
*decl
,
9401 gfc_symbol
**result
)
9406 gcc_assert (name
[0] == (char) TOUPPER (name
[0]));
9411 where
= gfc_current_locus
;
9413 if (gfc_get_symbol (name
, NULL
, &sym
))
9418 gfc_internal_error ("Failed to create structure type '%s' at %C", name
);
9422 if (sym
->components
!= NULL
|| sym
->attr
.zero_comp
)
9424 gfc_error ("Type definition of %qs at %C was already defined at %L",
9425 sym
->name
, &sym
->declared_at
);
9429 sym
->declared_at
= where
;
9431 if (sym
->attr
.flavor
!= fl
9432 && !gfc_add_flavor (&sym
->attr
, fl
, sym
->name
, NULL
))
9435 if (!sym
->hash_value
)
9436 /* Set the hash for the compound name for this type. */
9437 sym
->hash_value
= gfc_hash_value (sym
);
9439 /* Normally the type is expected to have been completely parsed by the time
9440 a field declaration with this type is seen. For unions, maps, and nested
9441 structure declarations, we need to indicate that it is okay that we
9442 haven't seen any components yet. This will be updated after the structure
9444 sym
->attr
.zero_comp
= 0;
9446 /* Structures always act like derived-types with the SEQUENCE attribute */
9447 gfc_add_sequence (&sym
->attr
, sym
->name
, NULL
);
9449 if (result
) *result
= sym
;
9455 /* Match the opening of a MAP block. Like a struct within a union in C;
9456 behaves identical to STRUCTURE blocks. */
9459 gfc_match_map (void)
9461 /* Counter used to give unique internal names to map structures. */
9462 static unsigned int gfc_map_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 MAP statement at %C");
9472 gfc_current_locus
= old_loc
;
9476 /* Map blocks 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, "MM$%u", gfc_map_id
++);
9480 if (!get_struct_decl (name
, FL_STRUCT
, &old_loc
, &sym
))
9483 gfc_new_block
= sym
;
9489 /* Match the opening of a UNION block. */
9492 gfc_match_union (void)
9494 /* Counter used to give unique internal names to union types. */
9495 static unsigned int gfc_union_id
= 0;
9496 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9500 old_loc
= gfc_current_locus
;
9502 if (gfc_match_eos () != MATCH_YES
)
9504 gfc_error ("Junk after UNION statement at %C");
9505 gfc_current_locus
= old_loc
;
9509 /* Unions are anonymous so we make up unique names for the symbol table
9510 which are invalid Fortran identifiers. */
9511 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "UU$%u", gfc_union_id
++);
9513 if (!get_struct_decl (name
, FL_UNION
, &old_loc
, &sym
))
9516 gfc_new_block
= sym
;
9522 /* Match the beginning of a STRUCTURE declaration. This is similar to
9523 matching the beginning of a derived type declaration with a few
9524 twists. The resulting type symbol has no access control or other
9525 interesting attributes. */
9528 gfc_match_structure_decl (void)
9530 /* Counter used to give unique internal names to anonymous structures. */
9531 static unsigned int gfc_structure_id
= 0;
9532 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9537 if (!flag_dec_structure
)
9539 gfc_error ("%s at %C is a DEC extension, enable with "
9540 "%<-fdec-structure%>",
9547 m
= gfc_match (" /%n/", name
);
9550 /* Non-nested structure declarations require a structure name. */
9551 if (!gfc_comp_struct (gfc_current_state ()))
9553 gfc_error ("Structure name expected in non-nested structure "
9554 "declaration at %C");
9557 /* This is an anonymous structure; make up a unique name for it
9558 (upper-case letters never make it to symbol names from the source).
9559 The important thing is initializing the type variable
9560 and setting gfc_new_symbol, which is immediately used by
9561 parse_structure () and variable_decl () to add components of
9563 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "SS$%u", gfc_structure_id
++);
9566 where
= gfc_current_locus
;
9567 /* No field list allowed after non-nested structure declaration. */
9568 if (!gfc_comp_struct (gfc_current_state ())
9569 && gfc_match_eos () != MATCH_YES
)
9571 gfc_error ("Junk after non-nested STRUCTURE statement at %C");
9575 /* Make sure the name is not the name of an intrinsic type. */
9576 if (gfc_is_intrinsic_typename (name
))
9578 gfc_error ("Structure name %qs at %C cannot be the same as an"
9579 " intrinsic type", name
);
9583 /* Store the actual type symbol for the structure with an upper-case first
9584 letter (an invalid Fortran identifier). */
9586 if (!get_struct_decl (gfc_dt_upper_string (name
), FL_STRUCT
, &where
, &sym
))
9589 gfc_new_block
= sym
;
9594 /* This function does some work to determine which matcher should be used to
9595 * match a statement beginning with "TYPE". This is used to disambiguate TYPE
9596 * as an alias for PRINT from derived type declarations, TYPE IS statements,
9597 * and derived type data declarations. */
9600 gfc_match_type (gfc_statement
*st
)
9602 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9606 /* Requires -fdec. */
9610 m
= gfc_match ("type");
9613 /* If we already have an error in the buffer, it is probably from failing to
9614 * match a derived type data declaration. Let it happen. */
9615 else if (gfc_error_flag_test ())
9618 old_loc
= gfc_current_locus
;
9621 /* If we see an attribute list before anything else it's definitely a derived
9622 * type declaration. */
9623 if (gfc_match (" ,") == MATCH_YES
|| gfc_match (" ::") == MATCH_YES
)
9625 gfc_current_locus
= old_loc
;
9626 *st
= ST_DERIVED_DECL
;
9627 return gfc_match_derived_decl ();
9630 /* By now "TYPE" has already been matched. If we do not see a name, this may
9631 * be something like "TYPE *" or "TYPE <fmt>". */
9632 m
= gfc_match_name (name
);
9635 /* Let print match if it can, otherwise throw an error from
9636 * gfc_match_derived_decl. */
9637 gfc_current_locus
= old_loc
;
9638 if (gfc_match_print () == MATCH_YES
)
9643 gfc_current_locus
= old_loc
;
9644 *st
= ST_DERIVED_DECL
;
9645 return gfc_match_derived_decl ();
9648 /* A derived type declaration requires an EOS. Without it, assume print. */
9649 m
= gfc_match_eos ();
9652 /* Check manually for TYPE IS (... - this is invalid print syntax. */
9653 if (strncmp ("is", name
, 3) == 0
9654 && gfc_match (" (", name
) == MATCH_YES
)
9656 gfc_current_locus
= old_loc
;
9657 gcc_assert (gfc_match (" is") == MATCH_YES
);
9659 return gfc_match_type_is ();
9661 gfc_current_locus
= old_loc
;
9663 return gfc_match_print ();
9667 /* By now we have "TYPE <name> <EOS>". Check first if the name is an
9668 * intrinsic typename - if so let gfc_match_derived_decl dump an error.
9669 * Otherwise if gfc_match_derived_decl fails it's probably an existing
9670 * symbol which can be printed. */
9671 gfc_current_locus
= old_loc
;
9672 m
= gfc_match_derived_decl ();
9673 if (gfc_is_intrinsic_typename (name
) || m
== MATCH_YES
)
9675 *st
= ST_DERIVED_DECL
;
9678 gfc_current_locus
= old_loc
;
9680 return gfc_match_print ();
9687 /* Match the beginning of a derived type declaration. If a type name
9688 was the result of a function, then it is possible to have a symbol
9689 already to be known as a derived type yet have no components. */
9692 gfc_match_derived_decl (void)
9694 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9695 char parent
[GFC_MAX_SYMBOL_LEN
+ 1];
9696 symbol_attribute attr
;
9697 gfc_symbol
*sym
, *gensym
;
9698 gfc_symbol
*extended
;
9700 match is_type_attr_spec
= MATCH_NO
;
9701 bool seen_attr
= false;
9702 gfc_interface
*intr
= NULL
, *head
;
9703 bool parameterized_type
= false;
9704 bool seen_colons
= false;
9706 if (gfc_comp_struct (gfc_current_state ()))
9711 gfc_clear_attr (&attr
);
9716 is_type_attr_spec
= gfc_get_type_attr_spec (&attr
, parent
);
9717 if (is_type_attr_spec
== MATCH_ERROR
)
9719 if (is_type_attr_spec
== MATCH_YES
)
9721 } while (is_type_attr_spec
== MATCH_YES
);
9723 /* Deal with derived type extensions. The extension attribute has
9724 been added to 'attr' but now the parent type must be found and
9727 extended
= check_extended_derived_type (parent
);
9729 if (parent
[0] && !extended
)
9732 m
= gfc_match (" ::");
9739 gfc_error ("Expected :: in TYPE definition at %C");
9743 m
= gfc_match (" %n ", name
);
9747 /* Make sure that we don't identify TYPE IS (...) as a parameterized
9748 derived type named 'is'.
9749 TODO Expand the check, when 'name' = "is" by matching " (tname) "
9750 and checking if this is a(n intrinsic) typename. his picks up
9751 misplaced TYPE IS statements such as in select_type_1.f03. */
9752 if (gfc_peek_ascii_char () == '(')
9754 if (gfc_current_state () == COMP_SELECT_TYPE
9755 || (!seen_colons
&& !strcmp (name
, "is")))
9757 parameterized_type
= true;
9760 m
= gfc_match_eos ();
9761 if (m
!= MATCH_YES
&& !parameterized_type
)
9764 /* Make sure the name is not the name of an intrinsic type. */
9765 if (gfc_is_intrinsic_typename (name
))
9767 gfc_error ("Type name %qs at %C cannot be the same as an intrinsic "
9772 if (gfc_get_symbol (name
, NULL
, &gensym
))
9775 if (!gensym
->attr
.generic
&& gensym
->ts
.type
!= BT_UNKNOWN
)
9777 gfc_error ("Derived type name %qs at %C already has a basic type "
9778 "of %s", gensym
->name
, gfc_typename (&gensym
->ts
));
9782 if (!gensym
->attr
.generic
9783 && !gfc_add_generic (&gensym
->attr
, gensym
->name
, NULL
))
9786 if (!gensym
->attr
.function
9787 && !gfc_add_function (&gensym
->attr
, gensym
->name
, NULL
))
9790 sym
= gfc_find_dt_in_generic (gensym
);
9792 if (sym
&& (sym
->components
!= NULL
|| sym
->attr
.zero_comp
))
9794 gfc_error ("Derived type definition of %qs at %C has already been "
9795 "defined", sym
->name
);
9801 /* Use upper case to save the actual derived-type symbol. */
9802 gfc_get_symbol (gfc_dt_upper_string (gensym
->name
), NULL
, &sym
);
9803 sym
->name
= gfc_get_string ("%s", gensym
->name
);
9804 head
= gensym
->generic
;
9805 intr
= gfc_get_interface ();
9807 intr
->where
= gfc_current_locus
;
9808 intr
->sym
->declared_at
= gfc_current_locus
;
9810 gensym
->generic
= intr
;
9811 gensym
->attr
.if_source
= IFSRC_DECL
;
9814 /* The symbol may already have the derived attribute without the
9815 components. The ways this can happen is via a function
9816 definition, an INTRINSIC statement or a subtype in another
9817 derived type that is a pointer. The first part of the AND clause
9818 is true if the symbol is not the return value of a function. */
9819 if (sym
->attr
.flavor
!= FL_DERIVED
9820 && !gfc_add_flavor (&sym
->attr
, FL_DERIVED
, sym
->name
, NULL
))
9823 if (attr
.access
!= ACCESS_UNKNOWN
9824 && !gfc_add_access (&sym
->attr
, attr
.access
, sym
->name
, NULL
))
9826 else if (sym
->attr
.access
== ACCESS_UNKNOWN
9827 && gensym
->attr
.access
!= ACCESS_UNKNOWN
9828 && !gfc_add_access (&sym
->attr
, gensym
->attr
.access
,
9832 if (sym
->attr
.access
!= ACCESS_UNKNOWN
9833 && gensym
->attr
.access
== ACCESS_UNKNOWN
)
9834 gensym
->attr
.access
= sym
->attr
.access
;
9836 /* See if the derived type was labeled as bind(c). */
9837 if (attr
.is_bind_c
!= 0)
9838 sym
->attr
.is_bind_c
= attr
.is_bind_c
;
9840 /* Construct the f2k_derived namespace if it is not yet there. */
9841 if (!sym
->f2k_derived
)
9842 sym
->f2k_derived
= gfc_get_namespace (NULL
, 0);
9844 if (parameterized_type
)
9846 /* Ignore error or mismatches by going to the end of the statement
9847 in order to avoid the component declarations causing problems. */
9848 m
= gfc_match_formal_arglist (sym
, 0, 0, true);
9850 gfc_error_recovery ();
9851 m
= gfc_match_eos ();
9854 sym
->attr
.pdt_template
= 1;
9857 if (extended
&& !sym
->components
)
9860 gfc_formal_arglist
*f
, *g
, *h
;
9862 /* Add the extended derived type as the first component. */
9863 gfc_add_component (sym
, parent
, &p
);
9865 gfc_set_sym_referenced (extended
);
9867 p
->ts
.type
= BT_DERIVED
;
9868 p
->ts
.u
.derived
= extended
;
9869 p
->initializer
= gfc_default_initializer (&p
->ts
);
9871 /* Set extension level. */
9872 if (extended
->attr
.extension
== 255)
9874 /* Since the extension field is 8 bit wide, we can only have
9875 up to 255 extension levels. */
9876 gfc_error ("Maximum extension level reached with type %qs at %L",
9877 extended
->name
, &extended
->declared_at
);
9880 sym
->attr
.extension
= extended
->attr
.extension
+ 1;
9882 /* Provide the links between the extended type and its extension. */
9883 if (!extended
->f2k_derived
)
9884 extended
->f2k_derived
= gfc_get_namespace (NULL
, 0);
9886 /* Copy the extended type-param-name-list from the extended type,
9887 append those of the extension and add the whole lot to the
9889 if (extended
->attr
.pdt_template
)
9892 sym
->attr
.pdt_template
= 1;
9893 for (f
= extended
->formal
; f
; f
= f
->next
)
9895 if (f
== extended
->formal
)
9897 g
= gfc_get_formal_arglist ();
9902 g
->next
= gfc_get_formal_arglist ();
9907 g
->next
= sym
->formal
;
9912 if (!sym
->hash_value
)
9913 /* Set the hash for the compound name for this type. */
9914 sym
->hash_value
= gfc_hash_value (sym
);
9916 /* Take over the ABSTRACT attribute. */
9917 sym
->attr
.abstract
= attr
.abstract
;
9919 gfc_new_block
= sym
;
9925 /* Cray Pointees can be declared as:
9926 pointer (ipt, a (n,m,...,*)) */
9929 gfc_mod_pointee_as (gfc_array_spec
*as
)
9931 as
->cray_pointee
= true; /* This will be useful to know later. */
9932 if (as
->type
== AS_ASSUMED_SIZE
)
9933 as
->cp_was_assumed
= true;
9934 else if (as
->type
== AS_ASSUMED_SHAPE
)
9936 gfc_error ("Cray Pointee at %C cannot be assumed shape array");
9943 /* Match the enum definition statement, here we are trying to match
9944 the first line of enum definition statement.
9945 Returns MATCH_YES if match is found. */
9948 gfc_match_enum (void)
9952 m
= gfc_match_eos ();
9956 if (!gfc_notify_std (GFC_STD_F2003
, "ENUM and ENUMERATOR at %C"))
9963 /* Returns an initializer whose value is one higher than the value of the
9964 LAST_INITIALIZER argument. If the argument is NULL, the
9965 initializers value will be set to zero. The initializer's kind
9966 will be set to gfc_c_int_kind.
9968 If -fshort-enums is given, the appropriate kind will be selected
9969 later after all enumerators have been parsed. A warning is issued
9970 here if an initializer exceeds gfc_c_int_kind. */
9973 enum_initializer (gfc_expr
*last_initializer
, locus where
)
9976 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_c_int_kind
, &where
);
9978 mpz_init (result
->value
.integer
);
9980 if (last_initializer
!= NULL
)
9982 mpz_add_ui (result
->value
.integer
, last_initializer
->value
.integer
, 1);
9983 result
->where
= last_initializer
->where
;
9985 if (gfc_check_integer_range (result
->value
.integer
,
9986 gfc_c_int_kind
) != ARITH_OK
)
9988 gfc_error ("Enumerator exceeds the C integer type at %C");
9994 /* Control comes here, if it's the very first enumerator and no
9995 initializer has been given. It will be initialized to zero. */
9996 mpz_set_si (result
->value
.integer
, 0);
10003 /* Match a variable name with an optional initializer. When this
10004 subroutine is called, a variable is expected to be parsed next.
10005 Depending on what is happening at the moment, updates either the
10006 symbol table or the current interface. */
10009 enumerator_decl (void)
10011 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10012 gfc_expr
*initializer
;
10013 gfc_array_spec
*as
= NULL
;
10020 initializer
= NULL
;
10021 old_locus
= gfc_current_locus
;
10023 /* When we get here, we've just matched a list of attributes and
10024 maybe a type and a double colon. The next thing we expect to see
10025 is the name of the symbol. */
10026 m
= gfc_match_name (name
);
10027 if (m
!= MATCH_YES
)
10030 var_locus
= gfc_current_locus
;
10032 /* OK, we've successfully matched the declaration. Now put the
10033 symbol in the current namespace. If we fail to create the symbol,
10035 if (!build_sym (name
, NULL
, false, &as
, &var_locus
))
10041 /* The double colon must be present in order to have initializers.
10042 Otherwise the statement is ambiguous with an assignment statement. */
10045 if (gfc_match_char ('=') == MATCH_YES
)
10047 m
= gfc_match_init_expr (&initializer
);
10050 gfc_error ("Expected an initialization expression at %C");
10054 if (m
!= MATCH_YES
)
10059 /* If we do not have an initializer, the initialization value of the
10060 previous enumerator (stored in last_initializer) is incremented
10061 by 1 and is used to initialize the current enumerator. */
10062 if (initializer
== NULL
)
10063 initializer
= enum_initializer (last_initializer
, old_locus
);
10065 if (initializer
== NULL
|| initializer
->ts
.type
!= BT_INTEGER
)
10067 gfc_error ("ENUMERATOR %L not initialized with integer expression",
10073 /* Store this current initializer, for the next enumerator variable
10074 to be parsed. add_init_expr_to_sym() zeros initializer, so we
10075 use last_initializer below. */
10076 last_initializer
= initializer
;
10077 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
10079 /* Maintain enumerator history. */
10080 gfc_find_symbol (name
, NULL
, 0, &sym
);
10081 create_enum_history (sym
, last_initializer
);
10083 return (t
) ? MATCH_YES
: MATCH_ERROR
;
10086 /* Free stuff up and return. */
10087 gfc_free_expr (initializer
);
10093 /* Match the enumerator definition statement. */
10096 gfc_match_enumerator_def (void)
10101 gfc_clear_ts (¤t_ts
);
10103 m
= gfc_match (" enumerator");
10104 if (m
!= MATCH_YES
)
10107 m
= gfc_match (" :: ");
10108 if (m
== MATCH_ERROR
)
10111 colon_seen
= (m
== MATCH_YES
);
10113 if (gfc_current_state () != COMP_ENUM
)
10115 gfc_error ("ENUM definition statement expected before %C");
10116 gfc_free_enum_history ();
10117 return MATCH_ERROR
;
10120 (¤t_ts
)->type
= BT_INTEGER
;
10121 (¤t_ts
)->kind
= gfc_c_int_kind
;
10123 gfc_clear_attr (¤t_attr
);
10124 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, NULL
);
10133 m
= enumerator_decl ();
10134 if (m
== MATCH_ERROR
)
10136 gfc_free_enum_history ();
10142 if (gfc_match_eos () == MATCH_YES
)
10144 if (gfc_match_char (',') != MATCH_YES
)
10148 if (gfc_current_state () == COMP_ENUM
)
10150 gfc_free_enum_history ();
10151 gfc_error ("Syntax error in ENUMERATOR definition at %C");
10156 gfc_free_array_spec (current_as
);
10163 /* Match binding attributes. */
10166 match_binding_attributes (gfc_typebound_proc
* ba
, bool generic
, bool ppc
)
10168 bool found_passing
= false;
10169 bool seen_ptr
= false;
10170 match m
= MATCH_YES
;
10172 /* Initialize to defaults. Do so even before the MATCH_NO check so that in
10173 this case the defaults are in there. */
10174 ba
->access
= ACCESS_UNKNOWN
;
10175 ba
->pass_arg
= NULL
;
10176 ba
->pass_arg_num
= 0;
10178 ba
->non_overridable
= 0;
10182 /* If we find a comma, we believe there are binding attributes. */
10183 m
= gfc_match_char (',');
10189 /* Access specifier. */
10191 m
= gfc_match (" public");
10192 if (m
== MATCH_ERROR
)
10194 if (m
== MATCH_YES
)
10196 if (ba
->access
!= ACCESS_UNKNOWN
)
10198 gfc_error ("Duplicate access-specifier at %C");
10202 ba
->access
= ACCESS_PUBLIC
;
10206 m
= gfc_match (" private");
10207 if (m
== MATCH_ERROR
)
10209 if (m
== MATCH_YES
)
10211 if (ba
->access
!= ACCESS_UNKNOWN
)
10213 gfc_error ("Duplicate access-specifier at %C");
10217 ba
->access
= ACCESS_PRIVATE
;
10221 /* If inside GENERIC, the following is not allowed. */
10226 m
= gfc_match (" nopass");
10227 if (m
== MATCH_ERROR
)
10229 if (m
== MATCH_YES
)
10233 gfc_error ("Binding attributes already specify passing,"
10234 " illegal NOPASS at %C");
10238 found_passing
= true;
10243 /* PASS possibly including argument. */
10244 m
= gfc_match (" pass");
10245 if (m
== MATCH_ERROR
)
10247 if (m
== MATCH_YES
)
10249 char arg
[GFC_MAX_SYMBOL_LEN
+ 1];
10253 gfc_error ("Binding attributes already specify passing,"
10254 " illegal PASS at %C");
10258 m
= gfc_match (" ( %n )", arg
);
10259 if (m
== MATCH_ERROR
)
10261 if (m
== MATCH_YES
)
10262 ba
->pass_arg
= gfc_get_string ("%s", arg
);
10263 gcc_assert ((m
== MATCH_YES
) == (ba
->pass_arg
!= NULL
));
10265 found_passing
= true;
10272 /* POINTER flag. */
10273 m
= gfc_match (" pointer");
10274 if (m
== MATCH_ERROR
)
10276 if (m
== MATCH_YES
)
10280 gfc_error ("Duplicate POINTER attribute at %C");
10290 /* NON_OVERRIDABLE flag. */
10291 m
= gfc_match (" non_overridable");
10292 if (m
== MATCH_ERROR
)
10294 if (m
== MATCH_YES
)
10296 if (ba
->non_overridable
)
10298 gfc_error ("Duplicate NON_OVERRIDABLE at %C");
10302 ba
->non_overridable
= 1;
10306 /* DEFERRED flag. */
10307 m
= gfc_match (" deferred");
10308 if (m
== MATCH_ERROR
)
10310 if (m
== MATCH_YES
)
10314 gfc_error ("Duplicate DEFERRED at %C");
10325 /* Nothing matching found. */
10327 gfc_error ("Expected access-specifier at %C");
10329 gfc_error ("Expected binding attribute at %C");
10332 while (gfc_match_char (',') == MATCH_YES
);
10334 /* NON_OVERRIDABLE and DEFERRED exclude themselves. */
10335 if (ba
->non_overridable
&& ba
->deferred
)
10337 gfc_error ("NON_OVERRIDABLE and DEFERRED can't both appear at %C");
10344 if (ba
->access
== ACCESS_UNKNOWN
)
10345 ba
->access
= gfc_typebound_default_access
;
10347 if (ppc
&& !seen_ptr
)
10349 gfc_error ("POINTER attribute is required for procedure pointer component"
10357 return MATCH_ERROR
;
10361 /* Match a PROCEDURE specific binding inside a derived type. */
10364 match_procedure_in_type (void)
10366 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10367 char target_buf
[GFC_MAX_SYMBOL_LEN
+ 1];
10368 char* target
= NULL
, *ifc
= NULL
;
10369 gfc_typebound_proc tb
;
10373 gfc_symtree
* stree
;
10378 /* Check current state. */
10379 gcc_assert (gfc_state_stack
->state
== COMP_DERIVED_CONTAINS
);
10380 block
= gfc_state_stack
->previous
->sym
;
10381 gcc_assert (block
);
10383 /* Try to match PROCEDURE(interface). */
10384 if (gfc_match (" (") == MATCH_YES
)
10386 m
= gfc_match_name (target_buf
);
10387 if (m
== MATCH_ERROR
)
10389 if (m
!= MATCH_YES
)
10391 gfc_error ("Interface-name expected after %<(%> at %C");
10392 return MATCH_ERROR
;
10395 if (gfc_match (" )") != MATCH_YES
)
10397 gfc_error ("%<)%> expected at %C");
10398 return MATCH_ERROR
;
10404 /* Construct the data structure. */
10405 memset (&tb
, 0, sizeof (tb
));
10406 tb
.where
= gfc_current_locus
;
10408 /* Match binding attributes. */
10409 m
= match_binding_attributes (&tb
, false, false);
10410 if (m
== MATCH_ERROR
)
10412 seen_attrs
= (m
== MATCH_YES
);
10414 /* Check that attribute DEFERRED is given if an interface is specified. */
10415 if (tb
.deferred
&& !ifc
)
10417 gfc_error ("Interface must be specified for DEFERRED binding at %C");
10418 return MATCH_ERROR
;
10420 if (ifc
&& !tb
.deferred
)
10422 gfc_error ("PROCEDURE(interface) at %C should be declared DEFERRED");
10423 return MATCH_ERROR
;
10426 /* Match the colons. */
10427 m
= gfc_match (" ::");
10428 if (m
== MATCH_ERROR
)
10430 seen_colons
= (m
== MATCH_YES
);
10431 if (seen_attrs
&& !seen_colons
)
10433 gfc_error ("Expected %<::%> after binding-attributes at %C");
10434 return MATCH_ERROR
;
10437 /* Match the binding names. */
10440 m
= gfc_match_name (name
);
10441 if (m
== MATCH_ERROR
)
10445 gfc_error ("Expected binding name at %C");
10446 return MATCH_ERROR
;
10449 if (num
>1 && !gfc_notify_std (GFC_STD_F2008
, "PROCEDURE list at %C"))
10450 return MATCH_ERROR
;
10452 /* Try to match the '=> target', if it's there. */
10454 m
= gfc_match (" =>");
10455 if (m
== MATCH_ERROR
)
10457 if (m
== MATCH_YES
)
10461 gfc_error ("%<=> target%> is invalid for DEFERRED binding at %C");
10462 return MATCH_ERROR
;
10467 gfc_error ("%<::%> needed in PROCEDURE binding with explicit target"
10469 return MATCH_ERROR
;
10472 m
= gfc_match_name (target_buf
);
10473 if (m
== MATCH_ERROR
)
10477 gfc_error ("Expected binding target after %<=>%> at %C");
10478 return MATCH_ERROR
;
10480 target
= target_buf
;
10483 /* If no target was found, it has the same name as the binding. */
10487 /* Get the namespace to insert the symbols into. */
10488 ns
= block
->f2k_derived
;
10491 /* If the binding is DEFERRED, check that the containing type is ABSTRACT. */
10492 if (tb
.deferred
&& !block
->attr
.abstract
)
10494 gfc_error ("Type %qs containing DEFERRED binding at %C "
10495 "is not ABSTRACT", block
->name
);
10496 return MATCH_ERROR
;
10499 /* See if we already have a binding with this name in the symtree which
10500 would be an error. If a GENERIC already targeted this binding, it may
10501 be already there but then typebound is still NULL. */
10502 stree
= gfc_find_symtree (ns
->tb_sym_root
, name
);
10503 if (stree
&& stree
->n
.tb
)
10505 gfc_error ("There is already a procedure with binding name %qs for "
10506 "the derived type %qs at %C", name
, block
->name
);
10507 return MATCH_ERROR
;
10510 /* Insert it and set attributes. */
10514 stree
= gfc_new_symtree (&ns
->tb_sym_root
, name
);
10515 gcc_assert (stree
);
10517 stree
->n
.tb
= gfc_get_typebound_proc (&tb
);
10519 if (gfc_get_sym_tree (target
, gfc_current_ns
, &stree
->n
.tb
->u
.specific
,
10521 return MATCH_ERROR
;
10522 gfc_set_sym_referenced (stree
->n
.tb
->u
.specific
->n
.sym
);
10523 gfc_add_flavor(&stree
->n
.tb
->u
.specific
->n
.sym
->attr
, FL_PROCEDURE
,
10524 target
, &stree
->n
.tb
->u
.specific
->n
.sym
->declared_at
);
10526 if (gfc_match_eos () == MATCH_YES
)
10528 if (gfc_match_char (',') != MATCH_YES
)
10533 gfc_error ("Syntax error in PROCEDURE statement at %C");
10534 return MATCH_ERROR
;
10538 /* Match a GENERIC procedure binding inside a derived type. */
10541 gfc_match_generic (void)
10543 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10544 char bind_name
[GFC_MAX_SYMBOL_LEN
+ 16]; /* Allow space for OPERATOR(...). */
10546 gfc_typebound_proc tbattr
; /* Used for match_binding_attributes. */
10547 gfc_typebound_proc
* tb
;
10549 interface_type op_type
;
10550 gfc_intrinsic_op op
;
10553 /* Check current state. */
10554 if (gfc_current_state () == COMP_DERIVED
)
10556 gfc_error ("GENERIC at %C must be inside a derived-type CONTAINS");
10557 return MATCH_ERROR
;
10559 if (gfc_current_state () != COMP_DERIVED_CONTAINS
)
10561 block
= gfc_state_stack
->previous
->sym
;
10562 ns
= block
->f2k_derived
;
10563 gcc_assert (block
&& ns
);
10565 memset (&tbattr
, 0, sizeof (tbattr
));
10566 tbattr
.where
= gfc_current_locus
;
10568 /* See if we get an access-specifier. */
10569 m
= match_binding_attributes (&tbattr
, true, false);
10570 if (m
== MATCH_ERROR
)
10573 /* Now the colons, those are required. */
10574 if (gfc_match (" ::") != MATCH_YES
)
10576 gfc_error ("Expected %<::%> at %C");
10580 /* Match the binding name; depending on type (operator / generic) format
10581 it for future error messages into bind_name. */
10583 m
= gfc_match_generic_spec (&op_type
, name
, &op
);
10584 if (m
== MATCH_ERROR
)
10585 return MATCH_ERROR
;
10588 gfc_error ("Expected generic name or operator descriptor at %C");
10594 case INTERFACE_GENERIC
:
10595 case INTERFACE_DTIO
:
10596 snprintf (bind_name
, sizeof (bind_name
), "%s", name
);
10599 case INTERFACE_USER_OP
:
10600 snprintf (bind_name
, sizeof (bind_name
), "OPERATOR(.%s.)", name
);
10603 case INTERFACE_INTRINSIC_OP
:
10604 snprintf (bind_name
, sizeof (bind_name
), "OPERATOR(%s)",
10605 gfc_op2string (op
));
10608 case INTERFACE_NAMELESS
:
10609 gfc_error ("Malformed GENERIC statement at %C");
10614 gcc_unreachable ();
10617 /* Match the required =>. */
10618 if (gfc_match (" =>") != MATCH_YES
)
10620 gfc_error ("Expected %<=>%> at %C");
10624 /* Try to find existing GENERIC binding with this name / for this operator;
10625 if there is something, check that it is another GENERIC and then extend
10626 it rather than building a new node. Otherwise, create it and put it
10627 at the right position. */
10631 case INTERFACE_DTIO
:
10632 case INTERFACE_USER_OP
:
10633 case INTERFACE_GENERIC
:
10635 const bool is_op
= (op_type
== INTERFACE_USER_OP
);
10638 st
= gfc_find_symtree (is_op
? ns
->tb_uop_root
: ns
->tb_sym_root
, name
);
10639 tb
= st
? st
->n
.tb
: NULL
;
10643 case INTERFACE_INTRINSIC_OP
:
10644 tb
= ns
->tb_op
[op
];
10648 gcc_unreachable ();
10653 if (!tb
->is_generic
)
10655 gcc_assert (op_type
== INTERFACE_GENERIC
);
10656 gfc_error ("There's already a non-generic procedure with binding name"
10657 " %qs for the derived type %qs at %C",
10658 bind_name
, block
->name
);
10662 if (tb
->access
!= tbattr
.access
)
10664 gfc_error ("Binding at %C must have the same access as already"
10665 " defined binding %qs", bind_name
);
10671 tb
= gfc_get_typebound_proc (NULL
);
10672 tb
->where
= gfc_current_locus
;
10673 tb
->access
= tbattr
.access
;
10674 tb
->is_generic
= 1;
10675 tb
->u
.generic
= NULL
;
10679 case INTERFACE_DTIO
:
10680 case INTERFACE_GENERIC
:
10681 case INTERFACE_USER_OP
:
10683 const bool is_op
= (op_type
== INTERFACE_USER_OP
);
10684 gfc_symtree
* st
= gfc_get_tbp_symtree (is_op
? &ns
->tb_uop_root
:
10685 &ns
->tb_sym_root
, name
);
10692 case INTERFACE_INTRINSIC_OP
:
10693 ns
->tb_op
[op
] = tb
;
10697 gcc_unreachable ();
10701 /* Now, match all following names as specific targets. */
10704 gfc_symtree
* target_st
;
10705 gfc_tbp_generic
* target
;
10707 m
= gfc_match_name (name
);
10708 if (m
== MATCH_ERROR
)
10712 gfc_error ("Expected specific binding name at %C");
10716 target_st
= gfc_get_tbp_symtree (&ns
->tb_sym_root
, name
);
10718 /* See if this is a duplicate specification. */
10719 for (target
= tb
->u
.generic
; target
; target
= target
->next
)
10720 if (target_st
== target
->specific_st
)
10722 gfc_error ("%qs already defined as specific binding for the"
10723 " generic %qs at %C", name
, bind_name
);
10727 target
= gfc_get_tbp_generic ();
10728 target
->specific_st
= target_st
;
10729 target
->specific
= NULL
;
10730 target
->next
= tb
->u
.generic
;
10731 target
->is_operator
= ((op_type
== INTERFACE_USER_OP
)
10732 || (op_type
== INTERFACE_INTRINSIC_OP
));
10733 tb
->u
.generic
= target
;
10735 while (gfc_match (" ,") == MATCH_YES
);
10737 /* Here should be the end. */
10738 if (gfc_match_eos () != MATCH_YES
)
10740 gfc_error ("Junk after GENERIC binding at %C");
10747 return MATCH_ERROR
;
10751 /* Match a FINAL declaration inside a derived type. */
10754 gfc_match_final_decl (void)
10756 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10759 gfc_namespace
* module_ns
;
10763 if (gfc_current_form
== FORM_FREE
)
10765 char c
= gfc_peek_ascii_char ();
10766 if (!gfc_is_whitespace (c
) && c
!= ':')
10770 if (gfc_state_stack
->state
!= COMP_DERIVED_CONTAINS
)
10772 if (gfc_current_form
== FORM_FIXED
)
10775 gfc_error ("FINAL declaration at %C must be inside a derived type "
10776 "CONTAINS section");
10777 return MATCH_ERROR
;
10780 block
= gfc_state_stack
->previous
->sym
;
10781 gcc_assert (block
);
10783 if (!gfc_state_stack
->previous
|| !gfc_state_stack
->previous
->previous
10784 || gfc_state_stack
->previous
->previous
->state
!= COMP_MODULE
)
10786 gfc_error ("Derived type declaration with FINAL at %C must be in the"
10787 " specification part of a MODULE");
10788 return MATCH_ERROR
;
10791 module_ns
= gfc_current_ns
;
10792 gcc_assert (module_ns
);
10793 gcc_assert (module_ns
->proc_name
->attr
.flavor
== FL_MODULE
);
10795 /* Match optional ::, don't care about MATCH_YES or MATCH_NO. */
10796 if (gfc_match (" ::") == MATCH_ERROR
)
10797 return MATCH_ERROR
;
10799 /* Match the sequence of procedure names. */
10806 if (first
&& gfc_match_eos () == MATCH_YES
)
10808 gfc_error ("Empty FINAL at %C");
10809 return MATCH_ERROR
;
10812 m
= gfc_match_name (name
);
10815 gfc_error ("Expected module procedure name at %C");
10816 return MATCH_ERROR
;
10818 else if (m
!= MATCH_YES
)
10819 return MATCH_ERROR
;
10821 if (gfc_match_eos () == MATCH_YES
)
10823 if (!last
&& gfc_match_char (',') != MATCH_YES
)
10825 gfc_error ("Expected %<,%> at %C");
10826 return MATCH_ERROR
;
10829 if (gfc_get_symbol (name
, module_ns
, &sym
))
10831 gfc_error ("Unknown procedure name %qs at %C", name
);
10832 return MATCH_ERROR
;
10835 /* Mark the symbol as module procedure. */
10836 if (sym
->attr
.proc
!= PROC_MODULE
10837 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
10838 return MATCH_ERROR
;
10840 /* Check if we already have this symbol in the list, this is an error. */
10841 for (f
= block
->f2k_derived
->finalizers
; f
; f
= f
->next
)
10842 if (f
->proc_sym
== sym
)
10844 gfc_error ("%qs at %C is already defined as FINAL procedure",
10846 return MATCH_ERROR
;
10849 /* Add this symbol to the list of finalizers. */
10850 gcc_assert (block
->f2k_derived
);
10852 f
= XCNEW (gfc_finalizer
);
10854 f
->proc_tree
= NULL
;
10855 f
->where
= gfc_current_locus
;
10856 f
->next
= block
->f2k_derived
->finalizers
;
10857 block
->f2k_derived
->finalizers
= f
;
10867 const ext_attr_t ext_attr_list
[] = {
10868 { "dllimport", EXT_ATTR_DLLIMPORT
, "dllimport" },
10869 { "dllexport", EXT_ATTR_DLLEXPORT
, "dllexport" },
10870 { "cdecl", EXT_ATTR_CDECL
, "cdecl" },
10871 { "stdcall", EXT_ATTR_STDCALL
, "stdcall" },
10872 { "fastcall", EXT_ATTR_FASTCALL
, "fastcall" },
10873 { "no_arg_check", EXT_ATTR_NO_ARG_CHECK
, NULL
},
10874 { NULL
, EXT_ATTR_LAST
, NULL
}
10877 /* Match a !GCC$ ATTRIBUTES statement of the form:
10878 !GCC$ ATTRIBUTES attribute-list :: var-name [, var-name] ...
10879 When we come here, we have already matched the !GCC$ ATTRIBUTES string.
10881 TODO: We should support all GCC attributes using the same syntax for
10882 the attribute list, i.e. the list in C
10883 __attributes(( attribute-list ))
10885 !GCC$ ATTRIBUTES attribute-list ::
10886 Cf. c-parser.c's c_parser_attributes; the data can then directly be
10889 As there is absolutely no risk of confusion, we should never return
10892 gfc_match_gcc_attributes (void)
10894 symbol_attribute attr
;
10895 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10900 gfc_clear_attr (&attr
);
10905 if (gfc_match_name (name
) != MATCH_YES
)
10906 return MATCH_ERROR
;
10908 for (id
= 0; id
< EXT_ATTR_LAST
; id
++)
10909 if (strcmp (name
, ext_attr_list
[id
].name
) == 0)
10912 if (id
== EXT_ATTR_LAST
)
10914 gfc_error ("Unknown attribute in !GCC$ ATTRIBUTES statement at %C");
10915 return MATCH_ERROR
;
10918 if (!gfc_add_ext_attribute (&attr
, (ext_attr_id_t
)id
, &gfc_current_locus
))
10919 return MATCH_ERROR
;
10921 gfc_gobble_whitespace ();
10922 ch
= gfc_next_ascii_char ();
10925 /* This is the successful exit condition for the loop. */
10926 if (gfc_next_ascii_char () == ':')
10936 if (gfc_match_eos () == MATCH_YES
)
10941 m
= gfc_match_name (name
);
10942 if (m
!= MATCH_YES
)
10945 if (find_special (name
, &sym
, true))
10946 return MATCH_ERROR
;
10948 sym
->attr
.ext_attr
|= attr
.ext_attr
;
10950 if (gfc_match_eos () == MATCH_YES
)
10953 if (gfc_match_char (',') != MATCH_YES
)
10960 gfc_error ("Syntax error in !GCC$ ATTRIBUTES statement at %C");
10961 return MATCH_ERROR
;
10965 /* Match a !GCC$ UNROLL statement of the form:
10968 The parameter n is the number of times we are supposed to unroll.
10970 When we come here, we have already matched the !GCC$ UNROLL string. */
10972 gfc_match_gcc_unroll (void)
10976 if (gfc_match_small_int (&value
) == MATCH_YES
)
10978 if (value
< 0 || value
> USHRT_MAX
)
10980 gfc_error ("%<GCC unroll%> directive requires a"
10981 " non-negative integral constant"
10982 " less than or equal to %u at %C",
10985 return MATCH_ERROR
;
10987 if (gfc_match_eos () == MATCH_YES
)
10989 directive_unroll
= value
== 0 ? 1 : value
;
10994 gfc_error ("Syntax error in !GCC$ UNROLL directive at %C");
10995 return MATCH_ERROR
;