1 /* Declaration statement matcher
2 Copyright (C) 2002-2018 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_charlen_int_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 (gfc_charlen_t len
, gfc_expr
*expr
,
1542 gfc_charlen_t check_len
)
1547 if (expr
->ts
.type
!= BT_CHARACTER
)
1550 if (expr
->expr_type
!= EXPR_CONSTANT
)
1552 gfc_error_now ("CHARACTER length must be a constant at %L", &expr
->where
);
1556 slen
= expr
->value
.character
.length
;
1559 s
= gfc_get_wide_string (len
+ 1);
1560 memcpy (s
, expr
->value
.character
.string
,
1561 MIN (len
, slen
) * sizeof (gfc_char_t
));
1563 gfc_wide_memset (&s
[slen
], ' ', len
- slen
);
1565 if (warn_character_truncation
&& slen
> len
)
1566 gfc_warning_now (OPT_Wcharacter_truncation
,
1567 "CHARACTER expression at %L is being truncated "
1568 "(%ld/%ld)", &expr
->where
,
1569 (long) slen
, (long) len
);
1571 /* Apply the standard by 'hand' otherwise it gets cleared for
1573 if (check_len
!= -1 && slen
!= check_len
1574 && !(gfc_option
.allow_std
& GFC_STD_GNU
))
1575 gfc_error_now ("The CHARACTER elements of the array constructor "
1576 "at %L must have the same length (%ld/%ld)",
1577 &expr
->where
, (long) slen
,
1581 free (expr
->value
.character
.string
);
1582 expr
->value
.character
.string
= s
;
1583 expr
->value
.character
.length
= len
;
1588 /* Function to create and update the enumerator history
1589 using the information passed as arguments.
1590 Pointer "max_enum" is also updated, to point to
1591 enum history node containing largest initializer.
1593 SYM points to the symbol node of enumerator.
1594 INIT points to its enumerator value. */
1597 create_enum_history (gfc_symbol
*sym
, gfc_expr
*init
)
1599 enumerator_history
*new_enum_history
;
1600 gcc_assert (sym
!= NULL
&& init
!= NULL
);
1602 new_enum_history
= XCNEW (enumerator_history
);
1604 new_enum_history
->sym
= sym
;
1605 new_enum_history
->initializer
= init
;
1606 new_enum_history
->next
= NULL
;
1608 if (enum_history
== NULL
)
1610 enum_history
= new_enum_history
;
1611 max_enum
= enum_history
;
1615 new_enum_history
->next
= enum_history
;
1616 enum_history
= new_enum_history
;
1618 if (mpz_cmp (max_enum
->initializer
->value
.integer
,
1619 new_enum_history
->initializer
->value
.integer
) < 0)
1620 max_enum
= new_enum_history
;
1625 /* Function to free enum kind history. */
1628 gfc_free_enum_history (void)
1630 enumerator_history
*current
= enum_history
;
1631 enumerator_history
*next
;
1633 while (current
!= NULL
)
1635 next
= current
->next
;
1640 enum_history
= NULL
;
1644 /* Function called by variable_decl() that adds an initialization
1645 expression to a symbol. */
1648 add_init_expr_to_sym (const char *name
, gfc_expr
**initp
, locus
*var_locus
)
1650 symbol_attribute attr
;
1655 if (find_special (name
, &sym
, false))
1660 /* If this symbol is confirming an implicit parameter type,
1661 then an initialization expression is not allowed. */
1662 if (attr
.flavor
== FL_PARAMETER
1663 && sym
->value
!= NULL
1666 gfc_error ("Initializer not allowed for PARAMETER %qs at %C",
1673 /* An initializer is required for PARAMETER declarations. */
1674 if (attr
.flavor
== FL_PARAMETER
)
1676 gfc_error ("PARAMETER at %L is missing an initializer", var_locus
);
1682 /* If a variable appears in a DATA block, it cannot have an
1686 gfc_error ("Variable %qs at %C with an initializer already "
1687 "appears in a DATA statement", sym
->name
);
1691 /* Check if the assignment can happen. This has to be put off
1692 until later for derived type variables and procedure pointers. */
1693 if (!gfc_bt_struct (sym
->ts
.type
) && !gfc_bt_struct (init
->ts
.type
)
1694 && sym
->ts
.type
!= BT_CLASS
&& init
->ts
.type
!= BT_CLASS
1695 && !sym
->attr
.proc_pointer
1696 && !gfc_check_assign_symbol (sym
, NULL
, init
))
1699 if (sym
->ts
.type
== BT_CHARACTER
&& sym
->ts
.u
.cl
1700 && init
->ts
.type
== BT_CHARACTER
)
1702 /* Update symbol character length according initializer. */
1703 if (!gfc_check_assign_symbol (sym
, NULL
, init
))
1706 if (sym
->ts
.u
.cl
->length
== NULL
)
1709 /* If there are multiple CHARACTER variables declared on the
1710 same line, we don't want them to share the same length. */
1711 sym
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1713 if (sym
->attr
.flavor
== FL_PARAMETER
)
1715 if (init
->expr_type
== EXPR_CONSTANT
)
1717 clen
= init
->value
.character
.length
;
1718 sym
->ts
.u
.cl
->length
1719 = gfc_get_int_expr (gfc_charlen_int_kind
,
1722 else if (init
->expr_type
== EXPR_ARRAY
)
1724 if (init
->ts
.u
.cl
&& init
->ts
.u
.cl
->length
)
1726 const gfc_expr
*length
= init
->ts
.u
.cl
->length
;
1727 if (length
->expr_type
!= EXPR_CONSTANT
)
1729 gfc_error ("Cannot initialize parameter array "
1731 "with variable length elements",
1735 clen
= mpz_get_si (length
->value
.integer
);
1737 else if (init
->value
.constructor
)
1740 c
= gfc_constructor_first (init
->value
.constructor
);
1741 clen
= c
->expr
->value
.character
.length
;
1745 sym
->ts
.u
.cl
->length
1746 = gfc_get_int_expr (gfc_charlen_int_kind
,
1749 else if (init
->ts
.u
.cl
&& init
->ts
.u
.cl
->length
)
1750 sym
->ts
.u
.cl
->length
=
1751 gfc_copy_expr (sym
->value
->ts
.u
.cl
->length
);
1754 /* Update initializer character length according symbol. */
1755 else if (sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1757 if (!gfc_specification_expr (sym
->ts
.u
.cl
->length
))
1760 int k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
,
1762 /* resolve_charlen will complain later on if the length
1763 is too large. Just skeep the initialization in that case. */
1764 if (mpz_cmp (sym
->ts
.u
.cl
->length
->value
.integer
,
1765 gfc_integer_kinds
[k
].huge
) <= 0)
1768 = gfc_mpz_get_hwi (sym
->ts
.u
.cl
->length
->value
.integer
);
1770 if (init
->expr_type
== EXPR_CONSTANT
)
1771 gfc_set_constant_character_len (len
, init
, -1);
1772 else if (init
->expr_type
== EXPR_ARRAY
)
1776 /* Build a new charlen to prevent simplification from
1777 deleting the length before it is resolved. */
1778 init
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1779 init
->ts
.u
.cl
->length
1780 = gfc_copy_expr (sym
->ts
.u
.cl
->length
);
1782 for (c
= gfc_constructor_first (init
->value
.constructor
);
1783 c
; c
= gfc_constructor_next (c
))
1784 gfc_set_constant_character_len (len
, c
->expr
, -1);
1790 /* If sym is implied-shape, set its upper bounds from init. */
1791 if (sym
->attr
.flavor
== FL_PARAMETER
&& sym
->attr
.dimension
1792 && sym
->as
->type
== AS_IMPLIED_SHAPE
)
1796 if (init
->rank
== 0)
1798 gfc_error ("Can't initialize implied-shape array at %L"
1799 " with scalar", &sym
->declared_at
);
1803 /* Shape should be present, we get an initialization expression. */
1804 gcc_assert (init
->shape
);
1806 for (dim
= 0; dim
< sym
->as
->rank
; ++dim
)
1809 gfc_expr
*e
, *lower
;
1811 lower
= sym
->as
->lower
[dim
];
1813 /* If the lower bound is an array element from another
1814 parameterized array, then it is marked with EXPR_VARIABLE and
1815 is an initialization expression. Try to reduce it. */
1816 if (lower
->expr_type
== EXPR_VARIABLE
)
1817 gfc_reduce_init_expr (lower
);
1819 if (lower
->expr_type
== EXPR_CONSTANT
)
1821 /* All dimensions must be without upper bound. */
1822 gcc_assert (!sym
->as
->upper
[dim
]);
1825 e
= gfc_get_constant_expr (BT_INTEGER
, k
, &sym
->declared_at
);
1826 mpz_add (e
->value
.integer
, lower
->value
.integer
,
1828 mpz_sub_ui (e
->value
.integer
, e
->value
.integer
, 1);
1829 sym
->as
->upper
[dim
] = e
;
1833 gfc_error ("Non-constant lower bound in implied-shape"
1834 " declaration at %L", &lower
->where
);
1839 sym
->as
->type
= AS_EXPLICIT
;
1842 /* Need to check if the expression we initialized this
1843 to was one of the iso_c_binding named constants. If so,
1844 and we're a parameter (constant), let it be iso_c.
1846 integer(c_int), parameter :: my_int = c_int
1847 integer(my_int) :: my_int_2
1848 If we mark my_int as iso_c (since we can see it's value
1849 is equal to one of the named constants), then my_int_2
1850 will be considered C interoperable. */
1851 if (sym
->ts
.type
!= BT_CHARACTER
&& !gfc_bt_struct (sym
->ts
.type
))
1853 sym
->ts
.is_iso_c
|= init
->ts
.is_iso_c
;
1854 sym
->ts
.is_c_interop
|= init
->ts
.is_c_interop
;
1855 /* attr bits needed for module files. */
1856 sym
->attr
.is_iso_c
|= init
->ts
.is_iso_c
;
1857 sym
->attr
.is_c_interop
|= init
->ts
.is_c_interop
;
1858 if (init
->ts
.is_iso_c
)
1859 sym
->ts
.f90_type
= init
->ts
.f90_type
;
1862 /* Add initializer. Make sure we keep the ranks sane. */
1863 if (sym
->attr
.dimension
&& init
->rank
== 0)
1868 if (sym
->attr
.flavor
== FL_PARAMETER
1869 && init
->expr_type
== EXPR_CONSTANT
1870 && spec_size (sym
->as
, &size
)
1871 && mpz_cmp_si (size
, 0) > 0)
1873 array
= gfc_get_array_expr (init
->ts
.type
, init
->ts
.kind
,
1875 for (n
= 0; n
< (int)mpz_get_si (size
); n
++)
1876 gfc_constructor_append_expr (&array
->value
.constructor
,
1879 : gfc_copy_expr (init
),
1882 array
->shape
= gfc_get_shape (sym
->as
->rank
);
1883 for (n
= 0; n
< sym
->as
->rank
; n
++)
1884 spec_dimen_size (sym
->as
, n
, &array
->shape
[n
]);
1889 init
->rank
= sym
->as
->rank
;
1893 if (sym
->attr
.save
== SAVE_NONE
)
1894 sym
->attr
.save
= SAVE_IMPLICIT
;
1902 /* Function called by variable_decl() that adds a name to a structure
1906 build_struct (const char *name
, gfc_charlen
*cl
, gfc_expr
**init
,
1907 gfc_array_spec
**as
)
1912 /* F03:C438/C439. If the current symbol is of the same derived type that we're
1913 constructing, it must have the pointer attribute. */
1914 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
1915 && current_ts
.u
.derived
== gfc_current_block ()
1916 && current_attr
.pointer
== 0)
1918 if (current_attr
.allocatable
1919 && !gfc_notify_std(GFC_STD_F2008
, "Component at %C "
1920 "must have the POINTER attribute"))
1924 else if (current_attr
.allocatable
== 0)
1926 gfc_error ("Component at %C must have the POINTER attribute");
1932 if (current_ts
.type
== BT_CLASS
1933 && !(current_attr
.pointer
|| current_attr
.allocatable
))
1935 gfc_error ("Component %qs with CLASS at %C must be allocatable "
1936 "or pointer", name
);
1940 if (gfc_current_block ()->attr
.pointer
&& (*as
)->rank
!= 0)
1942 if ((*as
)->type
!= AS_DEFERRED
&& (*as
)->type
!= AS_EXPLICIT
)
1944 gfc_error ("Array component of structure at %C must have explicit "
1945 "or deferred shape");
1950 /* If we are in a nested union/map definition, gfc_add_component will not
1951 properly find repeated components because:
1952 (i) gfc_add_component does a flat search, where components of unions
1953 and maps are implicity chained so nested components may conflict.
1954 (ii) Unions and maps are not linked as components of their parent
1955 structures until after they are parsed.
1956 For (i) we use gfc_find_component which searches recursively, and for (ii)
1957 we search each block directly from the parse stack until we find the top
1960 s
= gfc_state_stack
;
1961 if (s
->state
== COMP_UNION
|| s
->state
== COMP_MAP
)
1963 while (s
->state
== COMP_UNION
|| gfc_comp_struct (s
->state
))
1965 c
= gfc_find_component (s
->sym
, name
, true, true, NULL
);
1968 gfc_error_now ("Component %qs at %C already declared at %L",
1972 /* Break after we've searched the entire chain. */
1973 if (s
->state
== COMP_DERIVED
|| s
->state
== COMP_STRUCTURE
)
1979 if (!gfc_add_component (gfc_current_block(), name
, &c
))
1983 if (c
->ts
.type
== BT_CHARACTER
)
1986 if (c
->ts
.type
!= BT_CLASS
&& c
->ts
.type
!= BT_DERIVED
1987 && (c
->ts
.kind
== 0 || c
->ts
.type
== BT_CHARACTER
)
1988 && saved_kind_expr
!= NULL
)
1989 c
->kind_expr
= gfc_copy_expr (saved_kind_expr
);
1991 c
->attr
= current_attr
;
1993 c
->initializer
= *init
;
2000 c
->attr
.codimension
= 1;
2002 c
->attr
.dimension
= 1;
2006 gfc_apply_init (&c
->ts
, &c
->attr
, c
->initializer
);
2008 /* Check array components. */
2009 if (!c
->attr
.dimension
)
2012 if (c
->attr
.pointer
)
2014 if (c
->as
->type
!= AS_DEFERRED
)
2016 gfc_error ("Pointer array component of structure at %C must have a "
2021 else if (c
->attr
.allocatable
)
2023 if (c
->as
->type
!= AS_DEFERRED
)
2025 gfc_error ("Allocatable component of structure at %C must have a "
2032 if (c
->as
->type
!= AS_EXPLICIT
)
2034 gfc_error ("Array component of structure at %C must have an "
2041 if (c
->ts
.type
== BT_CLASS
)
2042 return gfc_build_class_symbol (&c
->ts
, &c
->attr
, &c
->as
);
2044 if (c
->attr
.pdt_kind
|| c
->attr
.pdt_len
)
2047 gfc_find_symbol (c
->name
, gfc_current_block ()->f2k_derived
,
2051 gfc_error ("Type parameter %qs at %C has no corresponding entry "
2052 "in the type parameter name list at %L",
2053 c
->name
, &gfc_current_block ()->declared_at
);
2057 sym
->attr
.pdt_kind
= c
->attr
.pdt_kind
;
2058 sym
->attr
.pdt_len
= c
->attr
.pdt_len
;
2060 sym
->value
= gfc_copy_expr (c
->initializer
);
2061 sym
->attr
.flavor
= FL_VARIABLE
;
2064 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
2065 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_template
2066 && decl_type_param_list
)
2067 c
->param_list
= gfc_copy_actual_arglist (decl_type_param_list
);
2073 /* Match a 'NULL()', and possibly take care of some side effects. */
2076 gfc_match_null (gfc_expr
**result
)
2079 match m
, m2
= MATCH_NO
;
2081 if ((m
= gfc_match (" null ( )")) == MATCH_ERROR
)
2087 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2089 if ((m2
= gfc_match (" null (")) != MATCH_YES
)
2092 old_loc
= gfc_current_locus
;
2093 if ((m2
= gfc_match (" %n ) ", name
)) == MATCH_ERROR
)
2096 && ((m2
= gfc_match (" mold = %n )", name
)) == MATCH_ERROR
))
2100 gfc_current_locus
= old_loc
;
2105 /* The NULL symbol now has to be/become an intrinsic function. */
2106 if (gfc_get_symbol ("null", NULL
, &sym
))
2108 gfc_error ("NULL() initialization at %C is ambiguous");
2112 gfc_intrinsic_symbol (sym
);
2114 if (sym
->attr
.proc
!= PROC_INTRINSIC
2115 && !(sym
->attr
.use_assoc
&& sym
->attr
.intrinsic
)
2116 && (!gfc_add_procedure(&sym
->attr
, PROC_INTRINSIC
, sym
->name
, NULL
)
2117 || !gfc_add_function (&sym
->attr
, sym
->name
, NULL
)))
2120 *result
= gfc_get_null_expr (&gfc_current_locus
);
2122 /* Invalid per F2008, C512. */
2123 if (m2
== MATCH_YES
)
2125 gfc_error ("NULL() initialization at %C may not have MOLD");
2133 /* Match the initialization expr for a data pointer or procedure pointer. */
2136 match_pointer_init (gfc_expr
**init
, int procptr
)
2140 if (gfc_pure (NULL
) && !gfc_comp_struct (gfc_state_stack
->state
))
2142 gfc_error ("Initialization of pointer at %C is not allowed in "
2143 "a PURE procedure");
2146 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
2148 /* Match NULL() initialization. */
2149 m
= gfc_match_null (init
);
2153 /* Match non-NULL initialization. */
2154 gfc_matching_ptr_assignment
= !procptr
;
2155 gfc_matching_procptr_assignment
= procptr
;
2156 m
= gfc_match_rvalue (init
);
2157 gfc_matching_ptr_assignment
= 0;
2158 gfc_matching_procptr_assignment
= 0;
2159 if (m
== MATCH_ERROR
)
2161 else if (m
== MATCH_NO
)
2163 gfc_error ("Error in pointer initialization at %C");
2167 if (!procptr
&& !gfc_resolve_expr (*init
))
2170 if (!gfc_notify_std (GFC_STD_F2008
, "non-NULL pointer "
2171 "initialization at %C"))
2179 check_function_name (char *name
)
2181 /* In functions that have a RESULT variable defined, the function name always
2182 refers to function calls. Therefore, the name is not allowed to appear in
2183 specification statements. When checking this, be careful about
2184 'hidden' procedure pointer results ('ppr@'). */
2186 if (gfc_current_state () == COMP_FUNCTION
)
2188 gfc_symbol
*block
= gfc_current_block ();
2189 if (block
&& block
->result
&& block
->result
!= block
2190 && strcmp (block
->result
->name
, "ppr@") != 0
2191 && strcmp (block
->name
, name
) == 0)
2193 gfc_error ("Function name %qs not allowed at %C", name
);
2202 /* Match a variable name with an optional initializer. When this
2203 subroutine is called, a variable is expected to be parsed next.
2204 Depending on what is happening at the moment, updates either the
2205 symbol table or the current interface. */
2208 variable_decl (int elem
)
2210 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2211 static unsigned int fill_id
= 0;
2212 gfc_expr
*initializer
, *char_len
;
2214 gfc_array_spec
*cp_as
; /* Extra copy for Cray Pointees. */
2226 /* When we get here, we've just matched a list of attributes and
2227 maybe a type and a double colon. The next thing we expect to see
2228 is the name of the symbol. */
2230 /* If we are parsing a structure with legacy support, we allow the symbol
2231 name to be '%FILL' which gives it an anonymous (inaccessible) name. */
2233 gfc_gobble_whitespace ();
2234 if (gfc_peek_ascii_char () == '%')
2236 gfc_next_ascii_char ();
2237 m
= gfc_match ("fill");
2242 m
= gfc_match_name (name
);
2250 if (gfc_current_state () != COMP_STRUCTURE
)
2252 if (flag_dec_structure
)
2253 gfc_error ("%qs not allowed outside STRUCTURE at %C", "%FILL");
2255 gfc_error ("%qs at %C is a DEC extension, enable with "
2256 "%<-fdec-structure%>", "%FILL");
2262 gfc_error ("%qs entity cannot have attributes at %C", "%FILL");
2266 /* %FILL components are given invalid fortran names. */
2267 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "%%FILL%u", fill_id
++);
2271 var_locus
= gfc_current_locus
;
2273 /* Now we could see the optional array spec. or character length. */
2274 m
= gfc_match_array_spec (&as
, true, true);
2275 if (m
== MATCH_ERROR
)
2279 as
= gfc_copy_array_spec (current_as
);
2281 && !merge_array_spec (current_as
, as
, true))
2287 if (flag_cray_pointer
)
2288 cp_as
= gfc_copy_array_spec (as
);
2290 /* At this point, we know for sure if the symbol is PARAMETER and can thus
2291 determine (and check) whether it can be implied-shape. If it
2292 was parsed as assumed-size, change it because PARAMETERs can not
2296 if (as
->type
== AS_IMPLIED_SHAPE
&& current_attr
.flavor
!= FL_PARAMETER
)
2299 gfc_error ("Non-PARAMETER symbol %qs at %L can't be implied-shape",
2304 if (as
->type
== AS_ASSUMED_SIZE
&& as
->rank
== 1
2305 && current_attr
.flavor
== FL_PARAMETER
)
2306 as
->type
= AS_IMPLIED_SHAPE
;
2308 if (as
->type
== AS_IMPLIED_SHAPE
2309 && !gfc_notify_std (GFC_STD_F2008
, "Implied-shape array at %L",
2319 cl_deferred
= false;
2321 if (current_ts
.type
== BT_CHARACTER
)
2323 switch (match_char_length (&char_len
, &cl_deferred
, false))
2326 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2328 cl
->length
= char_len
;
2331 /* Non-constant lengths need to be copied after the first
2332 element. Also copy assumed lengths. */
2335 && (current_ts
.u
.cl
->length
== NULL
2336 || current_ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
2338 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2339 cl
->length
= gfc_copy_expr (current_ts
.u
.cl
->length
);
2342 cl
= current_ts
.u
.cl
;
2344 cl_deferred
= current_ts
.deferred
;
2353 /* The dummy arguments and result of the abreviated form of MODULE
2354 PROCEDUREs, used in SUBMODULES should not be redefined. */
2355 if (gfc_current_ns
->proc_name
2356 && gfc_current_ns
->proc_name
->abr_modproc_decl
)
2358 gfc_find_symbol (name
, gfc_current_ns
, 1, &sym
);
2359 if (sym
!= NULL
&& (sym
->attr
.dummy
|| sym
->attr
.result
))
2362 gfc_error ("%qs at %C is a redefinition of the declaration "
2363 "in the corresponding interface for MODULE "
2364 "PROCEDURE %qs", sym
->name
,
2365 gfc_current_ns
->proc_name
->name
);
2370 /* %FILL components may not have initializers. */
2371 if (strncmp (name
, "%FILL", 5) == 0 && gfc_match_eos () != MATCH_YES
)
2373 gfc_error ("%qs entity cannot have an initializer at %C", "%FILL");
2378 /* If this symbol has already shown up in a Cray Pointer declaration,
2379 and this is not a component declaration,
2380 then we want to set the type & bail out. */
2381 if (flag_cray_pointer
&& !gfc_comp_struct (gfc_current_state ()))
2383 gfc_find_symbol (name
, gfc_current_ns
, 1, &sym
);
2384 if (sym
!= NULL
&& sym
->attr
.cray_pointee
)
2386 sym
->ts
.type
= current_ts
.type
;
2387 sym
->ts
.kind
= current_ts
.kind
;
2389 sym
->ts
.u
.derived
= current_ts
.u
.derived
;
2390 sym
->ts
.is_c_interop
= current_ts
.is_c_interop
;
2391 sym
->ts
.is_iso_c
= current_ts
.is_iso_c
;
2394 /* Check to see if we have an array specification. */
2397 if (sym
->as
!= NULL
)
2399 gfc_error ("Duplicate array spec for Cray pointee at %C");
2400 gfc_free_array_spec (cp_as
);
2406 if (!gfc_set_array_spec (sym
, cp_as
, &var_locus
))
2407 gfc_internal_error ("Couldn't set pointee array spec.");
2409 /* Fix the array spec. */
2410 m
= gfc_mod_pointee_as (sym
->as
);
2411 if (m
== MATCH_ERROR
)
2419 gfc_free_array_spec (cp_as
);
2423 /* Procedure pointer as function result. */
2424 if (gfc_current_state () == COMP_FUNCTION
2425 && strcmp ("ppr@", gfc_current_block ()->name
) == 0
2426 && strcmp (name
, gfc_current_block ()->ns
->proc_name
->name
) == 0)
2427 strcpy (name
, "ppr@");
2429 if (gfc_current_state () == COMP_FUNCTION
2430 && strcmp (name
, gfc_current_block ()->name
) == 0
2431 && gfc_current_block ()->result
2432 && strcmp ("ppr@", gfc_current_block ()->result
->name
) == 0)
2433 strcpy (name
, "ppr@");
2435 /* OK, we've successfully matched the declaration. Now put the
2436 symbol in the current namespace, because it might be used in the
2437 optional initialization expression for this symbol, e.g. this is
2440 integer, parameter :: i = huge(i)
2442 This is only true for parameters or variables of a basic type.
2443 For components of derived types, it is not true, so we don't
2444 create a symbol for those yet. If we fail to create the symbol,
2446 if (!gfc_comp_struct (gfc_current_state ())
2447 && !build_sym (name
, cl
, cl_deferred
, &as
, &var_locus
))
2453 if (!check_function_name (name
))
2459 /* We allow old-style initializations of the form
2460 integer i /2/, j(4) /3*3, 1/
2461 (if no colon has been seen). These are different from data
2462 statements in that initializers are only allowed to apply to the
2463 variable immediately preceding, i.e.
2465 is not allowed. Therefore we have to do some work manually, that
2466 could otherwise be left to the matchers for DATA statements. */
2468 if (!colon_seen
&& gfc_match (" /") == MATCH_YES
)
2470 if (!gfc_notify_std (GFC_STD_GNU
, "Old-style "
2471 "initialization at %C"))
2474 /* Allow old style initializations for components of STRUCTUREs and MAPs
2475 but not components of derived types. */
2476 else if (gfc_current_state () == COMP_DERIVED
)
2478 gfc_error ("Invalid old style initialization for derived type "
2484 /* For structure components, read the initializer as a special
2485 expression and let the rest of this function apply the initializer
2487 else if (gfc_comp_struct (gfc_current_state ()))
2489 m
= match_clist_expr (&initializer
, ¤t_ts
, as
);
2491 gfc_error ("Syntax error in old style initialization of %s at %C",
2497 /* Otherwise we treat the old style initialization just like a
2498 DATA declaration for the current variable. */
2500 return match_old_style_init (name
);
2503 /* The double colon must be present in order to have initializers.
2504 Otherwise the statement is ambiguous with an assignment statement. */
2507 if (gfc_match (" =>") == MATCH_YES
)
2509 if (!current_attr
.pointer
)
2511 gfc_error ("Initialization at %C isn't for a pointer variable");
2516 m
= match_pointer_init (&initializer
, 0);
2520 else if (gfc_match_char ('=') == MATCH_YES
)
2522 if (current_attr
.pointer
)
2524 gfc_error ("Pointer initialization at %C requires %<=>%>, "
2530 m
= gfc_match_init_expr (&initializer
);
2533 gfc_error ("Expected an initialization expression at %C");
2537 if (current_attr
.flavor
!= FL_PARAMETER
&& gfc_pure (NULL
)
2538 && !gfc_comp_struct (gfc_state_stack
->state
))
2540 gfc_error ("Initialization of variable at %C is not allowed in "
2541 "a PURE procedure");
2545 if (current_attr
.flavor
!= FL_PARAMETER
2546 && !gfc_comp_struct (gfc_state_stack
->state
))
2547 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
2554 if (initializer
!= NULL
&& current_attr
.allocatable
2555 && gfc_comp_struct (gfc_current_state ()))
2557 gfc_error ("Initialization of allocatable component at %C is not "
2563 if (gfc_current_state () == COMP_DERIVED
2564 && gfc_current_block ()->attr
.pdt_template
)
2567 gfc_find_symbol (name
, gfc_current_block ()->f2k_derived
,
2569 if (!param
&& (current_attr
.pdt_kind
|| current_attr
.pdt_len
))
2571 gfc_error ("The component with KIND or LEN attribute at %C does not "
2572 "not appear in the type parameter list at %L",
2573 &gfc_current_block ()->declared_at
);
2577 else if (param
&& !(current_attr
.pdt_kind
|| current_attr
.pdt_len
))
2579 gfc_error ("The component at %C that appears in the type parameter "
2580 "list at %L has neither the KIND nor LEN attribute",
2581 &gfc_current_block ()->declared_at
);
2585 else if (as
&& (current_attr
.pdt_kind
|| current_attr
.pdt_len
))
2587 gfc_error ("The component at %C which is a type parameter must be "
2592 else if (param
&& initializer
)
2593 param
->value
= gfc_copy_expr (initializer
);
2596 /* Add the initializer. Note that it is fine if initializer is
2597 NULL here, because we sometimes also need to check if a
2598 declaration *must* have an initialization expression. */
2599 if (!gfc_comp_struct (gfc_current_state ()))
2600 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
2603 if (current_ts
.type
== BT_DERIVED
2604 && !current_attr
.pointer
&& !initializer
)
2605 initializer
= gfc_default_initializer (¤t_ts
);
2606 t
= build_struct (name
, cl
, &initializer
, &as
);
2608 /* If we match a nested structure definition we expect to see the
2609 * body even if the variable declarations blow up, so we need to keep
2610 * the structure declaration around. */
2611 if (gfc_new_block
&& gfc_new_block
->attr
.flavor
== FL_STRUCT
)
2612 gfc_commit_symbol (gfc_new_block
);
2615 m
= (t
) ? MATCH_YES
: MATCH_ERROR
;
2618 /* Free stuff up and return. */
2619 gfc_free_expr (initializer
);
2620 gfc_free_array_spec (as
);
2626 /* Match an extended-f77 "TYPESPEC*bytesize"-style kind specification.
2627 This assumes that the byte size is equal to the kind number for
2628 non-COMPLEX types, and equal to twice the kind number for COMPLEX. */
2631 gfc_match_old_kind_spec (gfc_typespec
*ts
)
2636 if (gfc_match_char ('*') != MATCH_YES
)
2639 m
= gfc_match_small_literal_int (&ts
->kind
, NULL
);
2643 original_kind
= ts
->kind
;
2645 /* Massage the kind numbers for complex types. */
2646 if (ts
->type
== BT_COMPLEX
)
2650 gfc_error ("Old-style type declaration %s*%d not supported at %C",
2651 gfc_basic_typename (ts
->type
), original_kind
);
2658 if (ts
->type
== BT_INTEGER
&& ts
->kind
== 4 && flag_integer4_kind
== 8)
2661 if (ts
->type
== BT_REAL
|| ts
->type
== BT_COMPLEX
)
2665 if (flag_real4_kind
== 8)
2667 if (flag_real4_kind
== 10)
2669 if (flag_real4_kind
== 16)
2675 if (flag_real8_kind
== 4)
2677 if (flag_real8_kind
== 10)
2679 if (flag_real8_kind
== 16)
2684 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
2686 gfc_error ("Old-style type declaration %s*%d not supported at %C",
2687 gfc_basic_typename (ts
->type
), original_kind
);
2691 if (!gfc_notify_std (GFC_STD_GNU
,
2692 "Nonstandard type declaration %s*%d at %C",
2693 gfc_basic_typename(ts
->type
), original_kind
))
2700 /* Match a kind specification. Since kinds are generally optional, we
2701 usually return MATCH_NO if something goes wrong. If a "kind="
2702 string is found, then we know we have an error. */
2705 gfc_match_kind_spec (gfc_typespec
*ts
, bool kind_expr_only
)
2715 saved_kind_expr
= NULL
;
2717 where
= loc
= gfc_current_locus
;
2722 if (gfc_match_char ('(') == MATCH_NO
)
2725 /* Also gobbles optional text. */
2726 if (gfc_match (" kind = ") == MATCH_YES
)
2729 loc
= gfc_current_locus
;
2733 n
= gfc_match_init_expr (&e
);
2735 if (gfc_derived_parameter_expr (e
))
2738 saved_kind_expr
= gfc_copy_expr (e
);
2739 goto close_brackets
;
2744 if (gfc_matching_function
)
2746 /* The function kind expression might include use associated or
2747 imported parameters and try again after the specification
2749 if (gfc_match_char (')') != MATCH_YES
)
2751 gfc_error ("Missing right parenthesis at %C");
2757 gfc_undo_symbols ();
2762 /* ....or else, the match is real. */
2764 gfc_error ("Expected initialization expression at %C");
2772 gfc_error ("Expected scalar initialization expression at %C");
2777 if (gfc_extract_int (e
, &ts
->kind
, 1))
2783 /* Before throwing away the expression, let's see if we had a
2784 C interoperable kind (and store the fact). */
2785 if (e
->ts
.is_c_interop
== 1)
2787 /* Mark this as C interoperable if being declared with one
2788 of the named constants from iso_c_binding. */
2789 ts
->is_c_interop
= e
->ts
.is_iso_c
;
2790 ts
->f90_type
= e
->ts
.f90_type
;
2792 ts
->interop_kind
= e
->symtree
->n
.sym
;
2798 /* Ignore errors to this point, if we've gotten here. This means
2799 we ignore the m=MATCH_ERROR from above. */
2800 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
2802 gfc_error ("Kind %d not supported for type %s at %C", ts
->kind
,
2803 gfc_basic_typename (ts
->type
));
2804 gfc_current_locus
= where
;
2808 /* Warn if, e.g., c_int is used for a REAL variable, but not
2809 if, e.g., c_double is used for COMPLEX as the standard
2810 explicitly says that the kind type parameter for complex and real
2811 variable is the same, i.e. c_float == c_float_complex. */
2812 if (ts
->f90_type
!= BT_UNKNOWN
&& ts
->f90_type
!= ts
->type
2813 && !((ts
->f90_type
== BT_REAL
&& ts
->type
== BT_COMPLEX
)
2814 || (ts
->f90_type
== BT_COMPLEX
&& ts
->type
== BT_REAL
)))
2815 gfc_warning_now (0, "C kind type parameter is for type %s but type at %L "
2816 "is %s", gfc_basic_typename (ts
->f90_type
), &where
,
2817 gfc_basic_typename (ts
->type
));
2821 gfc_gobble_whitespace ();
2822 if ((c
= gfc_next_ascii_char ()) != ')'
2823 && (ts
->type
!= BT_CHARACTER
|| c
!= ','))
2825 if (ts
->type
== BT_CHARACTER
)
2826 gfc_error ("Missing right parenthesis or comma at %C");
2828 gfc_error ("Missing right parenthesis at %C");
2832 /* All tests passed. */
2835 if(m
== MATCH_ERROR
)
2836 gfc_current_locus
= where
;
2838 if (ts
->type
== BT_INTEGER
&& ts
->kind
== 4 && flag_integer4_kind
== 8)
2841 if (ts
->type
== BT_REAL
|| ts
->type
== BT_COMPLEX
)
2845 if (flag_real4_kind
== 8)
2847 if (flag_real4_kind
== 10)
2849 if (flag_real4_kind
== 16)
2855 if (flag_real8_kind
== 4)
2857 if (flag_real8_kind
== 10)
2859 if (flag_real8_kind
== 16)
2864 /* Return what we know from the test(s). */
2869 gfc_current_locus
= where
;
2875 match_char_kind (int * kind
, int * is_iso_c
)
2884 where
= gfc_current_locus
;
2886 n
= gfc_match_init_expr (&e
);
2888 if (n
!= MATCH_YES
&& gfc_matching_function
)
2890 /* The expression might include use-associated or imported
2891 parameters and try again after the specification
2894 gfc_undo_symbols ();
2899 gfc_error ("Expected initialization expression at %C");
2905 gfc_error ("Expected scalar initialization expression at %C");
2910 if (gfc_derived_parameter_expr (e
))
2912 saved_kind_expr
= e
;
2917 fail
= gfc_extract_int (e
, kind
, 1);
2918 *is_iso_c
= e
->ts
.is_iso_c
;
2927 /* Ignore errors to this point, if we've gotten here. This means
2928 we ignore the m=MATCH_ERROR from above. */
2929 if (gfc_validate_kind (BT_CHARACTER
, *kind
, true) < 0)
2931 gfc_error ("Kind %d is not supported for CHARACTER at %C", *kind
);
2935 /* All tests passed. */
2938 if (m
== MATCH_ERROR
)
2939 gfc_current_locus
= where
;
2941 /* Return what we know from the test(s). */
2946 gfc_current_locus
= where
;
2951 /* Match the various kind/length specifications in a CHARACTER
2952 declaration. We don't return MATCH_NO. */
2955 gfc_match_char_spec (gfc_typespec
*ts
)
2957 int kind
, seen_length
, is_iso_c
;
2969 /* Try the old-style specification first. */
2970 old_char_selector
= 0;
2972 m
= match_char_length (&len
, &deferred
, true);
2976 old_char_selector
= 1;
2981 m
= gfc_match_char ('(');
2984 m
= MATCH_YES
; /* Character without length is a single char. */
2988 /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ). */
2989 if (gfc_match (" kind =") == MATCH_YES
)
2991 m
= match_char_kind (&kind
, &is_iso_c
);
2993 if (m
== MATCH_ERROR
)
2998 if (gfc_match (" , len =") == MATCH_NO
)
3001 m
= char_len_param_value (&len
, &deferred
);
3004 if (m
== MATCH_ERROR
)
3011 /* Try to match "LEN = <len-param>" or "LEN = <len-param>, KIND = <int>". */
3012 if (gfc_match (" len =") == MATCH_YES
)
3014 m
= char_len_param_value (&len
, &deferred
);
3017 if (m
== MATCH_ERROR
)
3021 if (gfc_match_char (')') == MATCH_YES
)
3024 if (gfc_match (" , kind =") != MATCH_YES
)
3027 if (match_char_kind (&kind
, &is_iso_c
) == MATCH_ERROR
)
3033 /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ). */
3034 m
= char_len_param_value (&len
, &deferred
);
3037 if (m
== MATCH_ERROR
)
3041 m
= gfc_match_char (')');
3045 if (gfc_match_char (',') != MATCH_YES
)
3048 gfc_match (" kind ="); /* Gobble optional text. */
3050 m
= match_char_kind (&kind
, &is_iso_c
);
3051 if (m
== MATCH_ERROR
)
3057 /* Require a right-paren at this point. */
3058 m
= gfc_match_char (')');
3063 gfc_error ("Syntax error in CHARACTER declaration at %C");
3065 gfc_free_expr (len
);
3069 /* Deal with character functions after USE and IMPORT statements. */
3070 if (gfc_matching_function
)
3072 gfc_free_expr (len
);
3073 gfc_undo_symbols ();
3079 gfc_free_expr (len
);
3083 /* Do some final massaging of the length values. */
3084 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
3086 if (seen_length
== 0)
3087 cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
, 1);
3092 ts
->kind
= kind
== 0 ? gfc_default_character_kind
: kind
;
3093 ts
->deferred
= deferred
;
3095 /* We have to know if it was a C interoperable kind so we can
3096 do accurate type checking of bind(c) procs, etc. */
3098 /* Mark this as C interoperable if being declared with one
3099 of the named constants from iso_c_binding. */
3100 ts
->is_c_interop
= is_iso_c
;
3101 else if (len
!= NULL
)
3102 /* Here, we might have parsed something such as: character(c_char)
3103 In this case, the parsing code above grabs the c_char when
3104 looking for the length (line 1690, roughly). it's the last
3105 testcase for parsing the kind params of a character variable.
3106 However, it's not actually the length. this seems like it
3108 To see if the user used a C interop kind, test the expr
3109 of the so called length, and see if it's C interoperable. */
3110 ts
->is_c_interop
= len
->ts
.is_iso_c
;
3116 /* Matches a RECORD declaration. */
3119 match_record_decl (char *name
)
3122 old_loc
= gfc_current_locus
;
3125 m
= gfc_match (" record /");
3128 if (!flag_dec_structure
)
3130 gfc_current_locus
= old_loc
;
3131 gfc_error ("RECORD at %C is an extension, enable it with "
3135 m
= gfc_match (" %n/", name
);
3140 gfc_current_locus
= old_loc
;
3141 if (flag_dec_structure
3142 && (gfc_match (" record% ") == MATCH_YES
3143 || gfc_match (" record%t") == MATCH_YES
))
3144 gfc_error ("Structure name expected after RECORD at %C");
3152 /* This function uses the gfc_actual_arglist 'type_param_spec_list' as a source
3153 of expressions to substitute into the possibly parameterized expression
3154 'e'. Using a list is inefficient but should not be too bad since the
3155 number of type parameters is not likely to be large. */
3157 insert_parameter_exprs (gfc_expr
* e
, gfc_symbol
* sym ATTRIBUTE_UNUSED
,
3160 gfc_actual_arglist
*param
;
3163 if (e
->expr_type
!= EXPR_VARIABLE
)
3166 gcc_assert (e
->symtree
);
3167 if (e
->symtree
->n
.sym
->attr
.pdt_kind
3168 || (*f
!= 0 && e
->symtree
->n
.sym
->attr
.pdt_len
))
3170 for (param
= type_param_spec_list
; param
; param
= param
->next
)
3171 if (strcmp (e
->symtree
->n
.sym
->name
, param
->name
) == 0)
3176 copy
= gfc_copy_expr (param
->expr
);
3187 gfc_insert_kind_parameter_exprs (gfc_expr
*e
)
3189 return gfc_traverse_expr (e
, NULL
, &insert_parameter_exprs
, 0);
3194 gfc_insert_parameter_exprs (gfc_expr
*e
, gfc_actual_arglist
*param_list
)
3196 gfc_actual_arglist
*old_param_spec_list
= type_param_spec_list
;
3197 type_param_spec_list
= param_list
;
3198 return gfc_traverse_expr (e
, NULL
, &insert_parameter_exprs
, 1);
3199 type_param_spec_list
= NULL
;
3200 type_param_spec_list
= old_param_spec_list
;
3203 /* Determines the instance of a parameterized derived type to be used by
3204 matching determining the values of the kind parameters and using them
3205 in the name of the instance. If the instance exists, it is used, otherwise
3206 a new derived type is created. */
3208 gfc_get_pdt_instance (gfc_actual_arglist
*param_list
, gfc_symbol
**sym
,
3209 gfc_actual_arglist
**ext_param_list
)
3211 /* The PDT template symbol. */
3212 gfc_symbol
*pdt
= *sym
;
3213 /* The symbol for the parameter in the template f2k_namespace. */
3215 /* The hoped for instance of the PDT. */
3216 gfc_symbol
*instance
;
3217 /* The list of parameters appearing in the PDT declaration. */
3218 gfc_formal_arglist
*type_param_name_list
;
3219 /* Used to store the parameter specification list during recursive calls. */
3220 gfc_actual_arglist
*old_param_spec_list
;
3221 /* Pointers to the parameter specification being used. */
3222 gfc_actual_arglist
*actual_param
;
3223 gfc_actual_arglist
*tail
= NULL
;
3224 /* Used to build up the name of the PDT instance. The prefix uses 4
3225 characters and each KIND parameter 2 more. Allow 8 of the latter. */
3226 char name
[GFC_MAX_SYMBOL_LEN
+ 21];
3228 bool name_seen
= (param_list
== NULL
);
3229 bool assumed_seen
= false;
3230 bool deferred_seen
= false;
3231 bool spec_error
= false;
3233 gfc_expr
*kind_expr
;
3234 gfc_component
*c1
, *c2
;
3237 type_param_spec_list
= NULL
;
3239 type_param_name_list
= pdt
->formal
;
3240 actual_param
= param_list
;
3241 sprintf (name
, "Pdt%s", pdt
->name
);
3243 /* Run through the parameter name list and pick up the actual
3244 parameter values or use the default values in the PDT declaration. */
3245 for (; type_param_name_list
;
3246 type_param_name_list
= type_param_name_list
->next
)
3248 if (actual_param
&& actual_param
->spec_type
!= SPEC_EXPLICIT
)
3250 if (actual_param
->spec_type
== SPEC_ASSUMED
)
3251 spec_error
= deferred_seen
;
3253 spec_error
= assumed_seen
;
3257 gfc_error ("The type parameter spec list at %C cannot contain "
3258 "both ASSUMED and DEFERRED parameters");
3263 if (actual_param
&& actual_param
->name
)
3265 param
= type_param_name_list
->sym
;
3267 if (!param
|| !param
->name
)
3270 c1
= gfc_find_component (pdt
, param
->name
, false, true, NULL
);
3271 /* An error should already have been thrown in resolve.c
3272 (resolve_fl_derived0). */
3273 if (!pdt
->attr
.use_assoc
&& !c1
)
3279 if (!actual_param
&& !(c1
&& c1
->initializer
))
3281 gfc_error ("The type parameter spec list at %C does not contain "
3282 "enough parameter expressions");
3285 else if (!actual_param
&& c1
&& c1
->initializer
)
3286 kind_expr
= gfc_copy_expr (c1
->initializer
);
3287 else if (actual_param
&& actual_param
->spec_type
== SPEC_EXPLICIT
)
3288 kind_expr
= gfc_copy_expr (actual_param
->expr
);
3292 actual_param
= param_list
;
3293 for (;actual_param
; actual_param
= actual_param
->next
)
3294 if (actual_param
->name
3295 && strcmp (actual_param
->name
, param
->name
) == 0)
3297 if (actual_param
&& actual_param
->spec_type
== SPEC_EXPLICIT
)
3298 kind_expr
= gfc_copy_expr (actual_param
->expr
);
3301 if (c1
->initializer
)
3302 kind_expr
= gfc_copy_expr (c1
->initializer
);
3303 else if (!(actual_param
&& param
->attr
.pdt_len
))
3305 gfc_error ("The derived parameter '%qs' at %C does not "
3306 "have a default value", param
->name
);
3312 /* Store the current parameter expressions in a temporary actual
3313 arglist 'list' so that they can be substituted in the corresponding
3314 expressions in the PDT instance. */
3315 if (type_param_spec_list
== NULL
)
3317 type_param_spec_list
= gfc_get_actual_arglist ();
3318 tail
= type_param_spec_list
;
3322 tail
->next
= gfc_get_actual_arglist ();
3325 tail
->name
= param
->name
;
3329 /* Try simplification even for LEN expressions. */
3330 gfc_resolve_expr (kind_expr
);
3331 gfc_simplify_expr (kind_expr
, 1);
3332 /* Variable expressions seem to default to BT_PROCEDURE.
3333 TODO find out why this is and fix it. */
3334 if (kind_expr
->ts
.type
!= BT_INTEGER
3335 && kind_expr
->ts
.type
!= BT_PROCEDURE
)
3337 gfc_error ("The parameter expression at %C must be of "
3338 "INTEGER type and not %s type",
3339 gfc_basic_typename (kind_expr
->ts
.type
));
3343 tail
->expr
= gfc_copy_expr (kind_expr
);
3347 tail
->spec_type
= actual_param
->spec_type
;
3349 if (!param
->attr
.pdt_kind
)
3351 if (!name_seen
&& actual_param
)
3352 actual_param
= actual_param
->next
;
3355 gfc_free_expr (kind_expr
);
3362 && (actual_param
->spec_type
== SPEC_ASSUMED
3363 || actual_param
->spec_type
== SPEC_DEFERRED
))
3365 gfc_error ("The KIND parameter '%qs' at %C cannot either be "
3366 "ASSUMED or DEFERRED", param
->name
);
3370 if (!kind_expr
|| !gfc_is_constant_expr (kind_expr
))
3372 gfc_error ("The value for the KIND parameter '%qs' at %C does not "
3373 "reduce to a constant expression", param
->name
);
3377 gfc_extract_int (kind_expr
, &kind_value
);
3378 sprintf (name
+ strlen (name
), "_%d", kind_value
);
3380 if (!name_seen
&& actual_param
)
3381 actual_param
= actual_param
->next
;
3382 gfc_free_expr (kind_expr
);
3385 if (!name_seen
&& actual_param
)
3387 gfc_error ("The type parameter spec list at %C contains too many "
3388 "parameter expressions");
3392 /* Now we search for the PDT instance 'name'. If it doesn't exist, we
3393 build it, using 'pdt' as a template. */
3394 if (gfc_get_symbol (name
, pdt
->ns
, &instance
))
3396 gfc_error ("Parameterized derived type at %C is ambiguous");
3402 if (instance
->attr
.flavor
== FL_DERIVED
3403 && instance
->attr
.pdt_type
)
3407 *ext_param_list
= type_param_spec_list
;
3409 gfc_commit_symbols ();
3413 /* Start building the new instance of the parameterized type. */
3414 gfc_copy_attr (&instance
->attr
, &pdt
->attr
, &pdt
->declared_at
);
3415 instance
->attr
.pdt_template
= 0;
3416 instance
->attr
.pdt_type
= 1;
3417 instance
->declared_at
= gfc_current_locus
;
3419 /* Add the components, replacing the parameters in all expressions
3420 with the expressions for their values in 'type_param_spec_list'. */
3421 c1
= pdt
->components
;
3422 tail
= type_param_spec_list
;
3423 for (; c1
; c1
= c1
->next
)
3425 gfc_add_component (instance
, c1
->name
, &c2
);
3428 c2
->attr
= c1
->attr
;
3430 /* The order of declaration of the type_specs might not be the
3431 same as that of the components. */
3432 if (c1
->attr
.pdt_kind
|| c1
->attr
.pdt_len
)
3434 for (tail
= type_param_spec_list
; tail
; tail
= tail
->next
)
3435 if (strcmp (c1
->name
, tail
->name
) == 0)
3439 /* Deal with type extension by recursively calling this function
3440 to obtain the instance of the extended type. */
3441 if (gfc_current_state () != COMP_DERIVED
3442 && c1
== pdt
->components
3443 && (c1
->ts
.type
== BT_DERIVED
|| c1
->ts
.type
== BT_CLASS
)
3444 && c1
->ts
.u
.derived
&& c1
->ts
.u
.derived
->attr
.pdt_template
3445 && gfc_get_derived_super_type (*sym
) == c2
->ts
.u
.derived
)
3447 gfc_formal_arglist
*f
;
3449 old_param_spec_list
= type_param_spec_list
;
3451 /* Obtain a spec list appropriate to the extended type..*/
3452 actual_param
= gfc_copy_actual_arglist (type_param_spec_list
);
3453 type_param_spec_list
= actual_param
;
3454 for (f
= c1
->ts
.u
.derived
->formal
; f
&& f
->next
; f
= f
->next
)
3455 actual_param
= actual_param
->next
;
3458 gfc_free_actual_arglist (actual_param
->next
);
3459 actual_param
->next
= NULL
;
3462 /* Now obtain the PDT instance for the extended type. */
3463 c2
->param_list
= type_param_spec_list
;
3464 m
= gfc_get_pdt_instance (type_param_spec_list
, &c2
->ts
.u
.derived
,
3466 type_param_spec_list
= old_param_spec_list
;
3468 c2
->ts
.u
.derived
->refs
++;
3469 gfc_set_sym_referenced (c2
->ts
.u
.derived
);
3471 /* Set extension level. */
3472 if (c2
->ts
.u
.derived
->attr
.extension
== 255)
3474 /* Since the extension field is 8 bit wide, we can only have
3475 up to 255 extension levels. */
3476 gfc_error ("Maximum extension level reached with type %qs at %L",
3477 c2
->ts
.u
.derived
->name
,
3478 &c2
->ts
.u
.derived
->declared_at
);
3481 instance
->attr
.extension
= c2
->ts
.u
.derived
->attr
.extension
+ 1;
3486 /* Set the component kind using the parameterized expression. */
3487 if ((c1
->ts
.kind
== 0 || c1
->ts
.type
== BT_CHARACTER
)
3488 && c1
->kind_expr
!= NULL
)
3490 gfc_expr
*e
= gfc_copy_expr (c1
->kind_expr
);
3491 gfc_insert_kind_parameter_exprs (e
);
3492 gfc_simplify_expr (e
, 1);
3493 gfc_extract_int (e
, &c2
->ts
.kind
);
3495 if (gfc_validate_kind (c2
->ts
.type
, c2
->ts
.kind
, true) < 0)
3497 gfc_error ("Kind %d not supported for type %s at %C",
3498 c2
->ts
.kind
, gfc_basic_typename (c2
->ts
.type
));
3503 /* Similarly, set the string length if parameterized. */
3504 if (c1
->ts
.type
== BT_CHARACTER
3505 && c1
->ts
.u
.cl
->length
3506 && gfc_derived_parameter_expr (c1
->ts
.u
.cl
->length
))
3509 e
= gfc_copy_expr (c1
->ts
.u
.cl
->length
);
3510 gfc_insert_kind_parameter_exprs (e
);
3511 gfc_simplify_expr (e
, 1);
3512 c2
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
3513 c2
->ts
.u
.cl
->length
= e
;
3514 c2
->attr
.pdt_string
= 1;
3517 /* Set up either the KIND/LEN initializer, if constant,
3518 or the parameterized expression. Use the template
3519 initializer if one is not already set in this instance. */
3520 if (c2
->attr
.pdt_kind
|| c2
->attr
.pdt_len
)
3522 if (tail
&& tail
->expr
&& gfc_is_constant_expr (tail
->expr
))
3523 c2
->initializer
= gfc_copy_expr (tail
->expr
);
3524 else if (tail
&& tail
->expr
)
3526 c2
->param_list
= gfc_get_actual_arglist ();
3527 c2
->param_list
->name
= tail
->name
;
3528 c2
->param_list
->expr
= gfc_copy_expr (tail
->expr
);
3529 c2
->param_list
->next
= NULL
;
3532 if (!c2
->initializer
&& c1
->initializer
)
3533 c2
->initializer
= gfc_copy_expr (c1
->initializer
);
3536 /* Copy the array spec. */
3537 c2
->as
= gfc_copy_array_spec (c1
->as
);
3538 if (c1
->ts
.type
== BT_CLASS
)
3539 CLASS_DATA (c2
)->as
= gfc_copy_array_spec (CLASS_DATA (c1
)->as
);
3541 /* Determine if an array spec is parameterized. If so, substitute
3542 in the parameter expressions for the bounds and set the pdt_array
3543 attribute. Notice that this attribute must be unconditionally set
3544 if this is an array of parameterized character length. */
3545 if (c1
->as
&& c1
->as
->type
== AS_EXPLICIT
)
3547 bool pdt_array
= false;
3549 /* Are the bounds of the array parameterized? */
3550 for (i
= 0; i
< c1
->as
->rank
; i
++)
3552 if (gfc_derived_parameter_expr (c1
->as
->lower
[i
]))
3554 if (gfc_derived_parameter_expr (c1
->as
->upper
[i
]))
3558 /* If they are, free the expressions for the bounds and
3559 replace them with the template expressions with substitute
3561 for (i
= 0; pdt_array
&& i
< c1
->as
->rank
; i
++)
3564 e
= gfc_copy_expr (c1
->as
->lower
[i
]);
3565 gfc_insert_kind_parameter_exprs (e
);
3566 gfc_simplify_expr (e
, 1);
3567 gfc_free_expr (c2
->as
->lower
[i
]);
3568 c2
->as
->lower
[i
] = e
;
3569 e
= gfc_copy_expr (c1
->as
->upper
[i
]);
3570 gfc_insert_kind_parameter_exprs (e
);
3571 gfc_simplify_expr (e
, 1);
3572 gfc_free_expr (c2
->as
->upper
[i
]);
3573 c2
->as
->upper
[i
] = e
;
3575 c2
->attr
.pdt_array
= pdt_array
? 1 : c2
->attr
.pdt_string
;
3576 if (c1
->initializer
)
3578 c2
->initializer
= gfc_copy_expr (c1
->initializer
);
3579 gfc_insert_kind_parameter_exprs (c2
->initializer
);
3580 gfc_simplify_expr (c2
->initializer
, 1);
3584 /* Recurse into this function for PDT components. */
3585 if ((c1
->ts
.type
== BT_DERIVED
|| c1
->ts
.type
== BT_CLASS
)
3586 && c1
->ts
.u
.derived
&& c1
->ts
.u
.derived
->attr
.pdt_template
)
3588 gfc_actual_arglist
*params
;
3589 /* The component in the template has a list of specification
3590 expressions derived from its declaration. */
3591 params
= gfc_copy_actual_arglist (c1
->param_list
);
3592 actual_param
= params
;
3593 /* Substitute the template parameters with the expressions
3594 from the specification list. */
3595 for (;actual_param
; actual_param
= actual_param
->next
)
3596 gfc_insert_parameter_exprs (actual_param
->expr
,
3597 type_param_spec_list
);
3599 /* Now obtain the PDT instance for the component. */
3600 old_param_spec_list
= type_param_spec_list
;
3601 m
= gfc_get_pdt_instance (params
, &c2
->ts
.u
.derived
, NULL
);
3602 type_param_spec_list
= old_param_spec_list
;
3604 c2
->param_list
= params
;
3605 if (!(c2
->attr
.pointer
|| c2
->attr
.allocatable
))
3606 c2
->initializer
= gfc_default_initializer (&c2
->ts
);
3608 if (c2
->attr
.allocatable
)
3609 instance
->attr
.alloc_comp
= 1;
3613 gfc_commit_symbol (instance
);
3615 *ext_param_list
= type_param_spec_list
;
3620 gfc_free_actual_arglist (type_param_spec_list
);
3625 /* Matches a declaration-type-spec (F03:R502). If successful, sets the ts
3626 structure to the matched specification. This is necessary for FUNCTION and
3627 IMPLICIT statements.
3629 If implicit_flag is nonzero, then we don't check for the optional
3630 kind specification. Not doing so is needed for matching an IMPLICIT
3631 statement correctly. */
3634 gfc_match_decl_type_spec (gfc_typespec
*ts
, int implicit_flag
)
3636 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3637 gfc_symbol
*sym
, *dt_sym
;
3640 bool seen_deferred_kind
, matched_type
;
3641 const char *dt_name
;
3643 decl_type_param_list
= NULL
;
3645 /* A belt and braces check that the typespec is correctly being treated
3646 as a deferred characteristic association. */
3647 seen_deferred_kind
= (gfc_current_state () == COMP_FUNCTION
)
3648 && (gfc_current_block ()->result
->ts
.kind
== -1)
3649 && (ts
->kind
== -1);
3651 if (seen_deferred_kind
)
3654 /* Clear the current binding label, in case one is given. */
3655 curr_binding_label
= NULL
;
3657 if (gfc_match (" byte") == MATCH_YES
)
3659 if (!gfc_notify_std (GFC_STD_GNU
, "BYTE type at %C"))
3662 if (gfc_validate_kind (BT_INTEGER
, 1, true) < 0)
3664 gfc_error ("BYTE type used at %C "
3665 "is not available on the target machine");
3669 ts
->type
= BT_INTEGER
;
3675 m
= gfc_match (" type (");
3676 matched_type
= (m
== MATCH_YES
);
3679 gfc_gobble_whitespace ();
3680 if (gfc_peek_ascii_char () == '*')
3682 if ((m
= gfc_match ("*)")) != MATCH_YES
)
3684 if (gfc_comp_struct (gfc_current_state ()))
3686 gfc_error ("Assumed type at %C is not allowed for components");
3689 if (!gfc_notify_std (GFC_STD_F2008_TS
, "Assumed type "
3692 ts
->type
= BT_ASSUMED
;
3696 m
= gfc_match ("%n", name
);
3697 matched_type
= (m
== MATCH_YES
);
3700 if ((matched_type
&& strcmp ("integer", name
) == 0)
3701 || (!matched_type
&& gfc_match (" integer") == MATCH_YES
))
3703 ts
->type
= BT_INTEGER
;
3704 ts
->kind
= gfc_default_integer_kind
;
3708 if ((matched_type
&& strcmp ("character", name
) == 0)
3709 || (!matched_type
&& gfc_match (" character") == MATCH_YES
))
3712 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
3713 "intrinsic-type-spec at %C"))
3716 ts
->type
= BT_CHARACTER
;
3717 if (implicit_flag
== 0)
3718 m
= gfc_match_char_spec (ts
);
3722 if (matched_type
&& m
== MATCH_YES
&& gfc_match_char (')') != MATCH_YES
)
3728 if ((matched_type
&& strcmp ("real", name
) == 0)
3729 || (!matched_type
&& gfc_match (" real") == MATCH_YES
))
3732 ts
->kind
= gfc_default_real_kind
;
3737 && (strcmp ("doubleprecision", name
) == 0
3738 || (strcmp ("double", name
) == 0
3739 && gfc_match (" precision") == MATCH_YES
)))
3740 || (!matched_type
&& gfc_match (" double precision") == MATCH_YES
))
3743 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
3744 "intrinsic-type-spec at %C"))
3746 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
3750 ts
->kind
= gfc_default_double_kind
;
3754 if ((matched_type
&& strcmp ("complex", name
) == 0)
3755 || (!matched_type
&& gfc_match (" complex") == MATCH_YES
))
3757 ts
->type
= BT_COMPLEX
;
3758 ts
->kind
= gfc_default_complex_kind
;
3763 && (strcmp ("doublecomplex", name
) == 0
3764 || (strcmp ("double", name
) == 0
3765 && gfc_match (" complex") == MATCH_YES
)))
3766 || (!matched_type
&& gfc_match (" double complex") == MATCH_YES
))
3768 if (!gfc_notify_std (GFC_STD_GNU
, "DOUBLE COMPLEX at %C"))
3772 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
3773 "intrinsic-type-spec at %C"))
3776 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
3779 ts
->type
= BT_COMPLEX
;
3780 ts
->kind
= gfc_default_double_kind
;
3784 if ((matched_type
&& strcmp ("logical", name
) == 0)
3785 || (!matched_type
&& gfc_match (" logical") == MATCH_YES
))
3787 ts
->type
= BT_LOGICAL
;
3788 ts
->kind
= gfc_default_logical_kind
;
3794 m
= gfc_match_actual_arglist (1, &decl_type_param_list
, true);
3795 if (m
== MATCH_ERROR
)
3798 m
= gfc_match_char (')');
3802 m
= match_record_decl (name
);
3804 if (matched_type
|| m
== MATCH_YES
)
3806 ts
->type
= BT_DERIVED
;
3807 /* We accept record/s/ or type(s) where s is a structure, but we
3808 * don't need all the extra derived-type stuff for structures. */
3809 if (gfc_find_symbol (gfc_dt_upper_string (name
), NULL
, 1, &sym
))
3811 gfc_error ("Type name %qs at %C is ambiguous", name
);
3815 if (sym
&& sym
->attr
.flavor
== FL_DERIVED
3816 && sym
->attr
.pdt_template
3817 && gfc_current_state () != COMP_DERIVED
)
3819 m
= gfc_get_pdt_instance (decl_type_param_list
, &sym
, NULL
);
3822 gcc_assert (!sym
->attr
.pdt_template
&& sym
->attr
.pdt_type
);
3823 ts
->u
.derived
= sym
;
3824 strcpy (name
, gfc_dt_lower_string (sym
->name
));
3827 if (sym
&& sym
->attr
.flavor
== FL_STRUCT
)
3829 ts
->u
.derived
= sym
;
3832 /* Actually a derived type. */
3837 /* Match nested STRUCTURE declarations; only valid within another
3838 structure declaration. */
3839 if (flag_dec_structure
3840 && (gfc_current_state () == COMP_STRUCTURE
3841 || gfc_current_state () == COMP_MAP
))
3843 m
= gfc_match (" structure");
3846 m
= gfc_match_structure_decl ();
3849 /* gfc_new_block is updated by match_structure_decl. */
3850 ts
->type
= BT_DERIVED
;
3851 ts
->u
.derived
= gfc_new_block
;
3855 if (m
== MATCH_ERROR
)
3859 /* Match CLASS declarations. */
3860 m
= gfc_match (" class ( * )");
3861 if (m
== MATCH_ERROR
)
3863 else if (m
== MATCH_YES
)
3867 ts
->type
= BT_CLASS
;
3868 gfc_find_symbol ("STAR", gfc_current_ns
, 1, &upe
);
3871 upe
= gfc_new_symbol ("STAR", gfc_current_ns
);
3872 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "STAR");
3874 gfc_set_sym_referenced (upe
);
3876 upe
->ts
.type
= BT_VOID
;
3877 upe
->attr
.unlimited_polymorphic
= 1;
3878 /* This is essential to force the construction of
3879 unlimited polymorphic component class containers. */
3880 upe
->attr
.zero_comp
= 1;
3881 if (!gfc_add_flavor (&upe
->attr
, FL_DERIVED
, NULL
,
3882 &gfc_current_locus
))
3887 st
= gfc_get_tbp_symtree (&gfc_current_ns
->sym_root
, "STAR");
3891 ts
->u
.derived
= upe
;
3895 m
= gfc_match (" class (");
3898 m
= gfc_match ("%n", name
);
3904 ts
->type
= BT_CLASS
;
3906 if (!gfc_notify_std (GFC_STD_F2003
, "CLASS statement at %C"))
3909 m
= gfc_match_actual_arglist (1, &decl_type_param_list
, true);
3910 if (m
== MATCH_ERROR
)
3913 m
= gfc_match_char (')');
3918 /* Defer association of the derived type until the end of the
3919 specification block. However, if the derived type can be
3920 found, add it to the typespec. */
3921 if (gfc_matching_function
)
3923 ts
->u
.derived
= NULL
;
3924 if (gfc_current_state () != COMP_INTERFACE
3925 && !gfc_find_symbol (name
, NULL
, 1, &sym
) && sym
)
3927 sym
= gfc_find_dt_in_generic (sym
);
3928 ts
->u
.derived
= sym
;
3933 /* Search for the name but allow the components to be defined later. If
3934 type = -1, this typespec has been seen in a function declaration but
3935 the type could not be accessed at that point. The actual derived type is
3936 stored in a symtree with the first letter of the name capitalized; the
3937 symtree with the all lower-case name contains the associated
3938 generic function. */
3939 dt_name
= gfc_dt_upper_string (name
);
3944 gfc_get_ha_symbol (name
, &sym
);
3945 if (sym
->generic
&& gfc_find_symbol (dt_name
, NULL
, 0, &dt_sym
))
3947 gfc_error ("Type name %qs at %C is ambiguous", name
);
3950 if (sym
->generic
&& !dt_sym
)
3951 dt_sym
= gfc_find_dt_in_generic (sym
);
3953 /* Host associated PDTs can get confused with their constructors
3954 because they ar instantiated in the template's namespace. */
3957 if (gfc_find_symbol (dt_name
, NULL
, 1, &dt_sym
))
3959 gfc_error ("Type name %qs at %C is ambiguous", name
);
3962 if (dt_sym
&& !dt_sym
->attr
.pdt_type
)
3966 else if (ts
->kind
== -1)
3968 int iface
= gfc_state_stack
->previous
->state
!= COMP_INTERFACE
3969 || gfc_current_ns
->has_import_set
;
3970 gfc_find_symbol (name
, NULL
, iface
, &sym
);
3971 if (sym
&& sym
->generic
&& gfc_find_symbol (dt_name
, NULL
, 1, &dt_sym
))
3973 gfc_error ("Type name %qs at %C is ambiguous", name
);
3976 if (sym
&& sym
->generic
&& !dt_sym
)
3977 dt_sym
= gfc_find_dt_in_generic (sym
);
3984 if ((sym
->attr
.flavor
!= FL_UNKNOWN
&& sym
->attr
.flavor
!= FL_STRUCT
3985 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.generic
))
3986 || sym
->attr
.subroutine
)
3988 gfc_error ("Type name %qs at %C conflicts with previously declared "
3989 "entity at %L, which has the same name", name
,
3994 if (sym
&& sym
->attr
.flavor
== FL_DERIVED
3995 && sym
->attr
.pdt_template
3996 && gfc_current_state () != COMP_DERIVED
)
3998 m
= gfc_get_pdt_instance (decl_type_param_list
, &sym
, NULL
);
4001 gcc_assert (!sym
->attr
.pdt_template
&& sym
->attr
.pdt_type
);
4002 ts
->u
.derived
= sym
;
4003 strcpy (name
, gfc_dt_lower_string (sym
->name
));
4006 gfc_save_symbol_data (sym
);
4007 gfc_set_sym_referenced (sym
);
4008 if (!sym
->attr
.generic
4009 && !gfc_add_generic (&sym
->attr
, sym
->name
, NULL
))
4012 if (!sym
->attr
.function
4013 && !gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
4016 if (dt_sym
&& dt_sym
->attr
.flavor
== FL_DERIVED
4017 && dt_sym
->attr
.pdt_template
4018 && gfc_current_state () != COMP_DERIVED
)
4020 m
= gfc_get_pdt_instance (decl_type_param_list
, &dt_sym
, NULL
);
4023 gcc_assert (!dt_sym
->attr
.pdt_template
&& dt_sym
->attr
.pdt_type
);
4028 gfc_interface
*intr
, *head
;
4030 /* Use upper case to save the actual derived-type symbol. */
4031 gfc_get_symbol (dt_name
, NULL
, &dt_sym
);
4032 dt_sym
->name
= gfc_get_string ("%s", sym
->name
);
4033 head
= sym
->generic
;
4034 intr
= gfc_get_interface ();
4036 intr
->where
= gfc_current_locus
;
4038 sym
->generic
= intr
;
4039 sym
->attr
.if_source
= IFSRC_DECL
;
4042 gfc_save_symbol_data (dt_sym
);
4044 gfc_set_sym_referenced (dt_sym
);
4046 if (dt_sym
->attr
.flavor
!= FL_DERIVED
&& dt_sym
->attr
.flavor
!= FL_STRUCT
4047 && !gfc_add_flavor (&dt_sym
->attr
, FL_DERIVED
, sym
->name
, NULL
))
4050 ts
->u
.derived
= dt_sym
;
4056 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
4057 "intrinsic-type-spec at %C"))
4060 /* For all types except double, derived and character, look for an
4061 optional kind specifier. MATCH_NO is actually OK at this point. */
4062 if (implicit_flag
== 1)
4064 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
4070 if (gfc_current_form
== FORM_FREE
)
4072 c
= gfc_peek_ascii_char ();
4073 if (!gfc_is_whitespace (c
) && c
!= '*' && c
!= '('
4074 && c
!= ':' && c
!= ',')
4076 if (matched_type
&& c
== ')')
4078 gfc_next_ascii_char ();
4085 m
= gfc_match_kind_spec (ts
, false);
4086 if (m
== MATCH_NO
&& ts
->type
!= BT_CHARACTER
)
4088 m
= gfc_match_old_kind_spec (ts
);
4089 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) == -1)
4093 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
4096 /* Defer association of the KIND expression of function results
4097 until after USE and IMPORT statements. */
4098 if ((gfc_current_state () == COMP_NONE
&& gfc_error_flag_test ())
4099 || gfc_matching_function
)
4103 m
= MATCH_YES
; /* No kind specifier found. */
4109 /* Match an IMPLICIT NONE statement. Actually, this statement is
4110 already matched in parse.c, or we would not end up here in the
4111 first place. So the only thing we need to check, is if there is
4112 trailing garbage. If not, the match is successful. */
4115 gfc_match_implicit_none (void)
4119 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4121 bool external
= false;
4122 locus cur_loc
= gfc_current_locus
;
4124 if (gfc_current_ns
->seen_implicit_none
4125 || gfc_current_ns
->has_implicit_none_export
)
4127 gfc_error ("Duplicate IMPLICIT NONE statement at %C");
4131 gfc_gobble_whitespace ();
4132 c
= gfc_peek_ascii_char ();
4135 (void) gfc_next_ascii_char ();
4136 if (!gfc_notify_std (GFC_STD_F2018
, "IMPORT NONE with spec list at %C"))
4139 gfc_gobble_whitespace ();
4140 if (gfc_peek_ascii_char () == ')')
4142 (void) gfc_next_ascii_char ();
4148 m
= gfc_match (" %n", name
);
4152 if (strcmp (name
, "type") == 0)
4154 else if (strcmp (name
, "external") == 0)
4159 gfc_gobble_whitespace ();
4160 c
= gfc_next_ascii_char ();
4171 if (gfc_match_eos () != MATCH_YES
)
4174 gfc_set_implicit_none (type
, external
, &cur_loc
);
4180 /* Match the letter range(s) of an IMPLICIT statement. */
4183 match_implicit_range (void)
4189 cur_loc
= gfc_current_locus
;
4191 gfc_gobble_whitespace ();
4192 c
= gfc_next_ascii_char ();
4195 gfc_error ("Missing character range in IMPLICIT at %C");
4202 gfc_gobble_whitespace ();
4203 c1
= gfc_next_ascii_char ();
4207 gfc_gobble_whitespace ();
4208 c
= gfc_next_ascii_char ();
4213 inner
= 0; /* Fall through. */
4220 gfc_gobble_whitespace ();
4221 c2
= gfc_next_ascii_char ();
4225 gfc_gobble_whitespace ();
4226 c
= gfc_next_ascii_char ();
4228 if ((c
!= ',') && (c
!= ')'))
4241 gfc_error ("Letters must be in alphabetic order in "
4242 "IMPLICIT statement at %C");
4246 /* See if we can add the newly matched range to the pending
4247 implicits from this IMPLICIT statement. We do not check for
4248 conflicts with whatever earlier IMPLICIT statements may have
4249 set. This is done when we've successfully finished matching
4251 if (!gfc_add_new_implicit_range (c1
, c2
))
4258 gfc_syntax_error (ST_IMPLICIT
);
4260 gfc_current_locus
= cur_loc
;
4265 /* Match an IMPLICIT statement, storing the types for
4266 gfc_set_implicit() if the statement is accepted by the parser.
4267 There is a strange looking, but legal syntactic construction
4268 possible. It looks like:
4270 IMPLICIT INTEGER (a-b) (c-d)
4272 This is legal if "a-b" is a constant expression that happens to
4273 equal one of the legal kinds for integers. The real problem
4274 happens with an implicit specification that looks like:
4276 IMPLICIT INTEGER (a-b)
4278 In this case, a typespec matcher that is "greedy" (as most of the
4279 matchers are) gobbles the character range as a kindspec, leaving
4280 nothing left. We therefore have to go a bit more slowly in the
4281 matching process by inhibiting the kindspec checking during
4282 typespec matching and checking for a kind later. */
4285 gfc_match_implicit (void)
4292 if (gfc_current_ns
->seen_implicit_none
)
4294 gfc_error ("IMPLICIT statement at %C following an IMPLICIT NONE (type) "
4301 /* We don't allow empty implicit statements. */
4302 if (gfc_match_eos () == MATCH_YES
)
4304 gfc_error ("Empty IMPLICIT statement at %C");
4310 /* First cleanup. */
4311 gfc_clear_new_implicit ();
4313 /* A basic type is mandatory here. */
4314 m
= gfc_match_decl_type_spec (&ts
, 1);
4315 if (m
== MATCH_ERROR
)
4320 cur_loc
= gfc_current_locus
;
4321 m
= match_implicit_range ();
4325 /* We may have <TYPE> (<RANGE>). */
4326 gfc_gobble_whitespace ();
4327 c
= gfc_peek_ascii_char ();
4328 if (c
== ',' || c
== '\n' || c
== ';' || c
== '!')
4330 /* Check for CHARACTER with no length parameter. */
4331 if (ts
.type
== BT_CHARACTER
&& !ts
.u
.cl
)
4333 ts
.kind
= gfc_default_character_kind
;
4334 ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4335 ts
.u
.cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
,
4339 /* Record the Successful match. */
4340 if (!gfc_merge_new_implicit (&ts
))
4343 c
= gfc_next_ascii_char ();
4344 else if (gfc_match_eos () == MATCH_ERROR
)
4349 gfc_current_locus
= cur_loc
;
4352 /* Discard the (incorrectly) matched range. */
4353 gfc_clear_new_implicit ();
4355 /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
4356 if (ts
.type
== BT_CHARACTER
)
4357 m
= gfc_match_char_spec (&ts
);
4360 m
= gfc_match_kind_spec (&ts
, false);
4363 m
= gfc_match_old_kind_spec (&ts
);
4364 if (m
== MATCH_ERROR
)
4370 if (m
== MATCH_ERROR
)
4373 m
= match_implicit_range ();
4374 if (m
== MATCH_ERROR
)
4379 gfc_gobble_whitespace ();
4380 c
= gfc_next_ascii_char ();
4381 if (c
!= ',' && gfc_match_eos () != MATCH_YES
)
4384 if (!gfc_merge_new_implicit (&ts
))
4392 gfc_syntax_error (ST_IMPLICIT
);
4400 gfc_match_import (void)
4402 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4407 if (gfc_current_ns
->proc_name
== NULL
4408 || gfc_current_ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
4410 gfc_error ("IMPORT statement at %C only permitted in "
4411 "an INTERFACE body");
4415 if (gfc_current_ns
->proc_name
->attr
.module_procedure
)
4417 gfc_error ("F2008: C1210 IMPORT statement at %C is not permitted "
4418 "in a module procedure interface body");
4422 if (!gfc_notify_std (GFC_STD_F2003
, "IMPORT statement at %C"))
4425 if (gfc_match_eos () == MATCH_YES
)
4427 /* All host variables should be imported. */
4428 gfc_current_ns
->has_import_set
= 1;
4432 if (gfc_match (" ::") == MATCH_YES
)
4434 if (gfc_match_eos () == MATCH_YES
)
4436 gfc_error ("Expecting list of named entities at %C");
4444 m
= gfc_match (" %n", name
);
4448 if (gfc_current_ns
->parent
!= NULL
4449 && gfc_find_symbol (name
, gfc_current_ns
->parent
, 1, &sym
))
4451 gfc_error ("Type name %qs at %C is ambiguous", name
);
4454 else if (!sym
&& gfc_current_ns
->proc_name
->ns
->parent
!= NULL
4455 && gfc_find_symbol (name
,
4456 gfc_current_ns
->proc_name
->ns
->parent
,
4459 gfc_error ("Type name %qs at %C is ambiguous", name
);
4465 gfc_error ("Cannot IMPORT %qs from host scoping unit "
4466 "at %C - does not exist.", name
);
4470 if (gfc_find_symtree (gfc_current_ns
->sym_root
, name
))
4472 gfc_warning (0, "%qs is already IMPORTed from host scoping unit "
4477 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, name
);
4480 sym
->attr
.imported
= 1;
4482 if (sym
->attr
.generic
&& (sym
= gfc_find_dt_in_generic (sym
)))
4484 /* The actual derived type is stored in a symtree with the first
4485 letter of the name capitalized; the symtree with the all
4486 lower-case name contains the associated generic function. */
4487 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
,
4488 gfc_dt_upper_string (name
));
4491 sym
->attr
.imported
= 1;
4504 if (gfc_match_eos () == MATCH_YES
)
4506 if (gfc_match_char (',') != MATCH_YES
)
4513 gfc_error ("Syntax error in IMPORT statement at %C");
4518 /* A minimal implementation of gfc_match without whitespace, escape
4519 characters or variable arguments. Returns true if the next
4520 characters match the TARGET template exactly. */
4523 match_string_p (const char *target
)
4527 for (p
= target
; *p
; p
++)
4528 if ((char) gfc_next_ascii_char () != *p
)
4533 /* Matches an attribute specification including array specs. If
4534 successful, leaves the variables current_attr and current_as
4535 holding the specification. Also sets the colon_seen variable for
4536 later use by matchers associated with initializations.
4538 This subroutine is a little tricky in the sense that we don't know
4539 if we really have an attr-spec until we hit the double colon.
4540 Until that time, we can only return MATCH_NO. This forces us to
4541 check for duplicate specification at this level. */
4544 match_attr_spec (void)
4546 /* Modifiers that can exist in a type statement. */
4548 { GFC_DECL_BEGIN
= 0,
4549 DECL_ALLOCATABLE
= GFC_DECL_BEGIN
, DECL_DIMENSION
, DECL_EXTERNAL
,
4550 DECL_IN
, DECL_OUT
, DECL_INOUT
, DECL_INTRINSIC
, DECL_OPTIONAL
,
4551 DECL_PARAMETER
, DECL_POINTER
, DECL_PROTECTED
, DECL_PRIVATE
,
4552 DECL_STATIC
, DECL_AUTOMATIC
,
4553 DECL_PUBLIC
, DECL_SAVE
, DECL_TARGET
, DECL_VALUE
, DECL_VOLATILE
,
4554 DECL_IS_BIND_C
, DECL_CODIMENSION
, DECL_ASYNCHRONOUS
, DECL_CONTIGUOUS
,
4555 DECL_LEN
, DECL_KIND
, DECL_NONE
, GFC_DECL_END
/* Sentinel */
4558 /* GFC_DECL_END is the sentinel, index starts at 0. */
4559 #define NUM_DECL GFC_DECL_END
4561 locus start
, seen_at
[NUM_DECL
];
4568 gfc_clear_attr (¤t_attr
);
4569 start
= gfc_current_locus
;
4575 /* See if we get all of the keywords up to the final double colon. */
4576 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
4584 gfc_gobble_whitespace ();
4586 ch
= gfc_next_ascii_char ();
4589 /* This is the successful exit condition for the loop. */
4590 if (gfc_next_ascii_char () == ':')
4595 gfc_gobble_whitespace ();
4596 switch (gfc_peek_ascii_char ())
4599 gfc_next_ascii_char ();
4600 switch (gfc_next_ascii_char ())
4603 if (match_string_p ("locatable"))
4605 /* Matched "allocatable". */
4606 d
= DECL_ALLOCATABLE
;
4611 if (match_string_p ("ynchronous"))
4613 /* Matched "asynchronous". */
4614 d
= DECL_ASYNCHRONOUS
;
4619 if (match_string_p ("tomatic"))
4621 /* Matched "automatic". */
4629 /* Try and match the bind(c). */
4630 m
= gfc_match_bind_c (NULL
, true);
4633 else if (m
== MATCH_ERROR
)
4638 gfc_next_ascii_char ();
4639 if ('o' != gfc_next_ascii_char ())
4641 switch (gfc_next_ascii_char ())
4644 if (match_string_p ("imension"))
4646 d
= DECL_CODIMENSION
;
4651 if (match_string_p ("tiguous"))
4653 d
= DECL_CONTIGUOUS
;
4660 if (match_string_p ("dimension"))
4665 if (match_string_p ("external"))
4670 if (match_string_p ("int"))
4672 ch
= gfc_next_ascii_char ();
4675 if (match_string_p ("nt"))
4677 /* Matched "intent". */
4678 /* TODO: Call match_intent_spec from here. */
4679 if (gfc_match (" ( in out )") == MATCH_YES
)
4681 else if (gfc_match (" ( in )") == MATCH_YES
)
4683 else if (gfc_match (" ( out )") == MATCH_YES
)
4689 if (match_string_p ("insic"))
4691 /* Matched "intrinsic". */
4699 if (match_string_p ("kind"))
4704 if (match_string_p ("len"))
4709 if (match_string_p ("optional"))
4714 gfc_next_ascii_char ();
4715 switch (gfc_next_ascii_char ())
4718 if (match_string_p ("rameter"))
4720 /* Matched "parameter". */
4726 if (match_string_p ("inter"))
4728 /* Matched "pointer". */
4734 ch
= gfc_next_ascii_char ();
4737 if (match_string_p ("vate"))
4739 /* Matched "private". */
4745 if (match_string_p ("tected"))
4747 /* Matched "protected". */
4754 if (match_string_p ("blic"))
4756 /* Matched "public". */
4764 gfc_next_ascii_char ();
4765 switch (gfc_next_ascii_char ())
4768 if (match_string_p ("ve"))
4770 /* Matched "save". */
4776 if (match_string_p ("atic"))
4778 /* Matched "static". */
4786 if (match_string_p ("target"))
4791 gfc_next_ascii_char ();
4792 ch
= gfc_next_ascii_char ();
4795 if (match_string_p ("lue"))
4797 /* Matched "value". */
4803 if (match_string_p ("latile"))
4805 /* Matched "volatile". */
4813 /* No double colon and no recognizable decl_type, so assume that
4814 we've been looking at something else the whole time. */
4821 /* Check to make sure any parens are paired up correctly. */
4822 if (gfc_match_parens () == MATCH_ERROR
)
4829 seen_at
[d
] = gfc_current_locus
;
4831 if (d
== DECL_DIMENSION
|| d
== DECL_CODIMENSION
)
4833 gfc_array_spec
*as
= NULL
;
4835 m
= gfc_match_array_spec (&as
, d
== DECL_DIMENSION
,
4836 d
== DECL_CODIMENSION
);
4838 if (current_as
== NULL
)
4840 else if (m
== MATCH_YES
)
4842 if (!merge_array_spec (as
, current_as
, false))
4849 if (d
== DECL_CODIMENSION
)
4850 gfc_error ("Missing codimension specification at %C");
4852 gfc_error ("Missing dimension specification at %C");
4856 if (m
== MATCH_ERROR
)
4861 /* Since we've seen a double colon, we have to be looking at an
4862 attr-spec. This means that we can now issue errors. */
4863 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
4868 case DECL_ALLOCATABLE
:
4869 attr
= "ALLOCATABLE";
4871 case DECL_ASYNCHRONOUS
:
4872 attr
= "ASYNCHRONOUS";
4874 case DECL_CODIMENSION
:
4875 attr
= "CODIMENSION";
4877 case DECL_CONTIGUOUS
:
4878 attr
= "CONTIGUOUS";
4880 case DECL_DIMENSION
:
4887 attr
= "INTENT (IN)";
4890 attr
= "INTENT (OUT)";
4893 attr
= "INTENT (IN OUT)";
4895 case DECL_INTRINSIC
:
4907 case DECL_PARAMETER
:
4913 case DECL_PROTECTED
:
4928 case DECL_AUTOMATIC
:
4934 case DECL_IS_BIND_C
:
4944 attr
= NULL
; /* This shouldn't happen. */
4947 gfc_error ("Duplicate %s attribute at %L", attr
, &seen_at
[d
]);
4952 /* Now that we've dealt with duplicate attributes, add the attributes
4953 to the current attribute. */
4954 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
4961 if ((d
== DECL_STATIC
|| d
== DECL_AUTOMATIC
)
4962 && !flag_dec_static
)
4964 gfc_error ("%s at %L is a DEC extension, enable with "
4966 d
== DECL_STATIC
? "STATIC" : "AUTOMATIC", &seen_at
[d
]);
4970 /* Allow SAVE with STATIC, but don't complain. */
4971 if (d
== DECL_STATIC
&& seen
[DECL_SAVE
])
4974 if (gfc_current_state () == COMP_DERIVED
4975 && d
!= DECL_DIMENSION
&& d
!= DECL_CODIMENSION
4976 && d
!= DECL_POINTER
&& d
!= DECL_PRIVATE
4977 && d
!= DECL_PUBLIC
&& d
!= DECL_CONTIGUOUS
&& d
!= DECL_NONE
)
4979 if (d
== DECL_ALLOCATABLE
)
4981 if (!gfc_notify_std (GFC_STD_F2003
, "ALLOCATABLE "
4982 "attribute at %C in a TYPE definition"))
4988 else if (d
== DECL_KIND
)
4990 if (!gfc_notify_std (GFC_STD_F2003
, "KIND "
4991 "attribute at %C in a TYPE definition"))
4996 if (current_ts
.type
!= BT_INTEGER
)
4998 gfc_error ("Component with KIND attribute at %C must be "
5003 if (current_ts
.kind
!= gfc_default_integer_kind
)
5005 gfc_error ("Component with KIND attribute at %C must be "
5006 "default integer kind (%d)",
5007 gfc_default_integer_kind
);
5012 else if (d
== DECL_LEN
)
5014 if (!gfc_notify_std (GFC_STD_F2003
, "LEN "
5015 "attribute at %C in a TYPE definition"))
5020 if (current_ts
.type
!= BT_INTEGER
)
5022 gfc_error ("Component with LEN attribute at %C must be "
5027 if (current_ts
.kind
!= gfc_default_integer_kind
)
5029 gfc_error ("Component with LEN attribute at %C must be "
5030 "default integer kind (%d)",
5031 gfc_default_integer_kind
);
5038 gfc_error ("Attribute at %L is not allowed in a TYPE definition",
5045 if ((d
== DECL_PRIVATE
|| d
== DECL_PUBLIC
)
5046 && gfc_current_state () != COMP_MODULE
)
5048 if (d
== DECL_PRIVATE
)
5052 if (gfc_current_state () == COMP_DERIVED
5053 && gfc_state_stack
->previous
5054 && gfc_state_stack
->previous
->state
== COMP_MODULE
)
5056 if (!gfc_notify_std (GFC_STD_F2003
, "Attribute %s "
5057 "at %L in a TYPE definition", attr
,
5066 gfc_error ("%s attribute at %L is not allowed outside of the "
5067 "specification part of a module", attr
, &seen_at
[d
]);
5073 if (gfc_current_state () != COMP_DERIVED
5074 && (d
== DECL_KIND
|| d
== DECL_LEN
))
5076 gfc_error ("Attribute at %L is not allowed outside a TYPE "
5077 "definition", &seen_at
[d
]);
5084 case DECL_ALLOCATABLE
:
5085 t
= gfc_add_allocatable (¤t_attr
, &seen_at
[d
]);
5088 case DECL_ASYNCHRONOUS
:
5089 if (!gfc_notify_std (GFC_STD_F2003
, "ASYNCHRONOUS attribute at %C"))
5092 t
= gfc_add_asynchronous (¤t_attr
, NULL
, &seen_at
[d
]);
5095 case DECL_CODIMENSION
:
5096 t
= gfc_add_codimension (¤t_attr
, NULL
, &seen_at
[d
]);
5099 case DECL_CONTIGUOUS
:
5100 if (!gfc_notify_std (GFC_STD_F2008
, "CONTIGUOUS attribute at %C"))
5103 t
= gfc_add_contiguous (¤t_attr
, NULL
, &seen_at
[d
]);
5106 case DECL_DIMENSION
:
5107 t
= gfc_add_dimension (¤t_attr
, NULL
, &seen_at
[d
]);
5111 t
= gfc_add_external (¤t_attr
, &seen_at
[d
]);
5115 t
= gfc_add_intent (¤t_attr
, INTENT_IN
, &seen_at
[d
]);
5119 t
= gfc_add_intent (¤t_attr
, INTENT_OUT
, &seen_at
[d
]);
5123 t
= gfc_add_intent (¤t_attr
, INTENT_INOUT
, &seen_at
[d
]);
5126 case DECL_INTRINSIC
:
5127 t
= gfc_add_intrinsic (¤t_attr
, &seen_at
[d
]);
5131 t
= gfc_add_optional (¤t_attr
, &seen_at
[d
]);
5135 t
= gfc_add_kind (¤t_attr
, &seen_at
[d
]);
5139 t
= gfc_add_len (¤t_attr
, &seen_at
[d
]);
5142 case DECL_PARAMETER
:
5143 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, &seen_at
[d
]);
5147 t
= gfc_add_pointer (¤t_attr
, &seen_at
[d
]);
5150 case DECL_PROTECTED
:
5151 if (gfc_current_state () != COMP_MODULE
5152 || (gfc_current_ns
->proc_name
5153 && gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
))
5155 gfc_error ("PROTECTED at %C only allowed in specification "
5156 "part of a module");
5161 if (!gfc_notify_std (GFC_STD_F2003
, "PROTECTED attribute at %C"))
5164 t
= gfc_add_protected (¤t_attr
, NULL
, &seen_at
[d
]);
5168 t
= gfc_add_access (¤t_attr
, ACCESS_PRIVATE
, NULL
,
5173 t
= gfc_add_access (¤t_attr
, ACCESS_PUBLIC
, NULL
,
5179 t
= gfc_add_save (¤t_attr
, SAVE_EXPLICIT
, NULL
, &seen_at
[d
]);
5182 case DECL_AUTOMATIC
:
5183 t
= gfc_add_automatic (¤t_attr
, NULL
, &seen_at
[d
]);
5187 t
= gfc_add_target (¤t_attr
, &seen_at
[d
]);
5190 case DECL_IS_BIND_C
:
5191 t
= gfc_add_is_bind_c(¤t_attr
, NULL
, &seen_at
[d
], 0);
5195 if (!gfc_notify_std (GFC_STD_F2003
, "VALUE attribute at %C"))
5198 t
= gfc_add_value (¤t_attr
, NULL
, &seen_at
[d
]);
5202 if (!gfc_notify_std (GFC_STD_F2003
, "VOLATILE attribute at %C"))
5205 t
= gfc_add_volatile (¤t_attr
, NULL
, &seen_at
[d
]);
5209 gfc_internal_error ("match_attr_spec(): Bad attribute");
5219 /* Since Fortran 2008 module variables implicitly have the SAVE attribute. */
5220 if ((gfc_current_state () == COMP_MODULE
5221 || gfc_current_state () == COMP_SUBMODULE
)
5222 && !current_attr
.save
5223 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
5224 current_attr
.save
= SAVE_IMPLICIT
;
5230 gfc_current_locus
= start
;
5231 gfc_free_array_spec (current_as
);
5238 /* Set the binding label, dest_label, either with the binding label
5239 stored in the given gfc_typespec, ts, or if none was provided, it
5240 will be the symbol name in all lower case, as required by the draft
5241 (J3/04-007, section 15.4.1). If a binding label was given and
5242 there is more than one argument (num_idents), it is an error. */
5245 set_binding_label (const char **dest_label
, const char *sym_name
,
5248 if (num_idents
> 1 && has_name_equals
)
5250 gfc_error ("Multiple identifiers provided with "
5251 "single NAME= specifier at %C");
5255 if (curr_binding_label
)
5256 /* Binding label given; store in temp holder till have sym. */
5257 *dest_label
= curr_binding_label
;
5260 /* No binding label given, and the NAME= specifier did not exist,
5261 which means there was no NAME="". */
5262 if (sym_name
!= NULL
&& has_name_equals
== 0)
5263 *dest_label
= IDENTIFIER_POINTER (get_identifier (sym_name
));
5270 /* Set the status of the given common block as being BIND(C) or not,
5271 depending on the given parameter, is_bind_c. */
5274 set_com_block_bind_c (gfc_common_head
*com_block
, int is_bind_c
)
5276 com_block
->is_bind_c
= is_bind_c
;
5281 /* Verify that the given gfc_typespec is for a C interoperable type. */
5284 gfc_verify_c_interop (gfc_typespec
*ts
)
5286 if (ts
->type
== BT_DERIVED
&& ts
->u
.derived
!= NULL
)
5287 return (ts
->u
.derived
->ts
.is_c_interop
|| ts
->u
.derived
->attr
.is_bind_c
)
5289 else if (ts
->type
== BT_CLASS
)
5291 else if (ts
->is_c_interop
!= 1 && ts
->type
!= BT_ASSUMED
)
5298 /* Verify that the variables of a given common block, which has been
5299 defined with the attribute specifier bind(c), to be of a C
5300 interoperable type. Errors will be reported here, if
5304 verify_com_block_vars_c_interop (gfc_common_head
*com_block
)
5306 gfc_symbol
*curr_sym
= NULL
;
5309 curr_sym
= com_block
->head
;
5311 /* Make sure we have at least one symbol. */
5312 if (curr_sym
== NULL
)
5315 /* Here we know we have a symbol, so we'll execute this loop
5319 /* The second to last param, 1, says this is in a common block. */
5320 retval
= verify_bind_c_sym (curr_sym
, &(curr_sym
->ts
), 1, com_block
);
5321 curr_sym
= curr_sym
->common_next
;
5322 } while (curr_sym
!= NULL
);
5328 /* Verify that a given BIND(C) symbol is C interoperable. If it is not,
5329 an appropriate error message is reported. */
5332 verify_bind_c_sym (gfc_symbol
*tmp_sym
, gfc_typespec
*ts
,
5333 int is_in_common
, gfc_common_head
*com_block
)
5335 bool bind_c_function
= false;
5338 if (tmp_sym
->attr
.function
&& tmp_sym
->attr
.is_bind_c
)
5339 bind_c_function
= true;
5341 if (tmp_sym
->attr
.function
&& tmp_sym
->result
!= NULL
)
5343 tmp_sym
= tmp_sym
->result
;
5344 /* Make sure it wasn't an implicitly typed result. */
5345 if (tmp_sym
->attr
.implicit_type
&& warn_c_binding_type
)
5347 gfc_warning (OPT_Wc_binding_type
,
5348 "Implicitly declared BIND(C) function %qs at "
5349 "%L may not be C interoperable", tmp_sym
->name
,
5350 &tmp_sym
->declared_at
);
5351 tmp_sym
->ts
.f90_type
= tmp_sym
->ts
.type
;
5352 /* Mark it as C interoperable to prevent duplicate warnings. */
5353 tmp_sym
->ts
.is_c_interop
= 1;
5354 tmp_sym
->attr
.is_c_interop
= 1;
5358 /* Here, we know we have the bind(c) attribute, so if we have
5359 enough type info, then verify that it's a C interop kind.
5360 The info could be in the symbol already, or possibly still in
5361 the given ts (current_ts), so look in both. */
5362 if (tmp_sym
->ts
.type
!= BT_UNKNOWN
|| ts
->type
!= BT_UNKNOWN
)
5364 if (!gfc_verify_c_interop (&(tmp_sym
->ts
)))
5366 /* See if we're dealing with a sym in a common block or not. */
5367 if (is_in_common
== 1 && warn_c_binding_type
)
5369 gfc_warning (OPT_Wc_binding_type
,
5370 "Variable %qs in common block %qs at %L "
5371 "may not be a C interoperable "
5372 "kind though common block %qs is BIND(C)",
5373 tmp_sym
->name
, com_block
->name
,
5374 &(tmp_sym
->declared_at
), com_block
->name
);
5378 if (tmp_sym
->ts
.type
== BT_DERIVED
|| ts
->type
== BT_DERIVED
)
5379 gfc_error ("Type declaration %qs at %L is not C "
5380 "interoperable but it is BIND(C)",
5381 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5382 else if (warn_c_binding_type
)
5383 gfc_warning (OPT_Wc_binding_type
, "Variable %qs at %L "
5384 "may not be a C interoperable "
5385 "kind but it is BIND(C)",
5386 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5390 /* Variables declared w/in a common block can't be bind(c)
5391 since there's no way for C to see these variables, so there's
5392 semantically no reason for the attribute. */
5393 if (is_in_common
== 1 && tmp_sym
->attr
.is_bind_c
== 1)
5395 gfc_error ("Variable %qs in common block %qs at "
5396 "%L cannot be declared with BIND(C) "
5397 "since it is not a global",
5398 tmp_sym
->name
, com_block
->name
,
5399 &(tmp_sym
->declared_at
));
5403 /* Scalar variables that are bind(c) can not have the pointer
5404 or allocatable attributes. */
5405 if (tmp_sym
->attr
.is_bind_c
== 1)
5407 if (tmp_sym
->attr
.pointer
== 1)
5409 gfc_error ("Variable %qs at %L cannot have both the "
5410 "POINTER and BIND(C) attributes",
5411 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5415 if (tmp_sym
->attr
.allocatable
== 1)
5417 gfc_error ("Variable %qs at %L cannot have both the "
5418 "ALLOCATABLE and BIND(C) attributes",
5419 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5425 /* If it is a BIND(C) function, make sure the return value is a
5426 scalar value. The previous tests in this function made sure
5427 the type is interoperable. */
5428 if (bind_c_function
&& tmp_sym
->as
!= NULL
)
5429 gfc_error ("Return type of BIND(C) function %qs at %L cannot "
5430 "be an array", tmp_sym
->name
, &(tmp_sym
->declared_at
));
5432 /* BIND(C) functions can not return a character string. */
5433 if (bind_c_function
&& tmp_sym
->ts
.type
== BT_CHARACTER
)
5434 if (tmp_sym
->ts
.u
.cl
== NULL
|| tmp_sym
->ts
.u
.cl
->length
== NULL
5435 || tmp_sym
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
5436 || mpz_cmp_si (tmp_sym
->ts
.u
.cl
->length
->value
.integer
, 1) != 0)
5437 gfc_error ("Return type of BIND(C) function %qs at %L cannot "
5438 "be a character string", tmp_sym
->name
,
5439 &(tmp_sym
->declared_at
));
5442 /* See if the symbol has been marked as private. If it has, make sure
5443 there is no binding label and warn the user if there is one. */
5444 if (tmp_sym
->attr
.access
== ACCESS_PRIVATE
5445 && tmp_sym
->binding_label
)
5446 /* Use gfc_warning_now because we won't say that the symbol fails
5447 just because of this. */
5448 gfc_warning_now (0, "Symbol %qs at %L is marked PRIVATE but has been "
5449 "given the binding label %qs", tmp_sym
->name
,
5450 &(tmp_sym
->declared_at
), tmp_sym
->binding_label
);
5456 /* Set the appropriate fields for a symbol that's been declared as
5457 BIND(C) (the is_bind_c flag and the binding label), and verify that
5458 the type is C interoperable. Errors are reported by the functions
5459 used to set/test these fields. */
5462 set_verify_bind_c_sym (gfc_symbol
*tmp_sym
, int num_idents
)
5466 /* TODO: Do we need to make sure the vars aren't marked private? */
5468 /* Set the is_bind_c bit in symbol_attribute. */
5469 gfc_add_is_bind_c (&(tmp_sym
->attr
), tmp_sym
->name
, &gfc_current_locus
, 0);
5471 if (!set_binding_label (&tmp_sym
->binding_label
, tmp_sym
->name
, num_idents
))
5478 /* Set the fields marking the given common block as BIND(C), including
5479 a binding label, and report any errors encountered. */
5482 set_verify_bind_c_com_block (gfc_common_head
*com_block
, int num_idents
)
5486 /* destLabel, common name, typespec (which may have binding label). */
5487 if (!set_binding_label (&com_block
->binding_label
, com_block
->name
,
5491 /* Set the given common block (com_block) to being bind(c) (1). */
5492 set_com_block_bind_c (com_block
, 1);
5498 /* Retrieve the list of one or more identifiers that the given bind(c)
5499 attribute applies to. */
5502 get_bind_c_idents (void)
5504 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5506 gfc_symbol
*tmp_sym
= NULL
;
5508 gfc_common_head
*com_block
= NULL
;
5510 if (gfc_match_name (name
) == MATCH_YES
)
5512 found_id
= MATCH_YES
;
5513 gfc_get_ha_symbol (name
, &tmp_sym
);
5515 else if (match_common_name (name
) == MATCH_YES
)
5517 found_id
= MATCH_YES
;
5518 com_block
= gfc_get_common (name
, 0);
5522 gfc_error ("Need either entity or common block name for "
5523 "attribute specification statement at %C");
5527 /* Save the current identifier and look for more. */
5530 /* Increment the number of identifiers found for this spec stmt. */
5533 /* Make sure we have a sym or com block, and verify that it can
5534 be bind(c). Set the appropriate field(s) and look for more
5536 if (tmp_sym
!= NULL
|| com_block
!= NULL
)
5538 if (tmp_sym
!= NULL
)
5540 if (!set_verify_bind_c_sym (tmp_sym
, num_idents
))
5545 if (!set_verify_bind_c_com_block (com_block
, num_idents
))
5549 /* Look to see if we have another identifier. */
5551 if (gfc_match_eos () == MATCH_YES
)
5552 found_id
= MATCH_NO
;
5553 else if (gfc_match_char (',') != MATCH_YES
)
5554 found_id
= MATCH_NO
;
5555 else if (gfc_match_name (name
) == MATCH_YES
)
5557 found_id
= MATCH_YES
;
5558 gfc_get_ha_symbol (name
, &tmp_sym
);
5560 else if (match_common_name (name
) == MATCH_YES
)
5562 found_id
= MATCH_YES
;
5563 com_block
= gfc_get_common (name
, 0);
5567 gfc_error ("Missing entity or common block name for "
5568 "attribute specification statement at %C");
5574 gfc_internal_error ("Missing symbol");
5576 } while (found_id
== MATCH_YES
);
5578 /* if we get here we were successful */
5583 /* Try and match a BIND(C) attribute specification statement. */
5586 gfc_match_bind_c_stmt (void)
5588 match found_match
= MATCH_NO
;
5593 /* This may not be necessary. */
5595 /* Clear the temporary binding label holder. */
5596 curr_binding_label
= NULL
;
5598 /* Look for the bind(c). */
5599 found_match
= gfc_match_bind_c (NULL
, true);
5601 if (found_match
== MATCH_YES
)
5603 if (!gfc_notify_std (GFC_STD_F2003
, "BIND(C) statement at %C"))
5606 /* Look for the :: now, but it is not required. */
5609 /* Get the identifier(s) that needs to be updated. This may need to
5610 change to hand the flag(s) for the attr specified so all identifiers
5611 found can have all appropriate parts updated (assuming that the same
5612 spec stmt can have multiple attrs, such as both bind(c) and
5614 if (!get_bind_c_idents ())
5615 /* Error message should have printed already. */
5623 /* Match a data declaration statement. */
5626 gfc_match_data_decl (void)
5632 type_param_spec_list
= NULL
;
5633 decl_type_param_list
= NULL
;
5635 num_idents_on_line
= 0;
5637 m
= gfc_match_decl_type_spec (¤t_ts
, 0);
5641 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
5642 && !gfc_comp_struct (gfc_current_state ()))
5644 sym
= gfc_use_derived (current_ts
.u
.derived
);
5652 current_ts
.u
.derived
= sym
;
5655 m
= match_attr_spec ();
5656 if (m
== MATCH_ERROR
)
5662 if (current_ts
.type
== BT_CLASS
5663 && current_ts
.u
.derived
->attr
.unlimited_polymorphic
)
5666 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
5667 && current_ts
.u
.derived
->components
== NULL
5668 && !current_ts
.u
.derived
->attr
.zero_comp
)
5671 if (current_attr
.pointer
&& gfc_comp_struct (gfc_current_state ()))
5674 if (current_attr
.allocatable
&& gfc_current_state () == COMP_DERIVED
5675 && current_ts
.u
.derived
== gfc_current_block ())
5678 gfc_find_symbol (current_ts
.u
.derived
->name
,
5679 current_ts
.u
.derived
->ns
, 1, &sym
);
5681 /* Any symbol that we find had better be a type definition
5682 which has its components defined, or be a structure definition
5683 actively being parsed. */
5684 if (sym
!= NULL
&& gfc_fl_struct (sym
->attr
.flavor
)
5685 && (current_ts
.u
.derived
->components
!= NULL
5686 || current_ts
.u
.derived
->attr
.zero_comp
5687 || current_ts
.u
.derived
== gfc_new_block
))
5690 gfc_error ("Derived type at %C has not been previously defined "
5691 "and so cannot appear in a derived type definition");
5697 /* If we have an old-style character declaration, and no new-style
5698 attribute specifications, then there a comma is optional between
5699 the type specification and the variable list. */
5700 if (m
== MATCH_NO
&& current_ts
.type
== BT_CHARACTER
&& old_char_selector
)
5701 gfc_match_char (',');
5703 /* Give the types/attributes to symbols that follow. Give the element
5704 a number so that repeat character length expressions can be copied. */
5708 num_idents_on_line
++;
5709 m
= variable_decl (elem
++);
5710 if (m
== MATCH_ERROR
)
5715 if (gfc_match_eos () == MATCH_YES
)
5717 if (gfc_match_char (',') != MATCH_YES
)
5721 if (!gfc_error_flag_test ())
5723 /* An anonymous structure declaration is unambiguous; if we matched one
5724 according to gfc_match_structure_decl, we need to return MATCH_YES
5725 here to avoid confusing the remaining matchers, even if there was an
5726 error during variable_decl. We must flush any such errors. Note this
5727 causes the parser to gracefully continue parsing the remaining input
5728 as a structure body, which likely follows. */
5729 if (current_ts
.type
== BT_DERIVED
&& current_ts
.u
.derived
5730 && gfc_fl_struct (current_ts
.u
.derived
->attr
.flavor
))
5732 gfc_error_now ("Syntax error in anonymous structure declaration"
5734 /* Skip the bad variable_decl and line up for the start of the
5736 gfc_error_recovery ();
5741 gfc_error ("Syntax error in data declaration at %C");
5746 gfc_free_data_all (gfc_current_ns
);
5749 if (saved_kind_expr
)
5750 gfc_free_expr (saved_kind_expr
);
5751 if (type_param_spec_list
)
5752 gfc_free_actual_arglist (type_param_spec_list
);
5753 if (decl_type_param_list
)
5754 gfc_free_actual_arglist (decl_type_param_list
);
5755 saved_kind_expr
= NULL
;
5756 gfc_free_array_spec (current_as
);
5762 /* Match a prefix associated with a function or subroutine
5763 declaration. If the typespec pointer is nonnull, then a typespec
5764 can be matched. Note that if nothing matches, MATCH_YES is
5765 returned (the null string was matched). */
5768 gfc_match_prefix (gfc_typespec
*ts
)
5774 gfc_clear_attr (¤t_attr
);
5776 seen_impure
= false;
5778 gcc_assert (!gfc_matching_prefix
);
5779 gfc_matching_prefix
= true;
5783 found_prefix
= false;
5785 /* MODULE is a prefix like PURE, ELEMENTAL, etc., having a
5786 corresponding attribute seems natural and distinguishes these
5787 procedures from procedure types of PROC_MODULE, which these are
5789 if (gfc_match ("module% ") == MATCH_YES
)
5791 if (!gfc_notify_std (GFC_STD_F2008
, "MODULE prefix at %C"))
5794 current_attr
.module_procedure
= 1;
5795 found_prefix
= true;
5798 if (!seen_type
&& ts
!= NULL
5799 && gfc_match_decl_type_spec (ts
, 0) == MATCH_YES
5800 && gfc_match_space () == MATCH_YES
)
5804 found_prefix
= true;
5807 if (gfc_match ("elemental% ") == MATCH_YES
)
5809 if (!gfc_add_elemental (¤t_attr
, NULL
))
5812 found_prefix
= true;
5815 if (gfc_match ("pure% ") == MATCH_YES
)
5817 if (!gfc_add_pure (¤t_attr
, NULL
))
5820 found_prefix
= true;
5823 if (gfc_match ("recursive% ") == MATCH_YES
)
5825 if (!gfc_add_recursive (¤t_attr
, NULL
))
5828 found_prefix
= true;
5831 /* IMPURE is a somewhat special case, as it needs not set an actual
5832 attribute but rather only prevents ELEMENTAL routines from being
5833 automatically PURE. */
5834 if (gfc_match ("impure% ") == MATCH_YES
)
5836 if (!gfc_notify_std (GFC_STD_F2008
, "IMPURE procedure at %C"))
5840 found_prefix
= true;
5843 while (found_prefix
);
5845 /* IMPURE and PURE must not both appear, of course. */
5846 if (seen_impure
&& current_attr
.pure
)
5848 gfc_error ("PURE and IMPURE must not appear both at %C");
5852 /* If IMPURE it not seen but the procedure is ELEMENTAL, mark it as PURE. */
5853 if (!seen_impure
&& current_attr
.elemental
&& !current_attr
.pure
)
5855 if (!gfc_add_pure (¤t_attr
, NULL
))
5859 /* At this point, the next item is not a prefix. */
5860 gcc_assert (gfc_matching_prefix
);
5862 gfc_matching_prefix
= false;
5866 gcc_assert (gfc_matching_prefix
);
5867 gfc_matching_prefix
= false;
5872 /* Copy attributes matched by gfc_match_prefix() to attributes on a symbol. */
5875 copy_prefix (symbol_attribute
*dest
, locus
*where
)
5877 if (dest
->module_procedure
)
5879 if (current_attr
.elemental
)
5880 dest
->elemental
= 1;
5882 if (current_attr
.pure
)
5885 if (current_attr
.recursive
)
5886 dest
->recursive
= 1;
5888 /* Module procedures are unusual in that the 'dest' is copied from
5889 the interface declaration. However, this is an oportunity to
5890 check that the submodule declaration is compliant with the
5892 if (dest
->elemental
&& !current_attr
.elemental
)
5894 gfc_error ("ELEMENTAL prefix in MODULE PROCEDURE interface is "
5895 "missing at %L", where
);
5899 if (dest
->pure
&& !current_attr
.pure
)
5901 gfc_error ("PURE prefix in MODULE PROCEDURE interface is "
5902 "missing at %L", where
);
5906 if (dest
->recursive
&& !current_attr
.recursive
)
5908 gfc_error ("RECURSIVE prefix in MODULE PROCEDURE interface is "
5909 "missing at %L", where
);
5916 if (current_attr
.elemental
&& !gfc_add_elemental (dest
, where
))
5919 if (current_attr
.pure
&& !gfc_add_pure (dest
, where
))
5922 if (current_attr
.recursive
&& !gfc_add_recursive (dest
, where
))
5929 /* Match a formal argument list or, if typeparam is true, a
5930 type_param_name_list. */
5933 gfc_match_formal_arglist (gfc_symbol
*progname
, int st_flag
,
5934 int null_flag
, bool typeparam
)
5936 gfc_formal_arglist
*head
, *tail
, *p
, *q
;
5937 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5940 gfc_formal_arglist
*formal
= NULL
;
5944 /* Keep the interface formal argument list and null it so that the
5945 matching for the new declaration can be done. The numbers and
5946 names of the arguments are checked here. The interface formal
5947 arguments are retained in formal_arglist and the characteristics
5948 are compared in resolve.c(resolve_fl_procedure). See the remark
5949 in get_proc_name about the eventual need to copy the formal_arglist
5950 and populate the formal namespace of the interface symbol. */
5951 if (progname
->attr
.module_procedure
5952 && progname
->attr
.host_assoc
)
5954 formal
= progname
->formal
;
5955 progname
->formal
= NULL
;
5958 if (gfc_match_char ('(') != MATCH_YES
)
5965 if (gfc_match_char (')') == MATCH_YES
)
5970 if (gfc_match_char ('*') == MATCH_YES
)
5973 if (!typeparam
&& !gfc_notify_std (GFC_STD_F95_OBS
,
5974 "Alternate-return argument at %C"))
5980 gfc_error_now ("A parameter name is required at %C");
5984 m
= gfc_match_name (name
);
5988 gfc_error_now ("A parameter name is required at %C");
5992 if (!typeparam
&& gfc_get_symbol (name
, NULL
, &sym
))
5995 && gfc_get_symbol (name
, progname
->f2k_derived
, &sym
))
5999 p
= gfc_get_formal_arglist ();
6011 /* We don't add the VARIABLE flavor because the name could be a
6012 dummy procedure. We don't apply these attributes to formal
6013 arguments of statement functions. */
6014 if (sym
!= NULL
&& !st_flag
6015 && (!gfc_add_dummy(&sym
->attr
, sym
->name
, NULL
)
6016 || !gfc_missing_attr (&sym
->attr
, NULL
)))
6022 /* The name of a program unit can be in a different namespace,
6023 so check for it explicitly. After the statement is accepted,
6024 the name is checked for especially in gfc_get_symbol(). */
6025 if (gfc_new_block
!= NULL
&& sym
!= NULL
&& !typeparam
6026 && strcmp (sym
->name
, gfc_new_block
->name
) == 0)
6028 gfc_error ("Name %qs at %C is the name of the procedure",
6034 if (gfc_match_char (')') == MATCH_YES
)
6037 m
= gfc_match_char (',');
6041 gfc_error_now ("Expected parameter list in type declaration "
6044 gfc_error ("Unexpected junk in formal argument list at %C");
6050 /* Check for duplicate symbols in the formal argument list. */
6053 for (p
= head
; p
->next
; p
= p
->next
)
6058 for (q
= p
->next
; q
; q
= q
->next
)
6059 if (p
->sym
== q
->sym
)
6062 gfc_error_now ("Duplicate name %qs in parameter "
6063 "list at %C", p
->sym
->name
);
6065 gfc_error ("Duplicate symbol %qs in formal argument "
6066 "list at %C", p
->sym
->name
);
6074 if (!gfc_add_explicit_interface (progname
, IFSRC_DECL
, head
, NULL
))
6080 /* gfc_error_now used in following and return with MATCH_YES because
6081 doing otherwise results in a cascade of extraneous errors and in
6082 some cases an ICE in symbol.c(gfc_release_symbol). */
6083 if (progname
->attr
.module_procedure
&& progname
->attr
.host_assoc
)
6085 bool arg_count_mismatch
= false;
6087 if (!formal
&& head
)
6088 arg_count_mismatch
= true;
6090 /* Abbreviated module procedure declaration is not meant to have any
6091 formal arguments! */
6092 if (!progname
->abr_modproc_decl
&& formal
&& !head
)
6093 arg_count_mismatch
= true;
6095 for (p
= formal
, q
= head
; p
&& q
; p
= p
->next
, q
= q
->next
)
6097 if ((p
->next
!= NULL
&& q
->next
== NULL
)
6098 || (p
->next
== NULL
&& q
->next
!= NULL
))
6099 arg_count_mismatch
= true;
6100 else if ((p
->sym
== NULL
&& q
->sym
== NULL
)
6101 || strcmp (p
->sym
->name
, q
->sym
->name
) == 0)
6104 gfc_error_now ("Mismatch in MODULE PROCEDURE formal "
6105 "argument names (%s/%s) at %C",
6106 p
->sym
->name
, q
->sym
->name
);
6109 if (arg_count_mismatch
)
6110 gfc_error_now ("Mismatch in number of MODULE PROCEDURE "
6111 "formal arguments at %C");
6117 gfc_free_formal_arglist (head
);
6122 /* Match a RESULT specification following a function declaration or
6123 ENTRY statement. Also matches the end-of-statement. */
6126 match_result (gfc_symbol
*function
, gfc_symbol
**result
)
6128 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6132 if (gfc_match (" result (") != MATCH_YES
)
6135 m
= gfc_match_name (name
);
6139 /* Get the right paren, and that's it because there could be the
6140 bind(c) attribute after the result clause. */
6141 if (gfc_match_char (')') != MATCH_YES
)
6143 /* TODO: should report the missing right paren here. */
6147 if (strcmp (function
->name
, name
) == 0)
6149 gfc_error ("RESULT variable at %C must be different than function name");
6153 if (gfc_get_symbol (name
, NULL
, &r
))
6156 if (!gfc_add_result (&r
->attr
, r
->name
, NULL
))
6165 /* Match a function suffix, which could be a combination of a result
6166 clause and BIND(C), either one, or neither. The draft does not
6167 require them to come in a specific order. */
6170 gfc_match_suffix (gfc_symbol
*sym
, gfc_symbol
**result
)
6172 match is_bind_c
; /* Found bind(c). */
6173 match is_result
; /* Found result clause. */
6174 match found_match
; /* Status of whether we've found a good match. */
6175 char peek_char
; /* Character we're going to peek at. */
6176 bool allow_binding_name
;
6178 /* Initialize to having found nothing. */
6179 found_match
= MATCH_NO
;
6180 is_bind_c
= MATCH_NO
;
6181 is_result
= MATCH_NO
;
6183 /* Get the next char to narrow between result and bind(c). */
6184 gfc_gobble_whitespace ();
6185 peek_char
= gfc_peek_ascii_char ();
6187 /* C binding names are not allowed for internal procedures. */
6188 if (gfc_current_state () == COMP_CONTAINS
6189 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
6190 allow_binding_name
= false;
6192 allow_binding_name
= true;
6197 /* Look for result clause. */
6198 is_result
= match_result (sym
, result
);
6199 if (is_result
== MATCH_YES
)
6201 /* Now see if there is a bind(c) after it. */
6202 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
6203 /* We've found the result clause and possibly bind(c). */
6204 found_match
= MATCH_YES
;
6207 /* This should only be MATCH_ERROR. */
6208 found_match
= is_result
;
6211 /* Look for bind(c) first. */
6212 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
6213 if (is_bind_c
== MATCH_YES
)
6215 /* Now see if a result clause followed it. */
6216 is_result
= match_result (sym
, result
);
6217 found_match
= MATCH_YES
;
6221 /* Should only be a MATCH_ERROR if we get here after seeing 'b'. */
6222 found_match
= MATCH_ERROR
;
6226 gfc_error ("Unexpected junk after function declaration at %C");
6227 found_match
= MATCH_ERROR
;
6231 if (is_bind_c
== MATCH_YES
)
6233 /* Fortran 2008 draft allows BIND(C) for internal procedures. */
6234 if (gfc_current_state () == COMP_CONTAINS
6235 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
6236 && !gfc_notify_std (GFC_STD_F2008
, "BIND(C) attribute "
6237 "at %L may not be specified for an internal "
6238 "procedure", &gfc_current_locus
))
6241 if (!gfc_add_is_bind_c (&(sym
->attr
), sym
->name
, &gfc_current_locus
, 1))
6249 /* Procedure pointer return value without RESULT statement:
6250 Add "hidden" result variable named "ppr@". */
6253 add_hidden_procptr_result (gfc_symbol
*sym
)
6257 if (gfc_notification_std (GFC_STD_F2003
) == ERROR
)
6260 /* First usage case: PROCEDURE and EXTERNAL statements. */
6261 case1
= gfc_current_state () == COMP_FUNCTION
&& gfc_current_block ()
6262 && strcmp (gfc_current_block ()->name
, sym
->name
) == 0
6263 && sym
->attr
.external
;
6264 /* Second usage case: INTERFACE statements. */
6265 case2
= gfc_current_state () == COMP_INTERFACE
&& gfc_state_stack
->previous
6266 && gfc_state_stack
->previous
->state
== COMP_FUNCTION
6267 && strcmp (gfc_state_stack
->previous
->sym
->name
, sym
->name
) == 0;
6273 gfc_get_sym_tree ("ppr@", gfc_current_ns
, &stree
, false);
6277 gfc_get_sym_tree ("ppr@", gfc_current_ns
->parent
, &stree
, false);
6278 st2
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "ppr@");
6279 st2
->n
.sym
= stree
->n
.sym
;
6280 stree
->n
.sym
->refs
++;
6282 sym
->result
= stree
->n
.sym
;
6284 sym
->result
->attr
.proc_pointer
= sym
->attr
.proc_pointer
;
6285 sym
->result
->attr
.pointer
= sym
->attr
.pointer
;
6286 sym
->result
->attr
.external
= sym
->attr
.external
;
6287 sym
->result
->attr
.referenced
= sym
->attr
.referenced
;
6288 sym
->result
->ts
= sym
->ts
;
6289 sym
->attr
.proc_pointer
= 0;
6290 sym
->attr
.pointer
= 0;
6291 sym
->attr
.external
= 0;
6292 if (sym
->result
->attr
.external
&& sym
->result
->attr
.pointer
)
6294 sym
->result
->attr
.pointer
= 0;
6295 sym
->result
->attr
.proc_pointer
= 1;
6298 return gfc_add_result (&sym
->result
->attr
, sym
->result
->name
, NULL
);
6300 /* POINTER after PROCEDURE/EXTERNAL/INTERFACE statement. */
6301 else if (sym
->attr
.function
&& !sym
->attr
.external
&& sym
->attr
.pointer
6302 && sym
->result
&& sym
->result
!= sym
&& sym
->result
->attr
.external
6303 && sym
== gfc_current_ns
->proc_name
6304 && sym
== sym
->result
->ns
->proc_name
6305 && strcmp ("ppr@", sym
->result
->name
) == 0)
6307 sym
->result
->attr
.proc_pointer
= 1;
6308 sym
->attr
.pointer
= 0;
6316 /* Match the interface for a PROCEDURE declaration,
6317 including brackets (R1212). */
6320 match_procedure_interface (gfc_symbol
**proc_if
)
6324 locus old_loc
, entry_loc
;
6325 gfc_namespace
*old_ns
= gfc_current_ns
;
6326 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6328 old_loc
= entry_loc
= gfc_current_locus
;
6329 gfc_clear_ts (¤t_ts
);
6331 if (gfc_match (" (") != MATCH_YES
)
6333 gfc_current_locus
= entry_loc
;
6337 /* Get the type spec. for the procedure interface. */
6338 old_loc
= gfc_current_locus
;
6339 m
= gfc_match_decl_type_spec (¤t_ts
, 0);
6340 gfc_gobble_whitespace ();
6341 if (m
== MATCH_YES
|| (m
== MATCH_NO
&& gfc_peek_ascii_char () == ')'))
6344 if (m
== MATCH_ERROR
)
6347 /* Procedure interface is itself a procedure. */
6348 gfc_current_locus
= old_loc
;
6349 m
= gfc_match_name (name
);
6351 /* First look to see if it is already accessible in the current
6352 namespace because it is use associated or contained. */
6354 if (gfc_find_sym_tree (name
, NULL
, 0, &st
))
6357 /* If it is still not found, then try the parent namespace, if it
6358 exists and create the symbol there if it is still not found. */
6359 if (gfc_current_ns
->parent
)
6360 gfc_current_ns
= gfc_current_ns
->parent
;
6361 if (st
== NULL
&& gfc_get_ha_sym_tree (name
, &st
))
6364 gfc_current_ns
= old_ns
;
6365 *proc_if
= st
->n
.sym
;
6370 /* Resolve interface if possible. That way, attr.procedure is only set
6371 if it is declared by a later procedure-declaration-stmt, which is
6372 invalid per F08:C1216 (cf. resolve_procedure_interface). */
6373 while ((*proc_if
)->ts
.interface
6374 && *proc_if
!= (*proc_if
)->ts
.interface
)
6375 *proc_if
= (*proc_if
)->ts
.interface
;
6377 if ((*proc_if
)->attr
.flavor
== FL_UNKNOWN
6378 && (*proc_if
)->ts
.type
== BT_UNKNOWN
6379 && !gfc_add_flavor (&(*proc_if
)->attr
, FL_PROCEDURE
,
6380 (*proc_if
)->name
, NULL
))
6385 if (gfc_match (" )") != MATCH_YES
)
6387 gfc_current_locus
= entry_loc
;
6395 /* Match a PROCEDURE declaration (R1211). */
6398 match_procedure_decl (void)
6401 gfc_symbol
*sym
, *proc_if
= NULL
;
6403 gfc_expr
*initializer
= NULL
;
6405 /* Parse interface (with brackets). */
6406 m
= match_procedure_interface (&proc_if
);
6410 /* Parse attributes (with colons). */
6411 m
= match_attr_spec();
6412 if (m
== MATCH_ERROR
)
6415 if (proc_if
&& proc_if
->attr
.is_bind_c
&& !current_attr
.is_bind_c
)
6417 current_attr
.is_bind_c
= 1;
6418 has_name_equals
= 0;
6419 curr_binding_label
= NULL
;
6422 /* Get procedure symbols. */
6425 m
= gfc_match_symbol (&sym
, 0);
6428 else if (m
== MATCH_ERROR
)
6431 /* Add current_attr to the symbol attributes. */
6432 if (!gfc_copy_attr (&sym
->attr
, ¤t_attr
, NULL
))
6435 if (sym
->attr
.is_bind_c
)
6437 /* Check for C1218. */
6438 if (!proc_if
|| !proc_if
->attr
.is_bind_c
)
6440 gfc_error ("BIND(C) attribute at %C requires "
6441 "an interface with BIND(C)");
6444 /* Check for C1217. */
6445 if (has_name_equals
&& sym
->attr
.pointer
)
6447 gfc_error ("BIND(C) procedure with NAME may not have "
6448 "POINTER attribute at %C");
6451 if (has_name_equals
&& sym
->attr
.dummy
)
6453 gfc_error ("Dummy procedure at %C may not have "
6454 "BIND(C) attribute with NAME");
6457 /* Set binding label for BIND(C). */
6458 if (!set_binding_label (&sym
->binding_label
, sym
->name
, num
))
6462 if (!gfc_add_external (&sym
->attr
, NULL
))
6465 if (add_hidden_procptr_result (sym
))
6468 if (!gfc_add_proc (&sym
->attr
, sym
->name
, NULL
))
6471 /* Set interface. */
6472 if (proc_if
!= NULL
)
6474 if (sym
->ts
.type
!= BT_UNKNOWN
)
6476 gfc_error ("Procedure %qs at %L already has basic type of %s",
6477 sym
->name
, &gfc_current_locus
,
6478 gfc_basic_typename (sym
->ts
.type
));
6481 sym
->ts
.interface
= proc_if
;
6482 sym
->attr
.untyped
= 1;
6483 sym
->attr
.if_source
= IFSRC_IFBODY
;
6485 else if (current_ts
.type
!= BT_UNKNOWN
)
6487 if (!gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
6489 sym
->ts
.interface
= gfc_new_symbol ("", gfc_current_ns
);
6490 sym
->ts
.interface
->ts
= current_ts
;
6491 sym
->ts
.interface
->attr
.flavor
= FL_PROCEDURE
;
6492 sym
->ts
.interface
->attr
.function
= 1;
6493 sym
->attr
.function
= 1;
6494 sym
->attr
.if_source
= IFSRC_UNKNOWN
;
6497 if (gfc_match (" =>") == MATCH_YES
)
6499 if (!current_attr
.pointer
)
6501 gfc_error ("Initialization at %C isn't for a pointer variable");
6506 m
= match_pointer_init (&initializer
, 1);
6510 if (!add_init_expr_to_sym (sym
->name
, &initializer
, &gfc_current_locus
))
6515 if (gfc_match_eos () == MATCH_YES
)
6517 if (gfc_match_char (',') != MATCH_YES
)
6522 gfc_error ("Syntax error in PROCEDURE statement at %C");
6526 /* Free stuff up and return. */
6527 gfc_free_expr (initializer
);
6533 match_binding_attributes (gfc_typebound_proc
* ba
, bool generic
, bool ppc
);
6536 /* Match a procedure pointer component declaration (R445). */
6539 match_ppc_decl (void)
6542 gfc_symbol
*proc_if
= NULL
;
6546 gfc_expr
*initializer
= NULL
;
6547 gfc_typebound_proc
* tb
;
6548 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6550 /* Parse interface (with brackets). */
6551 m
= match_procedure_interface (&proc_if
);
6555 /* Parse attributes. */
6556 tb
= XCNEW (gfc_typebound_proc
);
6557 tb
->where
= gfc_current_locus
;
6558 m
= match_binding_attributes (tb
, false, true);
6559 if (m
== MATCH_ERROR
)
6562 gfc_clear_attr (¤t_attr
);
6563 current_attr
.procedure
= 1;
6564 current_attr
.proc_pointer
= 1;
6565 current_attr
.access
= tb
->access
;
6566 current_attr
.flavor
= FL_PROCEDURE
;
6568 /* Match the colons (required). */
6569 if (gfc_match (" ::") != MATCH_YES
)
6571 gfc_error ("Expected %<::%> after binding-attributes at %C");
6575 /* Check for C450. */
6576 if (!tb
->nopass
&& proc_if
== NULL
)
6578 gfc_error("NOPASS or explicit interface required at %C");
6582 if (!gfc_notify_std (GFC_STD_F2003
, "Procedure pointer component at %C"))
6585 /* Match PPC names. */
6589 m
= gfc_match_name (name
);
6592 else if (m
== MATCH_ERROR
)
6595 if (!gfc_add_component (gfc_current_block(), name
, &c
))
6598 /* Add current_attr to the symbol attributes. */
6599 if (!gfc_copy_attr (&c
->attr
, ¤t_attr
, NULL
))
6602 if (!gfc_add_external (&c
->attr
, NULL
))
6605 if (!gfc_add_proc (&c
->attr
, name
, NULL
))
6612 c
->tb
= XCNEW (gfc_typebound_proc
);
6613 c
->tb
->where
= gfc_current_locus
;
6617 /* Set interface. */
6618 if (proc_if
!= NULL
)
6620 c
->ts
.interface
= proc_if
;
6621 c
->attr
.untyped
= 1;
6622 c
->attr
.if_source
= IFSRC_IFBODY
;
6624 else if (ts
.type
!= BT_UNKNOWN
)
6627 c
->ts
.interface
= gfc_new_symbol ("", gfc_current_ns
);
6628 c
->ts
.interface
->result
= c
->ts
.interface
;
6629 c
->ts
.interface
->ts
= ts
;
6630 c
->ts
.interface
->attr
.flavor
= FL_PROCEDURE
;
6631 c
->ts
.interface
->attr
.function
= 1;
6632 c
->attr
.function
= 1;
6633 c
->attr
.if_source
= IFSRC_UNKNOWN
;
6636 if (gfc_match (" =>") == MATCH_YES
)
6638 m
= match_pointer_init (&initializer
, 1);
6641 gfc_free_expr (initializer
);
6644 c
->initializer
= initializer
;
6647 if (gfc_match_eos () == MATCH_YES
)
6649 if (gfc_match_char (',') != MATCH_YES
)
6654 gfc_error ("Syntax error in procedure pointer component at %C");
6659 /* Match a PROCEDURE declaration inside an interface (R1206). */
6662 match_procedure_in_interface (void)
6666 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6669 if (current_interface
.type
== INTERFACE_NAMELESS
6670 || current_interface
.type
== INTERFACE_ABSTRACT
)
6672 gfc_error ("PROCEDURE at %C must be in a generic interface");
6676 /* Check if the F2008 optional double colon appears. */
6677 gfc_gobble_whitespace ();
6678 old_locus
= gfc_current_locus
;
6679 if (gfc_match ("::") == MATCH_YES
)
6681 if (!gfc_notify_std (GFC_STD_F2008
, "double colon in "
6682 "MODULE PROCEDURE statement at %L", &old_locus
))
6686 gfc_current_locus
= old_locus
;
6690 m
= gfc_match_name (name
);
6693 else if (m
== MATCH_ERROR
)
6695 if (gfc_get_symbol (name
, gfc_current_ns
->parent
, &sym
))
6698 if (!gfc_add_interface (sym
))
6701 if (gfc_match_eos () == MATCH_YES
)
6703 if (gfc_match_char (',') != MATCH_YES
)
6710 gfc_error ("Syntax error in PROCEDURE statement at %C");
6715 /* General matcher for PROCEDURE declarations. */
6717 static match
match_procedure_in_type (void);
6720 gfc_match_procedure (void)
6724 switch (gfc_current_state ())
6729 case COMP_SUBMODULE
:
6730 case COMP_SUBROUTINE
:
6733 m
= match_procedure_decl ();
6735 case COMP_INTERFACE
:
6736 m
= match_procedure_in_interface ();
6739 m
= match_ppc_decl ();
6741 case COMP_DERIVED_CONTAINS
:
6742 m
= match_procedure_in_type ();
6751 if (!gfc_notify_std (GFC_STD_F2003
, "PROCEDURE statement at %C"))
6758 /* Warn if a matched procedure has the same name as an intrinsic; this is
6759 simply a wrapper around gfc_warn_intrinsic_shadow that interprets the current
6760 parser-state-stack to find out whether we're in a module. */
6763 do_warn_intrinsic_shadow (const gfc_symbol
* sym
, bool func
)
6767 in_module
= (gfc_state_stack
->previous
6768 && (gfc_state_stack
->previous
->state
== COMP_MODULE
6769 || gfc_state_stack
->previous
->state
== COMP_SUBMODULE
));
6771 gfc_warn_intrinsic_shadow (sym
, in_module
, func
);
6775 /* Match a function declaration. */
6778 gfc_match_function_decl (void)
6780 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6781 gfc_symbol
*sym
, *result
;
6785 match found_match
; /* Status returned by match func. */
6787 if (gfc_current_state () != COMP_NONE
6788 && gfc_current_state () != COMP_INTERFACE
6789 && gfc_current_state () != COMP_CONTAINS
)
6792 gfc_clear_ts (¤t_ts
);
6794 old_loc
= gfc_current_locus
;
6796 m
= gfc_match_prefix (¤t_ts
);
6799 gfc_current_locus
= old_loc
;
6803 if (gfc_match ("function% %n", name
) != MATCH_YES
)
6805 gfc_current_locus
= old_loc
;
6809 if (get_proc_name (name
, &sym
, false))
6812 if (add_hidden_procptr_result (sym
))
6815 if (current_attr
.module_procedure
)
6816 sym
->attr
.module_procedure
= 1;
6818 gfc_new_block
= sym
;
6820 m
= gfc_match_formal_arglist (sym
, 0, 0);
6823 gfc_error ("Expected formal argument list in function "
6824 "definition at %C");
6828 else if (m
== MATCH_ERROR
)
6833 /* According to the draft, the bind(c) and result clause can
6834 come in either order after the formal_arg_list (i.e., either
6835 can be first, both can exist together or by themselves or neither
6836 one). Therefore, the match_result can't match the end of the
6837 string, and check for the bind(c) or result clause in either order. */
6838 found_match
= gfc_match_eos ();
6840 /* Make sure that it isn't already declared as BIND(C). If it is, it
6841 must have been marked BIND(C) with a BIND(C) attribute and that is
6842 not allowed for procedures. */
6843 if (sym
->attr
.is_bind_c
== 1)
6845 sym
->attr
.is_bind_c
= 0;
6846 if (sym
->old_symbol
!= NULL
)
6847 gfc_error_now ("BIND(C) attribute at %L can only be used for "
6848 "variables or common blocks",
6849 &(sym
->old_symbol
->declared_at
));
6851 gfc_error_now ("BIND(C) attribute at %L can only be used for "
6852 "variables or common blocks", &gfc_current_locus
);
6855 if (found_match
!= MATCH_YES
)
6857 /* If we haven't found the end-of-statement, look for a suffix. */
6858 suffix_match
= gfc_match_suffix (sym
, &result
);
6859 if (suffix_match
== MATCH_YES
)
6860 /* Need to get the eos now. */
6861 found_match
= gfc_match_eos ();
6863 found_match
= suffix_match
;
6866 if(found_match
!= MATCH_YES
)
6870 /* Make changes to the symbol. */
6873 if (!gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
6876 if (!gfc_missing_attr (&sym
->attr
, NULL
))
6879 if (!copy_prefix (&sym
->attr
, &sym
->declared_at
))
6881 if(!sym
->attr
.module_procedure
)
6887 /* Delay matching the function characteristics until after the
6888 specification block by signalling kind=-1. */
6889 sym
->declared_at
= old_loc
;
6890 if (current_ts
.type
!= BT_UNKNOWN
)
6891 current_ts
.kind
= -1;
6893 current_ts
.kind
= 0;
6897 if (current_ts
.type
!= BT_UNKNOWN
6898 && !gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
6904 if (current_ts
.type
!= BT_UNKNOWN
6905 && !gfc_add_type (result
, ¤t_ts
, &gfc_current_locus
))
6907 sym
->result
= result
;
6910 /* Warn if this procedure has the same name as an intrinsic. */
6911 do_warn_intrinsic_shadow (sym
, true);
6917 gfc_current_locus
= old_loc
;
6922 /* This is mostly a copy of parse.c(add_global_procedure) but modified to
6923 pass the name of the entry, rather than the gfc_current_block name, and
6924 to return false upon finding an existing global entry. */
6927 add_global_entry (const char *name
, const char *binding_label
, bool sub
,
6931 enum gfc_symbol_type type
;
6933 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
6935 /* Only in Fortran 2003: For procedures with a binding label also the Fortran
6936 name is a global identifier. */
6937 if (!binding_label
|| gfc_notification_std (GFC_STD_F2008
))
6939 s
= gfc_get_gsymbol (name
);
6941 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= type
))
6943 gfc_global_used (s
, where
);
6952 s
->ns
= gfc_current_ns
;
6956 /* Don't add the symbol multiple times. */
6958 && (!gfc_notification_std (GFC_STD_F2008
)
6959 || strcmp (name
, binding_label
) != 0))
6961 s
= gfc_get_gsymbol (binding_label
);
6963 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= type
))
6965 gfc_global_used (s
, where
);
6972 s
->binding_label
= binding_label
;
6975 s
->ns
= gfc_current_ns
;
6983 /* Match an ENTRY statement. */
6986 gfc_match_entry (void)
6991 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6992 gfc_compile_state state
;
6996 bool module_procedure
;
7000 m
= gfc_match_name (name
);
7004 if (!gfc_notify_std (GFC_STD_F2008_OBS
, "ENTRY statement at %C"))
7007 state
= gfc_current_state ();
7008 if (state
!= COMP_SUBROUTINE
&& state
!= COMP_FUNCTION
)
7013 gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
7016 gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
7018 case COMP_SUBMODULE
:
7019 gfc_error ("ENTRY statement at %C cannot appear within a SUBMODULE");
7021 case COMP_BLOCK_DATA
:
7022 gfc_error ("ENTRY statement at %C cannot appear within "
7025 case COMP_INTERFACE
:
7026 gfc_error ("ENTRY statement at %C cannot appear within "
7029 case COMP_STRUCTURE
:
7030 gfc_error ("ENTRY statement at %C cannot appear within "
7031 "a STRUCTURE block");
7034 gfc_error ("ENTRY statement at %C cannot appear within "
7035 "a DERIVED TYPE block");
7038 gfc_error ("ENTRY statement at %C cannot appear within "
7039 "an IF-THEN block");
7042 case COMP_DO_CONCURRENT
:
7043 gfc_error ("ENTRY statement at %C cannot appear within "
7047 gfc_error ("ENTRY statement at %C cannot appear within "
7051 gfc_error ("ENTRY statement at %C cannot appear within "
7055 gfc_error ("ENTRY statement at %C cannot appear within "
7059 gfc_error ("ENTRY statement at %C cannot appear within "
7060 "a contained subprogram");
7063 gfc_error ("Unexpected ENTRY statement at %C");
7068 if ((state
== COMP_SUBROUTINE
|| state
== COMP_FUNCTION
)
7069 && gfc_state_stack
->previous
->state
== COMP_INTERFACE
)
7071 gfc_error ("ENTRY statement at %C cannot appear within an INTERFACE");
7075 module_procedure
= gfc_current_ns
->parent
!= NULL
7076 && gfc_current_ns
->parent
->proc_name
7077 && gfc_current_ns
->parent
->proc_name
->attr
.flavor
7080 if (gfc_current_ns
->parent
!= NULL
7081 && gfc_current_ns
->parent
->proc_name
7082 && !module_procedure
)
7084 gfc_error("ENTRY statement at %C cannot appear in a "
7085 "contained procedure");
7089 /* Module function entries need special care in get_proc_name
7090 because previous references within the function will have
7091 created symbols attached to the current namespace. */
7092 if (get_proc_name (name
, &entry
,
7093 gfc_current_ns
->parent
!= NULL
7094 && module_procedure
))
7097 proc
= gfc_current_block ();
7099 /* Make sure that it isn't already declared as BIND(C). If it is, it
7100 must have been marked BIND(C) with a BIND(C) attribute and that is
7101 not allowed for procedures. */
7102 if (entry
->attr
.is_bind_c
== 1)
7104 entry
->attr
.is_bind_c
= 0;
7105 if (entry
->old_symbol
!= NULL
)
7106 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7107 "variables or common blocks",
7108 &(entry
->old_symbol
->declared_at
));
7110 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7111 "variables or common blocks", &gfc_current_locus
);
7114 /* Check what next non-whitespace character is so we can tell if there
7115 is the required parens if we have a BIND(C). */
7116 old_loc
= gfc_current_locus
;
7117 gfc_gobble_whitespace ();
7118 peek_char
= gfc_peek_ascii_char ();
7120 if (state
== COMP_SUBROUTINE
)
7122 m
= gfc_match_formal_arglist (entry
, 0, 1);
7126 /* Call gfc_match_bind_c with allow_binding_name = true as ENTRY can
7127 never be an internal procedure. */
7128 is_bind_c
= gfc_match_bind_c (entry
, true);
7129 if (is_bind_c
== MATCH_ERROR
)
7131 if (is_bind_c
== MATCH_YES
)
7133 if (peek_char
!= '(')
7135 gfc_error ("Missing required parentheses before BIND(C) at %C");
7138 if (!gfc_add_is_bind_c (&(entry
->attr
), entry
->name
,
7139 &(entry
->declared_at
), 1))
7143 if (!gfc_current_ns
->parent
7144 && !add_global_entry (name
, entry
->binding_label
, true,
7148 /* An entry in a subroutine. */
7149 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
7150 || !gfc_add_subroutine (&entry
->attr
, entry
->name
, NULL
))
7155 /* An entry in a function.
7156 We need to take special care because writing
7161 ENTRY f() RESULT (r)
7163 ENTRY f RESULT (r). */
7164 if (gfc_match_eos () == MATCH_YES
)
7166 gfc_current_locus
= old_loc
;
7167 /* Match the empty argument list, and add the interface to
7169 m
= gfc_match_formal_arglist (entry
, 0, 1);
7172 m
= gfc_match_formal_arglist (entry
, 0, 0);
7179 if (gfc_match_eos () == MATCH_YES
)
7181 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
7182 || !gfc_add_function (&entry
->attr
, entry
->name
, NULL
))
7185 entry
->result
= entry
;
7189 m
= gfc_match_suffix (entry
, &result
);
7191 gfc_syntax_error (ST_ENTRY
);
7197 if (!gfc_add_result (&result
->attr
, result
->name
, NULL
)
7198 || !gfc_add_entry (&entry
->attr
, result
->name
, NULL
)
7199 || !gfc_add_function (&entry
->attr
, result
->name
, NULL
))
7201 entry
->result
= result
;
7205 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
7206 || !gfc_add_function (&entry
->attr
, entry
->name
, NULL
))
7208 entry
->result
= entry
;
7212 if (!gfc_current_ns
->parent
7213 && !add_global_entry (name
, entry
->binding_label
, false,
7218 if (gfc_match_eos () != MATCH_YES
)
7220 gfc_syntax_error (ST_ENTRY
);
7224 entry
->attr
.recursive
= proc
->attr
.recursive
;
7225 entry
->attr
.elemental
= proc
->attr
.elemental
;
7226 entry
->attr
.pure
= proc
->attr
.pure
;
7228 el
= gfc_get_entry_list ();
7230 el
->next
= gfc_current_ns
->entries
;
7231 gfc_current_ns
->entries
= el
;
7233 el
->id
= el
->next
->id
+ 1;
7237 new_st
.op
= EXEC_ENTRY
;
7238 new_st
.ext
.entry
= el
;
7244 /* Match a subroutine statement, including optional prefixes. */
7247 gfc_match_subroutine (void)
7249 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7254 bool allow_binding_name
;
7256 if (gfc_current_state () != COMP_NONE
7257 && gfc_current_state () != COMP_INTERFACE
7258 && gfc_current_state () != COMP_CONTAINS
)
7261 m
= gfc_match_prefix (NULL
);
7265 m
= gfc_match ("subroutine% %n", name
);
7269 if (get_proc_name (name
, &sym
, false))
7272 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
7273 the symbol existed before. */
7274 sym
->declared_at
= gfc_current_locus
;
7276 if (current_attr
.module_procedure
)
7277 sym
->attr
.module_procedure
= 1;
7279 if (add_hidden_procptr_result (sym
))
7282 gfc_new_block
= sym
;
7284 /* Check what next non-whitespace character is so we can tell if there
7285 is the required parens if we have a BIND(C). */
7286 gfc_gobble_whitespace ();
7287 peek_char
= gfc_peek_ascii_char ();
7289 if (!gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
))
7292 if (gfc_match_formal_arglist (sym
, 0, 1) != MATCH_YES
)
7295 /* Make sure that it isn't already declared as BIND(C). If it is, it
7296 must have been marked BIND(C) with a BIND(C) attribute and that is
7297 not allowed for procedures. */
7298 if (sym
->attr
.is_bind_c
== 1)
7300 sym
->attr
.is_bind_c
= 0;
7301 if (sym
->old_symbol
!= NULL
)
7302 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7303 "variables or common blocks",
7304 &(sym
->old_symbol
->declared_at
));
7306 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7307 "variables or common blocks", &gfc_current_locus
);
7310 /* C binding names are not allowed for internal procedures. */
7311 if (gfc_current_state () == COMP_CONTAINS
7312 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
7313 allow_binding_name
= false;
7315 allow_binding_name
= true;
7317 /* Here, we are just checking if it has the bind(c) attribute, and if
7318 so, then we need to make sure it's all correct. If it doesn't,
7319 we still need to continue matching the rest of the subroutine line. */
7320 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
7321 if (is_bind_c
== MATCH_ERROR
)
7323 /* There was an attempt at the bind(c), but it was wrong. An
7324 error message should have been printed w/in the gfc_match_bind_c
7325 so here we'll just return the MATCH_ERROR. */
7329 if (is_bind_c
== MATCH_YES
)
7331 /* The following is allowed in the Fortran 2008 draft. */
7332 if (gfc_current_state () == COMP_CONTAINS
7333 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
7334 && !gfc_notify_std (GFC_STD_F2008
, "BIND(C) attribute "
7335 "at %L may not be specified for an internal "
7336 "procedure", &gfc_current_locus
))
7339 if (peek_char
!= '(')
7341 gfc_error ("Missing required parentheses before BIND(C) at %C");
7344 if (!gfc_add_is_bind_c (&(sym
->attr
), sym
->name
,
7345 &(sym
->declared_at
), 1))
7349 if (gfc_match_eos () != MATCH_YES
)
7351 gfc_syntax_error (ST_SUBROUTINE
);
7355 if (!copy_prefix (&sym
->attr
, &sym
->declared_at
))
7357 if(!sym
->attr
.module_procedure
)
7363 /* Warn if it has the same name as an intrinsic. */
7364 do_warn_intrinsic_shadow (sym
, false);
7370 /* Check that the NAME identifier in a BIND attribute or statement
7371 is conform to C identifier rules. */
7374 check_bind_name_identifier (char **name
)
7376 char *n
= *name
, *p
;
7378 /* Remove leading spaces. */
7382 /* On an empty string, free memory and set name to NULL. */
7390 /* Remove trailing spaces. */
7391 p
= n
+ strlen(n
) - 1;
7395 /* Insert the identifier into the symbol table. */
7400 /* Now check that identifier is valid under C rules. */
7403 gfc_error ("Invalid C identifier in NAME= specifier at %C");
7408 if (!(ISALNUM (*p
) || *p
== '_' || *p
== '$'))
7410 gfc_error ("Invalid C identifier in NAME= specifier at %C");
7418 /* Match a BIND(C) specifier, with the optional 'name=' specifier if
7419 given, and set the binding label in either the given symbol (if not
7420 NULL), or in the current_ts. The symbol may be NULL because we may
7421 encounter the BIND(C) before the declaration itself. Return
7422 MATCH_NO if what we're looking at isn't a BIND(C) specifier,
7423 MATCH_ERROR if it is a BIND(C) clause but an error was encountered,
7424 or MATCH_YES if the specifier was correct and the binding label and
7425 bind(c) fields were set correctly for the given symbol or the
7426 current_ts. If allow_binding_name is false, no binding name may be
7430 gfc_match_bind_c (gfc_symbol
*sym
, bool allow_binding_name
)
7432 char *binding_label
= NULL
;
7435 /* Initialize the flag that specifies whether we encountered a NAME=
7436 specifier or not. */
7437 has_name_equals
= 0;
7439 /* This much we have to be able to match, in this order, if
7440 there is a bind(c) label. */
7441 if (gfc_match (" bind ( c ") != MATCH_YES
)
7444 /* Now see if there is a binding label, or if we've reached the
7445 end of the bind(c) attribute without one. */
7446 if (gfc_match_char (',') == MATCH_YES
)
7448 if (gfc_match (" name = ") != MATCH_YES
)
7450 gfc_error ("Syntax error in NAME= specifier for binding label "
7452 /* should give an error message here */
7456 has_name_equals
= 1;
7458 if (gfc_match_init_expr (&e
) != MATCH_YES
)
7464 if (!gfc_simplify_expr(e
, 0))
7466 gfc_error ("NAME= specifier at %C should be a constant expression");
7471 if (e
->expr_type
!= EXPR_CONSTANT
|| e
->ts
.type
!= BT_CHARACTER
7472 || e
->ts
.kind
!= gfc_default_character_kind
|| e
->rank
!= 0)
7474 gfc_error ("NAME= specifier at %C should be a scalar of "
7475 "default character kind");
7480 // Get a C string from the Fortran string constant
7481 binding_label
= gfc_widechar_to_char (e
->value
.character
.string
,
7482 e
->value
.character
.length
);
7485 // Check that it is valid (old gfc_match_name_C)
7486 if (check_bind_name_identifier (&binding_label
) != MATCH_YES
)
7490 /* Get the required right paren. */
7491 if (gfc_match_char (')') != MATCH_YES
)
7493 gfc_error ("Missing closing paren for binding label at %C");
7497 if (has_name_equals
&& !allow_binding_name
)
7499 gfc_error ("No binding name is allowed in BIND(C) at %C");
7503 if (has_name_equals
&& sym
!= NULL
&& sym
->attr
.dummy
)
7505 gfc_error ("For dummy procedure %s, no binding name is "
7506 "allowed in BIND(C) at %C", sym
->name
);
7511 /* Save the binding label to the symbol. If sym is null, we're
7512 probably matching the typespec attributes of a declaration and
7513 haven't gotten the name yet, and therefore, no symbol yet. */
7517 sym
->binding_label
= binding_label
;
7519 curr_binding_label
= binding_label
;
7521 else if (allow_binding_name
)
7523 /* No binding label, but if symbol isn't null, we
7524 can set the label for it here.
7525 If name="" or allow_binding_name is false, no C binding name is
7527 if (sym
!= NULL
&& sym
->name
!= NULL
&& has_name_equals
== 0)
7528 sym
->binding_label
= IDENTIFIER_POINTER (get_identifier (sym
->name
));
7531 if (has_name_equals
&& gfc_current_state () == COMP_INTERFACE
7532 && current_interface
.type
== INTERFACE_ABSTRACT
)
7534 gfc_error ("NAME not allowed on BIND(C) for ABSTRACT INTERFACE at %C");
7542 /* Return nonzero if we're currently compiling a contained procedure. */
7545 contained_procedure (void)
7547 gfc_state_data
*s
= gfc_state_stack
;
7549 if ((s
->state
== COMP_SUBROUTINE
|| s
->state
== COMP_FUNCTION
)
7550 && s
->previous
!= NULL
&& s
->previous
->state
== COMP_CONTAINS
)
7556 /* Set the kind of each enumerator. The kind is selected such that it is
7557 interoperable with the corresponding C enumeration type, making
7558 sure that -fshort-enums is honored. */
7563 enumerator_history
*current_history
= NULL
;
7567 if (max_enum
== NULL
|| enum_history
== NULL
)
7570 if (!flag_short_enums
)
7576 kind
= gfc_integer_kinds
[i
++].kind
;
7578 while (kind
< gfc_c_int_kind
7579 && gfc_check_integer_range (max_enum
->initializer
->value
.integer
,
7582 current_history
= enum_history
;
7583 while (current_history
!= NULL
)
7585 current_history
->sym
->ts
.kind
= kind
;
7586 current_history
= current_history
->next
;
7591 /* Match any of the various end-block statements. Returns the type of
7592 END to the caller. The END INTERFACE, END IF, END DO, END SELECT
7593 and END BLOCK statements cannot be replaced by a single END statement. */
7596 gfc_match_end (gfc_statement
*st
)
7598 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7599 gfc_compile_state state
;
7601 const char *block_name
;
7605 gfc_namespace
*parent_ns
, *ns
, *prev_ns
;
7606 gfc_namespace
**nsp
;
7607 bool abreviated_modproc_decl
= false;
7608 bool got_matching_end
= false;
7610 old_loc
= gfc_current_locus
;
7611 if (gfc_match ("end") != MATCH_YES
)
7614 state
= gfc_current_state ();
7615 block_name
= gfc_current_block () == NULL
7616 ? NULL
: gfc_current_block ()->name
;
7620 case COMP_ASSOCIATE
:
7622 if (!strncmp (block_name
, "block@", strlen("block@")))
7627 case COMP_DERIVED_CONTAINS
:
7628 state
= gfc_state_stack
->previous
->state
;
7629 block_name
= gfc_state_stack
->previous
->sym
== NULL
7630 ? NULL
: gfc_state_stack
->previous
->sym
->name
;
7631 abreviated_modproc_decl
= gfc_state_stack
->previous
->sym
7632 && gfc_state_stack
->previous
->sym
->abr_modproc_decl
;
7639 if (!abreviated_modproc_decl
)
7640 abreviated_modproc_decl
= gfc_current_block ()
7641 && gfc_current_block ()->abr_modproc_decl
;
7647 *st
= ST_END_PROGRAM
;
7648 target
= " program";
7652 case COMP_SUBROUTINE
:
7653 *st
= ST_END_SUBROUTINE
;
7654 if (!abreviated_modproc_decl
)
7655 target
= " subroutine";
7657 target
= " procedure";
7658 eos_ok
= !contained_procedure ();
7662 *st
= ST_END_FUNCTION
;
7663 if (!abreviated_modproc_decl
)
7664 target
= " function";
7666 target
= " procedure";
7667 eos_ok
= !contained_procedure ();
7670 case COMP_BLOCK_DATA
:
7671 *st
= ST_END_BLOCK_DATA
;
7672 target
= " block data";
7677 *st
= ST_END_MODULE
;
7682 case COMP_SUBMODULE
:
7683 *st
= ST_END_SUBMODULE
;
7684 target
= " submodule";
7688 case COMP_INTERFACE
:
7689 *st
= ST_END_INTERFACE
;
7690 target
= " interface";
7706 case COMP_STRUCTURE
:
7707 *st
= ST_END_STRUCTURE
;
7708 target
= " structure";
7713 case COMP_DERIVED_CONTAINS
:
7719 case COMP_ASSOCIATE
:
7720 *st
= ST_END_ASSOCIATE
;
7721 target
= " associate";
7738 case COMP_DO_CONCURRENT
:
7745 *st
= ST_END_CRITICAL
;
7746 target
= " critical";
7751 case COMP_SELECT_TYPE
:
7752 *st
= ST_END_SELECT
;
7758 *st
= ST_END_FORALL
;
7773 last_initializer
= NULL
;
7775 gfc_free_enum_history ();
7779 gfc_error ("Unexpected END statement at %C");
7783 old_loc
= gfc_current_locus
;
7784 if (gfc_match_eos () == MATCH_YES
)
7786 if (!eos_ok
&& (*st
== ST_END_SUBROUTINE
|| *st
== ST_END_FUNCTION
))
7788 if (!gfc_notify_std (GFC_STD_F2008
, "END statement "
7789 "instead of %s statement at %L",
7790 abreviated_modproc_decl
? "END PROCEDURE"
7791 : gfc_ascii_statement(*st
), &old_loc
))
7796 /* We would have required END [something]. */
7797 gfc_error ("%s statement expected at %L",
7798 gfc_ascii_statement (*st
), &old_loc
);
7805 /* Verify that we've got the sort of end-block that we're expecting. */
7806 if (gfc_match (target
) != MATCH_YES
)
7808 gfc_error ("Expecting %s statement at %L", abreviated_modproc_decl
7809 ? "END PROCEDURE" : gfc_ascii_statement(*st
), &old_loc
);
7813 got_matching_end
= true;
7815 old_loc
= gfc_current_locus
;
7816 /* If we're at the end, make sure a block name wasn't required. */
7817 if (gfc_match_eos () == MATCH_YES
)
7820 if (*st
!= ST_ENDDO
&& *st
!= ST_ENDIF
&& *st
!= ST_END_SELECT
7821 && *st
!= ST_END_FORALL
&& *st
!= ST_END_WHERE
&& *st
!= ST_END_BLOCK
7822 && *st
!= ST_END_ASSOCIATE
&& *st
!= ST_END_CRITICAL
)
7828 gfc_error ("Expected block name of %qs in %s statement at %L",
7829 block_name
, gfc_ascii_statement (*st
), &old_loc
);
7834 /* END INTERFACE has a special handler for its several possible endings. */
7835 if (*st
== ST_END_INTERFACE
)
7836 return gfc_match_end_interface ();
7838 /* We haven't hit the end of statement, so what is left must be an
7840 m
= gfc_match_space ();
7842 m
= gfc_match_name (name
);
7845 gfc_error ("Expected terminating name at %C");
7849 if (block_name
== NULL
)
7852 /* We have to pick out the declared submodule name from the composite
7853 required by F2008:11.2.3 para 2, which ends in the declared name. */
7854 if (state
== COMP_SUBMODULE
)
7855 block_name
= strchr (block_name
, '.') + 1;
7857 if (strcmp (name
, block_name
) != 0 && strcmp (block_name
, "ppr@") != 0)
7859 gfc_error ("Expected label %qs for %s statement at %C", block_name
,
7860 gfc_ascii_statement (*st
));
7863 /* Procedure pointer as function result. */
7864 else if (strcmp (block_name
, "ppr@") == 0
7865 && strcmp (name
, gfc_current_block ()->ns
->proc_name
->name
) != 0)
7867 gfc_error ("Expected label %qs for %s statement at %C",
7868 gfc_current_block ()->ns
->proc_name
->name
,
7869 gfc_ascii_statement (*st
));
7873 if (gfc_match_eos () == MATCH_YES
)
7877 gfc_syntax_error (*st
);
7880 gfc_current_locus
= old_loc
;
7882 /* If we are missing an END BLOCK, we created a half-ready namespace.
7883 Remove it from the parent namespace's sibling list. */
7885 while (state
== COMP_BLOCK
&& !got_matching_end
)
7887 parent_ns
= gfc_current_ns
->parent
;
7889 nsp
= &(gfc_state_stack
->previous
->tail
->ext
.block
.ns
);
7895 if (ns
== gfc_current_ns
)
7897 if (prev_ns
== NULL
)
7900 prev_ns
->sibling
= ns
->sibling
;
7906 gfc_free_namespace (gfc_current_ns
);
7907 gfc_current_ns
= parent_ns
;
7908 gfc_state_stack
= gfc_state_stack
->previous
;
7909 state
= gfc_current_state ();
7917 /***************** Attribute declaration statements ****************/
7919 /* Set the attribute of a single variable. */
7924 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7927 /* Workaround -Wmaybe-uninitialized false positive during
7928 profiledbootstrap by initializing them. */
7929 gfc_symbol
*sym
= NULL
;
7935 m
= gfc_match_name (name
);
7939 if (find_special (name
, &sym
, false))
7942 if (!check_function_name (name
))
7948 var_locus
= gfc_current_locus
;
7950 /* Deal with possible array specification for certain attributes. */
7951 if (current_attr
.dimension
7952 || current_attr
.codimension
7953 || current_attr
.allocatable
7954 || current_attr
.pointer
7955 || current_attr
.target
)
7957 m
= gfc_match_array_spec (&as
, !current_attr
.codimension
,
7958 !current_attr
.dimension
7959 && !current_attr
.pointer
7960 && !current_attr
.target
);
7961 if (m
== MATCH_ERROR
)
7964 if (current_attr
.dimension
&& m
== MATCH_NO
)
7966 gfc_error ("Missing array specification at %L in DIMENSION "
7967 "statement", &var_locus
);
7972 if (current_attr
.dimension
&& sym
->value
)
7974 gfc_error ("Dimensions specified for %s at %L after its "
7975 "initialization", sym
->name
, &var_locus
);
7980 if (current_attr
.codimension
&& m
== MATCH_NO
)
7982 gfc_error ("Missing array specification at %L in CODIMENSION "
7983 "statement", &var_locus
);
7988 if ((current_attr
.allocatable
|| current_attr
.pointer
)
7989 && (m
== MATCH_YES
) && (as
->type
!= AS_DEFERRED
))
7991 gfc_error ("Array specification must be deferred at %L", &var_locus
);
7997 /* Update symbol table. DIMENSION attribute is set in
7998 gfc_set_array_spec(). For CLASS variables, this must be applied
7999 to the first component, or '_data' field. */
8000 if (sym
->ts
.type
== BT_CLASS
&& sym
->ts
.u
.derived
->attr
.is_class
)
8002 if (!gfc_copy_attr (&CLASS_DATA(sym
)->attr
, ¤t_attr
, &var_locus
))
8010 if (current_attr
.dimension
== 0 && current_attr
.codimension
== 0
8011 && !gfc_copy_attr (&sym
->attr
, ¤t_attr
, &var_locus
))
8018 if (sym
->ts
.type
== BT_CLASS
8019 && !gfc_build_class_symbol (&sym
->ts
, &sym
->attr
, &sym
->as
))
8025 if (!gfc_set_array_spec (sym
, as
, &var_locus
))
8031 if (sym
->attr
.cray_pointee
&& sym
->as
!= NULL
)
8033 /* Fix the array spec. */
8034 m
= gfc_mod_pointee_as (sym
->as
);
8035 if (m
== MATCH_ERROR
)
8039 if (!gfc_add_attribute (&sym
->attr
, &var_locus
))
8045 if ((current_attr
.external
|| current_attr
.intrinsic
)
8046 && sym
->attr
.flavor
!= FL_PROCEDURE
8047 && !gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, NULL
))
8053 add_hidden_procptr_result (sym
);
8058 gfc_free_array_spec (as
);
8063 /* Generic attribute declaration subroutine. Used for attributes that
8064 just have a list of names. */
8071 /* Gobble the optional double colon, by simply ignoring the result
8081 if (gfc_match_eos () == MATCH_YES
)
8087 if (gfc_match_char (',') != MATCH_YES
)
8089 gfc_error ("Unexpected character in variable list at %C");
8099 /* This routine matches Cray Pointer declarations of the form:
8100 pointer ( <pointer>, <pointee> )
8102 pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...
8103 The pointer, if already declared, should be an integer. Otherwise, we
8104 set it as BT_INTEGER with kind gfc_index_integer_kind. The pointee may
8105 be either a scalar, or an array declaration. No space is allocated for
8106 the pointee. For the statement
8107 pointer (ipt, ar(10))
8108 any subsequent uses of ar will be translated (in C-notation) as
8109 ar(i) => ((<type> *) ipt)(i)
8110 After gimplification, pointee variable will disappear in the code. */
8113 cray_pointer_decl (void)
8116 gfc_array_spec
*as
= NULL
;
8117 gfc_symbol
*cptr
; /* Pointer symbol. */
8118 gfc_symbol
*cpte
; /* Pointee symbol. */
8124 if (gfc_match_char ('(') != MATCH_YES
)
8126 gfc_error ("Expected %<(%> at %C");
8130 /* Match pointer. */
8131 var_locus
= gfc_current_locus
;
8132 gfc_clear_attr (¤t_attr
);
8133 gfc_add_cray_pointer (¤t_attr
, &var_locus
);
8134 current_ts
.type
= BT_INTEGER
;
8135 current_ts
.kind
= gfc_index_integer_kind
;
8137 m
= gfc_match_symbol (&cptr
, 0);
8140 gfc_error ("Expected variable name at %C");
8144 if (!gfc_add_cray_pointer (&cptr
->attr
, &var_locus
))
8147 gfc_set_sym_referenced (cptr
);
8149 if (cptr
->ts
.type
== BT_UNKNOWN
) /* Override the type, if necessary. */
8151 cptr
->ts
.type
= BT_INTEGER
;
8152 cptr
->ts
.kind
= gfc_index_integer_kind
;
8154 else if (cptr
->ts
.type
!= BT_INTEGER
)
8156 gfc_error ("Cray pointer at %C must be an integer");
8159 else if (cptr
->ts
.kind
< gfc_index_integer_kind
)
8160 gfc_warning (0, "Cray pointer at %C has %d bytes of precision;"
8161 " memory addresses require %d bytes",
8162 cptr
->ts
.kind
, gfc_index_integer_kind
);
8164 if (gfc_match_char (',') != MATCH_YES
)
8166 gfc_error ("Expected \",\" at %C");
8170 /* Match Pointee. */
8171 var_locus
= gfc_current_locus
;
8172 gfc_clear_attr (¤t_attr
);
8173 gfc_add_cray_pointee (¤t_attr
, &var_locus
);
8174 current_ts
.type
= BT_UNKNOWN
;
8175 current_ts
.kind
= 0;
8177 m
= gfc_match_symbol (&cpte
, 0);
8180 gfc_error ("Expected variable name at %C");
8184 /* Check for an optional array spec. */
8185 m
= gfc_match_array_spec (&as
, true, false);
8186 if (m
== MATCH_ERROR
)
8188 gfc_free_array_spec (as
);
8191 else if (m
== MATCH_NO
)
8193 gfc_free_array_spec (as
);
8197 if (!gfc_add_cray_pointee (&cpte
->attr
, &var_locus
))
8200 gfc_set_sym_referenced (cpte
);
8202 if (cpte
->as
== NULL
)
8204 if (!gfc_set_array_spec (cpte
, as
, &var_locus
))
8205 gfc_internal_error ("Couldn't set Cray pointee array spec.");
8207 else if (as
!= NULL
)
8209 gfc_error ("Duplicate array spec for Cray pointee at %C");
8210 gfc_free_array_spec (as
);
8216 if (cpte
->as
!= NULL
)
8218 /* Fix array spec. */
8219 m
= gfc_mod_pointee_as (cpte
->as
);
8220 if (m
== MATCH_ERROR
)
8224 /* Point the Pointee at the Pointer. */
8225 cpte
->cp_pointer
= cptr
;
8227 if (gfc_match_char (')') != MATCH_YES
)
8229 gfc_error ("Expected \")\" at %C");
8232 m
= gfc_match_char (',');
8234 done
= true; /* Stop searching for more declarations. */
8238 if (m
== MATCH_ERROR
/* Failed when trying to find ',' above. */
8239 || gfc_match_eos () != MATCH_YES
)
8241 gfc_error ("Expected %<,%> or end of statement at %C");
8249 gfc_match_external (void)
8252 gfc_clear_attr (¤t_attr
);
8253 current_attr
.external
= 1;
8255 return attr_decl ();
8260 gfc_match_intent (void)
8264 /* This is not allowed within a BLOCK construct! */
8265 if (gfc_current_state () == COMP_BLOCK
)
8267 gfc_error ("INTENT is not allowed inside of BLOCK at %C");
8271 intent
= match_intent_spec ();
8272 if (intent
== INTENT_UNKNOWN
)
8275 gfc_clear_attr (¤t_attr
);
8276 current_attr
.intent
= intent
;
8278 return attr_decl ();
8283 gfc_match_intrinsic (void)
8286 gfc_clear_attr (¤t_attr
);
8287 current_attr
.intrinsic
= 1;
8289 return attr_decl ();
8294 gfc_match_optional (void)
8296 /* This is not allowed within a BLOCK construct! */
8297 if (gfc_current_state () == COMP_BLOCK
)
8299 gfc_error ("OPTIONAL is not allowed inside of BLOCK at %C");
8303 gfc_clear_attr (¤t_attr
);
8304 current_attr
.optional
= 1;
8306 return attr_decl ();
8311 gfc_match_pointer (void)
8313 gfc_gobble_whitespace ();
8314 if (gfc_peek_ascii_char () == '(')
8316 if (!flag_cray_pointer
)
8318 gfc_error ("Cray pointer declaration at %C requires -fcray-pointer "
8322 return cray_pointer_decl ();
8326 gfc_clear_attr (¤t_attr
);
8327 current_attr
.pointer
= 1;
8329 return attr_decl ();
8335 gfc_match_allocatable (void)
8337 gfc_clear_attr (¤t_attr
);
8338 current_attr
.allocatable
= 1;
8340 return attr_decl ();
8345 gfc_match_codimension (void)
8347 gfc_clear_attr (¤t_attr
);
8348 current_attr
.codimension
= 1;
8350 return attr_decl ();
8355 gfc_match_contiguous (void)
8357 if (!gfc_notify_std (GFC_STD_F2008
, "CONTIGUOUS statement at %C"))
8360 gfc_clear_attr (¤t_attr
);
8361 current_attr
.contiguous
= 1;
8363 return attr_decl ();
8368 gfc_match_dimension (void)
8370 gfc_clear_attr (¤t_attr
);
8371 current_attr
.dimension
= 1;
8373 return attr_decl ();
8378 gfc_match_target (void)
8380 gfc_clear_attr (¤t_attr
);
8381 current_attr
.target
= 1;
8383 return attr_decl ();
8387 /* Match the list of entities being specified in a PUBLIC or PRIVATE
8391 access_attr_decl (gfc_statement st
)
8393 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8394 interface_type type
;
8396 gfc_symbol
*sym
, *dt_sym
;
8397 gfc_intrinsic_op op
;
8400 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
8405 m
= gfc_match_generic_spec (&type
, name
, &op
);
8408 if (m
== MATCH_ERROR
)
8413 case INTERFACE_NAMELESS
:
8414 case INTERFACE_ABSTRACT
:
8417 case INTERFACE_GENERIC
:
8418 case INTERFACE_DTIO
:
8420 if (gfc_get_symbol (name
, NULL
, &sym
))
8423 if (type
== INTERFACE_DTIO
8424 && gfc_current_ns
->proc_name
8425 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
8426 && sym
->attr
.flavor
== FL_UNKNOWN
)
8427 sym
->attr
.flavor
= FL_PROCEDURE
;
8429 if (!gfc_add_access (&sym
->attr
,
8431 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
,
8435 if (sym
->attr
.generic
&& (dt_sym
= gfc_find_dt_in_generic (sym
))
8436 && !gfc_add_access (&dt_sym
->attr
,
8438 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
,
8444 case INTERFACE_INTRINSIC_OP
:
8445 if (gfc_current_ns
->operator_access
[op
] == ACCESS_UNKNOWN
)
8447 gfc_intrinsic_op other_op
;
8449 gfc_current_ns
->operator_access
[op
] =
8450 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
8452 /* Handle the case if there is another op with the same
8453 function, for INTRINSIC_EQ vs. INTRINSIC_EQ_OS and so on. */
8454 other_op
= gfc_equivalent_op (op
);
8456 if (other_op
!= INTRINSIC_NONE
)
8457 gfc_current_ns
->operator_access
[other_op
] =
8458 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
8463 gfc_error ("Access specification of the %s operator at %C has "
8464 "already been specified", gfc_op2string (op
));
8470 case INTERFACE_USER_OP
:
8471 uop
= gfc_get_uop (name
);
8473 if (uop
->access
== ACCESS_UNKNOWN
)
8475 uop
->access
= (st
== ST_PUBLIC
)
8476 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
8480 gfc_error ("Access specification of the .%s. operator at %C "
8481 "has already been specified", sym
->name
);
8488 if (gfc_match_char (',') == MATCH_NO
)
8492 if (gfc_match_eos () != MATCH_YES
)
8497 gfc_syntax_error (st
);
8505 gfc_match_protected (void)
8510 if (!gfc_current_ns
->proc_name
8511 || gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
8513 gfc_error ("PROTECTED at %C only allowed in specification "
8514 "part of a module");
8519 if (!gfc_notify_std (GFC_STD_F2003
, "PROTECTED statement at %C"))
8522 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
8527 if (gfc_match_eos () == MATCH_YES
)
8532 m
= gfc_match_symbol (&sym
, 0);
8536 if (!gfc_add_protected (&sym
->attr
, sym
->name
, &gfc_current_locus
))
8548 if (gfc_match_eos () == MATCH_YES
)
8550 if (gfc_match_char (',') != MATCH_YES
)
8557 gfc_error ("Syntax error in PROTECTED statement at %C");
8562 /* The PRIVATE statement is a bit weird in that it can be an attribute
8563 declaration, but also works as a standalone statement inside of a
8564 type declaration or a module. */
8567 gfc_match_private (gfc_statement
*st
)
8570 if (gfc_match ("private") != MATCH_YES
)
8573 if (gfc_current_state () != COMP_MODULE
8574 && !(gfc_current_state () == COMP_DERIVED
8575 && gfc_state_stack
->previous
8576 && gfc_state_stack
->previous
->state
== COMP_MODULE
)
8577 && !(gfc_current_state () == COMP_DERIVED_CONTAINS
8578 && gfc_state_stack
->previous
&& gfc_state_stack
->previous
->previous
8579 && gfc_state_stack
->previous
->previous
->state
== COMP_MODULE
))
8581 gfc_error ("PRIVATE statement at %C is only allowed in the "
8582 "specification part of a module");
8586 if (gfc_current_state () == COMP_DERIVED
)
8588 if (gfc_match_eos () == MATCH_YES
)
8594 gfc_syntax_error (ST_PRIVATE
);
8598 if (gfc_match_eos () == MATCH_YES
)
8605 return access_attr_decl (ST_PRIVATE
);
8610 gfc_match_public (gfc_statement
*st
)
8613 if (gfc_match ("public") != MATCH_YES
)
8616 if (gfc_current_state () != COMP_MODULE
)
8618 gfc_error ("PUBLIC statement at %C is only allowed in the "
8619 "specification part of a module");
8623 if (gfc_match_eos () == MATCH_YES
)
8630 return access_attr_decl (ST_PUBLIC
);
8634 /* Workhorse for gfc_match_parameter. */
8644 m
= gfc_match_symbol (&sym
, 0);
8646 gfc_error ("Expected variable name at %C in PARAMETER statement");
8651 if (gfc_match_char ('=') == MATCH_NO
)
8653 gfc_error ("Expected = sign in PARAMETER statement at %C");
8657 m
= gfc_match_init_expr (&init
);
8659 gfc_error ("Expected expression at %C in PARAMETER statement");
8663 if (sym
->ts
.type
== BT_UNKNOWN
8664 && !gfc_set_default_type (sym
, 1, NULL
))
8670 if (!gfc_check_assign_symbol (sym
, NULL
, init
)
8671 || !gfc_add_flavor (&sym
->attr
, FL_PARAMETER
, sym
->name
, NULL
))
8679 gfc_error ("Initializing already initialized variable at %C");
8684 t
= add_init_expr_to_sym (sym
->name
, &init
, &gfc_current_locus
);
8685 return (t
) ? MATCH_YES
: MATCH_ERROR
;
8688 gfc_free_expr (init
);
8693 /* Match a parameter statement, with the weird syntax that these have. */
8696 gfc_match_parameter (void)
8698 const char *term
= " )%t";
8701 if (gfc_match_char ('(') == MATCH_NO
)
8703 /* With legacy PARAMETER statements, don't expect a terminating ')'. */
8704 if (!gfc_notify_std (GFC_STD_LEGACY
, "PARAMETER without '()' at %C"))
8715 if (gfc_match (term
) == MATCH_YES
)
8718 if (gfc_match_char (',') != MATCH_YES
)
8720 gfc_error ("Unexpected characters in PARAMETER statement at %C");
8731 gfc_match_automatic (void)
8735 bool seen_symbol
= false;
8737 if (!flag_dec_static
)
8739 gfc_error ("%s at %C is a DEC extension, enable with "
8750 m
= gfc_match_symbol (&sym
, 0);
8760 if (!gfc_add_automatic (&sym
->attr
, sym
->name
, &gfc_current_locus
))
8766 if (gfc_match_eos () == MATCH_YES
)
8768 if (gfc_match_char (',') != MATCH_YES
)
8774 gfc_error ("Expected entity-list in AUTOMATIC statement at %C");
8781 gfc_error ("Syntax error in AUTOMATIC statement at %C");
8787 gfc_match_static (void)
8791 bool seen_symbol
= false;
8793 if (!flag_dec_static
)
8795 gfc_error ("%s at %C is a DEC extension, enable with "
8805 m
= gfc_match_symbol (&sym
, 0);
8815 if (!gfc_add_save (&sym
->attr
, SAVE_EXPLICIT
, sym
->name
,
8816 &gfc_current_locus
))
8822 if (gfc_match_eos () == MATCH_YES
)
8824 if (gfc_match_char (',') != MATCH_YES
)
8830 gfc_error ("Expected entity-list in STATIC statement at %C");
8837 gfc_error ("Syntax error in STATIC statement at %C");
8842 /* Save statements have a special syntax. */
8845 gfc_match_save (void)
8847 char n
[GFC_MAX_SYMBOL_LEN
+1];
8852 if (gfc_match_eos () == MATCH_YES
)
8854 if (gfc_current_ns
->seen_save
)
8856 if (!gfc_notify_std (GFC_STD_LEGACY
, "Blanket SAVE statement at %C "
8857 "follows previous SAVE statement"))
8861 gfc_current_ns
->save_all
= gfc_current_ns
->seen_save
= 1;
8865 if (gfc_current_ns
->save_all
)
8867 if (!gfc_notify_std (GFC_STD_LEGACY
, "SAVE statement at %C follows "
8868 "blanket SAVE statement"))
8876 m
= gfc_match_symbol (&sym
, 0);
8880 if (!gfc_add_save (&sym
->attr
, SAVE_EXPLICIT
, sym
->name
,
8881 &gfc_current_locus
))
8892 m
= gfc_match (" / %n /", &n
);
8893 if (m
== MATCH_ERROR
)
8898 c
= gfc_get_common (n
, 0);
8901 gfc_current_ns
->seen_save
= 1;
8904 if (gfc_match_eos () == MATCH_YES
)
8906 if (gfc_match_char (',') != MATCH_YES
)
8913 gfc_error ("Syntax error in SAVE statement at %C");
8919 gfc_match_value (void)
8924 /* This is not allowed within a BLOCK construct! */
8925 if (gfc_current_state () == COMP_BLOCK
)
8927 gfc_error ("VALUE is not allowed inside of BLOCK at %C");
8931 if (!gfc_notify_std (GFC_STD_F2003
, "VALUE statement at %C"))
8934 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
8939 if (gfc_match_eos () == MATCH_YES
)
8944 m
= gfc_match_symbol (&sym
, 0);
8948 if (!gfc_add_value (&sym
->attr
, sym
->name
, &gfc_current_locus
))
8960 if (gfc_match_eos () == MATCH_YES
)
8962 if (gfc_match_char (',') != MATCH_YES
)
8969 gfc_error ("Syntax error in VALUE statement at %C");
8975 gfc_match_volatile (void)
8980 if (!gfc_notify_std (GFC_STD_F2003
, "VOLATILE statement at %C"))
8983 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
8988 if (gfc_match_eos () == MATCH_YES
)
8993 /* VOLATILE is special because it can be added to host-associated
8994 symbols locally. Except for coarrays. */
8995 m
= gfc_match_symbol (&sym
, 1);
8999 /* F2008, C560+C561. VOLATILE for host-/use-associated variable or
9000 for variable in a BLOCK which is defined outside of the BLOCK. */
9001 if (sym
->ns
!= gfc_current_ns
&& sym
->attr
.codimension
)
9003 gfc_error ("Specifying VOLATILE for coarray variable %qs at "
9004 "%C, which is use-/host-associated", sym
->name
);
9007 if (!gfc_add_volatile (&sym
->attr
, sym
->name
, &gfc_current_locus
))
9019 if (gfc_match_eos () == MATCH_YES
)
9021 if (gfc_match_char (',') != MATCH_YES
)
9028 gfc_error ("Syntax error in VOLATILE statement at %C");
9034 gfc_match_asynchronous (void)
9039 if (!gfc_notify_std (GFC_STD_F2003
, "ASYNCHRONOUS statement at %C"))
9042 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
9047 if (gfc_match_eos () == MATCH_YES
)
9052 /* ASYNCHRONOUS is special because it can be added to host-associated
9054 m
= gfc_match_symbol (&sym
, 1);
9058 if (!gfc_add_asynchronous (&sym
->attr
, sym
->name
, &gfc_current_locus
))
9070 if (gfc_match_eos () == MATCH_YES
)
9072 if (gfc_match_char (',') != MATCH_YES
)
9079 gfc_error ("Syntax error in ASYNCHRONOUS statement at %C");
9084 /* Match a module procedure statement in a submodule. */
9087 gfc_match_submod_proc (void)
9089 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9090 gfc_symbol
*sym
, *fsym
;
9092 gfc_formal_arglist
*formal
, *head
, *tail
;
9094 if (gfc_current_state () != COMP_CONTAINS
9095 || !(gfc_state_stack
->previous
9096 && (gfc_state_stack
->previous
->state
== COMP_SUBMODULE
9097 || gfc_state_stack
->previous
->state
== COMP_MODULE
)))
9100 m
= gfc_match (" module% procedure% %n", name
);
9104 if (!gfc_notify_std (GFC_STD_F2008
, "MODULE PROCEDURE declaration "
9108 if (get_proc_name (name
, &sym
, false))
9111 /* Make sure that the result field is appropriately filled, even though
9112 the result symbol will be replaced later on. */
9113 if (sym
->tlink
&& sym
->tlink
->attr
.function
)
9115 if (sym
->tlink
->result
9116 && sym
->tlink
->result
!= sym
->tlink
)
9117 sym
->result
= sym
->tlink
->result
;
9122 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
9123 the symbol existed before. */
9124 sym
->declared_at
= gfc_current_locus
;
9126 if (!sym
->attr
.module_procedure
)
9129 /* Signal match_end to expect "end procedure". */
9130 sym
->abr_modproc_decl
= 1;
9132 /* Change from IFSRC_IFBODY coming from the interface declaration. */
9133 sym
->attr
.if_source
= IFSRC_DECL
;
9135 gfc_new_block
= sym
;
9137 /* Make a new formal arglist with the symbols in the procedure
9140 for (formal
= sym
->formal
; formal
&& formal
->sym
; formal
= formal
->next
)
9142 if (formal
== sym
->formal
)
9143 head
= tail
= gfc_get_formal_arglist ();
9146 tail
->next
= gfc_get_formal_arglist ();
9150 if (gfc_copy_dummy_sym (&fsym
, formal
->sym
, 0))
9154 gfc_set_sym_referenced (fsym
);
9157 /* The dummy symbols get cleaned up, when the formal_namespace of the
9158 interface declaration is cleared. This allows us to add the
9159 explicit interface as is done for other type of procedure. */
9160 if (!gfc_add_explicit_interface (sym
, IFSRC_DECL
, head
,
9161 &gfc_current_locus
))
9164 if (gfc_match_eos () != MATCH_YES
)
9166 gfc_syntax_error (ST_MODULE_PROC
);
9173 gfc_free_formal_arglist (head
);
9178 /* Match a module procedure statement. Note that we have to modify
9179 symbols in the parent's namespace because the current one was there
9180 to receive symbols that are in an interface's formal argument list. */
9183 gfc_match_modproc (void)
9185 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9189 gfc_namespace
*module_ns
;
9190 gfc_interface
*old_interface_head
, *interface
;
9192 if (gfc_state_stack
->state
!= COMP_INTERFACE
9193 || gfc_state_stack
->previous
== NULL
9194 || current_interface
.type
== INTERFACE_NAMELESS
9195 || current_interface
.type
== INTERFACE_ABSTRACT
)
9197 gfc_error ("MODULE PROCEDURE at %C must be in a generic module "
9202 module_ns
= gfc_current_ns
->parent
;
9203 for (; module_ns
; module_ns
= module_ns
->parent
)
9204 if (module_ns
->proc_name
->attr
.flavor
== FL_MODULE
9205 || module_ns
->proc_name
->attr
.flavor
== FL_PROGRAM
9206 || (module_ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
9207 && !module_ns
->proc_name
->attr
.contained
))
9210 if (module_ns
== NULL
)
9213 /* Store the current state of the interface. We will need it if we
9214 end up with a syntax error and need to recover. */
9215 old_interface_head
= gfc_current_interface_head ();
9217 /* Check if the F2008 optional double colon appears. */
9218 gfc_gobble_whitespace ();
9219 old_locus
= gfc_current_locus
;
9220 if (gfc_match ("::") == MATCH_YES
)
9222 if (!gfc_notify_std (GFC_STD_F2008
, "double colon in "
9223 "MODULE PROCEDURE statement at %L", &old_locus
))
9227 gfc_current_locus
= old_locus
;
9232 old_locus
= gfc_current_locus
;
9234 m
= gfc_match_name (name
);
9240 /* Check for syntax error before starting to add symbols to the
9241 current namespace. */
9242 if (gfc_match_eos () == MATCH_YES
)
9245 if (!last
&& gfc_match_char (',') != MATCH_YES
)
9248 /* Now we're sure the syntax is valid, we process this item
9250 if (gfc_get_symbol (name
, module_ns
, &sym
))
9253 if (sym
->attr
.intrinsic
)
9255 gfc_error ("Intrinsic procedure at %L cannot be a MODULE "
9256 "PROCEDURE", &old_locus
);
9260 if (sym
->attr
.proc
!= PROC_MODULE
9261 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
9264 if (!gfc_add_interface (sym
))
9267 sym
->attr
.mod_proc
= 1;
9268 sym
->declared_at
= old_locus
;
9277 /* Restore the previous state of the interface. */
9278 interface
= gfc_current_interface_head ();
9279 gfc_set_current_interface_head (old_interface_head
);
9281 /* Free the new interfaces. */
9282 while (interface
!= old_interface_head
)
9284 gfc_interface
*i
= interface
->next
;
9289 /* And issue a syntax error. */
9290 gfc_syntax_error (ST_MODULE_PROC
);
9295 /* Check a derived type that is being extended. */
9298 check_extended_derived_type (char *name
)
9300 gfc_symbol
*extended
;
9302 if (gfc_find_symbol (name
, gfc_current_ns
, 1, &extended
))
9304 gfc_error ("Ambiguous symbol in TYPE definition at %C");
9308 extended
= gfc_find_dt_in_generic (extended
);
9313 gfc_error ("Symbol %qs at %C has not been previously defined", name
);
9317 if (extended
->attr
.flavor
!= FL_DERIVED
)
9319 gfc_error ("%qs in EXTENDS expression at %C is not a "
9320 "derived type", name
);
9324 if (extended
->attr
.is_bind_c
)
9326 gfc_error ("%qs cannot be extended at %C because it "
9327 "is BIND(C)", extended
->name
);
9331 if (extended
->attr
.sequence
)
9333 gfc_error ("%qs cannot be extended at %C because it "
9334 "is a SEQUENCE type", extended
->name
);
9342 /* Match the optional attribute specifiers for a type declaration.
9343 Return MATCH_ERROR if an error is encountered in one of the handled
9344 attributes (public, private, bind(c)), MATCH_NO if what's found is
9345 not a handled attribute, and MATCH_YES otherwise. TODO: More error
9346 checking on attribute conflicts needs to be done. */
9349 gfc_get_type_attr_spec (symbol_attribute
*attr
, char *name
)
9351 /* See if the derived type is marked as private. */
9352 if (gfc_match (" , private") == MATCH_YES
)
9354 if (gfc_current_state () != COMP_MODULE
)
9356 gfc_error ("Derived type at %C can only be PRIVATE in the "
9357 "specification part of a module");
9361 if (!gfc_add_access (attr
, ACCESS_PRIVATE
, NULL
, NULL
))
9364 else if (gfc_match (" , public") == MATCH_YES
)
9366 if (gfc_current_state () != COMP_MODULE
)
9368 gfc_error ("Derived type at %C can only be PUBLIC in the "
9369 "specification part of a module");
9373 if (!gfc_add_access (attr
, ACCESS_PUBLIC
, NULL
, NULL
))
9376 else if (gfc_match (" , bind ( c )") == MATCH_YES
)
9378 /* If the type is defined to be bind(c) it then needs to make
9379 sure that all fields are interoperable. This will
9380 need to be a semantic check on the finished derived type.
9381 See 15.2.3 (lines 9-12) of F2003 draft. */
9382 if (!gfc_add_is_bind_c (attr
, NULL
, &gfc_current_locus
, 0))
9385 /* TODO: attr conflicts need to be checked, probably in symbol.c. */
9387 else if (gfc_match (" , abstract") == MATCH_YES
)
9389 if (!gfc_notify_std (GFC_STD_F2003
, "ABSTRACT type at %C"))
9392 if (!gfc_add_abstract (attr
, &gfc_current_locus
))
9395 else if (name
&& gfc_match (" , extends ( %n )", name
) == MATCH_YES
)
9397 if (!gfc_add_extension (attr
, &gfc_current_locus
))
9403 /* If we get here, something matched. */
9408 /* Common function for type declaration blocks similar to derived types, such
9409 as STRUCTURES and MAPs. Unlike derived types, a structure type
9410 does NOT have a generic symbol matching the name given by the user.
9411 STRUCTUREs can share names with variables and PARAMETERs so we must allow
9412 for the creation of an independent symbol.
9413 Other parameters are a message to prefix errors with, the name of the new
9414 type to be created, and the flavor to add to the resulting symbol. */
9417 get_struct_decl (const char *name
, sym_flavor fl
, locus
*decl
,
9418 gfc_symbol
**result
)
9423 gcc_assert (name
[0] == (char) TOUPPER (name
[0]));
9428 where
= gfc_current_locus
;
9430 if (gfc_get_symbol (name
, NULL
, &sym
))
9435 gfc_internal_error ("Failed to create structure type '%s' at %C", name
);
9439 if (sym
->components
!= NULL
|| sym
->attr
.zero_comp
)
9441 gfc_error ("Type definition of %qs at %C was already defined at %L",
9442 sym
->name
, &sym
->declared_at
);
9446 sym
->declared_at
= where
;
9448 if (sym
->attr
.flavor
!= fl
9449 && !gfc_add_flavor (&sym
->attr
, fl
, sym
->name
, NULL
))
9452 if (!sym
->hash_value
)
9453 /* Set the hash for the compound name for this type. */
9454 sym
->hash_value
= gfc_hash_value (sym
);
9456 /* Normally the type is expected to have been completely parsed by the time
9457 a field declaration with this type is seen. For unions, maps, and nested
9458 structure declarations, we need to indicate that it is okay that we
9459 haven't seen any components yet. This will be updated after the structure
9461 sym
->attr
.zero_comp
= 0;
9463 /* Structures always act like derived-types with the SEQUENCE attribute */
9464 gfc_add_sequence (&sym
->attr
, sym
->name
, NULL
);
9466 if (result
) *result
= sym
;
9472 /* Match the opening of a MAP block. Like a struct within a union in C;
9473 behaves identical to STRUCTURE blocks. */
9476 gfc_match_map (void)
9478 /* Counter used to give unique internal names to map structures. */
9479 static unsigned int gfc_map_id
= 0;
9480 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9484 old_loc
= gfc_current_locus
;
9486 if (gfc_match_eos () != MATCH_YES
)
9488 gfc_error ("Junk after MAP statement at %C");
9489 gfc_current_locus
= old_loc
;
9493 /* Map blocks are anonymous so we make up unique names for the symbol table
9494 which are invalid Fortran identifiers. */
9495 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "MM$%u", gfc_map_id
++);
9497 if (!get_struct_decl (name
, FL_STRUCT
, &old_loc
, &sym
))
9500 gfc_new_block
= sym
;
9506 /* Match the opening of a UNION block. */
9509 gfc_match_union (void)
9511 /* Counter used to give unique internal names to union types. */
9512 static unsigned int gfc_union_id
= 0;
9513 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9517 old_loc
= gfc_current_locus
;
9519 if (gfc_match_eos () != MATCH_YES
)
9521 gfc_error ("Junk after UNION statement at %C");
9522 gfc_current_locus
= old_loc
;
9526 /* Unions are anonymous so we make up unique names for the symbol table
9527 which are invalid Fortran identifiers. */
9528 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "UU$%u", gfc_union_id
++);
9530 if (!get_struct_decl (name
, FL_UNION
, &old_loc
, &sym
))
9533 gfc_new_block
= sym
;
9539 /* Match the beginning of a STRUCTURE declaration. This is similar to
9540 matching the beginning of a derived type declaration with a few
9541 twists. The resulting type symbol has no access control or other
9542 interesting attributes. */
9545 gfc_match_structure_decl (void)
9547 /* Counter used to give unique internal names to anonymous structures. */
9548 static unsigned int gfc_structure_id
= 0;
9549 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9554 if (!flag_dec_structure
)
9556 gfc_error ("%s at %C is a DEC extension, enable with "
9557 "%<-fdec-structure%>",
9564 m
= gfc_match (" /%n/", name
);
9567 /* Non-nested structure declarations require a structure name. */
9568 if (!gfc_comp_struct (gfc_current_state ()))
9570 gfc_error ("Structure name expected in non-nested structure "
9571 "declaration at %C");
9574 /* This is an anonymous structure; make up a unique name for it
9575 (upper-case letters never make it to symbol names from the source).
9576 The important thing is initializing the type variable
9577 and setting gfc_new_symbol, which is immediately used by
9578 parse_structure () and variable_decl () to add components of
9580 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "SS$%u", gfc_structure_id
++);
9583 where
= gfc_current_locus
;
9584 /* No field list allowed after non-nested structure declaration. */
9585 if (!gfc_comp_struct (gfc_current_state ())
9586 && gfc_match_eos () != MATCH_YES
)
9588 gfc_error ("Junk after non-nested STRUCTURE statement at %C");
9592 /* Make sure the name is not the name of an intrinsic type. */
9593 if (gfc_is_intrinsic_typename (name
))
9595 gfc_error ("Structure name %qs at %C cannot be the same as an"
9596 " intrinsic type", name
);
9600 /* Store the actual type symbol for the structure with an upper-case first
9601 letter (an invalid Fortran identifier). */
9603 if (!get_struct_decl (gfc_dt_upper_string (name
), FL_STRUCT
, &where
, &sym
))
9606 gfc_new_block
= sym
;
9611 /* This function does some work to determine which matcher should be used to
9612 * match a statement beginning with "TYPE". This is used to disambiguate TYPE
9613 * as an alias for PRINT from derived type declarations, TYPE IS statements,
9614 * and derived type data declarations. */
9617 gfc_match_type (gfc_statement
*st
)
9619 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9623 /* Requires -fdec. */
9627 m
= gfc_match ("type");
9630 /* If we already have an error in the buffer, it is probably from failing to
9631 * match a derived type data declaration. Let it happen. */
9632 else if (gfc_error_flag_test ())
9635 old_loc
= gfc_current_locus
;
9638 /* If we see an attribute list before anything else it's definitely a derived
9639 * type declaration. */
9640 if (gfc_match (" ,") == MATCH_YES
|| gfc_match (" ::") == MATCH_YES
)
9642 gfc_current_locus
= old_loc
;
9643 *st
= ST_DERIVED_DECL
;
9644 return gfc_match_derived_decl ();
9647 /* By now "TYPE" has already been matched. If we do not see a name, this may
9648 * be something like "TYPE *" or "TYPE <fmt>". */
9649 m
= gfc_match_name (name
);
9652 /* Let print match if it can, otherwise throw an error from
9653 * gfc_match_derived_decl. */
9654 gfc_current_locus
= old_loc
;
9655 if (gfc_match_print () == MATCH_YES
)
9660 gfc_current_locus
= old_loc
;
9661 *st
= ST_DERIVED_DECL
;
9662 return gfc_match_derived_decl ();
9665 /* A derived type declaration requires an EOS. Without it, assume print. */
9666 m
= gfc_match_eos ();
9669 /* Check manually for TYPE IS (... - this is invalid print syntax. */
9670 if (strncmp ("is", name
, 3) == 0
9671 && gfc_match (" (", name
) == MATCH_YES
)
9673 gfc_current_locus
= old_loc
;
9674 gcc_assert (gfc_match (" is") == MATCH_YES
);
9676 return gfc_match_type_is ();
9678 gfc_current_locus
= old_loc
;
9680 return gfc_match_print ();
9684 /* By now we have "TYPE <name> <EOS>". Check first if the name is an
9685 * intrinsic typename - if so let gfc_match_derived_decl dump an error.
9686 * Otherwise if gfc_match_derived_decl fails it's probably an existing
9687 * symbol which can be printed. */
9688 gfc_current_locus
= old_loc
;
9689 m
= gfc_match_derived_decl ();
9690 if (gfc_is_intrinsic_typename (name
) || m
== MATCH_YES
)
9692 *st
= ST_DERIVED_DECL
;
9695 gfc_current_locus
= old_loc
;
9697 return gfc_match_print ();
9704 /* Match the beginning of a derived type declaration. If a type name
9705 was the result of a function, then it is possible to have a symbol
9706 already to be known as a derived type yet have no components. */
9709 gfc_match_derived_decl (void)
9711 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9712 char parent
[GFC_MAX_SYMBOL_LEN
+ 1];
9713 symbol_attribute attr
;
9714 gfc_symbol
*sym
, *gensym
;
9715 gfc_symbol
*extended
;
9717 match is_type_attr_spec
= MATCH_NO
;
9718 bool seen_attr
= false;
9719 gfc_interface
*intr
= NULL
, *head
;
9720 bool parameterized_type
= false;
9721 bool seen_colons
= false;
9723 if (gfc_comp_struct (gfc_current_state ()))
9728 gfc_clear_attr (&attr
);
9733 is_type_attr_spec
= gfc_get_type_attr_spec (&attr
, parent
);
9734 if (is_type_attr_spec
== MATCH_ERROR
)
9736 if (is_type_attr_spec
== MATCH_YES
)
9738 } while (is_type_attr_spec
== MATCH_YES
);
9740 /* Deal with derived type extensions. The extension attribute has
9741 been added to 'attr' but now the parent type must be found and
9744 extended
= check_extended_derived_type (parent
);
9746 if (parent
[0] && !extended
)
9749 m
= gfc_match (" ::");
9756 gfc_error ("Expected :: in TYPE definition at %C");
9760 m
= gfc_match (" %n ", name
);
9764 /* Make sure that we don't identify TYPE IS (...) as a parameterized
9765 derived type named 'is'.
9766 TODO Expand the check, when 'name' = "is" by matching " (tname) "
9767 and checking if this is a(n intrinsic) typename. his picks up
9768 misplaced TYPE IS statements such as in select_type_1.f03. */
9769 if (gfc_peek_ascii_char () == '(')
9771 if (gfc_current_state () == COMP_SELECT_TYPE
9772 || (!seen_colons
&& !strcmp (name
, "is")))
9774 parameterized_type
= true;
9777 m
= gfc_match_eos ();
9778 if (m
!= MATCH_YES
&& !parameterized_type
)
9781 /* Make sure the name is not the name of an intrinsic type. */
9782 if (gfc_is_intrinsic_typename (name
))
9784 gfc_error ("Type name %qs at %C cannot be the same as an intrinsic "
9789 if (gfc_get_symbol (name
, NULL
, &gensym
))
9792 if (!gensym
->attr
.generic
&& gensym
->ts
.type
!= BT_UNKNOWN
)
9794 gfc_error ("Derived type name %qs at %C already has a basic type "
9795 "of %s", gensym
->name
, gfc_typename (&gensym
->ts
));
9799 if (!gensym
->attr
.generic
9800 && !gfc_add_generic (&gensym
->attr
, gensym
->name
, NULL
))
9803 if (!gensym
->attr
.function
9804 && !gfc_add_function (&gensym
->attr
, gensym
->name
, NULL
))
9807 sym
= gfc_find_dt_in_generic (gensym
);
9809 if (sym
&& (sym
->components
!= NULL
|| sym
->attr
.zero_comp
))
9811 gfc_error ("Derived type definition of %qs at %C has already been "
9812 "defined", sym
->name
);
9818 /* Use upper case to save the actual derived-type symbol. */
9819 gfc_get_symbol (gfc_dt_upper_string (gensym
->name
), NULL
, &sym
);
9820 sym
->name
= gfc_get_string ("%s", gensym
->name
);
9821 head
= gensym
->generic
;
9822 intr
= gfc_get_interface ();
9824 intr
->where
= gfc_current_locus
;
9825 intr
->sym
->declared_at
= gfc_current_locus
;
9827 gensym
->generic
= intr
;
9828 gensym
->attr
.if_source
= IFSRC_DECL
;
9831 /* The symbol may already have the derived attribute without the
9832 components. The ways this can happen is via a function
9833 definition, an INTRINSIC statement or a subtype in another
9834 derived type that is a pointer. The first part of the AND clause
9835 is true if the symbol is not the return value of a function. */
9836 if (sym
->attr
.flavor
!= FL_DERIVED
9837 && !gfc_add_flavor (&sym
->attr
, FL_DERIVED
, sym
->name
, NULL
))
9840 if (attr
.access
!= ACCESS_UNKNOWN
9841 && !gfc_add_access (&sym
->attr
, attr
.access
, sym
->name
, NULL
))
9843 else if (sym
->attr
.access
== ACCESS_UNKNOWN
9844 && gensym
->attr
.access
!= ACCESS_UNKNOWN
9845 && !gfc_add_access (&sym
->attr
, gensym
->attr
.access
,
9849 if (sym
->attr
.access
!= ACCESS_UNKNOWN
9850 && gensym
->attr
.access
== ACCESS_UNKNOWN
)
9851 gensym
->attr
.access
= sym
->attr
.access
;
9853 /* See if the derived type was labeled as bind(c). */
9854 if (attr
.is_bind_c
!= 0)
9855 sym
->attr
.is_bind_c
= attr
.is_bind_c
;
9857 /* Construct the f2k_derived namespace if it is not yet there. */
9858 if (!sym
->f2k_derived
)
9859 sym
->f2k_derived
= gfc_get_namespace (NULL
, 0);
9861 if (parameterized_type
)
9863 /* Ignore error or mismatches by going to the end of the statement
9864 in order to avoid the component declarations causing problems. */
9865 m
= gfc_match_formal_arglist (sym
, 0, 0, true);
9867 gfc_error_recovery ();
9868 m
= gfc_match_eos ();
9871 gfc_error_recovery ();
9872 gfc_error_now ("Garbage after PARAMETERIZED TYPE declaration at %C");
9874 sym
->attr
.pdt_template
= 1;
9877 if (extended
&& !sym
->components
)
9880 gfc_formal_arglist
*f
, *g
, *h
;
9882 /* Add the extended derived type as the first component. */
9883 gfc_add_component (sym
, parent
, &p
);
9885 gfc_set_sym_referenced (extended
);
9887 p
->ts
.type
= BT_DERIVED
;
9888 p
->ts
.u
.derived
= extended
;
9889 p
->initializer
= gfc_default_initializer (&p
->ts
);
9891 /* Set extension level. */
9892 if (extended
->attr
.extension
== 255)
9894 /* Since the extension field is 8 bit wide, we can only have
9895 up to 255 extension levels. */
9896 gfc_error ("Maximum extension level reached with type %qs at %L",
9897 extended
->name
, &extended
->declared_at
);
9900 sym
->attr
.extension
= extended
->attr
.extension
+ 1;
9902 /* Provide the links between the extended type and its extension. */
9903 if (!extended
->f2k_derived
)
9904 extended
->f2k_derived
= gfc_get_namespace (NULL
, 0);
9906 /* Copy the extended type-param-name-list from the extended type,
9907 append those of the extension and add the whole lot to the
9909 if (extended
->attr
.pdt_template
)
9912 sym
->attr
.pdt_template
= 1;
9913 for (f
= extended
->formal
; f
; f
= f
->next
)
9915 if (f
== extended
->formal
)
9917 g
= gfc_get_formal_arglist ();
9922 g
->next
= gfc_get_formal_arglist ();
9927 g
->next
= sym
->formal
;
9932 if (!sym
->hash_value
)
9933 /* Set the hash for the compound name for this type. */
9934 sym
->hash_value
= gfc_hash_value (sym
);
9936 /* Take over the ABSTRACT attribute. */
9937 sym
->attr
.abstract
= attr
.abstract
;
9939 gfc_new_block
= sym
;
9945 /* Cray Pointees can be declared as:
9946 pointer (ipt, a (n,m,...,*)) */
9949 gfc_mod_pointee_as (gfc_array_spec
*as
)
9951 as
->cray_pointee
= true; /* This will be useful to know later. */
9952 if (as
->type
== AS_ASSUMED_SIZE
)
9953 as
->cp_was_assumed
= true;
9954 else if (as
->type
== AS_ASSUMED_SHAPE
)
9956 gfc_error ("Cray Pointee at %C cannot be assumed shape array");
9963 /* Match the enum definition statement, here we are trying to match
9964 the first line of enum definition statement.
9965 Returns MATCH_YES if match is found. */
9968 gfc_match_enum (void)
9972 m
= gfc_match_eos ();
9976 if (!gfc_notify_std (GFC_STD_F2003
, "ENUM and ENUMERATOR at %C"))
9983 /* Returns an initializer whose value is one higher than the value of the
9984 LAST_INITIALIZER argument. If the argument is NULL, the
9985 initializers value will be set to zero. The initializer's kind
9986 will be set to gfc_c_int_kind.
9988 If -fshort-enums is given, the appropriate kind will be selected
9989 later after all enumerators have been parsed. A warning is issued
9990 here if an initializer exceeds gfc_c_int_kind. */
9993 enum_initializer (gfc_expr
*last_initializer
, locus where
)
9996 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_c_int_kind
, &where
);
9998 mpz_init (result
->value
.integer
);
10000 if (last_initializer
!= NULL
)
10002 mpz_add_ui (result
->value
.integer
, last_initializer
->value
.integer
, 1);
10003 result
->where
= last_initializer
->where
;
10005 if (gfc_check_integer_range (result
->value
.integer
,
10006 gfc_c_int_kind
) != ARITH_OK
)
10008 gfc_error ("Enumerator exceeds the C integer type at %C");
10014 /* Control comes here, if it's the very first enumerator and no
10015 initializer has been given. It will be initialized to zero. */
10016 mpz_set_si (result
->value
.integer
, 0);
10023 /* Match a variable name with an optional initializer. When this
10024 subroutine is called, a variable is expected to be parsed next.
10025 Depending on what is happening at the moment, updates either the
10026 symbol table or the current interface. */
10029 enumerator_decl (void)
10031 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10032 gfc_expr
*initializer
;
10033 gfc_array_spec
*as
= NULL
;
10040 initializer
= NULL
;
10041 old_locus
= gfc_current_locus
;
10043 /* When we get here, we've just matched a list of attributes and
10044 maybe a type and a double colon. The next thing we expect to see
10045 is the name of the symbol. */
10046 m
= gfc_match_name (name
);
10047 if (m
!= MATCH_YES
)
10050 var_locus
= gfc_current_locus
;
10052 /* OK, we've successfully matched the declaration. Now put the
10053 symbol in the current namespace. If we fail to create the symbol,
10055 if (!build_sym (name
, NULL
, false, &as
, &var_locus
))
10061 /* The double colon must be present in order to have initializers.
10062 Otherwise the statement is ambiguous with an assignment statement. */
10065 if (gfc_match_char ('=') == MATCH_YES
)
10067 m
= gfc_match_init_expr (&initializer
);
10070 gfc_error ("Expected an initialization expression at %C");
10074 if (m
!= MATCH_YES
)
10079 /* If we do not have an initializer, the initialization value of the
10080 previous enumerator (stored in last_initializer) is incremented
10081 by 1 and is used to initialize the current enumerator. */
10082 if (initializer
== NULL
)
10083 initializer
= enum_initializer (last_initializer
, old_locus
);
10085 if (initializer
== NULL
|| initializer
->ts
.type
!= BT_INTEGER
)
10087 gfc_error ("ENUMERATOR %L not initialized with integer expression",
10093 /* Store this current initializer, for the next enumerator variable
10094 to be parsed. add_init_expr_to_sym() zeros initializer, so we
10095 use last_initializer below. */
10096 last_initializer
= initializer
;
10097 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
10099 /* Maintain enumerator history. */
10100 gfc_find_symbol (name
, NULL
, 0, &sym
);
10101 create_enum_history (sym
, last_initializer
);
10103 return (t
) ? MATCH_YES
: MATCH_ERROR
;
10106 /* Free stuff up and return. */
10107 gfc_free_expr (initializer
);
10113 /* Match the enumerator definition statement. */
10116 gfc_match_enumerator_def (void)
10121 gfc_clear_ts (¤t_ts
);
10123 m
= gfc_match (" enumerator");
10124 if (m
!= MATCH_YES
)
10127 m
= gfc_match (" :: ");
10128 if (m
== MATCH_ERROR
)
10131 colon_seen
= (m
== MATCH_YES
);
10133 if (gfc_current_state () != COMP_ENUM
)
10135 gfc_error ("ENUM definition statement expected before %C");
10136 gfc_free_enum_history ();
10137 return MATCH_ERROR
;
10140 (¤t_ts
)->type
= BT_INTEGER
;
10141 (¤t_ts
)->kind
= gfc_c_int_kind
;
10143 gfc_clear_attr (¤t_attr
);
10144 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, NULL
);
10153 m
= enumerator_decl ();
10154 if (m
== MATCH_ERROR
)
10156 gfc_free_enum_history ();
10162 if (gfc_match_eos () == MATCH_YES
)
10164 if (gfc_match_char (',') != MATCH_YES
)
10168 if (gfc_current_state () == COMP_ENUM
)
10170 gfc_free_enum_history ();
10171 gfc_error ("Syntax error in ENUMERATOR definition at %C");
10176 gfc_free_array_spec (current_as
);
10183 /* Match binding attributes. */
10186 match_binding_attributes (gfc_typebound_proc
* ba
, bool generic
, bool ppc
)
10188 bool found_passing
= false;
10189 bool seen_ptr
= false;
10190 match m
= MATCH_YES
;
10192 /* Initialize to defaults. Do so even before the MATCH_NO check so that in
10193 this case the defaults are in there. */
10194 ba
->access
= ACCESS_UNKNOWN
;
10195 ba
->pass_arg
= NULL
;
10196 ba
->pass_arg_num
= 0;
10198 ba
->non_overridable
= 0;
10202 /* If we find a comma, we believe there are binding attributes. */
10203 m
= gfc_match_char (',');
10209 /* Access specifier. */
10211 m
= gfc_match (" public");
10212 if (m
== MATCH_ERROR
)
10214 if (m
== MATCH_YES
)
10216 if (ba
->access
!= ACCESS_UNKNOWN
)
10218 gfc_error ("Duplicate access-specifier at %C");
10222 ba
->access
= ACCESS_PUBLIC
;
10226 m
= gfc_match (" private");
10227 if (m
== MATCH_ERROR
)
10229 if (m
== MATCH_YES
)
10231 if (ba
->access
!= ACCESS_UNKNOWN
)
10233 gfc_error ("Duplicate access-specifier at %C");
10237 ba
->access
= ACCESS_PRIVATE
;
10241 /* If inside GENERIC, the following is not allowed. */
10246 m
= gfc_match (" nopass");
10247 if (m
== MATCH_ERROR
)
10249 if (m
== MATCH_YES
)
10253 gfc_error ("Binding attributes already specify passing,"
10254 " illegal NOPASS at %C");
10258 found_passing
= true;
10263 /* PASS possibly including argument. */
10264 m
= gfc_match (" pass");
10265 if (m
== MATCH_ERROR
)
10267 if (m
== MATCH_YES
)
10269 char arg
[GFC_MAX_SYMBOL_LEN
+ 1];
10273 gfc_error ("Binding attributes already specify passing,"
10274 " illegal PASS at %C");
10278 m
= gfc_match (" ( %n )", arg
);
10279 if (m
== MATCH_ERROR
)
10281 if (m
== MATCH_YES
)
10282 ba
->pass_arg
= gfc_get_string ("%s", arg
);
10283 gcc_assert ((m
== MATCH_YES
) == (ba
->pass_arg
!= NULL
));
10285 found_passing
= true;
10292 /* POINTER flag. */
10293 m
= gfc_match (" pointer");
10294 if (m
== MATCH_ERROR
)
10296 if (m
== MATCH_YES
)
10300 gfc_error ("Duplicate POINTER attribute at %C");
10310 /* NON_OVERRIDABLE flag. */
10311 m
= gfc_match (" non_overridable");
10312 if (m
== MATCH_ERROR
)
10314 if (m
== MATCH_YES
)
10316 if (ba
->non_overridable
)
10318 gfc_error ("Duplicate NON_OVERRIDABLE at %C");
10322 ba
->non_overridable
= 1;
10326 /* DEFERRED flag. */
10327 m
= gfc_match (" deferred");
10328 if (m
== MATCH_ERROR
)
10330 if (m
== MATCH_YES
)
10334 gfc_error ("Duplicate DEFERRED at %C");
10345 /* Nothing matching found. */
10347 gfc_error ("Expected access-specifier at %C");
10349 gfc_error ("Expected binding attribute at %C");
10352 while (gfc_match_char (',') == MATCH_YES
);
10354 /* NON_OVERRIDABLE and DEFERRED exclude themselves. */
10355 if (ba
->non_overridable
&& ba
->deferred
)
10357 gfc_error ("NON_OVERRIDABLE and DEFERRED can't both appear at %C");
10364 if (ba
->access
== ACCESS_UNKNOWN
)
10365 ba
->access
= gfc_typebound_default_access
;
10367 if (ppc
&& !seen_ptr
)
10369 gfc_error ("POINTER attribute is required for procedure pointer component"
10377 return MATCH_ERROR
;
10381 /* Match a PROCEDURE specific binding inside a derived type. */
10384 match_procedure_in_type (void)
10386 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10387 char target_buf
[GFC_MAX_SYMBOL_LEN
+ 1];
10388 char* target
= NULL
, *ifc
= NULL
;
10389 gfc_typebound_proc tb
;
10393 gfc_symtree
* stree
;
10398 /* Check current state. */
10399 gcc_assert (gfc_state_stack
->state
== COMP_DERIVED_CONTAINS
);
10400 block
= gfc_state_stack
->previous
->sym
;
10401 gcc_assert (block
);
10403 /* Try to match PROCEDURE(interface). */
10404 if (gfc_match (" (") == MATCH_YES
)
10406 m
= gfc_match_name (target_buf
);
10407 if (m
== MATCH_ERROR
)
10409 if (m
!= MATCH_YES
)
10411 gfc_error ("Interface-name expected after %<(%> at %C");
10412 return MATCH_ERROR
;
10415 if (gfc_match (" )") != MATCH_YES
)
10417 gfc_error ("%<)%> expected at %C");
10418 return MATCH_ERROR
;
10424 /* Construct the data structure. */
10425 memset (&tb
, 0, sizeof (tb
));
10426 tb
.where
= gfc_current_locus
;
10428 /* Match binding attributes. */
10429 m
= match_binding_attributes (&tb
, false, false);
10430 if (m
== MATCH_ERROR
)
10432 seen_attrs
= (m
== MATCH_YES
);
10434 /* Check that attribute DEFERRED is given if an interface is specified. */
10435 if (tb
.deferred
&& !ifc
)
10437 gfc_error ("Interface must be specified for DEFERRED binding at %C");
10438 return MATCH_ERROR
;
10440 if (ifc
&& !tb
.deferred
)
10442 gfc_error ("PROCEDURE(interface) at %C should be declared DEFERRED");
10443 return MATCH_ERROR
;
10446 /* Match the colons. */
10447 m
= gfc_match (" ::");
10448 if (m
== MATCH_ERROR
)
10450 seen_colons
= (m
== MATCH_YES
);
10451 if (seen_attrs
&& !seen_colons
)
10453 gfc_error ("Expected %<::%> after binding-attributes at %C");
10454 return MATCH_ERROR
;
10457 /* Match the binding names. */
10460 m
= gfc_match_name (name
);
10461 if (m
== MATCH_ERROR
)
10465 gfc_error ("Expected binding name at %C");
10466 return MATCH_ERROR
;
10469 if (num
>1 && !gfc_notify_std (GFC_STD_F2008
, "PROCEDURE list at %C"))
10470 return MATCH_ERROR
;
10472 /* Try to match the '=> target', if it's there. */
10474 m
= gfc_match (" =>");
10475 if (m
== MATCH_ERROR
)
10477 if (m
== MATCH_YES
)
10481 gfc_error ("%<=> target%> is invalid for DEFERRED binding at %C");
10482 return MATCH_ERROR
;
10487 gfc_error ("%<::%> needed in PROCEDURE binding with explicit target"
10489 return MATCH_ERROR
;
10492 m
= gfc_match_name (target_buf
);
10493 if (m
== MATCH_ERROR
)
10497 gfc_error ("Expected binding target after %<=>%> at %C");
10498 return MATCH_ERROR
;
10500 target
= target_buf
;
10503 /* If no target was found, it has the same name as the binding. */
10507 /* Get the namespace to insert the symbols into. */
10508 ns
= block
->f2k_derived
;
10511 /* If the binding is DEFERRED, check that the containing type is ABSTRACT. */
10512 if (tb
.deferred
&& !block
->attr
.abstract
)
10514 gfc_error ("Type %qs containing DEFERRED binding at %C "
10515 "is not ABSTRACT", block
->name
);
10516 return MATCH_ERROR
;
10519 /* See if we already have a binding with this name in the symtree which
10520 would be an error. If a GENERIC already targeted this binding, it may
10521 be already there but then typebound is still NULL. */
10522 stree
= gfc_find_symtree (ns
->tb_sym_root
, name
);
10523 if (stree
&& stree
->n
.tb
)
10525 gfc_error ("There is already a procedure with binding name %qs for "
10526 "the derived type %qs at %C", name
, block
->name
);
10527 return MATCH_ERROR
;
10530 /* Insert it and set attributes. */
10534 stree
= gfc_new_symtree (&ns
->tb_sym_root
, name
);
10535 gcc_assert (stree
);
10537 stree
->n
.tb
= gfc_get_typebound_proc (&tb
);
10539 if (gfc_get_sym_tree (target
, gfc_current_ns
, &stree
->n
.tb
->u
.specific
,
10541 return MATCH_ERROR
;
10542 gfc_set_sym_referenced (stree
->n
.tb
->u
.specific
->n
.sym
);
10543 gfc_add_flavor(&stree
->n
.tb
->u
.specific
->n
.sym
->attr
, FL_PROCEDURE
,
10544 target
, &stree
->n
.tb
->u
.specific
->n
.sym
->declared_at
);
10546 if (gfc_match_eos () == MATCH_YES
)
10548 if (gfc_match_char (',') != MATCH_YES
)
10553 gfc_error ("Syntax error in PROCEDURE statement at %C");
10554 return MATCH_ERROR
;
10558 /* Match a GENERIC procedure binding inside a derived type. */
10561 gfc_match_generic (void)
10563 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10564 char bind_name
[GFC_MAX_SYMBOL_LEN
+ 16]; /* Allow space for OPERATOR(...). */
10566 gfc_typebound_proc tbattr
; /* Used for match_binding_attributes. */
10567 gfc_typebound_proc
* tb
;
10569 interface_type op_type
;
10570 gfc_intrinsic_op op
;
10573 /* Check current state. */
10574 if (gfc_current_state () == COMP_DERIVED
)
10576 gfc_error ("GENERIC at %C must be inside a derived-type CONTAINS");
10577 return MATCH_ERROR
;
10579 if (gfc_current_state () != COMP_DERIVED_CONTAINS
)
10581 block
= gfc_state_stack
->previous
->sym
;
10582 ns
= block
->f2k_derived
;
10583 gcc_assert (block
&& ns
);
10585 memset (&tbattr
, 0, sizeof (tbattr
));
10586 tbattr
.where
= gfc_current_locus
;
10588 /* See if we get an access-specifier. */
10589 m
= match_binding_attributes (&tbattr
, true, false);
10590 if (m
== MATCH_ERROR
)
10593 /* Now the colons, those are required. */
10594 if (gfc_match (" ::") != MATCH_YES
)
10596 gfc_error ("Expected %<::%> at %C");
10600 /* Match the binding name; depending on type (operator / generic) format
10601 it for future error messages into bind_name. */
10603 m
= gfc_match_generic_spec (&op_type
, name
, &op
);
10604 if (m
== MATCH_ERROR
)
10605 return MATCH_ERROR
;
10608 gfc_error ("Expected generic name or operator descriptor at %C");
10614 case INTERFACE_GENERIC
:
10615 case INTERFACE_DTIO
:
10616 snprintf (bind_name
, sizeof (bind_name
), "%s", name
);
10619 case INTERFACE_USER_OP
:
10620 snprintf (bind_name
, sizeof (bind_name
), "OPERATOR(.%s.)", name
);
10623 case INTERFACE_INTRINSIC_OP
:
10624 snprintf (bind_name
, sizeof (bind_name
), "OPERATOR(%s)",
10625 gfc_op2string (op
));
10628 case INTERFACE_NAMELESS
:
10629 gfc_error ("Malformed GENERIC statement at %C");
10634 gcc_unreachable ();
10637 /* Match the required =>. */
10638 if (gfc_match (" =>") != MATCH_YES
)
10640 gfc_error ("Expected %<=>%> at %C");
10644 /* Try to find existing GENERIC binding with this name / for this operator;
10645 if there is something, check that it is another GENERIC and then extend
10646 it rather than building a new node. Otherwise, create it and put it
10647 at the right position. */
10651 case INTERFACE_DTIO
:
10652 case INTERFACE_USER_OP
:
10653 case INTERFACE_GENERIC
:
10655 const bool is_op
= (op_type
== INTERFACE_USER_OP
);
10658 st
= gfc_find_symtree (is_op
? ns
->tb_uop_root
: ns
->tb_sym_root
, name
);
10659 tb
= st
? st
->n
.tb
: NULL
;
10663 case INTERFACE_INTRINSIC_OP
:
10664 tb
= ns
->tb_op
[op
];
10668 gcc_unreachable ();
10673 if (!tb
->is_generic
)
10675 gcc_assert (op_type
== INTERFACE_GENERIC
);
10676 gfc_error ("There's already a non-generic procedure with binding name"
10677 " %qs for the derived type %qs at %C",
10678 bind_name
, block
->name
);
10682 if (tb
->access
!= tbattr
.access
)
10684 gfc_error ("Binding at %C must have the same access as already"
10685 " defined binding %qs", bind_name
);
10691 tb
= gfc_get_typebound_proc (NULL
);
10692 tb
->where
= gfc_current_locus
;
10693 tb
->access
= tbattr
.access
;
10694 tb
->is_generic
= 1;
10695 tb
->u
.generic
= NULL
;
10699 case INTERFACE_DTIO
:
10700 case INTERFACE_GENERIC
:
10701 case INTERFACE_USER_OP
:
10703 const bool is_op
= (op_type
== INTERFACE_USER_OP
);
10704 gfc_symtree
* st
= gfc_get_tbp_symtree (is_op
? &ns
->tb_uop_root
:
10705 &ns
->tb_sym_root
, name
);
10712 case INTERFACE_INTRINSIC_OP
:
10713 ns
->tb_op
[op
] = tb
;
10717 gcc_unreachable ();
10721 /* Now, match all following names as specific targets. */
10724 gfc_symtree
* target_st
;
10725 gfc_tbp_generic
* target
;
10727 m
= gfc_match_name (name
);
10728 if (m
== MATCH_ERROR
)
10732 gfc_error ("Expected specific binding name at %C");
10736 target_st
= gfc_get_tbp_symtree (&ns
->tb_sym_root
, name
);
10738 /* See if this is a duplicate specification. */
10739 for (target
= tb
->u
.generic
; target
; target
= target
->next
)
10740 if (target_st
== target
->specific_st
)
10742 gfc_error ("%qs already defined as specific binding for the"
10743 " generic %qs at %C", name
, bind_name
);
10747 target
= gfc_get_tbp_generic ();
10748 target
->specific_st
= target_st
;
10749 target
->specific
= NULL
;
10750 target
->next
= tb
->u
.generic
;
10751 target
->is_operator
= ((op_type
== INTERFACE_USER_OP
)
10752 || (op_type
== INTERFACE_INTRINSIC_OP
));
10753 tb
->u
.generic
= target
;
10755 while (gfc_match (" ,") == MATCH_YES
);
10757 /* Here should be the end. */
10758 if (gfc_match_eos () != MATCH_YES
)
10760 gfc_error ("Junk after GENERIC binding at %C");
10767 return MATCH_ERROR
;
10771 /* Match a FINAL declaration inside a derived type. */
10774 gfc_match_final_decl (void)
10776 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10779 gfc_namespace
* module_ns
;
10783 if (gfc_current_form
== FORM_FREE
)
10785 char c
= gfc_peek_ascii_char ();
10786 if (!gfc_is_whitespace (c
) && c
!= ':')
10790 if (gfc_state_stack
->state
!= COMP_DERIVED_CONTAINS
)
10792 if (gfc_current_form
== FORM_FIXED
)
10795 gfc_error ("FINAL declaration at %C must be inside a derived type "
10796 "CONTAINS section");
10797 return MATCH_ERROR
;
10800 block
= gfc_state_stack
->previous
->sym
;
10801 gcc_assert (block
);
10803 if (!gfc_state_stack
->previous
|| !gfc_state_stack
->previous
->previous
10804 || gfc_state_stack
->previous
->previous
->state
!= COMP_MODULE
)
10806 gfc_error ("Derived type declaration with FINAL at %C must be in the"
10807 " specification part of a MODULE");
10808 return MATCH_ERROR
;
10811 module_ns
= gfc_current_ns
;
10812 gcc_assert (module_ns
);
10813 gcc_assert (module_ns
->proc_name
->attr
.flavor
== FL_MODULE
);
10815 /* Match optional ::, don't care about MATCH_YES or MATCH_NO. */
10816 if (gfc_match (" ::") == MATCH_ERROR
)
10817 return MATCH_ERROR
;
10819 /* Match the sequence of procedure names. */
10826 if (first
&& gfc_match_eos () == MATCH_YES
)
10828 gfc_error ("Empty FINAL at %C");
10829 return MATCH_ERROR
;
10832 m
= gfc_match_name (name
);
10835 gfc_error ("Expected module procedure name at %C");
10836 return MATCH_ERROR
;
10838 else if (m
!= MATCH_YES
)
10839 return MATCH_ERROR
;
10841 if (gfc_match_eos () == MATCH_YES
)
10843 if (!last
&& gfc_match_char (',') != MATCH_YES
)
10845 gfc_error ("Expected %<,%> at %C");
10846 return MATCH_ERROR
;
10849 if (gfc_get_symbol (name
, module_ns
, &sym
))
10851 gfc_error ("Unknown procedure name %qs at %C", name
);
10852 return MATCH_ERROR
;
10855 /* Mark the symbol as module procedure. */
10856 if (sym
->attr
.proc
!= PROC_MODULE
10857 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
10858 return MATCH_ERROR
;
10860 /* Check if we already have this symbol in the list, this is an error. */
10861 for (f
= block
->f2k_derived
->finalizers
; f
; f
= f
->next
)
10862 if (f
->proc_sym
== sym
)
10864 gfc_error ("%qs at %C is already defined as FINAL procedure",
10866 return MATCH_ERROR
;
10869 /* Add this symbol to the list of finalizers. */
10870 gcc_assert (block
->f2k_derived
);
10872 f
= XCNEW (gfc_finalizer
);
10874 f
->proc_tree
= NULL
;
10875 f
->where
= gfc_current_locus
;
10876 f
->next
= block
->f2k_derived
->finalizers
;
10877 block
->f2k_derived
->finalizers
= f
;
10887 const ext_attr_t ext_attr_list
[] = {
10888 { "dllimport", EXT_ATTR_DLLIMPORT
, "dllimport" },
10889 { "dllexport", EXT_ATTR_DLLEXPORT
, "dllexport" },
10890 { "cdecl", EXT_ATTR_CDECL
, "cdecl" },
10891 { "stdcall", EXT_ATTR_STDCALL
, "stdcall" },
10892 { "fastcall", EXT_ATTR_FASTCALL
, "fastcall" },
10893 { "no_arg_check", EXT_ATTR_NO_ARG_CHECK
, NULL
},
10894 { NULL
, EXT_ATTR_LAST
, NULL
}
10897 /* Match a !GCC$ ATTRIBUTES statement of the form:
10898 !GCC$ ATTRIBUTES attribute-list :: var-name [, var-name] ...
10899 When we come here, we have already matched the !GCC$ ATTRIBUTES string.
10901 TODO: We should support all GCC attributes using the same syntax for
10902 the attribute list, i.e. the list in C
10903 __attributes(( attribute-list ))
10905 !GCC$ ATTRIBUTES attribute-list ::
10906 Cf. c-parser.c's c_parser_attributes; the data can then directly be
10909 As there is absolutely no risk of confusion, we should never return
10912 gfc_match_gcc_attributes (void)
10914 symbol_attribute attr
;
10915 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10920 gfc_clear_attr (&attr
);
10925 if (gfc_match_name (name
) != MATCH_YES
)
10926 return MATCH_ERROR
;
10928 for (id
= 0; id
< EXT_ATTR_LAST
; id
++)
10929 if (strcmp (name
, ext_attr_list
[id
].name
) == 0)
10932 if (id
== EXT_ATTR_LAST
)
10934 gfc_error ("Unknown attribute in !GCC$ ATTRIBUTES statement at %C");
10935 return MATCH_ERROR
;
10938 if (!gfc_add_ext_attribute (&attr
, (ext_attr_id_t
)id
, &gfc_current_locus
))
10939 return MATCH_ERROR
;
10941 gfc_gobble_whitespace ();
10942 ch
= gfc_next_ascii_char ();
10945 /* This is the successful exit condition for the loop. */
10946 if (gfc_next_ascii_char () == ':')
10956 if (gfc_match_eos () == MATCH_YES
)
10961 m
= gfc_match_name (name
);
10962 if (m
!= MATCH_YES
)
10965 if (find_special (name
, &sym
, true))
10966 return MATCH_ERROR
;
10968 sym
->attr
.ext_attr
|= attr
.ext_attr
;
10970 if (gfc_match_eos () == MATCH_YES
)
10973 if (gfc_match_char (',') != MATCH_YES
)
10980 gfc_error ("Syntax error in !GCC$ ATTRIBUTES statement at %C");
10981 return MATCH_ERROR
;
10985 /* Match a !GCC$ UNROLL statement of the form:
10988 The parameter n is the number of times we are supposed to unroll.
10990 When we come here, we have already matched the !GCC$ UNROLL string. */
10992 gfc_match_gcc_unroll (void)
10996 if (gfc_match_small_int (&value
) == MATCH_YES
)
10998 if (value
< 0 || value
> USHRT_MAX
)
11000 gfc_error ("%<GCC unroll%> directive requires a"
11001 " non-negative integral constant"
11002 " less than or equal to %u at %C",
11005 return MATCH_ERROR
;
11007 if (gfc_match_eos () == MATCH_YES
)
11009 directive_unroll
= value
== 0 ? 1 : value
;
11014 gfc_error ("Syntax error in !GCC$ UNROLL directive at %C");
11015 return MATCH_ERROR
;