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 (int len
, gfc_expr
*expr
, int check_len
)
1546 if (expr
->ts
.type
!= BT_CHARACTER
)
1549 if (expr
->expr_type
!= EXPR_CONSTANT
)
1551 gfc_error_now ("CHARACTER length must be a constant at %L", &expr
->where
);
1555 slen
= expr
->value
.character
.length
;
1558 s
= gfc_get_wide_string (len
+ 1);
1559 memcpy (s
, expr
->value
.character
.string
,
1560 MIN (len
, slen
) * sizeof (gfc_char_t
));
1562 gfc_wide_memset (&s
[slen
], ' ', len
- slen
);
1564 if (warn_character_truncation
&& slen
> len
)
1565 gfc_warning_now (OPT_Wcharacter_truncation
,
1566 "CHARACTER expression at %L is being truncated "
1567 "(%d/%d)", &expr
->where
, slen
, len
);
1569 /* Apply the standard by 'hand' otherwise it gets cleared for
1571 if (check_len
!= -1 && slen
!= check_len
1572 && !(gfc_option
.allow_std
& GFC_STD_GNU
))
1573 gfc_error_now ("The CHARACTER elements of the array constructor "
1574 "at %L must have the same length (%d/%d)",
1575 &expr
->where
, slen
, check_len
);
1578 free (expr
->value
.character
.string
);
1579 expr
->value
.character
.string
= s
;
1580 expr
->value
.character
.length
= len
;
1585 /* Function to create and update the enumerator history
1586 using the information passed as arguments.
1587 Pointer "max_enum" is also updated, to point to
1588 enum history node containing largest initializer.
1590 SYM points to the symbol node of enumerator.
1591 INIT points to its enumerator value. */
1594 create_enum_history (gfc_symbol
*sym
, gfc_expr
*init
)
1596 enumerator_history
*new_enum_history
;
1597 gcc_assert (sym
!= NULL
&& init
!= NULL
);
1599 new_enum_history
= XCNEW (enumerator_history
);
1601 new_enum_history
->sym
= sym
;
1602 new_enum_history
->initializer
= init
;
1603 new_enum_history
->next
= NULL
;
1605 if (enum_history
== NULL
)
1607 enum_history
= new_enum_history
;
1608 max_enum
= enum_history
;
1612 new_enum_history
->next
= enum_history
;
1613 enum_history
= new_enum_history
;
1615 if (mpz_cmp (max_enum
->initializer
->value
.integer
,
1616 new_enum_history
->initializer
->value
.integer
) < 0)
1617 max_enum
= new_enum_history
;
1622 /* Function to free enum kind history. */
1625 gfc_free_enum_history (void)
1627 enumerator_history
*current
= enum_history
;
1628 enumerator_history
*next
;
1630 while (current
!= NULL
)
1632 next
= current
->next
;
1637 enum_history
= NULL
;
1641 /* Function called by variable_decl() that adds an initialization
1642 expression to a symbol. */
1645 add_init_expr_to_sym (const char *name
, gfc_expr
**initp
, locus
*var_locus
)
1647 symbol_attribute attr
;
1652 if (find_special (name
, &sym
, false))
1657 /* If this symbol is confirming an implicit parameter type,
1658 then an initialization expression is not allowed. */
1659 if (attr
.flavor
== FL_PARAMETER
1660 && sym
->value
!= NULL
1663 gfc_error ("Initializer not allowed for PARAMETER %qs at %C",
1670 /* An initializer is required for PARAMETER declarations. */
1671 if (attr
.flavor
== FL_PARAMETER
)
1673 gfc_error ("PARAMETER at %L is missing an initializer", var_locus
);
1679 /* If a variable appears in a DATA block, it cannot have an
1683 gfc_error ("Variable %qs at %C with an initializer already "
1684 "appears in a DATA statement", sym
->name
);
1688 /* Check if the assignment can happen. This has to be put off
1689 until later for derived type variables and procedure pointers. */
1690 if (!gfc_bt_struct (sym
->ts
.type
) && !gfc_bt_struct (init
->ts
.type
)
1691 && sym
->ts
.type
!= BT_CLASS
&& init
->ts
.type
!= BT_CLASS
1692 && !sym
->attr
.proc_pointer
1693 && !gfc_check_assign_symbol (sym
, NULL
, init
))
1696 if (sym
->ts
.type
== BT_CHARACTER
&& sym
->ts
.u
.cl
1697 && init
->ts
.type
== BT_CHARACTER
)
1699 /* Update symbol character length according initializer. */
1700 if (!gfc_check_assign_symbol (sym
, NULL
, init
))
1703 if (sym
->ts
.u
.cl
->length
== NULL
)
1706 /* If there are multiple CHARACTER variables declared on the
1707 same line, we don't want them to share the same length. */
1708 sym
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1710 if (sym
->attr
.flavor
== FL_PARAMETER
)
1712 if (init
->expr_type
== EXPR_CONSTANT
)
1714 clen
= init
->value
.character
.length
;
1715 sym
->ts
.u
.cl
->length
1716 = gfc_get_int_expr (gfc_charlen_int_kind
,
1719 else if (init
->expr_type
== EXPR_ARRAY
)
1723 const gfc_expr
*length
= init
->ts
.u
.cl
->length
;
1724 if (length
->expr_type
!= EXPR_CONSTANT
)
1726 gfc_error ("Cannot initialize parameter array "
1728 "with variable length elements",
1732 clen
= mpz_get_si (length
->value
.integer
);
1734 else if (init
->value
.constructor
)
1737 c
= gfc_constructor_first (init
->value
.constructor
);
1738 clen
= c
->expr
->value
.character
.length
;
1742 sym
->ts
.u
.cl
->length
1743 = gfc_get_int_expr (gfc_charlen_int_kind
,
1746 else if (init
->ts
.u
.cl
&& init
->ts
.u
.cl
->length
)
1747 sym
->ts
.u
.cl
->length
=
1748 gfc_copy_expr (sym
->value
->ts
.u
.cl
->length
);
1751 /* Update initializer character length according symbol. */
1752 else if (sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1756 if (!gfc_specification_expr (sym
->ts
.u
.cl
->length
))
1759 len
= mpz_get_si (sym
->ts
.u
.cl
->length
->value
.integer
);
1761 if (init
->expr_type
== EXPR_CONSTANT
)
1762 gfc_set_constant_character_len (len
, init
, -1);
1763 else if (init
->expr_type
== EXPR_ARRAY
)
1767 /* Build a new charlen to prevent simplification from
1768 deleting the length before it is resolved. */
1769 init
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1770 init
->ts
.u
.cl
->length
= gfc_copy_expr (sym
->ts
.u
.cl
->length
);
1772 for (c
= gfc_constructor_first (init
->value
.constructor
);
1773 c
; c
= gfc_constructor_next (c
))
1774 gfc_set_constant_character_len (len
, c
->expr
, -1);
1779 /* If sym is implied-shape, set its upper bounds from init. */
1780 if (sym
->attr
.flavor
== FL_PARAMETER
&& sym
->attr
.dimension
1781 && sym
->as
->type
== AS_IMPLIED_SHAPE
)
1785 if (init
->rank
== 0)
1787 gfc_error ("Can't initialize implied-shape array at %L"
1788 " with scalar", &sym
->declared_at
);
1792 /* Shape should be present, we get an initialization expression. */
1793 gcc_assert (init
->shape
);
1795 for (dim
= 0; dim
< sym
->as
->rank
; ++dim
)
1798 gfc_expr
*e
, *lower
;
1800 lower
= sym
->as
->lower
[dim
];
1802 /* If the lower bound is an array element from another
1803 parameterized array, then it is marked with EXPR_VARIABLE and
1804 is an initialization expression. Try to reduce it. */
1805 if (lower
->expr_type
== EXPR_VARIABLE
)
1806 gfc_reduce_init_expr (lower
);
1808 if (lower
->expr_type
== EXPR_CONSTANT
)
1810 /* All dimensions must be without upper bound. */
1811 gcc_assert (!sym
->as
->upper
[dim
]);
1814 e
= gfc_get_constant_expr (BT_INTEGER
, k
, &sym
->declared_at
);
1815 mpz_add (e
->value
.integer
, lower
->value
.integer
,
1817 mpz_sub_ui (e
->value
.integer
, e
->value
.integer
, 1);
1818 sym
->as
->upper
[dim
] = e
;
1822 gfc_error ("Non-constant lower bound in implied-shape"
1823 " declaration at %L", &lower
->where
);
1828 sym
->as
->type
= AS_EXPLICIT
;
1831 /* Need to check if the expression we initialized this
1832 to was one of the iso_c_binding named constants. If so,
1833 and we're a parameter (constant), let it be iso_c.
1835 integer(c_int), parameter :: my_int = c_int
1836 integer(my_int) :: my_int_2
1837 If we mark my_int as iso_c (since we can see it's value
1838 is equal to one of the named constants), then my_int_2
1839 will be considered C interoperable. */
1840 if (sym
->ts
.type
!= BT_CHARACTER
&& !gfc_bt_struct (sym
->ts
.type
))
1842 sym
->ts
.is_iso_c
|= init
->ts
.is_iso_c
;
1843 sym
->ts
.is_c_interop
|= init
->ts
.is_c_interop
;
1844 /* attr bits needed for module files. */
1845 sym
->attr
.is_iso_c
|= init
->ts
.is_iso_c
;
1846 sym
->attr
.is_c_interop
|= init
->ts
.is_c_interop
;
1847 if (init
->ts
.is_iso_c
)
1848 sym
->ts
.f90_type
= init
->ts
.f90_type
;
1851 /* Add initializer. Make sure we keep the ranks sane. */
1852 if (sym
->attr
.dimension
&& init
->rank
== 0)
1857 if (sym
->attr
.flavor
== FL_PARAMETER
1858 && init
->expr_type
== EXPR_CONSTANT
1859 && spec_size (sym
->as
, &size
)
1860 && mpz_cmp_si (size
, 0) > 0)
1862 array
= gfc_get_array_expr (init
->ts
.type
, init
->ts
.kind
,
1864 for (n
= 0; n
< (int)mpz_get_si (size
); n
++)
1865 gfc_constructor_append_expr (&array
->value
.constructor
,
1868 : gfc_copy_expr (init
),
1871 array
->shape
= gfc_get_shape (sym
->as
->rank
);
1872 for (n
= 0; n
< sym
->as
->rank
; n
++)
1873 spec_dimen_size (sym
->as
, n
, &array
->shape
[n
]);
1878 init
->rank
= sym
->as
->rank
;
1882 if (sym
->attr
.save
== SAVE_NONE
)
1883 sym
->attr
.save
= SAVE_IMPLICIT
;
1891 /* Function called by variable_decl() that adds a name to a structure
1895 build_struct (const char *name
, gfc_charlen
*cl
, gfc_expr
**init
,
1896 gfc_array_spec
**as
)
1901 /* F03:C438/C439. If the current symbol is of the same derived type that we're
1902 constructing, it must have the pointer attribute. */
1903 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
1904 && current_ts
.u
.derived
== gfc_current_block ()
1905 && current_attr
.pointer
== 0)
1907 if (current_attr
.allocatable
1908 && !gfc_notify_std(GFC_STD_F2008
, "Component at %C "
1909 "must have the POINTER attribute"))
1913 else if (current_attr
.allocatable
== 0)
1915 gfc_error ("Component at %C must have the POINTER attribute");
1921 if (current_ts
.type
== BT_CLASS
1922 && !(current_attr
.pointer
|| current_attr
.allocatable
))
1924 gfc_error ("Component %qs with CLASS at %C must be allocatable "
1925 "or pointer", name
);
1929 if (gfc_current_block ()->attr
.pointer
&& (*as
)->rank
!= 0)
1931 if ((*as
)->type
!= AS_DEFERRED
&& (*as
)->type
!= AS_EXPLICIT
)
1933 gfc_error ("Array component of structure at %C must have explicit "
1934 "or deferred shape");
1939 /* If we are in a nested union/map definition, gfc_add_component will not
1940 properly find repeated components because:
1941 (i) gfc_add_component does a flat search, where components of unions
1942 and maps are implicity chained so nested components may conflict.
1943 (ii) Unions and maps are not linked as components of their parent
1944 structures until after they are parsed.
1945 For (i) we use gfc_find_component which searches recursively, and for (ii)
1946 we search each block directly from the parse stack until we find the top
1949 s
= gfc_state_stack
;
1950 if (s
->state
== COMP_UNION
|| s
->state
== COMP_MAP
)
1952 while (s
->state
== COMP_UNION
|| gfc_comp_struct (s
->state
))
1954 c
= gfc_find_component (s
->sym
, name
, true, true, NULL
);
1957 gfc_error_now ("Component %qs at %C already declared at %L",
1961 /* Break after we've searched the entire chain. */
1962 if (s
->state
== COMP_DERIVED
|| s
->state
== COMP_STRUCTURE
)
1968 if (!gfc_add_component (gfc_current_block(), name
, &c
))
1972 if (c
->ts
.type
== BT_CHARACTER
)
1975 if (c
->ts
.type
!= BT_CLASS
&& c
->ts
.type
!= BT_DERIVED
1976 && (c
->ts
.kind
== 0 || c
->ts
.type
== BT_CHARACTER
)
1977 && saved_kind_expr
!= NULL
)
1978 c
->kind_expr
= gfc_copy_expr (saved_kind_expr
);
1980 c
->attr
= current_attr
;
1982 c
->initializer
= *init
;
1989 c
->attr
.codimension
= 1;
1991 c
->attr
.dimension
= 1;
1995 gfc_apply_init (&c
->ts
, &c
->attr
, c
->initializer
);
1997 /* Check array components. */
1998 if (!c
->attr
.dimension
)
2001 if (c
->attr
.pointer
)
2003 if (c
->as
->type
!= AS_DEFERRED
)
2005 gfc_error ("Pointer array component of structure at %C must have a "
2010 else if (c
->attr
.allocatable
)
2012 if (c
->as
->type
!= AS_DEFERRED
)
2014 gfc_error ("Allocatable component of structure at %C must have a "
2021 if (c
->as
->type
!= AS_EXPLICIT
)
2023 gfc_error ("Array component of structure at %C must have an "
2030 if (c
->ts
.type
== BT_CLASS
)
2031 return gfc_build_class_symbol (&c
->ts
, &c
->attr
, &c
->as
);
2033 if (c
->attr
.pdt_kind
|| c
->attr
.pdt_len
)
2036 gfc_find_symbol (c
->name
, gfc_current_block ()->f2k_derived
,
2040 gfc_error ("Type parameter %qs at %C has no corresponding entry "
2041 "in the type parameter name list at %L",
2042 c
->name
, &gfc_current_block ()->declared_at
);
2046 sym
->attr
.pdt_kind
= c
->attr
.pdt_kind
;
2047 sym
->attr
.pdt_len
= c
->attr
.pdt_len
;
2049 sym
->value
= gfc_copy_expr (c
->initializer
);
2050 sym
->attr
.flavor
= FL_VARIABLE
;
2053 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
2054 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_template
2055 && decl_type_param_list
)
2056 c
->param_list
= gfc_copy_actual_arglist (decl_type_param_list
);
2062 /* Match a 'NULL()', and possibly take care of some side effects. */
2065 gfc_match_null (gfc_expr
**result
)
2068 match m
, m2
= MATCH_NO
;
2070 if ((m
= gfc_match (" null ( )")) == MATCH_ERROR
)
2076 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2078 if ((m2
= gfc_match (" null (")) != MATCH_YES
)
2081 old_loc
= gfc_current_locus
;
2082 if ((m2
= gfc_match (" %n ) ", name
)) == MATCH_ERROR
)
2085 && ((m2
= gfc_match (" mold = %n )", name
)) == MATCH_ERROR
))
2089 gfc_current_locus
= old_loc
;
2094 /* The NULL symbol now has to be/become an intrinsic function. */
2095 if (gfc_get_symbol ("null", NULL
, &sym
))
2097 gfc_error ("NULL() initialization at %C is ambiguous");
2101 gfc_intrinsic_symbol (sym
);
2103 if (sym
->attr
.proc
!= PROC_INTRINSIC
2104 && !(sym
->attr
.use_assoc
&& sym
->attr
.intrinsic
)
2105 && (!gfc_add_procedure(&sym
->attr
, PROC_INTRINSIC
, sym
->name
, NULL
)
2106 || !gfc_add_function (&sym
->attr
, sym
->name
, NULL
)))
2109 *result
= gfc_get_null_expr (&gfc_current_locus
);
2111 /* Invalid per F2008, C512. */
2112 if (m2
== MATCH_YES
)
2114 gfc_error ("NULL() initialization at %C may not have MOLD");
2122 /* Match the initialization expr for a data pointer or procedure pointer. */
2125 match_pointer_init (gfc_expr
**init
, int procptr
)
2129 if (gfc_pure (NULL
) && !gfc_comp_struct (gfc_state_stack
->state
))
2131 gfc_error ("Initialization of pointer at %C is not allowed in "
2132 "a PURE procedure");
2135 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
2137 /* Match NULL() initialization. */
2138 m
= gfc_match_null (init
);
2142 /* Match non-NULL initialization. */
2143 gfc_matching_ptr_assignment
= !procptr
;
2144 gfc_matching_procptr_assignment
= procptr
;
2145 m
= gfc_match_rvalue (init
);
2146 gfc_matching_ptr_assignment
= 0;
2147 gfc_matching_procptr_assignment
= 0;
2148 if (m
== MATCH_ERROR
)
2150 else if (m
== MATCH_NO
)
2152 gfc_error ("Error in pointer initialization at %C");
2156 if (!procptr
&& !gfc_resolve_expr (*init
))
2159 if (!gfc_notify_std (GFC_STD_F2008
, "non-NULL pointer "
2160 "initialization at %C"))
2168 check_function_name (char *name
)
2170 /* In functions that have a RESULT variable defined, the function name always
2171 refers to function calls. Therefore, the name is not allowed to appear in
2172 specification statements. When checking this, be careful about
2173 'hidden' procedure pointer results ('ppr@'). */
2175 if (gfc_current_state () == COMP_FUNCTION
)
2177 gfc_symbol
*block
= gfc_current_block ();
2178 if (block
&& block
->result
&& block
->result
!= block
2179 && strcmp (block
->result
->name
, "ppr@") != 0
2180 && strcmp (block
->name
, name
) == 0)
2182 gfc_error ("Function name %qs not allowed at %C", name
);
2191 /* Match a variable name with an optional initializer. When this
2192 subroutine is called, a variable is expected to be parsed next.
2193 Depending on what is happening at the moment, updates either the
2194 symbol table or the current interface. */
2197 variable_decl (int elem
)
2199 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2200 static unsigned int fill_id
= 0;
2201 gfc_expr
*initializer
, *char_len
;
2203 gfc_array_spec
*cp_as
; /* Extra copy for Cray Pointees. */
2215 /* When we get here, we've just matched a list of attributes and
2216 maybe a type and a double colon. The next thing we expect to see
2217 is the name of the symbol. */
2219 /* If we are parsing a structure with legacy support, we allow the symbol
2220 name to be '%FILL' which gives it an anonymous (inaccessible) name. */
2222 gfc_gobble_whitespace ();
2223 if (gfc_peek_ascii_char () == '%')
2225 gfc_next_ascii_char ();
2226 m
= gfc_match ("fill");
2231 m
= gfc_match_name (name
);
2239 if (gfc_current_state () != COMP_STRUCTURE
)
2241 if (flag_dec_structure
)
2242 gfc_error ("%qs not allowed outside STRUCTURE at %C", "%FILL");
2244 gfc_error ("%qs at %C is a DEC extension, enable with "
2245 "%<-fdec-structure%>", "%FILL");
2251 gfc_error ("%qs entity cannot have attributes at %C", "%FILL");
2255 /* %FILL components are given invalid fortran names. */
2256 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "%%FILL%u", fill_id
++);
2260 var_locus
= gfc_current_locus
;
2262 /* Now we could see the optional array spec. or character length. */
2263 m
= gfc_match_array_spec (&as
, true, true);
2264 if (m
== MATCH_ERROR
)
2268 as
= gfc_copy_array_spec (current_as
);
2270 && !merge_array_spec (current_as
, as
, true))
2276 if (flag_cray_pointer
)
2277 cp_as
= gfc_copy_array_spec (as
);
2279 /* At this point, we know for sure if the symbol is PARAMETER and can thus
2280 determine (and check) whether it can be implied-shape. If it
2281 was parsed as assumed-size, change it because PARAMETERs can not
2285 if (as
->type
== AS_IMPLIED_SHAPE
&& current_attr
.flavor
!= FL_PARAMETER
)
2288 gfc_error ("Non-PARAMETER symbol %qs at %L can't be implied-shape",
2293 if (as
->type
== AS_ASSUMED_SIZE
&& as
->rank
== 1
2294 && current_attr
.flavor
== FL_PARAMETER
)
2295 as
->type
= AS_IMPLIED_SHAPE
;
2297 if (as
->type
== AS_IMPLIED_SHAPE
2298 && !gfc_notify_std (GFC_STD_F2008
, "Implied-shape array at %L",
2308 cl_deferred
= false;
2310 if (current_ts
.type
== BT_CHARACTER
)
2312 switch (match_char_length (&char_len
, &cl_deferred
, false))
2315 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2317 cl
->length
= char_len
;
2320 /* Non-constant lengths need to be copied after the first
2321 element. Also copy assumed lengths. */
2324 && (current_ts
.u
.cl
->length
== NULL
2325 || current_ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
2327 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2328 cl
->length
= gfc_copy_expr (current_ts
.u
.cl
->length
);
2331 cl
= current_ts
.u
.cl
;
2333 cl_deferred
= current_ts
.deferred
;
2342 /* The dummy arguments and result of the abreviated form of MODULE
2343 PROCEDUREs, used in SUBMODULES should not be redefined. */
2344 if (gfc_current_ns
->proc_name
2345 && gfc_current_ns
->proc_name
->abr_modproc_decl
)
2347 gfc_find_symbol (name
, gfc_current_ns
, 1, &sym
);
2348 if (sym
!= NULL
&& (sym
->attr
.dummy
|| sym
->attr
.result
))
2351 gfc_error ("%qs at %C is a redefinition of the declaration "
2352 "in the corresponding interface for MODULE "
2353 "PROCEDURE %qs", sym
->name
,
2354 gfc_current_ns
->proc_name
->name
);
2359 /* %FILL components may not have initializers. */
2360 if (strncmp (name
, "%FILL", 5) == 0 && gfc_match_eos () != MATCH_YES
)
2362 gfc_error ("%qs entity cannot have an initializer at %C", "%FILL");
2367 /* If this symbol has already shown up in a Cray Pointer declaration,
2368 and this is not a component declaration,
2369 then we want to set the type & bail out. */
2370 if (flag_cray_pointer
&& !gfc_comp_struct (gfc_current_state ()))
2372 gfc_find_symbol (name
, gfc_current_ns
, 1, &sym
);
2373 if (sym
!= NULL
&& sym
->attr
.cray_pointee
)
2375 sym
->ts
.type
= current_ts
.type
;
2376 sym
->ts
.kind
= current_ts
.kind
;
2378 sym
->ts
.u
.derived
= current_ts
.u
.derived
;
2379 sym
->ts
.is_c_interop
= current_ts
.is_c_interop
;
2380 sym
->ts
.is_iso_c
= current_ts
.is_iso_c
;
2383 /* Check to see if we have an array specification. */
2386 if (sym
->as
!= NULL
)
2388 gfc_error ("Duplicate array spec for Cray pointee at %C");
2389 gfc_free_array_spec (cp_as
);
2395 if (!gfc_set_array_spec (sym
, cp_as
, &var_locus
))
2396 gfc_internal_error ("Couldn't set pointee array spec.");
2398 /* Fix the array spec. */
2399 m
= gfc_mod_pointee_as (sym
->as
);
2400 if (m
== MATCH_ERROR
)
2408 gfc_free_array_spec (cp_as
);
2412 /* Procedure pointer as function result. */
2413 if (gfc_current_state () == COMP_FUNCTION
2414 && strcmp ("ppr@", gfc_current_block ()->name
) == 0
2415 && strcmp (name
, gfc_current_block ()->ns
->proc_name
->name
) == 0)
2416 strcpy (name
, "ppr@");
2418 if (gfc_current_state () == COMP_FUNCTION
2419 && strcmp (name
, gfc_current_block ()->name
) == 0
2420 && gfc_current_block ()->result
2421 && strcmp ("ppr@", gfc_current_block ()->result
->name
) == 0)
2422 strcpy (name
, "ppr@");
2424 /* OK, we've successfully matched the declaration. Now put the
2425 symbol in the current namespace, because it might be used in the
2426 optional initialization expression for this symbol, e.g. this is
2429 integer, parameter :: i = huge(i)
2431 This is only true for parameters or variables of a basic type.
2432 For components of derived types, it is not true, so we don't
2433 create a symbol for those yet. If we fail to create the symbol,
2435 if (!gfc_comp_struct (gfc_current_state ())
2436 && !build_sym (name
, cl
, cl_deferred
, &as
, &var_locus
))
2442 if (!check_function_name (name
))
2448 /* We allow old-style initializations of the form
2449 integer i /2/, j(4) /3*3, 1/
2450 (if no colon has been seen). These are different from data
2451 statements in that initializers are only allowed to apply to the
2452 variable immediately preceding, i.e.
2454 is not allowed. Therefore we have to do some work manually, that
2455 could otherwise be left to the matchers for DATA statements. */
2457 if (!colon_seen
&& gfc_match (" /") == MATCH_YES
)
2459 if (!gfc_notify_std (GFC_STD_GNU
, "Old-style "
2460 "initialization at %C"))
2463 /* Allow old style initializations for components of STRUCTUREs and MAPs
2464 but not components of derived types. */
2465 else if (gfc_current_state () == COMP_DERIVED
)
2467 gfc_error ("Invalid old style initialization for derived type "
2473 /* For structure components, read the initializer as a special
2474 expression and let the rest of this function apply the initializer
2476 else if (gfc_comp_struct (gfc_current_state ()))
2478 m
= match_clist_expr (&initializer
, ¤t_ts
, as
);
2480 gfc_error ("Syntax error in old style initialization of %s at %C",
2486 /* Otherwise we treat the old style initialization just like a
2487 DATA declaration for the current variable. */
2489 return match_old_style_init (name
);
2492 /* The double colon must be present in order to have initializers.
2493 Otherwise the statement is ambiguous with an assignment statement. */
2496 if (gfc_match (" =>") == MATCH_YES
)
2498 if (!current_attr
.pointer
)
2500 gfc_error ("Initialization at %C isn't for a pointer variable");
2505 m
= match_pointer_init (&initializer
, 0);
2509 else if (gfc_match_char ('=') == MATCH_YES
)
2511 if (current_attr
.pointer
)
2513 gfc_error ("Pointer initialization at %C requires %<=>%>, "
2519 m
= gfc_match_init_expr (&initializer
);
2522 gfc_error ("Expected an initialization expression at %C");
2526 if (current_attr
.flavor
!= FL_PARAMETER
&& gfc_pure (NULL
)
2527 && !gfc_comp_struct (gfc_state_stack
->state
))
2529 gfc_error ("Initialization of variable at %C is not allowed in "
2530 "a PURE procedure");
2534 if (current_attr
.flavor
!= FL_PARAMETER
2535 && !gfc_comp_struct (gfc_state_stack
->state
))
2536 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
2543 if (initializer
!= NULL
&& current_attr
.allocatable
2544 && gfc_comp_struct (gfc_current_state ()))
2546 gfc_error ("Initialization of allocatable component at %C is not "
2552 if (gfc_current_state () == COMP_DERIVED
2553 && gfc_current_block ()->attr
.pdt_template
)
2556 gfc_find_symbol (name
, gfc_current_block ()->f2k_derived
,
2558 if (!param
&& (current_attr
.pdt_kind
|| current_attr
.pdt_len
))
2560 gfc_error ("The component with KIND or LEN attribute at %C does not "
2561 "not appear in the type parameter list at %L",
2562 &gfc_current_block ()->declared_at
);
2566 else if (param
&& !(current_attr
.pdt_kind
|| current_attr
.pdt_len
))
2568 gfc_error ("The component at %C that appears in the type parameter "
2569 "list at %L has neither the KIND nor LEN attribute",
2570 &gfc_current_block ()->declared_at
);
2574 else if (as
&& (current_attr
.pdt_kind
|| current_attr
.pdt_len
))
2576 gfc_error ("The component at %C which is a type parameter must be "
2581 else if (param
&& initializer
)
2582 param
->value
= gfc_copy_expr (initializer
);
2585 /* Add the initializer. Note that it is fine if initializer is
2586 NULL here, because we sometimes also need to check if a
2587 declaration *must* have an initialization expression. */
2588 if (!gfc_comp_struct (gfc_current_state ()))
2589 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
2592 if (current_ts
.type
== BT_DERIVED
2593 && !current_attr
.pointer
&& !initializer
)
2594 initializer
= gfc_default_initializer (¤t_ts
);
2595 t
= build_struct (name
, cl
, &initializer
, &as
);
2597 /* If we match a nested structure definition we expect to see the
2598 * body even if the variable declarations blow up, so we need to keep
2599 * the structure declaration around. */
2600 if (gfc_new_block
&& gfc_new_block
->attr
.flavor
== FL_STRUCT
)
2601 gfc_commit_symbol (gfc_new_block
);
2604 m
= (t
) ? MATCH_YES
: MATCH_ERROR
;
2607 /* Free stuff up and return. */
2608 gfc_free_expr (initializer
);
2609 gfc_free_array_spec (as
);
2615 /* Match an extended-f77 "TYPESPEC*bytesize"-style kind specification.
2616 This assumes that the byte size is equal to the kind number for
2617 non-COMPLEX types, and equal to twice the kind number for COMPLEX. */
2620 gfc_match_old_kind_spec (gfc_typespec
*ts
)
2625 if (gfc_match_char ('*') != MATCH_YES
)
2628 m
= gfc_match_small_literal_int (&ts
->kind
, NULL
);
2632 original_kind
= ts
->kind
;
2634 /* Massage the kind numbers for complex types. */
2635 if (ts
->type
== BT_COMPLEX
)
2639 gfc_error ("Old-style type declaration %s*%d not supported at %C",
2640 gfc_basic_typename (ts
->type
), original_kind
);
2647 if (ts
->type
== BT_INTEGER
&& ts
->kind
== 4 && flag_integer4_kind
== 8)
2650 if (ts
->type
== BT_REAL
|| ts
->type
== BT_COMPLEX
)
2654 if (flag_real4_kind
== 8)
2656 if (flag_real4_kind
== 10)
2658 if (flag_real4_kind
== 16)
2664 if (flag_real8_kind
== 4)
2666 if (flag_real8_kind
== 10)
2668 if (flag_real8_kind
== 16)
2673 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
2675 gfc_error ("Old-style type declaration %s*%d not supported at %C",
2676 gfc_basic_typename (ts
->type
), original_kind
);
2680 if (!gfc_notify_std (GFC_STD_GNU
,
2681 "Nonstandard type declaration %s*%d at %C",
2682 gfc_basic_typename(ts
->type
), original_kind
))
2689 /* Match a kind specification. Since kinds are generally optional, we
2690 usually return MATCH_NO if something goes wrong. If a "kind="
2691 string is found, then we know we have an error. */
2694 gfc_match_kind_spec (gfc_typespec
*ts
, bool kind_expr_only
)
2704 saved_kind_expr
= NULL
;
2706 where
= loc
= gfc_current_locus
;
2711 if (gfc_match_char ('(') == MATCH_NO
)
2714 /* Also gobbles optional text. */
2715 if (gfc_match (" kind = ") == MATCH_YES
)
2718 loc
= gfc_current_locus
;
2722 n
= gfc_match_init_expr (&e
);
2724 if (gfc_derived_parameter_expr (e
))
2727 saved_kind_expr
= gfc_copy_expr (e
);
2728 goto close_brackets
;
2733 if (gfc_matching_function
)
2735 /* The function kind expression might include use associated or
2736 imported parameters and try again after the specification
2738 if (gfc_match_char (')') != MATCH_YES
)
2740 gfc_error ("Missing right parenthesis at %C");
2746 gfc_undo_symbols ();
2751 /* ....or else, the match is real. */
2753 gfc_error ("Expected initialization expression at %C");
2761 gfc_error ("Expected scalar initialization expression at %C");
2766 if (gfc_extract_int (e
, &ts
->kind
, 1))
2772 /* Before throwing away the expression, let's see if we had a
2773 C interoperable kind (and store the fact). */
2774 if (e
->ts
.is_c_interop
== 1)
2776 /* Mark this as C interoperable if being declared with one
2777 of the named constants from iso_c_binding. */
2778 ts
->is_c_interop
= e
->ts
.is_iso_c
;
2779 ts
->f90_type
= e
->ts
.f90_type
;
2781 ts
->interop_kind
= e
->symtree
->n
.sym
;
2787 /* Ignore errors to this point, if we've gotten here. This means
2788 we ignore the m=MATCH_ERROR from above. */
2789 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
2791 gfc_error ("Kind %d not supported for type %s at %C", ts
->kind
,
2792 gfc_basic_typename (ts
->type
));
2793 gfc_current_locus
= where
;
2797 /* Warn if, e.g., c_int is used for a REAL variable, but not
2798 if, e.g., c_double is used for COMPLEX as the standard
2799 explicitly says that the kind type parameter for complex and real
2800 variable is the same, i.e. c_float == c_float_complex. */
2801 if (ts
->f90_type
!= BT_UNKNOWN
&& ts
->f90_type
!= ts
->type
2802 && !((ts
->f90_type
== BT_REAL
&& ts
->type
== BT_COMPLEX
)
2803 || (ts
->f90_type
== BT_COMPLEX
&& ts
->type
== BT_REAL
)))
2804 gfc_warning_now (0, "C kind type parameter is for type %s but type at %L "
2805 "is %s", gfc_basic_typename (ts
->f90_type
), &where
,
2806 gfc_basic_typename (ts
->type
));
2810 gfc_gobble_whitespace ();
2811 if ((c
= gfc_next_ascii_char ()) != ')'
2812 && (ts
->type
!= BT_CHARACTER
|| c
!= ','))
2814 if (ts
->type
== BT_CHARACTER
)
2815 gfc_error ("Missing right parenthesis or comma at %C");
2817 gfc_error ("Missing right parenthesis at %C");
2821 /* All tests passed. */
2824 if(m
== MATCH_ERROR
)
2825 gfc_current_locus
= where
;
2827 if (ts
->type
== BT_INTEGER
&& ts
->kind
== 4 && flag_integer4_kind
== 8)
2830 if (ts
->type
== BT_REAL
|| ts
->type
== BT_COMPLEX
)
2834 if (flag_real4_kind
== 8)
2836 if (flag_real4_kind
== 10)
2838 if (flag_real4_kind
== 16)
2844 if (flag_real8_kind
== 4)
2846 if (flag_real8_kind
== 10)
2848 if (flag_real8_kind
== 16)
2853 /* Return what we know from the test(s). */
2858 gfc_current_locus
= where
;
2864 match_char_kind (int * kind
, int * is_iso_c
)
2873 where
= gfc_current_locus
;
2875 n
= gfc_match_init_expr (&e
);
2877 if (n
!= MATCH_YES
&& gfc_matching_function
)
2879 /* The expression might include use-associated or imported
2880 parameters and try again after the specification
2883 gfc_undo_symbols ();
2888 gfc_error ("Expected initialization expression at %C");
2894 gfc_error ("Expected scalar initialization expression at %C");
2899 if (gfc_derived_parameter_expr (e
))
2901 saved_kind_expr
= e
;
2906 fail
= gfc_extract_int (e
, kind
, 1);
2907 *is_iso_c
= e
->ts
.is_iso_c
;
2916 /* Ignore errors to this point, if we've gotten here. This means
2917 we ignore the m=MATCH_ERROR from above. */
2918 if (gfc_validate_kind (BT_CHARACTER
, *kind
, true) < 0)
2920 gfc_error ("Kind %d is not supported for CHARACTER at %C", *kind
);
2924 /* All tests passed. */
2927 if (m
== MATCH_ERROR
)
2928 gfc_current_locus
= where
;
2930 /* Return what we know from the test(s). */
2935 gfc_current_locus
= where
;
2940 /* Match the various kind/length specifications in a CHARACTER
2941 declaration. We don't return MATCH_NO. */
2944 gfc_match_char_spec (gfc_typespec
*ts
)
2946 int kind
, seen_length
, is_iso_c
;
2958 /* Try the old-style specification first. */
2959 old_char_selector
= 0;
2961 m
= match_char_length (&len
, &deferred
, true);
2965 old_char_selector
= 1;
2970 m
= gfc_match_char ('(');
2973 m
= MATCH_YES
; /* Character without length is a single char. */
2977 /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ). */
2978 if (gfc_match (" kind =") == MATCH_YES
)
2980 m
= match_char_kind (&kind
, &is_iso_c
);
2982 if (m
== MATCH_ERROR
)
2987 if (gfc_match (" , len =") == MATCH_NO
)
2990 m
= char_len_param_value (&len
, &deferred
);
2993 if (m
== MATCH_ERROR
)
3000 /* Try to match "LEN = <len-param>" or "LEN = <len-param>, KIND = <int>". */
3001 if (gfc_match (" len =") == MATCH_YES
)
3003 m
= char_len_param_value (&len
, &deferred
);
3006 if (m
== MATCH_ERROR
)
3010 if (gfc_match_char (')') == MATCH_YES
)
3013 if (gfc_match (" , kind =") != MATCH_YES
)
3016 if (match_char_kind (&kind
, &is_iso_c
) == MATCH_ERROR
)
3022 /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ). */
3023 m
= char_len_param_value (&len
, &deferred
);
3026 if (m
== MATCH_ERROR
)
3030 m
= gfc_match_char (')');
3034 if (gfc_match_char (',') != MATCH_YES
)
3037 gfc_match (" kind ="); /* Gobble optional text. */
3039 m
= match_char_kind (&kind
, &is_iso_c
);
3040 if (m
== MATCH_ERROR
)
3046 /* Require a right-paren at this point. */
3047 m
= gfc_match_char (')');
3052 gfc_error ("Syntax error in CHARACTER declaration at %C");
3054 gfc_free_expr (len
);
3058 /* Deal with character functions after USE and IMPORT statements. */
3059 if (gfc_matching_function
)
3061 gfc_free_expr (len
);
3062 gfc_undo_symbols ();
3068 gfc_free_expr (len
);
3072 /* Do some final massaging of the length values. */
3073 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
3075 if (seen_length
== 0)
3076 cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
, 1);
3081 ts
->kind
= kind
== 0 ? gfc_default_character_kind
: kind
;
3082 ts
->deferred
= deferred
;
3084 /* We have to know if it was a C interoperable kind so we can
3085 do accurate type checking of bind(c) procs, etc. */
3087 /* Mark this as C interoperable if being declared with one
3088 of the named constants from iso_c_binding. */
3089 ts
->is_c_interop
= is_iso_c
;
3090 else if (len
!= NULL
)
3091 /* Here, we might have parsed something such as: character(c_char)
3092 In this case, the parsing code above grabs the c_char when
3093 looking for the length (line 1690, roughly). it's the last
3094 testcase for parsing the kind params of a character variable.
3095 However, it's not actually the length. this seems like it
3097 To see if the user used a C interop kind, test the expr
3098 of the so called length, and see if it's C interoperable. */
3099 ts
->is_c_interop
= len
->ts
.is_iso_c
;
3105 /* Matches a RECORD declaration. */
3108 match_record_decl (char *name
)
3111 old_loc
= gfc_current_locus
;
3114 m
= gfc_match (" record /");
3117 if (!flag_dec_structure
)
3119 gfc_current_locus
= old_loc
;
3120 gfc_error ("RECORD at %C is an extension, enable it with "
3124 m
= gfc_match (" %n/", name
);
3129 gfc_current_locus
= old_loc
;
3130 if (flag_dec_structure
3131 && (gfc_match (" record% ") == MATCH_YES
3132 || gfc_match (" record%t") == MATCH_YES
))
3133 gfc_error ("Structure name expected after RECORD at %C");
3141 /* This function uses the gfc_actual_arglist 'type_param_spec_list' as a source
3142 of expressions to substitute into the possibly parameterized expression
3143 'e'. Using a list is inefficient but should not be too bad since the
3144 number of type parameters is not likely to be large. */
3146 insert_parameter_exprs (gfc_expr
* e
, gfc_symbol
* sym ATTRIBUTE_UNUSED
,
3149 gfc_actual_arglist
*param
;
3152 if (e
->expr_type
!= EXPR_VARIABLE
)
3155 gcc_assert (e
->symtree
);
3156 if (e
->symtree
->n
.sym
->attr
.pdt_kind
3157 || (*f
!= 0 && e
->symtree
->n
.sym
->attr
.pdt_len
))
3159 for (param
= type_param_spec_list
; param
; param
= param
->next
)
3160 if (strcmp (e
->symtree
->n
.sym
->name
, param
->name
) == 0)
3165 copy
= gfc_copy_expr (param
->expr
);
3176 gfc_insert_kind_parameter_exprs (gfc_expr
*e
)
3178 return gfc_traverse_expr (e
, NULL
, &insert_parameter_exprs
, 0);
3183 gfc_insert_parameter_exprs (gfc_expr
*e
, gfc_actual_arglist
*param_list
)
3185 gfc_actual_arglist
*old_param_spec_list
= type_param_spec_list
;
3186 type_param_spec_list
= param_list
;
3187 return gfc_traverse_expr (e
, NULL
, &insert_parameter_exprs
, 1);
3188 type_param_spec_list
= NULL
;
3189 type_param_spec_list
= old_param_spec_list
;
3192 /* Determines the instance of a parameterized derived type to be used by
3193 matching determining the values of the kind parameters and using them
3194 in the name of the instance. If the instance exists, it is used, otherwise
3195 a new derived type is created. */
3197 gfc_get_pdt_instance (gfc_actual_arglist
*param_list
, gfc_symbol
**sym
,
3198 gfc_actual_arglist
**ext_param_list
)
3200 /* The PDT template symbol. */
3201 gfc_symbol
*pdt
= *sym
;
3202 /* The symbol for the parameter in the template f2k_namespace. */
3204 /* The hoped for instance of the PDT. */
3205 gfc_symbol
*instance
;
3206 /* The list of parameters appearing in the PDT declaration. */
3207 gfc_formal_arglist
*type_param_name_list
;
3208 /* Used to store the parameter specification list during recursive calls. */
3209 gfc_actual_arglist
*old_param_spec_list
;
3210 /* Pointers to the parameter specification being used. */
3211 gfc_actual_arglist
*actual_param
;
3212 gfc_actual_arglist
*tail
= NULL
;
3213 /* Used to build up the name of the PDT instance. The prefix uses 4
3214 characters and each KIND parameter 2 more. Allow 8 of the latter. */
3215 char name
[GFC_MAX_SYMBOL_LEN
+ 21];
3217 bool name_seen
= (param_list
== NULL
);
3218 bool assumed_seen
= false;
3219 bool deferred_seen
= false;
3220 bool spec_error
= false;
3222 gfc_expr
*kind_expr
;
3223 gfc_component
*c1
, *c2
;
3226 type_param_spec_list
= NULL
;
3228 type_param_name_list
= pdt
->formal
;
3229 actual_param
= param_list
;
3230 sprintf (name
, "Pdt%s", pdt
->name
);
3232 /* Run through the parameter name list and pick up the actual
3233 parameter values or use the default values in the PDT declaration. */
3234 for (; type_param_name_list
;
3235 type_param_name_list
= type_param_name_list
->next
)
3237 if (actual_param
&& actual_param
->spec_type
!= SPEC_EXPLICIT
)
3239 if (actual_param
->spec_type
== SPEC_ASSUMED
)
3240 spec_error
= deferred_seen
;
3242 spec_error
= assumed_seen
;
3246 gfc_error ("The type parameter spec list at %C cannot contain "
3247 "both ASSUMED and DEFERRED parameters");
3252 if (actual_param
&& actual_param
->name
)
3254 param
= type_param_name_list
->sym
;
3256 if (!param
|| !param
->name
)
3259 c1
= gfc_find_component (pdt
, param
->name
, false, true, NULL
);
3260 /* An error should already have been thrown in resolve.c
3261 (resolve_fl_derived0). */
3262 if (!pdt
->attr
.use_assoc
&& !c1
)
3268 if (!actual_param
&& !(c1
&& c1
->initializer
))
3270 gfc_error ("The type parameter spec list at %C does not contain "
3271 "enough parameter expressions");
3274 else if (!actual_param
&& c1
&& c1
->initializer
)
3275 kind_expr
= gfc_copy_expr (c1
->initializer
);
3276 else if (actual_param
&& actual_param
->spec_type
== SPEC_EXPLICIT
)
3277 kind_expr
= gfc_copy_expr (actual_param
->expr
);
3281 actual_param
= param_list
;
3282 for (;actual_param
; actual_param
= actual_param
->next
)
3283 if (actual_param
->name
3284 && strcmp (actual_param
->name
, param
->name
) == 0)
3286 if (actual_param
&& actual_param
->spec_type
== SPEC_EXPLICIT
)
3287 kind_expr
= gfc_copy_expr (actual_param
->expr
);
3290 if (c1
->initializer
)
3291 kind_expr
= gfc_copy_expr (c1
->initializer
);
3292 else if (!(actual_param
&& param
->attr
.pdt_len
))
3294 gfc_error ("The derived parameter '%qs' at %C does not "
3295 "have a default value", param
->name
);
3301 /* Store the current parameter expressions in a temporary actual
3302 arglist 'list' so that they can be substituted in the corresponding
3303 expressions in the PDT instance. */
3304 if (type_param_spec_list
== NULL
)
3306 type_param_spec_list
= gfc_get_actual_arglist ();
3307 tail
= type_param_spec_list
;
3311 tail
->next
= gfc_get_actual_arglist ();
3314 tail
->name
= param
->name
;
3318 /* Try simplification even for LEN expressions. */
3319 gfc_resolve_expr (kind_expr
);
3320 gfc_simplify_expr (kind_expr
, 1);
3321 /* Variable expressions seem to default to BT_PROCEDURE.
3322 TODO find out why this is and fix it. */
3323 if (kind_expr
->ts
.type
!= BT_INTEGER
3324 && kind_expr
->ts
.type
!= BT_PROCEDURE
)
3326 gfc_error ("The parameter expression at %C must be of "
3327 "INTEGER type and not %s type",
3328 gfc_basic_typename (kind_expr
->ts
.type
));
3332 tail
->expr
= gfc_copy_expr (kind_expr
);
3336 tail
->spec_type
= actual_param
->spec_type
;
3338 if (!param
->attr
.pdt_kind
)
3340 if (!name_seen
&& actual_param
)
3341 actual_param
= actual_param
->next
;
3344 gfc_free_expr (kind_expr
);
3351 && (actual_param
->spec_type
== SPEC_ASSUMED
3352 || actual_param
->spec_type
== SPEC_DEFERRED
))
3354 gfc_error ("The KIND parameter '%qs' at %C cannot either be "
3355 "ASSUMED or DEFERRED", param
->name
);
3359 if (!kind_expr
|| !gfc_is_constant_expr (kind_expr
))
3361 gfc_error ("The value for the KIND parameter '%qs' at %C does not "
3362 "reduce to a constant expression", param
->name
);
3366 gfc_extract_int (kind_expr
, &kind_value
);
3367 sprintf (name
+ strlen (name
), "_%d", kind_value
);
3369 if (!name_seen
&& actual_param
)
3370 actual_param
= actual_param
->next
;
3371 gfc_free_expr (kind_expr
);
3374 if (!name_seen
&& actual_param
)
3376 gfc_error ("The type parameter spec list at %C contains too many "
3377 "parameter expressions");
3381 /* Now we search for the PDT instance 'name'. If it doesn't exist, we
3382 build it, using 'pdt' as a template. */
3383 if (gfc_get_symbol (name
, pdt
->ns
, &instance
))
3385 gfc_error ("Parameterized derived type at %C is ambiguous");
3391 if (instance
->attr
.flavor
== FL_DERIVED
3392 && instance
->attr
.pdt_type
)
3396 *ext_param_list
= type_param_spec_list
;
3398 gfc_commit_symbols ();
3402 /* Start building the new instance of the parameterized type. */
3403 gfc_copy_attr (&instance
->attr
, &pdt
->attr
, &pdt
->declared_at
);
3404 instance
->attr
.pdt_template
= 0;
3405 instance
->attr
.pdt_type
= 1;
3406 instance
->declared_at
= gfc_current_locus
;
3408 /* Add the components, replacing the parameters in all expressions
3409 with the expressions for their values in 'type_param_spec_list'. */
3410 c1
= pdt
->components
;
3411 tail
= type_param_spec_list
;
3412 for (; c1
; c1
= c1
->next
)
3414 gfc_add_component (instance
, c1
->name
, &c2
);
3417 c2
->attr
= c1
->attr
;
3419 /* The order of declaration of the type_specs might not be the
3420 same as that of the components. */
3421 if (c1
->attr
.pdt_kind
|| c1
->attr
.pdt_len
)
3423 for (tail
= type_param_spec_list
; tail
; tail
= tail
->next
)
3424 if (strcmp (c1
->name
, tail
->name
) == 0)
3428 /* Deal with type extension by recursively calling this function
3429 to obtain the instance of the extended type. */
3430 if (gfc_current_state () != COMP_DERIVED
3431 && c1
== pdt
->components
3432 && (c1
->ts
.type
== BT_DERIVED
|| c1
->ts
.type
== BT_CLASS
)
3433 && c1
->ts
.u
.derived
&& c1
->ts
.u
.derived
->attr
.pdt_template
3434 && gfc_get_derived_super_type (*sym
) == c2
->ts
.u
.derived
)
3436 gfc_formal_arglist
*f
;
3438 old_param_spec_list
= type_param_spec_list
;
3440 /* Obtain a spec list appropriate to the extended type..*/
3441 actual_param
= gfc_copy_actual_arglist (type_param_spec_list
);
3442 type_param_spec_list
= actual_param
;
3443 for (f
= c1
->ts
.u
.derived
->formal
; f
&& f
->next
; f
= f
->next
)
3444 actual_param
= actual_param
->next
;
3447 gfc_free_actual_arglist (actual_param
->next
);
3448 actual_param
->next
= NULL
;
3451 /* Now obtain the PDT instance for the extended type. */
3452 c2
->param_list
= type_param_spec_list
;
3453 m
= gfc_get_pdt_instance (type_param_spec_list
, &c2
->ts
.u
.derived
,
3455 type_param_spec_list
= old_param_spec_list
;
3457 c2
->ts
.u
.derived
->refs
++;
3458 gfc_set_sym_referenced (c2
->ts
.u
.derived
);
3460 /* Set extension level. */
3461 if (c2
->ts
.u
.derived
->attr
.extension
== 255)
3463 /* Since the extension field is 8 bit wide, we can only have
3464 up to 255 extension levels. */
3465 gfc_error ("Maximum extension level reached with type %qs at %L",
3466 c2
->ts
.u
.derived
->name
,
3467 &c2
->ts
.u
.derived
->declared_at
);
3470 instance
->attr
.extension
= c2
->ts
.u
.derived
->attr
.extension
+ 1;
3475 /* Set the component kind using the parameterized expression. */
3476 if ((c1
->ts
.kind
== 0 || c1
->ts
.type
== BT_CHARACTER
)
3477 && c1
->kind_expr
!= NULL
)
3479 gfc_expr
*e
= gfc_copy_expr (c1
->kind_expr
);
3480 gfc_insert_kind_parameter_exprs (e
);
3481 gfc_simplify_expr (e
, 1);
3482 gfc_extract_int (e
, &c2
->ts
.kind
);
3484 if (gfc_validate_kind (c2
->ts
.type
, c2
->ts
.kind
, true) < 0)
3486 gfc_error ("Kind %d not supported for type %s at %C",
3487 c2
->ts
.kind
, gfc_basic_typename (c2
->ts
.type
));
3492 /* Similarly, set the string length if parameterized. */
3493 if (c1
->ts
.type
== BT_CHARACTER
3494 && c1
->ts
.u
.cl
->length
3495 && gfc_derived_parameter_expr (c1
->ts
.u
.cl
->length
))
3498 e
= gfc_copy_expr (c1
->ts
.u
.cl
->length
);
3499 gfc_insert_kind_parameter_exprs (e
);
3500 gfc_simplify_expr (e
, 1);
3501 c2
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
3502 c2
->ts
.u
.cl
->length
= e
;
3503 c2
->attr
.pdt_string
= 1;
3506 /* Set up either the KIND/LEN initializer, if constant,
3507 or the parameterized expression. Use the template
3508 initializer if one is not already set in this instance. */
3509 if (c2
->attr
.pdt_kind
|| c2
->attr
.pdt_len
)
3511 if (tail
&& tail
->expr
&& gfc_is_constant_expr (tail
->expr
))
3512 c2
->initializer
= gfc_copy_expr (tail
->expr
);
3513 else if (tail
&& tail
->expr
)
3515 c2
->param_list
= gfc_get_actual_arglist ();
3516 c2
->param_list
->name
= tail
->name
;
3517 c2
->param_list
->expr
= gfc_copy_expr (tail
->expr
);
3518 c2
->param_list
->next
= NULL
;
3521 if (!c2
->initializer
&& c1
->initializer
)
3522 c2
->initializer
= gfc_copy_expr (c1
->initializer
);
3525 /* Copy the array spec. */
3526 c2
->as
= gfc_copy_array_spec (c1
->as
);
3527 if (c1
->ts
.type
== BT_CLASS
)
3528 CLASS_DATA (c2
)->as
= gfc_copy_array_spec (CLASS_DATA (c1
)->as
);
3530 /* Determine if an array spec is parameterized. If so, substitute
3531 in the parameter expressions for the bounds and set the pdt_array
3532 attribute. Notice that this attribute must be unconditionally set
3533 if this is an array of parameterized character length. */
3534 if (c1
->as
&& c1
->as
->type
== AS_EXPLICIT
)
3536 bool pdt_array
= false;
3538 /* Are the bounds of the array parameterized? */
3539 for (i
= 0; i
< c1
->as
->rank
; i
++)
3541 if (gfc_derived_parameter_expr (c1
->as
->lower
[i
]))
3543 if (gfc_derived_parameter_expr (c1
->as
->upper
[i
]))
3547 /* If they are, free the expressions for the bounds and
3548 replace them with the template expressions with substitute
3550 for (i
= 0; pdt_array
&& i
< c1
->as
->rank
; i
++)
3553 e
= gfc_copy_expr (c1
->as
->lower
[i
]);
3554 gfc_insert_kind_parameter_exprs (e
);
3555 gfc_simplify_expr (e
, 1);
3556 gfc_free_expr (c2
->as
->lower
[i
]);
3557 c2
->as
->lower
[i
] = e
;
3558 e
= gfc_copy_expr (c1
->as
->upper
[i
]);
3559 gfc_insert_kind_parameter_exprs (e
);
3560 gfc_simplify_expr (e
, 1);
3561 gfc_free_expr (c2
->as
->upper
[i
]);
3562 c2
->as
->upper
[i
] = e
;
3564 c2
->attr
.pdt_array
= pdt_array
? 1 : c2
->attr
.pdt_string
;
3565 if (c1
->initializer
)
3567 c2
->initializer
= gfc_copy_expr (c1
->initializer
);
3568 gfc_insert_kind_parameter_exprs (c2
->initializer
);
3569 gfc_simplify_expr (c2
->initializer
, 1);
3573 /* Recurse into this function for PDT components. */
3574 if ((c1
->ts
.type
== BT_DERIVED
|| c1
->ts
.type
== BT_CLASS
)
3575 && c1
->ts
.u
.derived
&& c1
->ts
.u
.derived
->attr
.pdt_template
)
3577 gfc_actual_arglist
*params
;
3578 /* The component in the template has a list of specification
3579 expressions derived from its declaration. */
3580 params
= gfc_copy_actual_arglist (c1
->param_list
);
3581 actual_param
= params
;
3582 /* Substitute the template parameters with the expressions
3583 from the specification list. */
3584 for (;actual_param
; actual_param
= actual_param
->next
)
3585 gfc_insert_parameter_exprs (actual_param
->expr
,
3586 type_param_spec_list
);
3588 /* Now obtain the PDT instance for the component. */
3589 old_param_spec_list
= type_param_spec_list
;
3590 m
= gfc_get_pdt_instance (params
, &c2
->ts
.u
.derived
, NULL
);
3591 type_param_spec_list
= old_param_spec_list
;
3593 c2
->param_list
= params
;
3594 if (!(c2
->attr
.pointer
|| c2
->attr
.allocatable
))
3595 c2
->initializer
= gfc_default_initializer (&c2
->ts
);
3597 if (c2
->attr
.allocatable
)
3598 instance
->attr
.alloc_comp
= 1;
3602 gfc_commit_symbol (instance
);
3604 *ext_param_list
= type_param_spec_list
;
3609 gfc_free_actual_arglist (type_param_spec_list
);
3614 /* Matches a declaration-type-spec (F03:R502). If successful, sets the ts
3615 structure to the matched specification. This is necessary for FUNCTION and
3616 IMPLICIT statements.
3618 If implicit_flag is nonzero, then we don't check for the optional
3619 kind specification. Not doing so is needed for matching an IMPLICIT
3620 statement correctly. */
3623 gfc_match_decl_type_spec (gfc_typespec
*ts
, int implicit_flag
)
3625 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3626 gfc_symbol
*sym
, *dt_sym
;
3629 bool seen_deferred_kind
, matched_type
;
3630 const char *dt_name
;
3632 decl_type_param_list
= NULL
;
3634 /* A belt and braces check that the typespec is correctly being treated
3635 as a deferred characteristic association. */
3636 seen_deferred_kind
= (gfc_current_state () == COMP_FUNCTION
)
3637 && (gfc_current_block ()->result
->ts
.kind
== -1)
3638 && (ts
->kind
== -1);
3640 if (seen_deferred_kind
)
3643 /* Clear the current binding label, in case one is given. */
3644 curr_binding_label
= NULL
;
3646 if (gfc_match (" byte") == MATCH_YES
)
3648 if (!gfc_notify_std (GFC_STD_GNU
, "BYTE type at %C"))
3651 if (gfc_validate_kind (BT_INTEGER
, 1, true) < 0)
3653 gfc_error ("BYTE type used at %C "
3654 "is not available on the target machine");
3658 ts
->type
= BT_INTEGER
;
3664 m
= gfc_match (" type (");
3665 matched_type
= (m
== MATCH_YES
);
3668 gfc_gobble_whitespace ();
3669 if (gfc_peek_ascii_char () == '*')
3671 if ((m
= gfc_match ("*)")) != MATCH_YES
)
3673 if (gfc_comp_struct (gfc_current_state ()))
3675 gfc_error ("Assumed type at %C is not allowed for components");
3678 if (!gfc_notify_std (GFC_STD_F2008_TS
, "Assumed type "
3681 ts
->type
= BT_ASSUMED
;
3685 m
= gfc_match ("%n", name
);
3686 matched_type
= (m
== MATCH_YES
);
3689 if ((matched_type
&& strcmp ("integer", name
) == 0)
3690 || (!matched_type
&& gfc_match (" integer") == MATCH_YES
))
3692 ts
->type
= BT_INTEGER
;
3693 ts
->kind
= gfc_default_integer_kind
;
3697 if ((matched_type
&& strcmp ("character", name
) == 0)
3698 || (!matched_type
&& gfc_match (" character") == MATCH_YES
))
3701 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
3702 "intrinsic-type-spec at %C"))
3705 ts
->type
= BT_CHARACTER
;
3706 if (implicit_flag
== 0)
3707 m
= gfc_match_char_spec (ts
);
3711 if (matched_type
&& m
== MATCH_YES
&& gfc_match_char (')') != MATCH_YES
)
3717 if ((matched_type
&& strcmp ("real", name
) == 0)
3718 || (!matched_type
&& gfc_match (" real") == MATCH_YES
))
3721 ts
->kind
= gfc_default_real_kind
;
3726 && (strcmp ("doubleprecision", name
) == 0
3727 || (strcmp ("double", name
) == 0
3728 && gfc_match (" precision") == MATCH_YES
)))
3729 || (!matched_type
&& gfc_match (" double precision") == MATCH_YES
))
3732 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
3733 "intrinsic-type-spec at %C"))
3735 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
3739 ts
->kind
= gfc_default_double_kind
;
3743 if ((matched_type
&& strcmp ("complex", name
) == 0)
3744 || (!matched_type
&& gfc_match (" complex") == MATCH_YES
))
3746 ts
->type
= BT_COMPLEX
;
3747 ts
->kind
= gfc_default_complex_kind
;
3752 && (strcmp ("doublecomplex", name
) == 0
3753 || (strcmp ("double", name
) == 0
3754 && gfc_match (" complex") == MATCH_YES
)))
3755 || (!matched_type
&& gfc_match (" double complex") == MATCH_YES
))
3757 if (!gfc_notify_std (GFC_STD_GNU
, "DOUBLE COMPLEX at %C"))
3761 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
3762 "intrinsic-type-spec at %C"))
3765 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
3768 ts
->type
= BT_COMPLEX
;
3769 ts
->kind
= gfc_default_double_kind
;
3773 if ((matched_type
&& strcmp ("logical", name
) == 0)
3774 || (!matched_type
&& gfc_match (" logical") == MATCH_YES
))
3776 ts
->type
= BT_LOGICAL
;
3777 ts
->kind
= gfc_default_logical_kind
;
3783 m
= gfc_match_actual_arglist (1, &decl_type_param_list
, true);
3784 if (m
== MATCH_ERROR
)
3787 m
= gfc_match_char (')');
3791 m
= match_record_decl (name
);
3793 if (matched_type
|| m
== MATCH_YES
)
3795 ts
->type
= BT_DERIVED
;
3796 /* We accept record/s/ or type(s) where s is a structure, but we
3797 * don't need all the extra derived-type stuff for structures. */
3798 if (gfc_find_symbol (gfc_dt_upper_string (name
), NULL
, 1, &sym
))
3800 gfc_error ("Type name %qs at %C is ambiguous", name
);
3804 if (sym
&& sym
->attr
.flavor
== FL_DERIVED
3805 && sym
->attr
.pdt_template
3806 && gfc_current_state () != COMP_DERIVED
)
3808 m
= gfc_get_pdt_instance (decl_type_param_list
, &sym
, NULL
);
3811 gcc_assert (!sym
->attr
.pdt_template
&& sym
->attr
.pdt_type
);
3812 ts
->u
.derived
= sym
;
3813 strcpy (name
, gfc_dt_lower_string (sym
->name
));
3816 if (sym
&& sym
->attr
.flavor
== FL_STRUCT
)
3818 ts
->u
.derived
= sym
;
3821 /* Actually a derived type. */
3826 /* Match nested STRUCTURE declarations; only valid within another
3827 structure declaration. */
3828 if (flag_dec_structure
3829 && (gfc_current_state () == COMP_STRUCTURE
3830 || gfc_current_state () == COMP_MAP
))
3832 m
= gfc_match (" structure");
3835 m
= gfc_match_structure_decl ();
3838 /* gfc_new_block is updated by match_structure_decl. */
3839 ts
->type
= BT_DERIVED
;
3840 ts
->u
.derived
= gfc_new_block
;
3844 if (m
== MATCH_ERROR
)
3848 /* Match CLASS declarations. */
3849 m
= gfc_match (" class ( * )");
3850 if (m
== MATCH_ERROR
)
3852 else if (m
== MATCH_YES
)
3856 ts
->type
= BT_CLASS
;
3857 gfc_find_symbol ("STAR", gfc_current_ns
, 1, &upe
);
3860 upe
= gfc_new_symbol ("STAR", gfc_current_ns
);
3861 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "STAR");
3863 gfc_set_sym_referenced (upe
);
3865 upe
->ts
.type
= BT_VOID
;
3866 upe
->attr
.unlimited_polymorphic
= 1;
3867 /* This is essential to force the construction of
3868 unlimited polymorphic component class containers. */
3869 upe
->attr
.zero_comp
= 1;
3870 if (!gfc_add_flavor (&upe
->attr
, FL_DERIVED
, NULL
,
3871 &gfc_current_locus
))
3876 st
= gfc_get_tbp_symtree (&gfc_current_ns
->sym_root
, "STAR");
3880 ts
->u
.derived
= upe
;
3884 m
= gfc_match (" class (");
3887 m
= gfc_match ("%n", name
);
3893 ts
->type
= BT_CLASS
;
3895 if (!gfc_notify_std (GFC_STD_F2003
, "CLASS statement at %C"))
3898 m
= gfc_match_actual_arglist (1, &decl_type_param_list
, true);
3899 if (m
== MATCH_ERROR
)
3902 m
= gfc_match_char (')');
3907 /* Defer association of the derived type until the end of the
3908 specification block. However, if the derived type can be
3909 found, add it to the typespec. */
3910 if (gfc_matching_function
)
3912 ts
->u
.derived
= NULL
;
3913 if (gfc_current_state () != COMP_INTERFACE
3914 && !gfc_find_symbol (name
, NULL
, 1, &sym
) && sym
)
3916 sym
= gfc_find_dt_in_generic (sym
);
3917 ts
->u
.derived
= sym
;
3922 /* Search for the name but allow the components to be defined later. If
3923 type = -1, this typespec has been seen in a function declaration but
3924 the type could not be accessed at that point. The actual derived type is
3925 stored in a symtree with the first letter of the name capitalized; the
3926 symtree with the all lower-case name contains the associated
3927 generic function. */
3928 dt_name
= gfc_dt_upper_string (name
);
3933 gfc_get_ha_symbol (name
, &sym
);
3934 if (sym
->generic
&& gfc_find_symbol (dt_name
, NULL
, 0, &dt_sym
))
3936 gfc_error ("Type name %qs at %C is ambiguous", name
);
3939 if (sym
->generic
&& !dt_sym
)
3940 dt_sym
= gfc_find_dt_in_generic (sym
);
3942 /* Host associated PDTs can get confused with their constructors
3943 because they ar instantiated in the template's namespace. */
3946 if (gfc_find_symbol (dt_name
, NULL
, 1, &dt_sym
))
3948 gfc_error ("Type name %qs at %C is ambiguous", name
);
3951 if (dt_sym
&& !dt_sym
->attr
.pdt_type
)
3955 else if (ts
->kind
== -1)
3957 int iface
= gfc_state_stack
->previous
->state
!= COMP_INTERFACE
3958 || gfc_current_ns
->has_import_set
;
3959 gfc_find_symbol (name
, NULL
, iface
, &sym
);
3960 if (sym
&& sym
->generic
&& gfc_find_symbol (dt_name
, NULL
, 1, &dt_sym
))
3962 gfc_error ("Type name %qs at %C is ambiguous", name
);
3965 if (sym
&& sym
->generic
&& !dt_sym
)
3966 dt_sym
= gfc_find_dt_in_generic (sym
);
3973 if ((sym
->attr
.flavor
!= FL_UNKNOWN
&& sym
->attr
.flavor
!= FL_STRUCT
3974 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.generic
))
3975 || sym
->attr
.subroutine
)
3977 gfc_error ("Type name %qs at %C conflicts with previously declared "
3978 "entity at %L, which has the same name", name
,
3983 if (sym
&& sym
->attr
.flavor
== FL_DERIVED
3984 && sym
->attr
.pdt_template
3985 && gfc_current_state () != COMP_DERIVED
)
3987 m
= gfc_get_pdt_instance (decl_type_param_list
, &sym
, NULL
);
3990 gcc_assert (!sym
->attr
.pdt_template
&& sym
->attr
.pdt_type
);
3991 ts
->u
.derived
= sym
;
3992 strcpy (name
, gfc_dt_lower_string (sym
->name
));
3995 gfc_save_symbol_data (sym
);
3996 gfc_set_sym_referenced (sym
);
3997 if (!sym
->attr
.generic
3998 && !gfc_add_generic (&sym
->attr
, sym
->name
, NULL
))
4001 if (!sym
->attr
.function
4002 && !gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
4005 if (dt_sym
&& dt_sym
->attr
.flavor
== FL_DERIVED
4006 && dt_sym
->attr
.pdt_template
4007 && gfc_current_state () != COMP_DERIVED
)
4009 m
= gfc_get_pdt_instance (decl_type_param_list
, &dt_sym
, NULL
);
4012 gcc_assert (!dt_sym
->attr
.pdt_template
&& dt_sym
->attr
.pdt_type
);
4017 gfc_interface
*intr
, *head
;
4019 /* Use upper case to save the actual derived-type symbol. */
4020 gfc_get_symbol (dt_name
, NULL
, &dt_sym
);
4021 dt_sym
->name
= gfc_get_string ("%s", sym
->name
);
4022 head
= sym
->generic
;
4023 intr
= gfc_get_interface ();
4025 intr
->where
= gfc_current_locus
;
4027 sym
->generic
= intr
;
4028 sym
->attr
.if_source
= IFSRC_DECL
;
4031 gfc_save_symbol_data (dt_sym
);
4033 gfc_set_sym_referenced (dt_sym
);
4035 if (dt_sym
->attr
.flavor
!= FL_DERIVED
&& dt_sym
->attr
.flavor
!= FL_STRUCT
4036 && !gfc_add_flavor (&dt_sym
->attr
, FL_DERIVED
, sym
->name
, NULL
))
4039 ts
->u
.derived
= dt_sym
;
4045 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
4046 "intrinsic-type-spec at %C"))
4049 /* For all types except double, derived and character, look for an
4050 optional kind specifier. MATCH_NO is actually OK at this point. */
4051 if (implicit_flag
== 1)
4053 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
4059 if (gfc_current_form
== FORM_FREE
)
4061 c
= gfc_peek_ascii_char ();
4062 if (!gfc_is_whitespace (c
) && c
!= '*' && c
!= '('
4063 && c
!= ':' && c
!= ',')
4065 if (matched_type
&& c
== ')')
4067 gfc_next_ascii_char ();
4074 m
= gfc_match_kind_spec (ts
, false);
4075 if (m
== MATCH_NO
&& ts
->type
!= BT_CHARACTER
)
4077 m
= gfc_match_old_kind_spec (ts
);
4078 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) == -1)
4082 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
4085 /* Defer association of the KIND expression of function results
4086 until after USE and IMPORT statements. */
4087 if ((gfc_current_state () == COMP_NONE
&& gfc_error_flag_test ())
4088 || gfc_matching_function
)
4092 m
= MATCH_YES
; /* No kind specifier found. */
4098 /* Match an IMPLICIT NONE statement. Actually, this statement is
4099 already matched in parse.c, or we would not end up here in the
4100 first place. So the only thing we need to check, is if there is
4101 trailing garbage. If not, the match is successful. */
4104 gfc_match_implicit_none (void)
4108 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4110 bool external
= false;
4111 locus cur_loc
= gfc_current_locus
;
4113 if (gfc_current_ns
->seen_implicit_none
4114 || gfc_current_ns
->has_implicit_none_export
)
4116 gfc_error ("Duplicate IMPLICIT NONE statement at %C");
4120 gfc_gobble_whitespace ();
4121 c
= gfc_peek_ascii_char ();
4124 (void) gfc_next_ascii_char ();
4125 if (!gfc_notify_std (GFC_STD_F2018
, "IMPORT NONE with spec list at %C"))
4128 gfc_gobble_whitespace ();
4129 if (gfc_peek_ascii_char () == ')')
4131 (void) gfc_next_ascii_char ();
4137 m
= gfc_match (" %n", name
);
4141 if (strcmp (name
, "type") == 0)
4143 else if (strcmp (name
, "external") == 0)
4148 gfc_gobble_whitespace ();
4149 c
= gfc_next_ascii_char ();
4160 if (gfc_match_eos () != MATCH_YES
)
4163 gfc_set_implicit_none (type
, external
, &cur_loc
);
4169 /* Match the letter range(s) of an IMPLICIT statement. */
4172 match_implicit_range (void)
4178 cur_loc
= gfc_current_locus
;
4180 gfc_gobble_whitespace ();
4181 c
= gfc_next_ascii_char ();
4184 gfc_error ("Missing character range in IMPLICIT at %C");
4191 gfc_gobble_whitespace ();
4192 c1
= gfc_next_ascii_char ();
4196 gfc_gobble_whitespace ();
4197 c
= gfc_next_ascii_char ();
4202 inner
= 0; /* Fall through. */
4209 gfc_gobble_whitespace ();
4210 c2
= gfc_next_ascii_char ();
4214 gfc_gobble_whitespace ();
4215 c
= gfc_next_ascii_char ();
4217 if ((c
!= ',') && (c
!= ')'))
4230 gfc_error ("Letters must be in alphabetic order in "
4231 "IMPLICIT statement at %C");
4235 /* See if we can add the newly matched range to the pending
4236 implicits from this IMPLICIT statement. We do not check for
4237 conflicts with whatever earlier IMPLICIT statements may have
4238 set. This is done when we've successfully finished matching
4240 if (!gfc_add_new_implicit_range (c1
, c2
))
4247 gfc_syntax_error (ST_IMPLICIT
);
4249 gfc_current_locus
= cur_loc
;
4254 /* Match an IMPLICIT statement, storing the types for
4255 gfc_set_implicit() if the statement is accepted by the parser.
4256 There is a strange looking, but legal syntactic construction
4257 possible. It looks like:
4259 IMPLICIT INTEGER (a-b) (c-d)
4261 This is legal if "a-b" is a constant expression that happens to
4262 equal one of the legal kinds for integers. The real problem
4263 happens with an implicit specification that looks like:
4265 IMPLICIT INTEGER (a-b)
4267 In this case, a typespec matcher that is "greedy" (as most of the
4268 matchers are) gobbles the character range as a kindspec, leaving
4269 nothing left. We therefore have to go a bit more slowly in the
4270 matching process by inhibiting the kindspec checking during
4271 typespec matching and checking for a kind later. */
4274 gfc_match_implicit (void)
4281 if (gfc_current_ns
->seen_implicit_none
)
4283 gfc_error ("IMPLICIT statement at %C following an IMPLICIT NONE (type) "
4290 /* We don't allow empty implicit statements. */
4291 if (gfc_match_eos () == MATCH_YES
)
4293 gfc_error ("Empty IMPLICIT statement at %C");
4299 /* First cleanup. */
4300 gfc_clear_new_implicit ();
4302 /* A basic type is mandatory here. */
4303 m
= gfc_match_decl_type_spec (&ts
, 1);
4304 if (m
== MATCH_ERROR
)
4309 cur_loc
= gfc_current_locus
;
4310 m
= match_implicit_range ();
4314 /* We may have <TYPE> (<RANGE>). */
4315 gfc_gobble_whitespace ();
4316 c
= gfc_peek_ascii_char ();
4317 if (c
== ',' || c
== '\n' || c
== ';' || c
== '!')
4319 /* Check for CHARACTER with no length parameter. */
4320 if (ts
.type
== BT_CHARACTER
&& !ts
.u
.cl
)
4322 ts
.kind
= gfc_default_character_kind
;
4323 ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4324 ts
.u
.cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
,
4328 /* Record the Successful match. */
4329 if (!gfc_merge_new_implicit (&ts
))
4332 c
= gfc_next_ascii_char ();
4333 else if (gfc_match_eos () == MATCH_ERROR
)
4338 gfc_current_locus
= cur_loc
;
4341 /* Discard the (incorrectly) matched range. */
4342 gfc_clear_new_implicit ();
4344 /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
4345 if (ts
.type
== BT_CHARACTER
)
4346 m
= gfc_match_char_spec (&ts
);
4349 m
= gfc_match_kind_spec (&ts
, false);
4352 m
= gfc_match_old_kind_spec (&ts
);
4353 if (m
== MATCH_ERROR
)
4359 if (m
== MATCH_ERROR
)
4362 m
= match_implicit_range ();
4363 if (m
== MATCH_ERROR
)
4368 gfc_gobble_whitespace ();
4369 c
= gfc_next_ascii_char ();
4370 if (c
!= ',' && gfc_match_eos () != MATCH_YES
)
4373 if (!gfc_merge_new_implicit (&ts
))
4381 gfc_syntax_error (ST_IMPLICIT
);
4389 gfc_match_import (void)
4391 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4396 if (gfc_current_ns
->proc_name
== NULL
4397 || gfc_current_ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
4399 gfc_error ("IMPORT statement at %C only permitted in "
4400 "an INTERFACE body");
4404 if (gfc_current_ns
->proc_name
->attr
.module_procedure
)
4406 gfc_error ("F2008: C1210 IMPORT statement at %C is not permitted "
4407 "in a module procedure interface body");
4411 if (!gfc_notify_std (GFC_STD_F2003
, "IMPORT statement at %C"))
4414 if (gfc_match_eos () == MATCH_YES
)
4416 /* All host variables should be imported. */
4417 gfc_current_ns
->has_import_set
= 1;
4421 if (gfc_match (" ::") == MATCH_YES
)
4423 if (gfc_match_eos () == MATCH_YES
)
4425 gfc_error ("Expecting list of named entities at %C");
4433 m
= gfc_match (" %n", name
);
4437 if (gfc_current_ns
->parent
!= NULL
4438 && gfc_find_symbol (name
, gfc_current_ns
->parent
, 1, &sym
))
4440 gfc_error ("Type name %qs at %C is ambiguous", name
);
4443 else if (!sym
&& gfc_current_ns
->proc_name
->ns
->parent
!= NULL
4444 && gfc_find_symbol (name
,
4445 gfc_current_ns
->proc_name
->ns
->parent
,
4448 gfc_error ("Type name %qs at %C is ambiguous", name
);
4454 gfc_error ("Cannot IMPORT %qs from host scoping unit "
4455 "at %C - does not exist.", name
);
4459 if (gfc_find_symtree (gfc_current_ns
->sym_root
, name
))
4461 gfc_warning (0, "%qs is already IMPORTed from host scoping unit "
4466 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, name
);
4469 sym
->attr
.imported
= 1;
4471 if (sym
->attr
.generic
&& (sym
= gfc_find_dt_in_generic (sym
)))
4473 /* The actual derived type is stored in a symtree with the first
4474 letter of the name capitalized; the symtree with the all
4475 lower-case name contains the associated generic function. */
4476 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
,
4477 gfc_dt_upper_string (name
));
4480 sym
->attr
.imported
= 1;
4493 if (gfc_match_eos () == MATCH_YES
)
4495 if (gfc_match_char (',') != MATCH_YES
)
4502 gfc_error ("Syntax error in IMPORT statement at %C");
4507 /* A minimal implementation of gfc_match without whitespace, escape
4508 characters or variable arguments. Returns true if the next
4509 characters match the TARGET template exactly. */
4512 match_string_p (const char *target
)
4516 for (p
= target
; *p
; p
++)
4517 if ((char) gfc_next_ascii_char () != *p
)
4522 /* Matches an attribute specification including array specs. If
4523 successful, leaves the variables current_attr and current_as
4524 holding the specification. Also sets the colon_seen variable for
4525 later use by matchers associated with initializations.
4527 This subroutine is a little tricky in the sense that we don't know
4528 if we really have an attr-spec until we hit the double colon.
4529 Until that time, we can only return MATCH_NO. This forces us to
4530 check for duplicate specification at this level. */
4533 match_attr_spec (void)
4535 /* Modifiers that can exist in a type statement. */
4537 { GFC_DECL_BEGIN
= 0,
4538 DECL_ALLOCATABLE
= GFC_DECL_BEGIN
, DECL_DIMENSION
, DECL_EXTERNAL
,
4539 DECL_IN
, DECL_OUT
, DECL_INOUT
, DECL_INTRINSIC
, DECL_OPTIONAL
,
4540 DECL_PARAMETER
, DECL_POINTER
, DECL_PROTECTED
, DECL_PRIVATE
,
4541 DECL_STATIC
, DECL_AUTOMATIC
,
4542 DECL_PUBLIC
, DECL_SAVE
, DECL_TARGET
, DECL_VALUE
, DECL_VOLATILE
,
4543 DECL_IS_BIND_C
, DECL_CODIMENSION
, DECL_ASYNCHRONOUS
, DECL_CONTIGUOUS
,
4544 DECL_LEN
, DECL_KIND
, DECL_NONE
, GFC_DECL_END
/* Sentinel */
4547 /* GFC_DECL_END is the sentinel, index starts at 0. */
4548 #define NUM_DECL GFC_DECL_END
4550 locus start
, seen_at
[NUM_DECL
];
4557 gfc_clear_attr (¤t_attr
);
4558 start
= gfc_current_locus
;
4564 /* See if we get all of the keywords up to the final double colon. */
4565 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
4573 gfc_gobble_whitespace ();
4575 ch
= gfc_next_ascii_char ();
4578 /* This is the successful exit condition for the loop. */
4579 if (gfc_next_ascii_char () == ':')
4584 gfc_gobble_whitespace ();
4585 switch (gfc_peek_ascii_char ())
4588 gfc_next_ascii_char ();
4589 switch (gfc_next_ascii_char ())
4592 if (match_string_p ("locatable"))
4594 /* Matched "allocatable". */
4595 d
= DECL_ALLOCATABLE
;
4600 if (match_string_p ("ynchronous"))
4602 /* Matched "asynchronous". */
4603 d
= DECL_ASYNCHRONOUS
;
4608 if (match_string_p ("tomatic"))
4610 /* Matched "automatic". */
4618 /* Try and match the bind(c). */
4619 m
= gfc_match_bind_c (NULL
, true);
4622 else if (m
== MATCH_ERROR
)
4627 gfc_next_ascii_char ();
4628 if ('o' != gfc_next_ascii_char ())
4630 switch (gfc_next_ascii_char ())
4633 if (match_string_p ("imension"))
4635 d
= DECL_CODIMENSION
;
4640 if (match_string_p ("tiguous"))
4642 d
= DECL_CONTIGUOUS
;
4649 if (match_string_p ("dimension"))
4654 if (match_string_p ("external"))
4659 if (match_string_p ("int"))
4661 ch
= gfc_next_ascii_char ();
4664 if (match_string_p ("nt"))
4666 /* Matched "intent". */
4667 /* TODO: Call match_intent_spec from here. */
4668 if (gfc_match (" ( in out )") == MATCH_YES
)
4670 else if (gfc_match (" ( in )") == MATCH_YES
)
4672 else if (gfc_match (" ( out )") == MATCH_YES
)
4678 if (match_string_p ("insic"))
4680 /* Matched "intrinsic". */
4688 if (match_string_p ("kind"))
4693 if (match_string_p ("len"))
4698 if (match_string_p ("optional"))
4703 gfc_next_ascii_char ();
4704 switch (gfc_next_ascii_char ())
4707 if (match_string_p ("rameter"))
4709 /* Matched "parameter". */
4715 if (match_string_p ("inter"))
4717 /* Matched "pointer". */
4723 ch
= gfc_next_ascii_char ();
4726 if (match_string_p ("vate"))
4728 /* Matched "private". */
4734 if (match_string_p ("tected"))
4736 /* Matched "protected". */
4743 if (match_string_p ("blic"))
4745 /* Matched "public". */
4753 gfc_next_ascii_char ();
4754 switch (gfc_next_ascii_char ())
4757 if (match_string_p ("ve"))
4759 /* Matched "save". */
4765 if (match_string_p ("atic"))
4767 /* Matched "static". */
4775 if (match_string_p ("target"))
4780 gfc_next_ascii_char ();
4781 ch
= gfc_next_ascii_char ();
4784 if (match_string_p ("lue"))
4786 /* Matched "value". */
4792 if (match_string_p ("latile"))
4794 /* Matched "volatile". */
4802 /* No double colon and no recognizable decl_type, so assume that
4803 we've been looking at something else the whole time. */
4810 /* Check to make sure any parens are paired up correctly. */
4811 if (gfc_match_parens () == MATCH_ERROR
)
4818 seen_at
[d
] = gfc_current_locus
;
4820 if (d
== DECL_DIMENSION
|| d
== DECL_CODIMENSION
)
4822 gfc_array_spec
*as
= NULL
;
4824 m
= gfc_match_array_spec (&as
, d
== DECL_DIMENSION
,
4825 d
== DECL_CODIMENSION
);
4827 if (current_as
== NULL
)
4829 else if (m
== MATCH_YES
)
4831 if (!merge_array_spec (as
, current_as
, false))
4838 if (d
== DECL_CODIMENSION
)
4839 gfc_error ("Missing codimension specification at %C");
4841 gfc_error ("Missing dimension specification at %C");
4845 if (m
== MATCH_ERROR
)
4850 /* Since we've seen a double colon, we have to be looking at an
4851 attr-spec. This means that we can now issue errors. */
4852 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
4857 case DECL_ALLOCATABLE
:
4858 attr
= "ALLOCATABLE";
4860 case DECL_ASYNCHRONOUS
:
4861 attr
= "ASYNCHRONOUS";
4863 case DECL_CODIMENSION
:
4864 attr
= "CODIMENSION";
4866 case DECL_CONTIGUOUS
:
4867 attr
= "CONTIGUOUS";
4869 case DECL_DIMENSION
:
4876 attr
= "INTENT (IN)";
4879 attr
= "INTENT (OUT)";
4882 attr
= "INTENT (IN OUT)";
4884 case DECL_INTRINSIC
:
4896 case DECL_PARAMETER
:
4902 case DECL_PROTECTED
:
4917 case DECL_AUTOMATIC
:
4923 case DECL_IS_BIND_C
:
4933 attr
= NULL
; /* This shouldn't happen. */
4936 gfc_error ("Duplicate %s attribute at %L", attr
, &seen_at
[d
]);
4941 /* Now that we've dealt with duplicate attributes, add the attributes
4942 to the current attribute. */
4943 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
4950 if ((d
== DECL_STATIC
|| d
== DECL_AUTOMATIC
)
4951 && !flag_dec_static
)
4953 gfc_error ("%s at %L is a DEC extension, enable with "
4955 d
== DECL_STATIC
? "STATIC" : "AUTOMATIC", &seen_at
[d
]);
4959 /* Allow SAVE with STATIC, but don't complain. */
4960 if (d
== DECL_STATIC
&& seen
[DECL_SAVE
])
4963 if (gfc_current_state () == COMP_DERIVED
4964 && d
!= DECL_DIMENSION
&& d
!= DECL_CODIMENSION
4965 && d
!= DECL_POINTER
&& d
!= DECL_PRIVATE
4966 && d
!= DECL_PUBLIC
&& d
!= DECL_CONTIGUOUS
&& d
!= DECL_NONE
)
4968 if (d
== DECL_ALLOCATABLE
)
4970 if (!gfc_notify_std (GFC_STD_F2003
, "ALLOCATABLE "
4971 "attribute at %C in a TYPE definition"))
4977 else if (d
== DECL_KIND
)
4979 if (!gfc_notify_std (GFC_STD_F2003
, "KIND "
4980 "attribute at %C in a TYPE definition"))
4985 if (current_ts
.type
!= BT_INTEGER
)
4987 gfc_error ("Component with KIND attribute at %C must be "
4992 if (current_ts
.kind
!= gfc_default_integer_kind
)
4994 gfc_error ("Component with KIND attribute at %C must be "
4995 "default integer kind (%d)",
4996 gfc_default_integer_kind
);
5001 else if (d
== DECL_LEN
)
5003 if (!gfc_notify_std (GFC_STD_F2003
, "LEN "
5004 "attribute at %C in a TYPE definition"))
5009 if (current_ts
.type
!= BT_INTEGER
)
5011 gfc_error ("Component with LEN attribute at %C must be "
5016 if (current_ts
.kind
!= gfc_default_integer_kind
)
5018 gfc_error ("Component with LEN attribute at %C must be "
5019 "default integer kind (%d)",
5020 gfc_default_integer_kind
);
5027 gfc_error ("Attribute at %L is not allowed in a TYPE definition",
5034 if ((d
== DECL_PRIVATE
|| d
== DECL_PUBLIC
)
5035 && gfc_current_state () != COMP_MODULE
)
5037 if (d
== DECL_PRIVATE
)
5041 if (gfc_current_state () == COMP_DERIVED
5042 && gfc_state_stack
->previous
5043 && gfc_state_stack
->previous
->state
== COMP_MODULE
)
5045 if (!gfc_notify_std (GFC_STD_F2003
, "Attribute %s "
5046 "at %L in a TYPE definition", attr
,
5055 gfc_error ("%s attribute at %L is not allowed outside of the "
5056 "specification part of a module", attr
, &seen_at
[d
]);
5062 if (gfc_current_state () != COMP_DERIVED
5063 && (d
== DECL_KIND
|| d
== DECL_LEN
))
5065 gfc_error ("Attribute at %L is not allowed outside a TYPE "
5066 "definition", &seen_at
[d
]);
5073 case DECL_ALLOCATABLE
:
5074 t
= gfc_add_allocatable (¤t_attr
, &seen_at
[d
]);
5077 case DECL_ASYNCHRONOUS
:
5078 if (!gfc_notify_std (GFC_STD_F2003
, "ASYNCHRONOUS attribute at %C"))
5081 t
= gfc_add_asynchronous (¤t_attr
, NULL
, &seen_at
[d
]);
5084 case DECL_CODIMENSION
:
5085 t
= gfc_add_codimension (¤t_attr
, NULL
, &seen_at
[d
]);
5088 case DECL_CONTIGUOUS
:
5089 if (!gfc_notify_std (GFC_STD_F2008
, "CONTIGUOUS attribute at %C"))
5092 t
= gfc_add_contiguous (¤t_attr
, NULL
, &seen_at
[d
]);
5095 case DECL_DIMENSION
:
5096 t
= gfc_add_dimension (¤t_attr
, NULL
, &seen_at
[d
]);
5100 t
= gfc_add_external (¤t_attr
, &seen_at
[d
]);
5104 t
= gfc_add_intent (¤t_attr
, INTENT_IN
, &seen_at
[d
]);
5108 t
= gfc_add_intent (¤t_attr
, INTENT_OUT
, &seen_at
[d
]);
5112 t
= gfc_add_intent (¤t_attr
, INTENT_INOUT
, &seen_at
[d
]);
5115 case DECL_INTRINSIC
:
5116 t
= gfc_add_intrinsic (¤t_attr
, &seen_at
[d
]);
5120 t
= gfc_add_optional (¤t_attr
, &seen_at
[d
]);
5124 t
= gfc_add_kind (¤t_attr
, &seen_at
[d
]);
5128 t
= gfc_add_len (¤t_attr
, &seen_at
[d
]);
5131 case DECL_PARAMETER
:
5132 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, &seen_at
[d
]);
5136 t
= gfc_add_pointer (¤t_attr
, &seen_at
[d
]);
5139 case DECL_PROTECTED
:
5140 if (gfc_current_state () != COMP_MODULE
5141 || (gfc_current_ns
->proc_name
5142 && gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
))
5144 gfc_error ("PROTECTED at %C only allowed in specification "
5145 "part of a module");
5150 if (!gfc_notify_std (GFC_STD_F2003
, "PROTECTED attribute at %C"))
5153 t
= gfc_add_protected (¤t_attr
, NULL
, &seen_at
[d
]);
5157 t
= gfc_add_access (¤t_attr
, ACCESS_PRIVATE
, NULL
,
5162 t
= gfc_add_access (¤t_attr
, ACCESS_PUBLIC
, NULL
,
5168 t
= gfc_add_save (¤t_attr
, SAVE_EXPLICIT
, NULL
, &seen_at
[d
]);
5171 case DECL_AUTOMATIC
:
5172 t
= gfc_add_automatic (¤t_attr
, NULL
, &seen_at
[d
]);
5176 t
= gfc_add_target (¤t_attr
, &seen_at
[d
]);
5179 case DECL_IS_BIND_C
:
5180 t
= gfc_add_is_bind_c(¤t_attr
, NULL
, &seen_at
[d
], 0);
5184 if (!gfc_notify_std (GFC_STD_F2003
, "VALUE attribute at %C"))
5187 t
= gfc_add_value (¤t_attr
, NULL
, &seen_at
[d
]);
5191 if (!gfc_notify_std (GFC_STD_F2003
, "VOLATILE attribute at %C"))
5194 t
= gfc_add_volatile (¤t_attr
, NULL
, &seen_at
[d
]);
5198 gfc_internal_error ("match_attr_spec(): Bad attribute");
5208 /* Since Fortran 2008 module variables implicitly have the SAVE attribute. */
5209 if ((gfc_current_state () == COMP_MODULE
5210 || gfc_current_state () == COMP_SUBMODULE
)
5211 && !current_attr
.save
5212 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
5213 current_attr
.save
= SAVE_IMPLICIT
;
5219 gfc_current_locus
= start
;
5220 gfc_free_array_spec (current_as
);
5227 /* Set the binding label, dest_label, either with the binding label
5228 stored in the given gfc_typespec, ts, or if none was provided, it
5229 will be the symbol name in all lower case, as required by the draft
5230 (J3/04-007, section 15.4.1). If a binding label was given and
5231 there is more than one argument (num_idents), it is an error. */
5234 set_binding_label (const char **dest_label
, const char *sym_name
,
5237 if (num_idents
> 1 && has_name_equals
)
5239 gfc_error ("Multiple identifiers provided with "
5240 "single NAME= specifier at %C");
5244 if (curr_binding_label
)
5245 /* Binding label given; store in temp holder till have sym. */
5246 *dest_label
= curr_binding_label
;
5249 /* No binding label given, and the NAME= specifier did not exist,
5250 which means there was no NAME="". */
5251 if (sym_name
!= NULL
&& has_name_equals
== 0)
5252 *dest_label
= IDENTIFIER_POINTER (get_identifier (sym_name
));
5259 /* Set the status of the given common block as being BIND(C) or not,
5260 depending on the given parameter, is_bind_c. */
5263 set_com_block_bind_c (gfc_common_head
*com_block
, int is_bind_c
)
5265 com_block
->is_bind_c
= is_bind_c
;
5270 /* Verify that the given gfc_typespec is for a C interoperable type. */
5273 gfc_verify_c_interop (gfc_typespec
*ts
)
5275 if (ts
->type
== BT_DERIVED
&& ts
->u
.derived
!= NULL
)
5276 return (ts
->u
.derived
->ts
.is_c_interop
|| ts
->u
.derived
->attr
.is_bind_c
)
5278 else if (ts
->type
== BT_CLASS
)
5280 else if (ts
->is_c_interop
!= 1 && ts
->type
!= BT_ASSUMED
)
5287 /* Verify that the variables of a given common block, which has been
5288 defined with the attribute specifier bind(c), to be of a C
5289 interoperable type. Errors will be reported here, if
5293 verify_com_block_vars_c_interop (gfc_common_head
*com_block
)
5295 gfc_symbol
*curr_sym
= NULL
;
5298 curr_sym
= com_block
->head
;
5300 /* Make sure we have at least one symbol. */
5301 if (curr_sym
== NULL
)
5304 /* Here we know we have a symbol, so we'll execute this loop
5308 /* The second to last param, 1, says this is in a common block. */
5309 retval
= verify_bind_c_sym (curr_sym
, &(curr_sym
->ts
), 1, com_block
);
5310 curr_sym
= curr_sym
->common_next
;
5311 } while (curr_sym
!= NULL
);
5317 /* Verify that a given BIND(C) symbol is C interoperable. If it is not,
5318 an appropriate error message is reported. */
5321 verify_bind_c_sym (gfc_symbol
*tmp_sym
, gfc_typespec
*ts
,
5322 int is_in_common
, gfc_common_head
*com_block
)
5324 bool bind_c_function
= false;
5327 if (tmp_sym
->attr
.function
&& tmp_sym
->attr
.is_bind_c
)
5328 bind_c_function
= true;
5330 if (tmp_sym
->attr
.function
&& tmp_sym
->result
!= NULL
)
5332 tmp_sym
= tmp_sym
->result
;
5333 /* Make sure it wasn't an implicitly typed result. */
5334 if (tmp_sym
->attr
.implicit_type
&& warn_c_binding_type
)
5336 gfc_warning (OPT_Wc_binding_type
,
5337 "Implicitly declared BIND(C) function %qs at "
5338 "%L may not be C interoperable", tmp_sym
->name
,
5339 &tmp_sym
->declared_at
);
5340 tmp_sym
->ts
.f90_type
= tmp_sym
->ts
.type
;
5341 /* Mark it as C interoperable to prevent duplicate warnings. */
5342 tmp_sym
->ts
.is_c_interop
= 1;
5343 tmp_sym
->attr
.is_c_interop
= 1;
5347 /* Here, we know we have the bind(c) attribute, so if we have
5348 enough type info, then verify that it's a C interop kind.
5349 The info could be in the symbol already, or possibly still in
5350 the given ts (current_ts), so look in both. */
5351 if (tmp_sym
->ts
.type
!= BT_UNKNOWN
|| ts
->type
!= BT_UNKNOWN
)
5353 if (!gfc_verify_c_interop (&(tmp_sym
->ts
)))
5355 /* See if we're dealing with a sym in a common block or not. */
5356 if (is_in_common
== 1 && warn_c_binding_type
)
5358 gfc_warning (OPT_Wc_binding_type
,
5359 "Variable %qs in common block %qs at %L "
5360 "may not be a C interoperable "
5361 "kind though common block %qs is BIND(C)",
5362 tmp_sym
->name
, com_block
->name
,
5363 &(tmp_sym
->declared_at
), com_block
->name
);
5367 if (tmp_sym
->ts
.type
== BT_DERIVED
|| ts
->type
== BT_DERIVED
)
5368 gfc_error ("Type declaration %qs at %L is not C "
5369 "interoperable but it is BIND(C)",
5370 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5371 else if (warn_c_binding_type
)
5372 gfc_warning (OPT_Wc_binding_type
, "Variable %qs at %L "
5373 "may not be a C interoperable "
5374 "kind but it is BIND(C)",
5375 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5379 /* Variables declared w/in a common block can't be bind(c)
5380 since there's no way for C to see these variables, so there's
5381 semantically no reason for the attribute. */
5382 if (is_in_common
== 1 && tmp_sym
->attr
.is_bind_c
== 1)
5384 gfc_error ("Variable %qs in common block %qs at "
5385 "%L cannot be declared with BIND(C) "
5386 "since it is not a global",
5387 tmp_sym
->name
, com_block
->name
,
5388 &(tmp_sym
->declared_at
));
5392 /* Scalar variables that are bind(c) can not have the pointer
5393 or allocatable attributes. */
5394 if (tmp_sym
->attr
.is_bind_c
== 1)
5396 if (tmp_sym
->attr
.pointer
== 1)
5398 gfc_error ("Variable %qs at %L cannot have both the "
5399 "POINTER and BIND(C) attributes",
5400 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5404 if (tmp_sym
->attr
.allocatable
== 1)
5406 gfc_error ("Variable %qs at %L cannot have both the "
5407 "ALLOCATABLE and BIND(C) attributes",
5408 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5414 /* If it is a BIND(C) function, make sure the return value is a
5415 scalar value. The previous tests in this function made sure
5416 the type is interoperable. */
5417 if (bind_c_function
&& tmp_sym
->as
!= NULL
)
5418 gfc_error ("Return type of BIND(C) function %qs at %L cannot "
5419 "be an array", tmp_sym
->name
, &(tmp_sym
->declared_at
));
5421 /* BIND(C) functions can not return a character string. */
5422 if (bind_c_function
&& tmp_sym
->ts
.type
== BT_CHARACTER
)
5423 if (tmp_sym
->ts
.u
.cl
== NULL
|| tmp_sym
->ts
.u
.cl
->length
== NULL
5424 || tmp_sym
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
5425 || mpz_cmp_si (tmp_sym
->ts
.u
.cl
->length
->value
.integer
, 1) != 0)
5426 gfc_error ("Return type of BIND(C) function %qs at %L cannot "
5427 "be a character string", tmp_sym
->name
,
5428 &(tmp_sym
->declared_at
));
5431 /* See if the symbol has been marked as private. If it has, make sure
5432 there is no binding label and warn the user if there is one. */
5433 if (tmp_sym
->attr
.access
== ACCESS_PRIVATE
5434 && tmp_sym
->binding_label
)
5435 /* Use gfc_warning_now because we won't say that the symbol fails
5436 just because of this. */
5437 gfc_warning_now (0, "Symbol %qs at %L is marked PRIVATE but has been "
5438 "given the binding label %qs", tmp_sym
->name
,
5439 &(tmp_sym
->declared_at
), tmp_sym
->binding_label
);
5445 /* Set the appropriate fields for a symbol that's been declared as
5446 BIND(C) (the is_bind_c flag and the binding label), and verify that
5447 the type is C interoperable. Errors are reported by the functions
5448 used to set/test these fields. */
5451 set_verify_bind_c_sym (gfc_symbol
*tmp_sym
, int num_idents
)
5455 /* TODO: Do we need to make sure the vars aren't marked private? */
5457 /* Set the is_bind_c bit in symbol_attribute. */
5458 gfc_add_is_bind_c (&(tmp_sym
->attr
), tmp_sym
->name
, &gfc_current_locus
, 0);
5460 if (!set_binding_label (&tmp_sym
->binding_label
, tmp_sym
->name
, num_idents
))
5467 /* Set the fields marking the given common block as BIND(C), including
5468 a binding label, and report any errors encountered. */
5471 set_verify_bind_c_com_block (gfc_common_head
*com_block
, int num_idents
)
5475 /* destLabel, common name, typespec (which may have binding label). */
5476 if (!set_binding_label (&com_block
->binding_label
, com_block
->name
,
5480 /* Set the given common block (com_block) to being bind(c) (1). */
5481 set_com_block_bind_c (com_block
, 1);
5487 /* Retrieve the list of one or more identifiers that the given bind(c)
5488 attribute applies to. */
5491 get_bind_c_idents (void)
5493 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5495 gfc_symbol
*tmp_sym
= NULL
;
5497 gfc_common_head
*com_block
= NULL
;
5499 if (gfc_match_name (name
) == MATCH_YES
)
5501 found_id
= MATCH_YES
;
5502 gfc_get_ha_symbol (name
, &tmp_sym
);
5504 else if (match_common_name (name
) == MATCH_YES
)
5506 found_id
= MATCH_YES
;
5507 com_block
= gfc_get_common (name
, 0);
5511 gfc_error ("Need either entity or common block name for "
5512 "attribute specification statement at %C");
5516 /* Save the current identifier and look for more. */
5519 /* Increment the number of identifiers found for this spec stmt. */
5522 /* Make sure we have a sym or com block, and verify that it can
5523 be bind(c). Set the appropriate field(s) and look for more
5525 if (tmp_sym
!= NULL
|| com_block
!= NULL
)
5527 if (tmp_sym
!= NULL
)
5529 if (!set_verify_bind_c_sym (tmp_sym
, num_idents
))
5534 if (!set_verify_bind_c_com_block (com_block
, num_idents
))
5538 /* Look to see if we have another identifier. */
5540 if (gfc_match_eos () == MATCH_YES
)
5541 found_id
= MATCH_NO
;
5542 else if (gfc_match_char (',') != MATCH_YES
)
5543 found_id
= MATCH_NO
;
5544 else if (gfc_match_name (name
) == MATCH_YES
)
5546 found_id
= MATCH_YES
;
5547 gfc_get_ha_symbol (name
, &tmp_sym
);
5549 else if (match_common_name (name
) == MATCH_YES
)
5551 found_id
= MATCH_YES
;
5552 com_block
= gfc_get_common (name
, 0);
5556 gfc_error ("Missing entity or common block name for "
5557 "attribute specification statement at %C");
5563 gfc_internal_error ("Missing symbol");
5565 } while (found_id
== MATCH_YES
);
5567 /* if we get here we were successful */
5572 /* Try and match a BIND(C) attribute specification statement. */
5575 gfc_match_bind_c_stmt (void)
5577 match found_match
= MATCH_NO
;
5582 /* This may not be necessary. */
5584 /* Clear the temporary binding label holder. */
5585 curr_binding_label
= NULL
;
5587 /* Look for the bind(c). */
5588 found_match
= gfc_match_bind_c (NULL
, true);
5590 if (found_match
== MATCH_YES
)
5592 if (!gfc_notify_std (GFC_STD_F2003
, "BIND(C) statement at %C"))
5595 /* Look for the :: now, but it is not required. */
5598 /* Get the identifier(s) that needs to be updated. This may need to
5599 change to hand the flag(s) for the attr specified so all identifiers
5600 found can have all appropriate parts updated (assuming that the same
5601 spec stmt can have multiple attrs, such as both bind(c) and
5603 if (!get_bind_c_idents ())
5604 /* Error message should have printed already. */
5612 /* Match a data declaration statement. */
5615 gfc_match_data_decl (void)
5621 type_param_spec_list
= NULL
;
5622 decl_type_param_list
= NULL
;
5624 num_idents_on_line
= 0;
5626 m
= gfc_match_decl_type_spec (¤t_ts
, 0);
5630 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
5631 && !gfc_comp_struct (gfc_current_state ()))
5633 sym
= gfc_use_derived (current_ts
.u
.derived
);
5641 current_ts
.u
.derived
= sym
;
5644 m
= match_attr_spec ();
5645 if (m
== MATCH_ERROR
)
5651 if (current_ts
.type
== BT_CLASS
5652 && current_ts
.u
.derived
->attr
.unlimited_polymorphic
)
5655 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
5656 && current_ts
.u
.derived
->components
== NULL
5657 && !current_ts
.u
.derived
->attr
.zero_comp
)
5660 if (current_attr
.pointer
&& gfc_comp_struct (gfc_current_state ()))
5663 if (current_attr
.allocatable
&& gfc_current_state () == COMP_DERIVED
5664 && current_ts
.u
.derived
== gfc_current_block ())
5667 gfc_find_symbol (current_ts
.u
.derived
->name
,
5668 current_ts
.u
.derived
->ns
, 1, &sym
);
5670 /* Any symbol that we find had better be a type definition
5671 which has its components defined, or be a structure definition
5672 actively being parsed. */
5673 if (sym
!= NULL
&& gfc_fl_struct (sym
->attr
.flavor
)
5674 && (current_ts
.u
.derived
->components
!= NULL
5675 || current_ts
.u
.derived
->attr
.zero_comp
5676 || current_ts
.u
.derived
== gfc_new_block
))
5679 gfc_error ("Derived type at %C has not been previously defined "
5680 "and so cannot appear in a derived type definition");
5686 /* If we have an old-style character declaration, and no new-style
5687 attribute specifications, then there a comma is optional between
5688 the type specification and the variable list. */
5689 if (m
== MATCH_NO
&& current_ts
.type
== BT_CHARACTER
&& old_char_selector
)
5690 gfc_match_char (',');
5692 /* Give the types/attributes to symbols that follow. Give the element
5693 a number so that repeat character length expressions can be copied. */
5697 num_idents_on_line
++;
5698 m
= variable_decl (elem
++);
5699 if (m
== MATCH_ERROR
)
5704 if (gfc_match_eos () == MATCH_YES
)
5706 if (gfc_match_char (',') != MATCH_YES
)
5710 if (!gfc_error_flag_test ())
5712 /* An anonymous structure declaration is unambiguous; if we matched one
5713 according to gfc_match_structure_decl, we need to return MATCH_YES
5714 here to avoid confusing the remaining matchers, even if there was an
5715 error during variable_decl. We must flush any such errors. Note this
5716 causes the parser to gracefully continue parsing the remaining input
5717 as a structure body, which likely follows. */
5718 if (current_ts
.type
== BT_DERIVED
&& current_ts
.u
.derived
5719 && gfc_fl_struct (current_ts
.u
.derived
->attr
.flavor
))
5721 gfc_error_now ("Syntax error in anonymous structure declaration"
5723 /* Skip the bad variable_decl and line up for the start of the
5725 gfc_error_recovery ();
5730 gfc_error ("Syntax error in data declaration at %C");
5735 gfc_free_data_all (gfc_current_ns
);
5738 if (saved_kind_expr
)
5739 gfc_free_expr (saved_kind_expr
);
5740 if (type_param_spec_list
)
5741 gfc_free_actual_arglist (type_param_spec_list
);
5742 if (decl_type_param_list
)
5743 gfc_free_actual_arglist (decl_type_param_list
);
5744 saved_kind_expr
= NULL
;
5745 gfc_free_array_spec (current_as
);
5751 /* Match a prefix associated with a function or subroutine
5752 declaration. If the typespec pointer is nonnull, then a typespec
5753 can be matched. Note that if nothing matches, MATCH_YES is
5754 returned (the null string was matched). */
5757 gfc_match_prefix (gfc_typespec
*ts
)
5763 gfc_clear_attr (¤t_attr
);
5765 seen_impure
= false;
5767 gcc_assert (!gfc_matching_prefix
);
5768 gfc_matching_prefix
= true;
5772 found_prefix
= false;
5774 /* MODULE is a prefix like PURE, ELEMENTAL, etc., having a
5775 corresponding attribute seems natural and distinguishes these
5776 procedures from procedure types of PROC_MODULE, which these are
5778 if (gfc_match ("module% ") == MATCH_YES
)
5780 if (!gfc_notify_std (GFC_STD_F2008
, "MODULE prefix at %C"))
5783 current_attr
.module_procedure
= 1;
5784 found_prefix
= true;
5787 if (!seen_type
&& ts
!= NULL
5788 && gfc_match_decl_type_spec (ts
, 0) == MATCH_YES
5789 && gfc_match_space () == MATCH_YES
)
5793 found_prefix
= true;
5796 if (gfc_match ("elemental% ") == MATCH_YES
)
5798 if (!gfc_add_elemental (¤t_attr
, NULL
))
5801 found_prefix
= true;
5804 if (gfc_match ("pure% ") == MATCH_YES
)
5806 if (!gfc_add_pure (¤t_attr
, NULL
))
5809 found_prefix
= true;
5812 if (gfc_match ("recursive% ") == MATCH_YES
)
5814 if (!gfc_add_recursive (¤t_attr
, NULL
))
5817 found_prefix
= true;
5820 /* IMPURE is a somewhat special case, as it needs not set an actual
5821 attribute but rather only prevents ELEMENTAL routines from being
5822 automatically PURE. */
5823 if (gfc_match ("impure% ") == MATCH_YES
)
5825 if (!gfc_notify_std (GFC_STD_F2008
, "IMPURE procedure at %C"))
5829 found_prefix
= true;
5832 while (found_prefix
);
5834 /* IMPURE and PURE must not both appear, of course. */
5835 if (seen_impure
&& current_attr
.pure
)
5837 gfc_error ("PURE and IMPURE must not appear both at %C");
5841 /* If IMPURE it not seen but the procedure is ELEMENTAL, mark it as PURE. */
5842 if (!seen_impure
&& current_attr
.elemental
&& !current_attr
.pure
)
5844 if (!gfc_add_pure (¤t_attr
, NULL
))
5848 /* At this point, the next item is not a prefix. */
5849 gcc_assert (gfc_matching_prefix
);
5851 gfc_matching_prefix
= false;
5855 gcc_assert (gfc_matching_prefix
);
5856 gfc_matching_prefix
= false;
5861 /* Copy attributes matched by gfc_match_prefix() to attributes on a symbol. */
5864 copy_prefix (symbol_attribute
*dest
, locus
*where
)
5866 if (dest
->module_procedure
)
5868 if (current_attr
.elemental
)
5869 dest
->elemental
= 1;
5871 if (current_attr
.pure
)
5874 if (current_attr
.recursive
)
5875 dest
->recursive
= 1;
5877 /* Module procedures are unusual in that the 'dest' is copied from
5878 the interface declaration. However, this is an oportunity to
5879 check that the submodule declaration is compliant with the
5881 if (dest
->elemental
&& !current_attr
.elemental
)
5883 gfc_error ("ELEMENTAL prefix in MODULE PROCEDURE interface is "
5884 "missing at %L", where
);
5888 if (dest
->pure
&& !current_attr
.pure
)
5890 gfc_error ("PURE prefix in MODULE PROCEDURE interface is "
5891 "missing at %L", where
);
5895 if (dest
->recursive
&& !current_attr
.recursive
)
5897 gfc_error ("RECURSIVE prefix in MODULE PROCEDURE interface is "
5898 "missing at %L", where
);
5905 if (current_attr
.elemental
&& !gfc_add_elemental (dest
, where
))
5908 if (current_attr
.pure
&& !gfc_add_pure (dest
, where
))
5911 if (current_attr
.recursive
&& !gfc_add_recursive (dest
, where
))
5918 /* Match a formal argument list or, if typeparam is true, a
5919 type_param_name_list. */
5922 gfc_match_formal_arglist (gfc_symbol
*progname
, int st_flag
,
5923 int null_flag
, bool typeparam
)
5925 gfc_formal_arglist
*head
, *tail
, *p
, *q
;
5926 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5929 gfc_formal_arglist
*formal
= NULL
;
5933 /* Keep the interface formal argument list and null it so that the
5934 matching for the new declaration can be done. The numbers and
5935 names of the arguments are checked here. The interface formal
5936 arguments are retained in formal_arglist and the characteristics
5937 are compared in resolve.c(resolve_fl_procedure). See the remark
5938 in get_proc_name about the eventual need to copy the formal_arglist
5939 and populate the formal namespace of the interface symbol. */
5940 if (progname
->attr
.module_procedure
5941 && progname
->attr
.host_assoc
)
5943 formal
= progname
->formal
;
5944 progname
->formal
= NULL
;
5947 if (gfc_match_char ('(') != MATCH_YES
)
5954 if (gfc_match_char (')') == MATCH_YES
)
5959 if (gfc_match_char ('*') == MATCH_YES
)
5962 if (!typeparam
&& !gfc_notify_std (GFC_STD_F95_OBS
,
5963 "Alternate-return argument at %C"))
5969 gfc_error_now ("A parameter name is required at %C");
5973 m
= gfc_match_name (name
);
5977 gfc_error_now ("A parameter name is required at %C");
5981 if (!typeparam
&& gfc_get_symbol (name
, NULL
, &sym
))
5984 && gfc_get_symbol (name
, progname
->f2k_derived
, &sym
))
5988 p
= gfc_get_formal_arglist ();
6000 /* We don't add the VARIABLE flavor because the name could be a
6001 dummy procedure. We don't apply these attributes to formal
6002 arguments of statement functions. */
6003 if (sym
!= NULL
&& !st_flag
6004 && (!gfc_add_dummy(&sym
->attr
, sym
->name
, NULL
)
6005 || !gfc_missing_attr (&sym
->attr
, NULL
)))
6011 /* The name of a program unit can be in a different namespace,
6012 so check for it explicitly. After the statement is accepted,
6013 the name is checked for especially in gfc_get_symbol(). */
6014 if (gfc_new_block
!= NULL
&& sym
!= NULL
&& !typeparam
6015 && strcmp (sym
->name
, gfc_new_block
->name
) == 0)
6017 gfc_error ("Name %qs at %C is the name of the procedure",
6023 if (gfc_match_char (')') == MATCH_YES
)
6026 m
= gfc_match_char (',');
6030 gfc_error_now ("Expected parameter list in type declaration "
6033 gfc_error ("Unexpected junk in formal argument list at %C");
6039 /* Check for duplicate symbols in the formal argument list. */
6042 for (p
= head
; p
->next
; p
= p
->next
)
6047 for (q
= p
->next
; q
; q
= q
->next
)
6048 if (p
->sym
== q
->sym
)
6051 gfc_error_now ("Duplicate name %qs in parameter "
6052 "list at %C", p
->sym
->name
);
6054 gfc_error ("Duplicate symbol %qs in formal argument "
6055 "list at %C", p
->sym
->name
);
6063 if (!gfc_add_explicit_interface (progname
, IFSRC_DECL
, head
, NULL
))
6069 /* gfc_error_now used in following and return with MATCH_YES because
6070 doing otherwise results in a cascade of extraneous errors and in
6071 some cases an ICE in symbol.c(gfc_release_symbol). */
6072 if (progname
->attr
.module_procedure
&& progname
->attr
.host_assoc
)
6074 bool arg_count_mismatch
= false;
6076 if (!formal
&& head
)
6077 arg_count_mismatch
= true;
6079 /* Abbreviated module procedure declaration is not meant to have any
6080 formal arguments! */
6081 if (!progname
->abr_modproc_decl
&& formal
&& !head
)
6082 arg_count_mismatch
= true;
6084 for (p
= formal
, q
= head
; p
&& q
; p
= p
->next
, q
= q
->next
)
6086 if ((p
->next
!= NULL
&& q
->next
== NULL
)
6087 || (p
->next
== NULL
&& q
->next
!= NULL
))
6088 arg_count_mismatch
= true;
6089 else if ((p
->sym
== NULL
&& q
->sym
== NULL
)
6090 || strcmp (p
->sym
->name
, q
->sym
->name
) == 0)
6093 gfc_error_now ("Mismatch in MODULE PROCEDURE formal "
6094 "argument names (%s/%s) at %C",
6095 p
->sym
->name
, q
->sym
->name
);
6098 if (arg_count_mismatch
)
6099 gfc_error_now ("Mismatch in number of MODULE PROCEDURE "
6100 "formal arguments at %C");
6106 gfc_free_formal_arglist (head
);
6111 /* Match a RESULT specification following a function declaration or
6112 ENTRY statement. Also matches the end-of-statement. */
6115 match_result (gfc_symbol
*function
, gfc_symbol
**result
)
6117 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6121 if (gfc_match (" result (") != MATCH_YES
)
6124 m
= gfc_match_name (name
);
6128 /* Get the right paren, and that's it because there could be the
6129 bind(c) attribute after the result clause. */
6130 if (gfc_match_char (')') != MATCH_YES
)
6132 /* TODO: should report the missing right paren here. */
6136 if (strcmp (function
->name
, name
) == 0)
6138 gfc_error ("RESULT variable at %C must be different than function name");
6142 if (gfc_get_symbol (name
, NULL
, &r
))
6145 if (!gfc_add_result (&r
->attr
, r
->name
, NULL
))
6154 /* Match a function suffix, which could be a combination of a result
6155 clause and BIND(C), either one, or neither. The draft does not
6156 require them to come in a specific order. */
6159 gfc_match_suffix (gfc_symbol
*sym
, gfc_symbol
**result
)
6161 match is_bind_c
; /* Found bind(c). */
6162 match is_result
; /* Found result clause. */
6163 match found_match
; /* Status of whether we've found a good match. */
6164 char peek_char
; /* Character we're going to peek at. */
6165 bool allow_binding_name
;
6167 /* Initialize to having found nothing. */
6168 found_match
= MATCH_NO
;
6169 is_bind_c
= MATCH_NO
;
6170 is_result
= MATCH_NO
;
6172 /* Get the next char to narrow between result and bind(c). */
6173 gfc_gobble_whitespace ();
6174 peek_char
= gfc_peek_ascii_char ();
6176 /* C binding names are not allowed for internal procedures. */
6177 if (gfc_current_state () == COMP_CONTAINS
6178 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
6179 allow_binding_name
= false;
6181 allow_binding_name
= true;
6186 /* Look for result clause. */
6187 is_result
= match_result (sym
, result
);
6188 if (is_result
== MATCH_YES
)
6190 /* Now see if there is a bind(c) after it. */
6191 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
6192 /* We've found the result clause and possibly bind(c). */
6193 found_match
= MATCH_YES
;
6196 /* This should only be MATCH_ERROR. */
6197 found_match
= is_result
;
6200 /* Look for bind(c) first. */
6201 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
6202 if (is_bind_c
== MATCH_YES
)
6204 /* Now see if a result clause followed it. */
6205 is_result
= match_result (sym
, result
);
6206 found_match
= MATCH_YES
;
6210 /* Should only be a MATCH_ERROR if we get here after seeing 'b'. */
6211 found_match
= MATCH_ERROR
;
6215 gfc_error ("Unexpected junk after function declaration at %C");
6216 found_match
= MATCH_ERROR
;
6220 if (is_bind_c
== MATCH_YES
)
6222 /* Fortran 2008 draft allows BIND(C) for internal procedures. */
6223 if (gfc_current_state () == COMP_CONTAINS
6224 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
6225 && !gfc_notify_std (GFC_STD_F2008
, "BIND(C) attribute "
6226 "at %L may not be specified for an internal "
6227 "procedure", &gfc_current_locus
))
6230 if (!gfc_add_is_bind_c (&(sym
->attr
), sym
->name
, &gfc_current_locus
, 1))
6238 /* Procedure pointer return value without RESULT statement:
6239 Add "hidden" result variable named "ppr@". */
6242 add_hidden_procptr_result (gfc_symbol
*sym
)
6246 if (gfc_notification_std (GFC_STD_F2003
) == ERROR
)
6249 /* First usage case: PROCEDURE and EXTERNAL statements. */
6250 case1
= gfc_current_state () == COMP_FUNCTION
&& gfc_current_block ()
6251 && strcmp (gfc_current_block ()->name
, sym
->name
) == 0
6252 && sym
->attr
.external
;
6253 /* Second usage case: INTERFACE statements. */
6254 case2
= gfc_current_state () == COMP_INTERFACE
&& gfc_state_stack
->previous
6255 && gfc_state_stack
->previous
->state
== COMP_FUNCTION
6256 && strcmp (gfc_state_stack
->previous
->sym
->name
, sym
->name
) == 0;
6262 gfc_get_sym_tree ("ppr@", gfc_current_ns
, &stree
, false);
6266 gfc_get_sym_tree ("ppr@", gfc_current_ns
->parent
, &stree
, false);
6267 st2
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "ppr@");
6268 st2
->n
.sym
= stree
->n
.sym
;
6269 stree
->n
.sym
->refs
++;
6271 sym
->result
= stree
->n
.sym
;
6273 sym
->result
->attr
.proc_pointer
= sym
->attr
.proc_pointer
;
6274 sym
->result
->attr
.pointer
= sym
->attr
.pointer
;
6275 sym
->result
->attr
.external
= sym
->attr
.external
;
6276 sym
->result
->attr
.referenced
= sym
->attr
.referenced
;
6277 sym
->result
->ts
= sym
->ts
;
6278 sym
->attr
.proc_pointer
= 0;
6279 sym
->attr
.pointer
= 0;
6280 sym
->attr
.external
= 0;
6281 if (sym
->result
->attr
.external
&& sym
->result
->attr
.pointer
)
6283 sym
->result
->attr
.pointer
= 0;
6284 sym
->result
->attr
.proc_pointer
= 1;
6287 return gfc_add_result (&sym
->result
->attr
, sym
->result
->name
, NULL
);
6289 /* POINTER after PROCEDURE/EXTERNAL/INTERFACE statement. */
6290 else if (sym
->attr
.function
&& !sym
->attr
.external
&& sym
->attr
.pointer
6291 && sym
->result
&& sym
->result
!= sym
&& sym
->result
->attr
.external
6292 && sym
== gfc_current_ns
->proc_name
6293 && sym
== sym
->result
->ns
->proc_name
6294 && strcmp ("ppr@", sym
->result
->name
) == 0)
6296 sym
->result
->attr
.proc_pointer
= 1;
6297 sym
->attr
.pointer
= 0;
6305 /* Match the interface for a PROCEDURE declaration,
6306 including brackets (R1212). */
6309 match_procedure_interface (gfc_symbol
**proc_if
)
6313 locus old_loc
, entry_loc
;
6314 gfc_namespace
*old_ns
= gfc_current_ns
;
6315 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6317 old_loc
= entry_loc
= gfc_current_locus
;
6318 gfc_clear_ts (¤t_ts
);
6320 if (gfc_match (" (") != MATCH_YES
)
6322 gfc_current_locus
= entry_loc
;
6326 /* Get the type spec. for the procedure interface. */
6327 old_loc
= gfc_current_locus
;
6328 m
= gfc_match_decl_type_spec (¤t_ts
, 0);
6329 gfc_gobble_whitespace ();
6330 if (m
== MATCH_YES
|| (m
== MATCH_NO
&& gfc_peek_ascii_char () == ')'))
6333 if (m
== MATCH_ERROR
)
6336 /* Procedure interface is itself a procedure. */
6337 gfc_current_locus
= old_loc
;
6338 m
= gfc_match_name (name
);
6340 /* First look to see if it is already accessible in the current
6341 namespace because it is use associated or contained. */
6343 if (gfc_find_sym_tree (name
, NULL
, 0, &st
))
6346 /* If it is still not found, then try the parent namespace, if it
6347 exists and create the symbol there if it is still not found. */
6348 if (gfc_current_ns
->parent
)
6349 gfc_current_ns
= gfc_current_ns
->parent
;
6350 if (st
== NULL
&& gfc_get_ha_sym_tree (name
, &st
))
6353 gfc_current_ns
= old_ns
;
6354 *proc_if
= st
->n
.sym
;
6359 /* Resolve interface if possible. That way, attr.procedure is only set
6360 if it is declared by a later procedure-declaration-stmt, which is
6361 invalid per F08:C1216 (cf. resolve_procedure_interface). */
6362 while ((*proc_if
)->ts
.interface
6363 && *proc_if
!= (*proc_if
)->ts
.interface
)
6364 *proc_if
= (*proc_if
)->ts
.interface
;
6366 if ((*proc_if
)->attr
.flavor
== FL_UNKNOWN
6367 && (*proc_if
)->ts
.type
== BT_UNKNOWN
6368 && !gfc_add_flavor (&(*proc_if
)->attr
, FL_PROCEDURE
,
6369 (*proc_if
)->name
, NULL
))
6374 if (gfc_match (" )") != MATCH_YES
)
6376 gfc_current_locus
= entry_loc
;
6384 /* Match a PROCEDURE declaration (R1211). */
6387 match_procedure_decl (void)
6390 gfc_symbol
*sym
, *proc_if
= NULL
;
6392 gfc_expr
*initializer
= NULL
;
6394 /* Parse interface (with brackets). */
6395 m
= match_procedure_interface (&proc_if
);
6399 /* Parse attributes (with colons). */
6400 m
= match_attr_spec();
6401 if (m
== MATCH_ERROR
)
6404 if (proc_if
&& proc_if
->attr
.is_bind_c
&& !current_attr
.is_bind_c
)
6406 current_attr
.is_bind_c
= 1;
6407 has_name_equals
= 0;
6408 curr_binding_label
= NULL
;
6411 /* Get procedure symbols. */
6414 m
= gfc_match_symbol (&sym
, 0);
6417 else if (m
== MATCH_ERROR
)
6420 /* Add current_attr to the symbol attributes. */
6421 if (!gfc_copy_attr (&sym
->attr
, ¤t_attr
, NULL
))
6424 if (sym
->attr
.is_bind_c
)
6426 /* Check for C1218. */
6427 if (!proc_if
|| !proc_if
->attr
.is_bind_c
)
6429 gfc_error ("BIND(C) attribute at %C requires "
6430 "an interface with BIND(C)");
6433 /* Check for C1217. */
6434 if (has_name_equals
&& sym
->attr
.pointer
)
6436 gfc_error ("BIND(C) procedure with NAME may not have "
6437 "POINTER attribute at %C");
6440 if (has_name_equals
&& sym
->attr
.dummy
)
6442 gfc_error ("Dummy procedure at %C may not have "
6443 "BIND(C) attribute with NAME");
6446 /* Set binding label for BIND(C). */
6447 if (!set_binding_label (&sym
->binding_label
, sym
->name
, num
))
6451 if (!gfc_add_external (&sym
->attr
, NULL
))
6454 if (add_hidden_procptr_result (sym
))
6457 if (!gfc_add_proc (&sym
->attr
, sym
->name
, NULL
))
6460 /* Set interface. */
6461 if (proc_if
!= NULL
)
6463 if (sym
->ts
.type
!= BT_UNKNOWN
)
6465 gfc_error ("Procedure %qs at %L already has basic type of %s",
6466 sym
->name
, &gfc_current_locus
,
6467 gfc_basic_typename (sym
->ts
.type
));
6470 sym
->ts
.interface
= proc_if
;
6471 sym
->attr
.untyped
= 1;
6472 sym
->attr
.if_source
= IFSRC_IFBODY
;
6474 else if (current_ts
.type
!= BT_UNKNOWN
)
6476 if (!gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
6478 sym
->ts
.interface
= gfc_new_symbol ("", gfc_current_ns
);
6479 sym
->ts
.interface
->ts
= current_ts
;
6480 sym
->ts
.interface
->attr
.flavor
= FL_PROCEDURE
;
6481 sym
->ts
.interface
->attr
.function
= 1;
6482 sym
->attr
.function
= 1;
6483 sym
->attr
.if_source
= IFSRC_UNKNOWN
;
6486 if (gfc_match (" =>") == MATCH_YES
)
6488 if (!current_attr
.pointer
)
6490 gfc_error ("Initialization at %C isn't for a pointer variable");
6495 m
= match_pointer_init (&initializer
, 1);
6499 if (!add_init_expr_to_sym (sym
->name
, &initializer
, &gfc_current_locus
))
6504 if (gfc_match_eos () == MATCH_YES
)
6506 if (gfc_match_char (',') != MATCH_YES
)
6511 gfc_error ("Syntax error in PROCEDURE statement at %C");
6515 /* Free stuff up and return. */
6516 gfc_free_expr (initializer
);
6522 match_binding_attributes (gfc_typebound_proc
* ba
, bool generic
, bool ppc
);
6525 /* Match a procedure pointer component declaration (R445). */
6528 match_ppc_decl (void)
6531 gfc_symbol
*proc_if
= NULL
;
6535 gfc_expr
*initializer
= NULL
;
6536 gfc_typebound_proc
* tb
;
6537 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6539 /* Parse interface (with brackets). */
6540 m
= match_procedure_interface (&proc_if
);
6544 /* Parse attributes. */
6545 tb
= XCNEW (gfc_typebound_proc
);
6546 tb
->where
= gfc_current_locus
;
6547 m
= match_binding_attributes (tb
, false, true);
6548 if (m
== MATCH_ERROR
)
6551 gfc_clear_attr (¤t_attr
);
6552 current_attr
.procedure
= 1;
6553 current_attr
.proc_pointer
= 1;
6554 current_attr
.access
= tb
->access
;
6555 current_attr
.flavor
= FL_PROCEDURE
;
6557 /* Match the colons (required). */
6558 if (gfc_match (" ::") != MATCH_YES
)
6560 gfc_error ("Expected %<::%> after binding-attributes at %C");
6564 /* Check for C450. */
6565 if (!tb
->nopass
&& proc_if
== NULL
)
6567 gfc_error("NOPASS or explicit interface required at %C");
6571 if (!gfc_notify_std (GFC_STD_F2003
, "Procedure pointer component at %C"))
6574 /* Match PPC names. */
6578 m
= gfc_match_name (name
);
6581 else if (m
== MATCH_ERROR
)
6584 if (!gfc_add_component (gfc_current_block(), name
, &c
))
6587 /* Add current_attr to the symbol attributes. */
6588 if (!gfc_copy_attr (&c
->attr
, ¤t_attr
, NULL
))
6591 if (!gfc_add_external (&c
->attr
, NULL
))
6594 if (!gfc_add_proc (&c
->attr
, name
, NULL
))
6601 c
->tb
= XCNEW (gfc_typebound_proc
);
6602 c
->tb
->where
= gfc_current_locus
;
6606 /* Set interface. */
6607 if (proc_if
!= NULL
)
6609 c
->ts
.interface
= proc_if
;
6610 c
->attr
.untyped
= 1;
6611 c
->attr
.if_source
= IFSRC_IFBODY
;
6613 else if (ts
.type
!= BT_UNKNOWN
)
6616 c
->ts
.interface
= gfc_new_symbol ("", gfc_current_ns
);
6617 c
->ts
.interface
->result
= c
->ts
.interface
;
6618 c
->ts
.interface
->ts
= ts
;
6619 c
->ts
.interface
->attr
.flavor
= FL_PROCEDURE
;
6620 c
->ts
.interface
->attr
.function
= 1;
6621 c
->attr
.function
= 1;
6622 c
->attr
.if_source
= IFSRC_UNKNOWN
;
6625 if (gfc_match (" =>") == MATCH_YES
)
6627 m
= match_pointer_init (&initializer
, 1);
6630 gfc_free_expr (initializer
);
6633 c
->initializer
= initializer
;
6636 if (gfc_match_eos () == MATCH_YES
)
6638 if (gfc_match_char (',') != MATCH_YES
)
6643 gfc_error ("Syntax error in procedure pointer component at %C");
6648 /* Match a PROCEDURE declaration inside an interface (R1206). */
6651 match_procedure_in_interface (void)
6655 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6658 if (current_interface
.type
== INTERFACE_NAMELESS
6659 || current_interface
.type
== INTERFACE_ABSTRACT
)
6661 gfc_error ("PROCEDURE at %C must be in a generic interface");
6665 /* Check if the F2008 optional double colon appears. */
6666 gfc_gobble_whitespace ();
6667 old_locus
= gfc_current_locus
;
6668 if (gfc_match ("::") == MATCH_YES
)
6670 if (!gfc_notify_std (GFC_STD_F2008
, "double colon in "
6671 "MODULE PROCEDURE statement at %L", &old_locus
))
6675 gfc_current_locus
= old_locus
;
6679 m
= gfc_match_name (name
);
6682 else if (m
== MATCH_ERROR
)
6684 if (gfc_get_symbol (name
, gfc_current_ns
->parent
, &sym
))
6687 if (!gfc_add_interface (sym
))
6690 if (gfc_match_eos () == MATCH_YES
)
6692 if (gfc_match_char (',') != MATCH_YES
)
6699 gfc_error ("Syntax error in PROCEDURE statement at %C");
6704 /* General matcher for PROCEDURE declarations. */
6706 static match
match_procedure_in_type (void);
6709 gfc_match_procedure (void)
6713 switch (gfc_current_state ())
6718 case COMP_SUBMODULE
:
6719 case COMP_SUBROUTINE
:
6722 m
= match_procedure_decl ();
6724 case COMP_INTERFACE
:
6725 m
= match_procedure_in_interface ();
6728 m
= match_ppc_decl ();
6730 case COMP_DERIVED_CONTAINS
:
6731 m
= match_procedure_in_type ();
6740 if (!gfc_notify_std (GFC_STD_F2003
, "PROCEDURE statement at %C"))
6747 /* Warn if a matched procedure has the same name as an intrinsic; this is
6748 simply a wrapper around gfc_warn_intrinsic_shadow that interprets the current
6749 parser-state-stack to find out whether we're in a module. */
6752 do_warn_intrinsic_shadow (const gfc_symbol
* sym
, bool func
)
6756 in_module
= (gfc_state_stack
->previous
6757 && (gfc_state_stack
->previous
->state
== COMP_MODULE
6758 || gfc_state_stack
->previous
->state
== COMP_SUBMODULE
));
6760 gfc_warn_intrinsic_shadow (sym
, in_module
, func
);
6764 /* Match a function declaration. */
6767 gfc_match_function_decl (void)
6769 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6770 gfc_symbol
*sym
, *result
;
6774 match found_match
; /* Status returned by match func. */
6776 if (gfc_current_state () != COMP_NONE
6777 && gfc_current_state () != COMP_INTERFACE
6778 && gfc_current_state () != COMP_CONTAINS
)
6781 gfc_clear_ts (¤t_ts
);
6783 old_loc
= gfc_current_locus
;
6785 m
= gfc_match_prefix (¤t_ts
);
6788 gfc_current_locus
= old_loc
;
6792 if (gfc_match ("function% %n", name
) != MATCH_YES
)
6794 gfc_current_locus
= old_loc
;
6798 if (get_proc_name (name
, &sym
, false))
6801 if (add_hidden_procptr_result (sym
))
6804 if (current_attr
.module_procedure
)
6805 sym
->attr
.module_procedure
= 1;
6807 gfc_new_block
= sym
;
6809 m
= gfc_match_formal_arglist (sym
, 0, 0);
6812 gfc_error ("Expected formal argument list in function "
6813 "definition at %C");
6817 else if (m
== MATCH_ERROR
)
6822 /* According to the draft, the bind(c) and result clause can
6823 come in either order after the formal_arg_list (i.e., either
6824 can be first, both can exist together or by themselves or neither
6825 one). Therefore, the match_result can't match the end of the
6826 string, and check for the bind(c) or result clause in either order. */
6827 found_match
= gfc_match_eos ();
6829 /* Make sure that it isn't already declared as BIND(C). If it is, it
6830 must have been marked BIND(C) with a BIND(C) attribute and that is
6831 not allowed for procedures. */
6832 if (sym
->attr
.is_bind_c
== 1)
6834 sym
->attr
.is_bind_c
= 0;
6835 if (sym
->old_symbol
!= NULL
)
6836 gfc_error_now ("BIND(C) attribute at %L can only be used for "
6837 "variables or common blocks",
6838 &(sym
->old_symbol
->declared_at
));
6840 gfc_error_now ("BIND(C) attribute at %L can only be used for "
6841 "variables or common blocks", &gfc_current_locus
);
6844 if (found_match
!= MATCH_YES
)
6846 /* If we haven't found the end-of-statement, look for a suffix. */
6847 suffix_match
= gfc_match_suffix (sym
, &result
);
6848 if (suffix_match
== MATCH_YES
)
6849 /* Need to get the eos now. */
6850 found_match
= gfc_match_eos ();
6852 found_match
= suffix_match
;
6855 if(found_match
!= MATCH_YES
)
6859 /* Make changes to the symbol. */
6862 if (!gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
6865 if (!gfc_missing_attr (&sym
->attr
, NULL
))
6868 if (!copy_prefix (&sym
->attr
, &sym
->declared_at
))
6870 if(!sym
->attr
.module_procedure
)
6876 /* Delay matching the function characteristics until after the
6877 specification block by signalling kind=-1. */
6878 sym
->declared_at
= old_loc
;
6879 if (current_ts
.type
!= BT_UNKNOWN
)
6880 current_ts
.kind
= -1;
6882 current_ts
.kind
= 0;
6886 if (current_ts
.type
!= BT_UNKNOWN
6887 && !gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
6893 if (current_ts
.type
!= BT_UNKNOWN
6894 && !gfc_add_type (result
, ¤t_ts
, &gfc_current_locus
))
6896 sym
->result
= result
;
6899 /* Warn if this procedure has the same name as an intrinsic. */
6900 do_warn_intrinsic_shadow (sym
, true);
6906 gfc_current_locus
= old_loc
;
6911 /* This is mostly a copy of parse.c(add_global_procedure) but modified to
6912 pass the name of the entry, rather than the gfc_current_block name, and
6913 to return false upon finding an existing global entry. */
6916 add_global_entry (const char *name
, const char *binding_label
, bool sub
,
6920 enum gfc_symbol_type type
;
6922 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
6924 /* Only in Fortran 2003: For procedures with a binding label also the Fortran
6925 name is a global identifier. */
6926 if (!binding_label
|| gfc_notification_std (GFC_STD_F2008
))
6928 s
= gfc_get_gsymbol (name
);
6930 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= type
))
6932 gfc_global_used (s
, where
);
6941 s
->ns
= gfc_current_ns
;
6945 /* Don't add the symbol multiple times. */
6947 && (!gfc_notification_std (GFC_STD_F2008
)
6948 || strcmp (name
, binding_label
) != 0))
6950 s
= gfc_get_gsymbol (binding_label
);
6952 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= type
))
6954 gfc_global_used (s
, where
);
6961 s
->binding_label
= binding_label
;
6964 s
->ns
= gfc_current_ns
;
6972 /* Match an ENTRY statement. */
6975 gfc_match_entry (void)
6980 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6981 gfc_compile_state state
;
6985 bool module_procedure
;
6989 m
= gfc_match_name (name
);
6993 if (!gfc_notify_std (GFC_STD_F2008_OBS
, "ENTRY statement at %C"))
6996 state
= gfc_current_state ();
6997 if (state
!= COMP_SUBROUTINE
&& state
!= COMP_FUNCTION
)
7002 gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
7005 gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
7007 case COMP_SUBMODULE
:
7008 gfc_error ("ENTRY statement at %C cannot appear within a SUBMODULE");
7010 case COMP_BLOCK_DATA
:
7011 gfc_error ("ENTRY statement at %C cannot appear within "
7014 case COMP_INTERFACE
:
7015 gfc_error ("ENTRY statement at %C cannot appear within "
7018 case COMP_STRUCTURE
:
7019 gfc_error ("ENTRY statement at %C cannot appear within "
7020 "a STRUCTURE block");
7023 gfc_error ("ENTRY statement at %C cannot appear within "
7024 "a DERIVED TYPE block");
7027 gfc_error ("ENTRY statement at %C cannot appear within "
7028 "an IF-THEN block");
7031 case COMP_DO_CONCURRENT
:
7032 gfc_error ("ENTRY statement at %C cannot appear within "
7036 gfc_error ("ENTRY statement at %C cannot appear within "
7040 gfc_error ("ENTRY statement at %C cannot appear within "
7044 gfc_error ("ENTRY statement at %C cannot appear within "
7048 gfc_error ("ENTRY statement at %C cannot appear within "
7049 "a contained subprogram");
7052 gfc_error ("Unexpected ENTRY statement at %C");
7057 if ((state
== COMP_SUBROUTINE
|| state
== COMP_FUNCTION
)
7058 && gfc_state_stack
->previous
->state
== COMP_INTERFACE
)
7060 gfc_error ("ENTRY statement at %C cannot appear within an INTERFACE");
7064 module_procedure
= gfc_current_ns
->parent
!= NULL
7065 && gfc_current_ns
->parent
->proc_name
7066 && gfc_current_ns
->parent
->proc_name
->attr
.flavor
7069 if (gfc_current_ns
->parent
!= NULL
7070 && gfc_current_ns
->parent
->proc_name
7071 && !module_procedure
)
7073 gfc_error("ENTRY statement at %C cannot appear in a "
7074 "contained procedure");
7078 /* Module function entries need special care in get_proc_name
7079 because previous references within the function will have
7080 created symbols attached to the current namespace. */
7081 if (get_proc_name (name
, &entry
,
7082 gfc_current_ns
->parent
!= NULL
7083 && module_procedure
))
7086 proc
= gfc_current_block ();
7088 /* Make sure that it isn't already declared as BIND(C). If it is, it
7089 must have been marked BIND(C) with a BIND(C) attribute and that is
7090 not allowed for procedures. */
7091 if (entry
->attr
.is_bind_c
== 1)
7093 entry
->attr
.is_bind_c
= 0;
7094 if (entry
->old_symbol
!= NULL
)
7095 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7096 "variables or common blocks",
7097 &(entry
->old_symbol
->declared_at
));
7099 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7100 "variables or common blocks", &gfc_current_locus
);
7103 /* Check what next non-whitespace character is so we can tell if there
7104 is the required parens if we have a BIND(C). */
7105 old_loc
= gfc_current_locus
;
7106 gfc_gobble_whitespace ();
7107 peek_char
= gfc_peek_ascii_char ();
7109 if (state
== COMP_SUBROUTINE
)
7111 m
= gfc_match_formal_arglist (entry
, 0, 1);
7115 /* Call gfc_match_bind_c with allow_binding_name = true as ENTRY can
7116 never be an internal procedure. */
7117 is_bind_c
= gfc_match_bind_c (entry
, true);
7118 if (is_bind_c
== MATCH_ERROR
)
7120 if (is_bind_c
== MATCH_YES
)
7122 if (peek_char
!= '(')
7124 gfc_error ("Missing required parentheses before BIND(C) at %C");
7127 if (!gfc_add_is_bind_c (&(entry
->attr
), entry
->name
,
7128 &(entry
->declared_at
), 1))
7132 if (!gfc_current_ns
->parent
7133 && !add_global_entry (name
, entry
->binding_label
, true,
7137 /* An entry in a subroutine. */
7138 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
7139 || !gfc_add_subroutine (&entry
->attr
, entry
->name
, NULL
))
7144 /* An entry in a function.
7145 We need to take special care because writing
7150 ENTRY f() RESULT (r)
7152 ENTRY f RESULT (r). */
7153 if (gfc_match_eos () == MATCH_YES
)
7155 gfc_current_locus
= old_loc
;
7156 /* Match the empty argument list, and add the interface to
7158 m
= gfc_match_formal_arglist (entry
, 0, 1);
7161 m
= gfc_match_formal_arglist (entry
, 0, 0);
7168 if (gfc_match_eos () == MATCH_YES
)
7170 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
7171 || !gfc_add_function (&entry
->attr
, entry
->name
, NULL
))
7174 entry
->result
= entry
;
7178 m
= gfc_match_suffix (entry
, &result
);
7180 gfc_syntax_error (ST_ENTRY
);
7186 if (!gfc_add_result (&result
->attr
, result
->name
, NULL
)
7187 || !gfc_add_entry (&entry
->attr
, result
->name
, NULL
)
7188 || !gfc_add_function (&entry
->attr
, result
->name
, NULL
))
7190 entry
->result
= result
;
7194 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
7195 || !gfc_add_function (&entry
->attr
, entry
->name
, NULL
))
7197 entry
->result
= entry
;
7201 if (!gfc_current_ns
->parent
7202 && !add_global_entry (name
, entry
->binding_label
, false,
7207 if (gfc_match_eos () != MATCH_YES
)
7209 gfc_syntax_error (ST_ENTRY
);
7213 entry
->attr
.recursive
= proc
->attr
.recursive
;
7214 entry
->attr
.elemental
= proc
->attr
.elemental
;
7215 entry
->attr
.pure
= proc
->attr
.pure
;
7217 el
= gfc_get_entry_list ();
7219 el
->next
= gfc_current_ns
->entries
;
7220 gfc_current_ns
->entries
= el
;
7222 el
->id
= el
->next
->id
+ 1;
7226 new_st
.op
= EXEC_ENTRY
;
7227 new_st
.ext
.entry
= el
;
7233 /* Match a subroutine statement, including optional prefixes. */
7236 gfc_match_subroutine (void)
7238 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7243 bool allow_binding_name
;
7245 if (gfc_current_state () != COMP_NONE
7246 && gfc_current_state () != COMP_INTERFACE
7247 && gfc_current_state () != COMP_CONTAINS
)
7250 m
= gfc_match_prefix (NULL
);
7254 m
= gfc_match ("subroutine% %n", name
);
7258 if (get_proc_name (name
, &sym
, false))
7261 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
7262 the symbol existed before. */
7263 sym
->declared_at
= gfc_current_locus
;
7265 if (current_attr
.module_procedure
)
7266 sym
->attr
.module_procedure
= 1;
7268 if (add_hidden_procptr_result (sym
))
7271 gfc_new_block
= sym
;
7273 /* Check what next non-whitespace character is so we can tell if there
7274 is the required parens if we have a BIND(C). */
7275 gfc_gobble_whitespace ();
7276 peek_char
= gfc_peek_ascii_char ();
7278 if (!gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
))
7281 if (gfc_match_formal_arglist (sym
, 0, 1) != MATCH_YES
)
7284 /* Make sure that it isn't already declared as BIND(C). If it is, it
7285 must have been marked BIND(C) with a BIND(C) attribute and that is
7286 not allowed for procedures. */
7287 if (sym
->attr
.is_bind_c
== 1)
7289 sym
->attr
.is_bind_c
= 0;
7290 if (sym
->old_symbol
!= NULL
)
7291 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7292 "variables or common blocks",
7293 &(sym
->old_symbol
->declared_at
));
7295 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7296 "variables or common blocks", &gfc_current_locus
);
7299 /* C binding names are not allowed for internal procedures. */
7300 if (gfc_current_state () == COMP_CONTAINS
7301 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
7302 allow_binding_name
= false;
7304 allow_binding_name
= true;
7306 /* Here, we are just checking if it has the bind(c) attribute, and if
7307 so, then we need to make sure it's all correct. If it doesn't,
7308 we still need to continue matching the rest of the subroutine line. */
7309 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
7310 if (is_bind_c
== MATCH_ERROR
)
7312 /* There was an attempt at the bind(c), but it was wrong. An
7313 error message should have been printed w/in the gfc_match_bind_c
7314 so here we'll just return the MATCH_ERROR. */
7318 if (is_bind_c
== MATCH_YES
)
7320 /* The following is allowed in the Fortran 2008 draft. */
7321 if (gfc_current_state () == COMP_CONTAINS
7322 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
7323 && !gfc_notify_std (GFC_STD_F2008
, "BIND(C) attribute "
7324 "at %L may not be specified for an internal "
7325 "procedure", &gfc_current_locus
))
7328 if (peek_char
!= '(')
7330 gfc_error ("Missing required parentheses before BIND(C) at %C");
7333 if (!gfc_add_is_bind_c (&(sym
->attr
), sym
->name
,
7334 &(sym
->declared_at
), 1))
7338 if (gfc_match_eos () != MATCH_YES
)
7340 gfc_syntax_error (ST_SUBROUTINE
);
7344 if (!copy_prefix (&sym
->attr
, &sym
->declared_at
))
7346 if(!sym
->attr
.module_procedure
)
7352 /* Warn if it has the same name as an intrinsic. */
7353 do_warn_intrinsic_shadow (sym
, false);
7359 /* Check that the NAME identifier in a BIND attribute or statement
7360 is conform to C identifier rules. */
7363 check_bind_name_identifier (char **name
)
7365 char *n
= *name
, *p
;
7367 /* Remove leading spaces. */
7371 /* On an empty string, free memory and set name to NULL. */
7379 /* Remove trailing spaces. */
7380 p
= n
+ strlen(n
) - 1;
7384 /* Insert the identifier into the symbol table. */
7389 /* Now check that identifier is valid under C rules. */
7392 gfc_error ("Invalid C identifier in NAME= specifier at %C");
7397 if (!(ISALNUM (*p
) || *p
== '_' || *p
== '$'))
7399 gfc_error ("Invalid C identifier in NAME= specifier at %C");
7407 /* Match a BIND(C) specifier, with the optional 'name=' specifier if
7408 given, and set the binding label in either the given symbol (if not
7409 NULL), or in the current_ts. The symbol may be NULL because we may
7410 encounter the BIND(C) before the declaration itself. Return
7411 MATCH_NO if what we're looking at isn't a BIND(C) specifier,
7412 MATCH_ERROR if it is a BIND(C) clause but an error was encountered,
7413 or MATCH_YES if the specifier was correct and the binding label and
7414 bind(c) fields were set correctly for the given symbol or the
7415 current_ts. If allow_binding_name is false, no binding name may be
7419 gfc_match_bind_c (gfc_symbol
*sym
, bool allow_binding_name
)
7421 char *binding_label
= NULL
;
7424 /* Initialize the flag that specifies whether we encountered a NAME=
7425 specifier or not. */
7426 has_name_equals
= 0;
7428 /* This much we have to be able to match, in this order, if
7429 there is a bind(c) label. */
7430 if (gfc_match (" bind ( c ") != MATCH_YES
)
7433 /* Now see if there is a binding label, or if we've reached the
7434 end of the bind(c) attribute without one. */
7435 if (gfc_match_char (',') == MATCH_YES
)
7437 if (gfc_match (" name = ") != MATCH_YES
)
7439 gfc_error ("Syntax error in NAME= specifier for binding label "
7441 /* should give an error message here */
7445 has_name_equals
= 1;
7447 if (gfc_match_init_expr (&e
) != MATCH_YES
)
7453 if (!gfc_simplify_expr(e
, 0))
7455 gfc_error ("NAME= specifier at %C should be a constant expression");
7460 if (e
->expr_type
!= EXPR_CONSTANT
|| e
->ts
.type
!= BT_CHARACTER
7461 || e
->ts
.kind
!= gfc_default_character_kind
|| e
->rank
!= 0)
7463 gfc_error ("NAME= specifier at %C should be a scalar of "
7464 "default character kind");
7469 // Get a C string from the Fortran string constant
7470 binding_label
= gfc_widechar_to_char (e
->value
.character
.string
,
7471 e
->value
.character
.length
);
7474 // Check that it is valid (old gfc_match_name_C)
7475 if (check_bind_name_identifier (&binding_label
) != MATCH_YES
)
7479 /* Get the required right paren. */
7480 if (gfc_match_char (')') != MATCH_YES
)
7482 gfc_error ("Missing closing paren for binding label at %C");
7486 if (has_name_equals
&& !allow_binding_name
)
7488 gfc_error ("No binding name is allowed in BIND(C) at %C");
7492 if (has_name_equals
&& sym
!= NULL
&& sym
->attr
.dummy
)
7494 gfc_error ("For dummy procedure %s, no binding name is "
7495 "allowed in BIND(C) at %C", sym
->name
);
7500 /* Save the binding label to the symbol. If sym is null, we're
7501 probably matching the typespec attributes of a declaration and
7502 haven't gotten the name yet, and therefore, no symbol yet. */
7506 sym
->binding_label
= binding_label
;
7508 curr_binding_label
= binding_label
;
7510 else if (allow_binding_name
)
7512 /* No binding label, but if symbol isn't null, we
7513 can set the label for it here.
7514 If name="" or allow_binding_name is false, no C binding name is
7516 if (sym
!= NULL
&& sym
->name
!= NULL
&& has_name_equals
== 0)
7517 sym
->binding_label
= IDENTIFIER_POINTER (get_identifier (sym
->name
));
7520 if (has_name_equals
&& gfc_current_state () == COMP_INTERFACE
7521 && current_interface
.type
== INTERFACE_ABSTRACT
)
7523 gfc_error ("NAME not allowed on BIND(C) for ABSTRACT INTERFACE at %C");
7531 /* Return nonzero if we're currently compiling a contained procedure. */
7534 contained_procedure (void)
7536 gfc_state_data
*s
= gfc_state_stack
;
7538 if ((s
->state
== COMP_SUBROUTINE
|| s
->state
== COMP_FUNCTION
)
7539 && s
->previous
!= NULL
&& s
->previous
->state
== COMP_CONTAINS
)
7545 /* Set the kind of each enumerator. The kind is selected such that it is
7546 interoperable with the corresponding C enumeration type, making
7547 sure that -fshort-enums is honored. */
7552 enumerator_history
*current_history
= NULL
;
7556 if (max_enum
== NULL
|| enum_history
== NULL
)
7559 if (!flag_short_enums
)
7565 kind
= gfc_integer_kinds
[i
++].kind
;
7567 while (kind
< gfc_c_int_kind
7568 && gfc_check_integer_range (max_enum
->initializer
->value
.integer
,
7571 current_history
= enum_history
;
7572 while (current_history
!= NULL
)
7574 current_history
->sym
->ts
.kind
= kind
;
7575 current_history
= current_history
->next
;
7580 /* Match any of the various end-block statements. Returns the type of
7581 END to the caller. The END INTERFACE, END IF, END DO, END SELECT
7582 and END BLOCK statements cannot be replaced by a single END statement. */
7585 gfc_match_end (gfc_statement
*st
)
7587 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7588 gfc_compile_state state
;
7590 const char *block_name
;
7594 gfc_namespace
*parent_ns
, *ns
, *prev_ns
;
7595 gfc_namespace
**nsp
;
7596 bool abreviated_modproc_decl
= false;
7597 bool got_matching_end
= false;
7599 old_loc
= gfc_current_locus
;
7600 if (gfc_match ("end") != MATCH_YES
)
7603 state
= gfc_current_state ();
7604 block_name
= gfc_current_block () == NULL
7605 ? NULL
: gfc_current_block ()->name
;
7609 case COMP_ASSOCIATE
:
7611 if (!strncmp (block_name
, "block@", strlen("block@")))
7616 case COMP_DERIVED_CONTAINS
:
7617 state
= gfc_state_stack
->previous
->state
;
7618 block_name
= gfc_state_stack
->previous
->sym
== NULL
7619 ? NULL
: gfc_state_stack
->previous
->sym
->name
;
7620 abreviated_modproc_decl
= gfc_state_stack
->previous
->sym
7621 && gfc_state_stack
->previous
->sym
->abr_modproc_decl
;
7628 if (!abreviated_modproc_decl
)
7629 abreviated_modproc_decl
= gfc_current_block ()
7630 && gfc_current_block ()->abr_modproc_decl
;
7636 *st
= ST_END_PROGRAM
;
7637 target
= " program";
7641 case COMP_SUBROUTINE
:
7642 *st
= ST_END_SUBROUTINE
;
7643 if (!abreviated_modproc_decl
)
7644 target
= " subroutine";
7646 target
= " procedure";
7647 eos_ok
= !contained_procedure ();
7651 *st
= ST_END_FUNCTION
;
7652 if (!abreviated_modproc_decl
)
7653 target
= " function";
7655 target
= " procedure";
7656 eos_ok
= !contained_procedure ();
7659 case COMP_BLOCK_DATA
:
7660 *st
= ST_END_BLOCK_DATA
;
7661 target
= " block data";
7666 *st
= ST_END_MODULE
;
7671 case COMP_SUBMODULE
:
7672 *st
= ST_END_SUBMODULE
;
7673 target
= " submodule";
7677 case COMP_INTERFACE
:
7678 *st
= ST_END_INTERFACE
;
7679 target
= " interface";
7695 case COMP_STRUCTURE
:
7696 *st
= ST_END_STRUCTURE
;
7697 target
= " structure";
7702 case COMP_DERIVED_CONTAINS
:
7708 case COMP_ASSOCIATE
:
7709 *st
= ST_END_ASSOCIATE
;
7710 target
= " associate";
7727 case COMP_DO_CONCURRENT
:
7734 *st
= ST_END_CRITICAL
;
7735 target
= " critical";
7740 case COMP_SELECT_TYPE
:
7741 *st
= ST_END_SELECT
;
7747 *st
= ST_END_FORALL
;
7762 last_initializer
= NULL
;
7764 gfc_free_enum_history ();
7768 gfc_error ("Unexpected END statement at %C");
7772 old_loc
= gfc_current_locus
;
7773 if (gfc_match_eos () == MATCH_YES
)
7775 if (!eos_ok
&& (*st
== ST_END_SUBROUTINE
|| *st
== ST_END_FUNCTION
))
7777 if (!gfc_notify_std (GFC_STD_F2008
, "END statement "
7778 "instead of %s statement at %L",
7779 abreviated_modproc_decl
? "END PROCEDURE"
7780 : gfc_ascii_statement(*st
), &old_loc
))
7785 /* We would have required END [something]. */
7786 gfc_error ("%s statement expected at %L",
7787 gfc_ascii_statement (*st
), &old_loc
);
7794 /* Verify that we've got the sort of end-block that we're expecting. */
7795 if (gfc_match (target
) != MATCH_YES
)
7797 gfc_error ("Expecting %s statement at %L", abreviated_modproc_decl
7798 ? "END PROCEDURE" : gfc_ascii_statement(*st
), &old_loc
);
7802 got_matching_end
= true;
7804 old_loc
= gfc_current_locus
;
7805 /* If we're at the end, make sure a block name wasn't required. */
7806 if (gfc_match_eos () == MATCH_YES
)
7809 if (*st
!= ST_ENDDO
&& *st
!= ST_ENDIF
&& *st
!= ST_END_SELECT
7810 && *st
!= ST_END_FORALL
&& *st
!= ST_END_WHERE
&& *st
!= ST_END_BLOCK
7811 && *st
!= ST_END_ASSOCIATE
&& *st
!= ST_END_CRITICAL
)
7817 gfc_error ("Expected block name of %qs in %s statement at %L",
7818 block_name
, gfc_ascii_statement (*st
), &old_loc
);
7823 /* END INTERFACE has a special handler for its several possible endings. */
7824 if (*st
== ST_END_INTERFACE
)
7825 return gfc_match_end_interface ();
7827 /* We haven't hit the end of statement, so what is left must be an
7829 m
= gfc_match_space ();
7831 m
= gfc_match_name (name
);
7834 gfc_error ("Expected terminating name at %C");
7838 if (block_name
== NULL
)
7841 /* We have to pick out the declared submodule name from the composite
7842 required by F2008:11.2.3 para 2, which ends in the declared name. */
7843 if (state
== COMP_SUBMODULE
)
7844 block_name
= strchr (block_name
, '.') + 1;
7846 if (strcmp (name
, block_name
) != 0 && strcmp (block_name
, "ppr@") != 0)
7848 gfc_error ("Expected label %qs for %s statement at %C", block_name
,
7849 gfc_ascii_statement (*st
));
7852 /* Procedure pointer as function result. */
7853 else if (strcmp (block_name
, "ppr@") == 0
7854 && strcmp (name
, gfc_current_block ()->ns
->proc_name
->name
) != 0)
7856 gfc_error ("Expected label %qs for %s statement at %C",
7857 gfc_current_block ()->ns
->proc_name
->name
,
7858 gfc_ascii_statement (*st
));
7862 if (gfc_match_eos () == MATCH_YES
)
7866 gfc_syntax_error (*st
);
7869 gfc_current_locus
= old_loc
;
7871 /* If we are missing an END BLOCK, we created a half-ready namespace.
7872 Remove it from the parent namespace's sibling list. */
7874 while (state
== COMP_BLOCK
&& !got_matching_end
)
7876 parent_ns
= gfc_current_ns
->parent
;
7878 nsp
= &(gfc_state_stack
->previous
->tail
->ext
.block
.ns
);
7884 if (ns
== gfc_current_ns
)
7886 if (prev_ns
== NULL
)
7889 prev_ns
->sibling
= ns
->sibling
;
7895 gfc_free_namespace (gfc_current_ns
);
7896 gfc_current_ns
= parent_ns
;
7897 gfc_state_stack
= gfc_state_stack
->previous
;
7898 state
= gfc_current_state ();
7906 /***************** Attribute declaration statements ****************/
7908 /* Set the attribute of a single variable. */
7913 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7916 /* Workaround -Wmaybe-uninitialized false positive during
7917 profiledbootstrap by initializing them. */
7918 gfc_symbol
*sym
= NULL
;
7924 m
= gfc_match_name (name
);
7928 if (find_special (name
, &sym
, false))
7931 if (!check_function_name (name
))
7937 var_locus
= gfc_current_locus
;
7939 /* Deal with possible array specification for certain attributes. */
7940 if (current_attr
.dimension
7941 || current_attr
.codimension
7942 || current_attr
.allocatable
7943 || current_attr
.pointer
7944 || current_attr
.target
)
7946 m
= gfc_match_array_spec (&as
, !current_attr
.codimension
,
7947 !current_attr
.dimension
7948 && !current_attr
.pointer
7949 && !current_attr
.target
);
7950 if (m
== MATCH_ERROR
)
7953 if (current_attr
.dimension
&& m
== MATCH_NO
)
7955 gfc_error ("Missing array specification at %L in DIMENSION "
7956 "statement", &var_locus
);
7961 if (current_attr
.dimension
&& sym
->value
)
7963 gfc_error ("Dimensions specified for %s at %L after its "
7964 "initialization", sym
->name
, &var_locus
);
7969 if (current_attr
.codimension
&& m
== MATCH_NO
)
7971 gfc_error ("Missing array specification at %L in CODIMENSION "
7972 "statement", &var_locus
);
7977 if ((current_attr
.allocatable
|| current_attr
.pointer
)
7978 && (m
== MATCH_YES
) && (as
->type
!= AS_DEFERRED
))
7980 gfc_error ("Array specification must be deferred at %L", &var_locus
);
7986 /* Update symbol table. DIMENSION attribute is set in
7987 gfc_set_array_spec(). For CLASS variables, this must be applied
7988 to the first component, or '_data' field. */
7989 if (sym
->ts
.type
== BT_CLASS
&& sym
->ts
.u
.derived
->attr
.is_class
)
7991 if (!gfc_copy_attr (&CLASS_DATA(sym
)->attr
, ¤t_attr
, &var_locus
))
7999 if (current_attr
.dimension
== 0 && current_attr
.codimension
== 0
8000 && !gfc_copy_attr (&sym
->attr
, ¤t_attr
, &var_locus
))
8007 if (sym
->ts
.type
== BT_CLASS
8008 && !gfc_build_class_symbol (&sym
->ts
, &sym
->attr
, &sym
->as
))
8014 if (!gfc_set_array_spec (sym
, as
, &var_locus
))
8020 if (sym
->attr
.cray_pointee
&& sym
->as
!= NULL
)
8022 /* Fix the array spec. */
8023 m
= gfc_mod_pointee_as (sym
->as
);
8024 if (m
== MATCH_ERROR
)
8028 if (!gfc_add_attribute (&sym
->attr
, &var_locus
))
8034 if ((current_attr
.external
|| current_attr
.intrinsic
)
8035 && sym
->attr
.flavor
!= FL_PROCEDURE
8036 && !gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, NULL
))
8042 add_hidden_procptr_result (sym
);
8047 gfc_free_array_spec (as
);
8052 /* Generic attribute declaration subroutine. Used for attributes that
8053 just have a list of names. */
8060 /* Gobble the optional double colon, by simply ignoring the result
8070 if (gfc_match_eos () == MATCH_YES
)
8076 if (gfc_match_char (',') != MATCH_YES
)
8078 gfc_error ("Unexpected character in variable list at %C");
8088 /* This routine matches Cray Pointer declarations of the form:
8089 pointer ( <pointer>, <pointee> )
8091 pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...
8092 The pointer, if already declared, should be an integer. Otherwise, we
8093 set it as BT_INTEGER with kind gfc_index_integer_kind. The pointee may
8094 be either a scalar, or an array declaration. No space is allocated for
8095 the pointee. For the statement
8096 pointer (ipt, ar(10))
8097 any subsequent uses of ar will be translated (in C-notation) as
8098 ar(i) => ((<type> *) ipt)(i)
8099 After gimplification, pointee variable will disappear in the code. */
8102 cray_pointer_decl (void)
8105 gfc_array_spec
*as
= NULL
;
8106 gfc_symbol
*cptr
; /* Pointer symbol. */
8107 gfc_symbol
*cpte
; /* Pointee symbol. */
8113 if (gfc_match_char ('(') != MATCH_YES
)
8115 gfc_error ("Expected %<(%> at %C");
8119 /* Match pointer. */
8120 var_locus
= gfc_current_locus
;
8121 gfc_clear_attr (¤t_attr
);
8122 gfc_add_cray_pointer (¤t_attr
, &var_locus
);
8123 current_ts
.type
= BT_INTEGER
;
8124 current_ts
.kind
= gfc_index_integer_kind
;
8126 m
= gfc_match_symbol (&cptr
, 0);
8129 gfc_error ("Expected variable name at %C");
8133 if (!gfc_add_cray_pointer (&cptr
->attr
, &var_locus
))
8136 gfc_set_sym_referenced (cptr
);
8138 if (cptr
->ts
.type
== BT_UNKNOWN
) /* Override the type, if necessary. */
8140 cptr
->ts
.type
= BT_INTEGER
;
8141 cptr
->ts
.kind
= gfc_index_integer_kind
;
8143 else if (cptr
->ts
.type
!= BT_INTEGER
)
8145 gfc_error ("Cray pointer at %C must be an integer");
8148 else if (cptr
->ts
.kind
< gfc_index_integer_kind
)
8149 gfc_warning (0, "Cray pointer at %C has %d bytes of precision;"
8150 " memory addresses require %d bytes",
8151 cptr
->ts
.kind
, gfc_index_integer_kind
);
8153 if (gfc_match_char (',') != MATCH_YES
)
8155 gfc_error ("Expected \",\" at %C");
8159 /* Match Pointee. */
8160 var_locus
= gfc_current_locus
;
8161 gfc_clear_attr (¤t_attr
);
8162 gfc_add_cray_pointee (¤t_attr
, &var_locus
);
8163 current_ts
.type
= BT_UNKNOWN
;
8164 current_ts
.kind
= 0;
8166 m
= gfc_match_symbol (&cpte
, 0);
8169 gfc_error ("Expected variable name at %C");
8173 /* Check for an optional array spec. */
8174 m
= gfc_match_array_spec (&as
, true, false);
8175 if (m
== MATCH_ERROR
)
8177 gfc_free_array_spec (as
);
8180 else if (m
== MATCH_NO
)
8182 gfc_free_array_spec (as
);
8186 if (!gfc_add_cray_pointee (&cpte
->attr
, &var_locus
))
8189 gfc_set_sym_referenced (cpte
);
8191 if (cpte
->as
== NULL
)
8193 if (!gfc_set_array_spec (cpte
, as
, &var_locus
))
8194 gfc_internal_error ("Couldn't set Cray pointee array spec.");
8196 else if (as
!= NULL
)
8198 gfc_error ("Duplicate array spec for Cray pointee at %C");
8199 gfc_free_array_spec (as
);
8205 if (cpte
->as
!= NULL
)
8207 /* Fix array spec. */
8208 m
= gfc_mod_pointee_as (cpte
->as
);
8209 if (m
== MATCH_ERROR
)
8213 /* Point the Pointee at the Pointer. */
8214 cpte
->cp_pointer
= cptr
;
8216 if (gfc_match_char (')') != MATCH_YES
)
8218 gfc_error ("Expected \")\" at %C");
8221 m
= gfc_match_char (',');
8223 done
= true; /* Stop searching for more declarations. */
8227 if (m
== MATCH_ERROR
/* Failed when trying to find ',' above. */
8228 || gfc_match_eos () != MATCH_YES
)
8230 gfc_error ("Expected %<,%> or end of statement at %C");
8238 gfc_match_external (void)
8241 gfc_clear_attr (¤t_attr
);
8242 current_attr
.external
= 1;
8244 return attr_decl ();
8249 gfc_match_intent (void)
8253 /* This is not allowed within a BLOCK construct! */
8254 if (gfc_current_state () == COMP_BLOCK
)
8256 gfc_error ("INTENT is not allowed inside of BLOCK at %C");
8260 intent
= match_intent_spec ();
8261 if (intent
== INTENT_UNKNOWN
)
8264 gfc_clear_attr (¤t_attr
);
8265 current_attr
.intent
= intent
;
8267 return attr_decl ();
8272 gfc_match_intrinsic (void)
8275 gfc_clear_attr (¤t_attr
);
8276 current_attr
.intrinsic
= 1;
8278 return attr_decl ();
8283 gfc_match_optional (void)
8285 /* This is not allowed within a BLOCK construct! */
8286 if (gfc_current_state () == COMP_BLOCK
)
8288 gfc_error ("OPTIONAL is not allowed inside of BLOCK at %C");
8292 gfc_clear_attr (¤t_attr
);
8293 current_attr
.optional
= 1;
8295 return attr_decl ();
8300 gfc_match_pointer (void)
8302 gfc_gobble_whitespace ();
8303 if (gfc_peek_ascii_char () == '(')
8305 if (!flag_cray_pointer
)
8307 gfc_error ("Cray pointer declaration at %C requires -fcray-pointer "
8311 return cray_pointer_decl ();
8315 gfc_clear_attr (¤t_attr
);
8316 current_attr
.pointer
= 1;
8318 return attr_decl ();
8324 gfc_match_allocatable (void)
8326 gfc_clear_attr (¤t_attr
);
8327 current_attr
.allocatable
= 1;
8329 return attr_decl ();
8334 gfc_match_codimension (void)
8336 gfc_clear_attr (¤t_attr
);
8337 current_attr
.codimension
= 1;
8339 return attr_decl ();
8344 gfc_match_contiguous (void)
8346 if (!gfc_notify_std (GFC_STD_F2008
, "CONTIGUOUS statement at %C"))
8349 gfc_clear_attr (¤t_attr
);
8350 current_attr
.contiguous
= 1;
8352 return attr_decl ();
8357 gfc_match_dimension (void)
8359 gfc_clear_attr (¤t_attr
);
8360 current_attr
.dimension
= 1;
8362 return attr_decl ();
8367 gfc_match_target (void)
8369 gfc_clear_attr (¤t_attr
);
8370 current_attr
.target
= 1;
8372 return attr_decl ();
8376 /* Match the list of entities being specified in a PUBLIC or PRIVATE
8380 access_attr_decl (gfc_statement st
)
8382 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8383 interface_type type
;
8385 gfc_symbol
*sym
, *dt_sym
;
8386 gfc_intrinsic_op op
;
8389 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
8394 m
= gfc_match_generic_spec (&type
, name
, &op
);
8397 if (m
== MATCH_ERROR
)
8402 case INTERFACE_NAMELESS
:
8403 case INTERFACE_ABSTRACT
:
8406 case INTERFACE_GENERIC
:
8407 case INTERFACE_DTIO
:
8409 if (gfc_get_symbol (name
, NULL
, &sym
))
8412 if (type
== INTERFACE_DTIO
8413 && gfc_current_ns
->proc_name
8414 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
8415 && sym
->attr
.flavor
== FL_UNKNOWN
)
8416 sym
->attr
.flavor
= FL_PROCEDURE
;
8418 if (!gfc_add_access (&sym
->attr
,
8420 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
,
8424 if (sym
->attr
.generic
&& (dt_sym
= gfc_find_dt_in_generic (sym
))
8425 && !gfc_add_access (&dt_sym
->attr
,
8427 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
,
8433 case INTERFACE_INTRINSIC_OP
:
8434 if (gfc_current_ns
->operator_access
[op
] == ACCESS_UNKNOWN
)
8436 gfc_intrinsic_op other_op
;
8438 gfc_current_ns
->operator_access
[op
] =
8439 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
8441 /* Handle the case if there is another op with the same
8442 function, for INTRINSIC_EQ vs. INTRINSIC_EQ_OS and so on. */
8443 other_op
= gfc_equivalent_op (op
);
8445 if (other_op
!= INTRINSIC_NONE
)
8446 gfc_current_ns
->operator_access
[other_op
] =
8447 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
8452 gfc_error ("Access specification of the %s operator at %C has "
8453 "already been specified", gfc_op2string (op
));
8459 case INTERFACE_USER_OP
:
8460 uop
= gfc_get_uop (name
);
8462 if (uop
->access
== ACCESS_UNKNOWN
)
8464 uop
->access
= (st
== ST_PUBLIC
)
8465 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
8469 gfc_error ("Access specification of the .%s. operator at %C "
8470 "has already been specified", sym
->name
);
8477 if (gfc_match_char (',') == MATCH_NO
)
8481 if (gfc_match_eos () != MATCH_YES
)
8486 gfc_syntax_error (st
);
8494 gfc_match_protected (void)
8499 if (!gfc_current_ns
->proc_name
8500 || gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
8502 gfc_error ("PROTECTED at %C only allowed in specification "
8503 "part of a module");
8508 if (!gfc_notify_std (GFC_STD_F2003
, "PROTECTED statement at %C"))
8511 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
8516 if (gfc_match_eos () == MATCH_YES
)
8521 m
= gfc_match_symbol (&sym
, 0);
8525 if (!gfc_add_protected (&sym
->attr
, sym
->name
, &gfc_current_locus
))
8537 if (gfc_match_eos () == MATCH_YES
)
8539 if (gfc_match_char (',') != MATCH_YES
)
8546 gfc_error ("Syntax error in PROTECTED statement at %C");
8551 /* The PRIVATE statement is a bit weird in that it can be an attribute
8552 declaration, but also works as a standalone statement inside of a
8553 type declaration or a module. */
8556 gfc_match_private (gfc_statement
*st
)
8559 if (gfc_match ("private") != MATCH_YES
)
8562 if (gfc_current_state () != COMP_MODULE
8563 && !(gfc_current_state () == COMP_DERIVED
8564 && gfc_state_stack
->previous
8565 && gfc_state_stack
->previous
->state
== COMP_MODULE
)
8566 && !(gfc_current_state () == COMP_DERIVED_CONTAINS
8567 && gfc_state_stack
->previous
&& gfc_state_stack
->previous
->previous
8568 && gfc_state_stack
->previous
->previous
->state
== COMP_MODULE
))
8570 gfc_error ("PRIVATE statement at %C is only allowed in the "
8571 "specification part of a module");
8575 if (gfc_current_state () == COMP_DERIVED
)
8577 if (gfc_match_eos () == MATCH_YES
)
8583 gfc_syntax_error (ST_PRIVATE
);
8587 if (gfc_match_eos () == MATCH_YES
)
8594 return access_attr_decl (ST_PRIVATE
);
8599 gfc_match_public (gfc_statement
*st
)
8602 if (gfc_match ("public") != MATCH_YES
)
8605 if (gfc_current_state () != COMP_MODULE
)
8607 gfc_error ("PUBLIC statement at %C is only allowed in the "
8608 "specification part of a module");
8612 if (gfc_match_eos () == MATCH_YES
)
8619 return access_attr_decl (ST_PUBLIC
);
8623 /* Workhorse for gfc_match_parameter. */
8633 m
= gfc_match_symbol (&sym
, 0);
8635 gfc_error ("Expected variable name at %C in PARAMETER statement");
8640 if (gfc_match_char ('=') == MATCH_NO
)
8642 gfc_error ("Expected = sign in PARAMETER statement at %C");
8646 m
= gfc_match_init_expr (&init
);
8648 gfc_error ("Expected expression at %C in PARAMETER statement");
8652 if (sym
->ts
.type
== BT_UNKNOWN
8653 && !gfc_set_default_type (sym
, 1, NULL
))
8659 if (!gfc_check_assign_symbol (sym
, NULL
, init
)
8660 || !gfc_add_flavor (&sym
->attr
, FL_PARAMETER
, sym
->name
, NULL
))
8668 gfc_error ("Initializing already initialized variable at %C");
8673 t
= add_init_expr_to_sym (sym
->name
, &init
, &gfc_current_locus
);
8674 return (t
) ? MATCH_YES
: MATCH_ERROR
;
8677 gfc_free_expr (init
);
8682 /* Match a parameter statement, with the weird syntax that these have. */
8685 gfc_match_parameter (void)
8687 const char *term
= " )%t";
8690 if (gfc_match_char ('(') == MATCH_NO
)
8692 /* With legacy PARAMETER statements, don't expect a terminating ')'. */
8693 if (!gfc_notify_std (GFC_STD_LEGACY
, "PARAMETER without '()' at %C"))
8704 if (gfc_match (term
) == MATCH_YES
)
8707 if (gfc_match_char (',') != MATCH_YES
)
8709 gfc_error ("Unexpected characters in PARAMETER statement at %C");
8720 gfc_match_automatic (void)
8724 bool seen_symbol
= false;
8726 if (!flag_dec_static
)
8728 gfc_error ("%s at %C is a DEC extension, enable with "
8739 m
= gfc_match_symbol (&sym
, 0);
8749 if (!gfc_add_automatic (&sym
->attr
, sym
->name
, &gfc_current_locus
))
8755 if (gfc_match_eos () == MATCH_YES
)
8757 if (gfc_match_char (',') != MATCH_YES
)
8763 gfc_error ("Expected entity-list in AUTOMATIC statement at %C");
8770 gfc_error ("Syntax error in AUTOMATIC statement at %C");
8776 gfc_match_static (void)
8780 bool seen_symbol
= false;
8782 if (!flag_dec_static
)
8784 gfc_error ("%s at %C is a DEC extension, enable with "
8794 m
= gfc_match_symbol (&sym
, 0);
8804 if (!gfc_add_save (&sym
->attr
, SAVE_EXPLICIT
, sym
->name
,
8805 &gfc_current_locus
))
8811 if (gfc_match_eos () == MATCH_YES
)
8813 if (gfc_match_char (',') != MATCH_YES
)
8819 gfc_error ("Expected entity-list in STATIC statement at %C");
8826 gfc_error ("Syntax error in STATIC statement at %C");
8831 /* Save statements have a special syntax. */
8834 gfc_match_save (void)
8836 char n
[GFC_MAX_SYMBOL_LEN
+1];
8841 if (gfc_match_eos () == MATCH_YES
)
8843 if (gfc_current_ns
->seen_save
)
8845 if (!gfc_notify_std (GFC_STD_LEGACY
, "Blanket SAVE statement at %C "
8846 "follows previous SAVE statement"))
8850 gfc_current_ns
->save_all
= gfc_current_ns
->seen_save
= 1;
8854 if (gfc_current_ns
->save_all
)
8856 if (!gfc_notify_std (GFC_STD_LEGACY
, "SAVE statement at %C follows "
8857 "blanket SAVE statement"))
8865 m
= gfc_match_symbol (&sym
, 0);
8869 if (!gfc_add_save (&sym
->attr
, SAVE_EXPLICIT
, sym
->name
,
8870 &gfc_current_locus
))
8881 m
= gfc_match (" / %n /", &n
);
8882 if (m
== MATCH_ERROR
)
8887 c
= gfc_get_common (n
, 0);
8890 gfc_current_ns
->seen_save
= 1;
8893 if (gfc_match_eos () == MATCH_YES
)
8895 if (gfc_match_char (',') != MATCH_YES
)
8902 gfc_error ("Syntax error in SAVE statement at %C");
8908 gfc_match_value (void)
8913 /* This is not allowed within a BLOCK construct! */
8914 if (gfc_current_state () == COMP_BLOCK
)
8916 gfc_error ("VALUE is not allowed inside of BLOCK at %C");
8920 if (!gfc_notify_std (GFC_STD_F2003
, "VALUE statement at %C"))
8923 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
8928 if (gfc_match_eos () == MATCH_YES
)
8933 m
= gfc_match_symbol (&sym
, 0);
8937 if (!gfc_add_value (&sym
->attr
, sym
->name
, &gfc_current_locus
))
8949 if (gfc_match_eos () == MATCH_YES
)
8951 if (gfc_match_char (',') != MATCH_YES
)
8958 gfc_error ("Syntax error in VALUE statement at %C");
8964 gfc_match_volatile (void)
8969 if (!gfc_notify_std (GFC_STD_F2003
, "VOLATILE statement at %C"))
8972 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
8977 if (gfc_match_eos () == MATCH_YES
)
8982 /* VOLATILE is special because it can be added to host-associated
8983 symbols locally. Except for coarrays. */
8984 m
= gfc_match_symbol (&sym
, 1);
8988 /* F2008, C560+C561. VOLATILE for host-/use-associated variable or
8989 for variable in a BLOCK which is defined outside of the BLOCK. */
8990 if (sym
->ns
!= gfc_current_ns
&& sym
->attr
.codimension
)
8992 gfc_error ("Specifying VOLATILE for coarray variable %qs at "
8993 "%C, which is use-/host-associated", sym
->name
);
8996 if (!gfc_add_volatile (&sym
->attr
, sym
->name
, &gfc_current_locus
))
9008 if (gfc_match_eos () == MATCH_YES
)
9010 if (gfc_match_char (',') != MATCH_YES
)
9017 gfc_error ("Syntax error in VOLATILE statement at %C");
9023 gfc_match_asynchronous (void)
9028 if (!gfc_notify_std (GFC_STD_F2003
, "ASYNCHRONOUS statement at %C"))
9031 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
9036 if (gfc_match_eos () == MATCH_YES
)
9041 /* ASYNCHRONOUS is special because it can be added to host-associated
9043 m
= gfc_match_symbol (&sym
, 1);
9047 if (!gfc_add_asynchronous (&sym
->attr
, sym
->name
, &gfc_current_locus
))
9059 if (gfc_match_eos () == MATCH_YES
)
9061 if (gfc_match_char (',') != MATCH_YES
)
9068 gfc_error ("Syntax error in ASYNCHRONOUS statement at %C");
9073 /* Match a module procedure statement in a submodule. */
9076 gfc_match_submod_proc (void)
9078 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9079 gfc_symbol
*sym
, *fsym
;
9081 gfc_formal_arglist
*formal
, *head
, *tail
;
9083 if (gfc_current_state () != COMP_CONTAINS
9084 || !(gfc_state_stack
->previous
9085 && (gfc_state_stack
->previous
->state
== COMP_SUBMODULE
9086 || gfc_state_stack
->previous
->state
== COMP_MODULE
)))
9089 m
= gfc_match (" module% procedure% %n", name
);
9093 if (!gfc_notify_std (GFC_STD_F2008
, "MODULE PROCEDURE declaration "
9097 if (get_proc_name (name
, &sym
, false))
9100 /* Make sure that the result field is appropriately filled, even though
9101 the result symbol will be replaced later on. */
9102 if (sym
->tlink
&& sym
->tlink
->attr
.function
)
9104 if (sym
->tlink
->result
9105 && sym
->tlink
->result
!= sym
->tlink
)
9106 sym
->result
= sym
->tlink
->result
;
9111 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
9112 the symbol existed before. */
9113 sym
->declared_at
= gfc_current_locus
;
9115 if (!sym
->attr
.module_procedure
)
9118 /* Signal match_end to expect "end procedure". */
9119 sym
->abr_modproc_decl
= 1;
9121 /* Change from IFSRC_IFBODY coming from the interface declaration. */
9122 sym
->attr
.if_source
= IFSRC_DECL
;
9124 gfc_new_block
= sym
;
9126 /* Make a new formal arglist with the symbols in the procedure
9129 for (formal
= sym
->formal
; formal
&& formal
->sym
; formal
= formal
->next
)
9131 if (formal
== sym
->formal
)
9132 head
= tail
= gfc_get_formal_arglist ();
9135 tail
->next
= gfc_get_formal_arglist ();
9139 if (gfc_copy_dummy_sym (&fsym
, formal
->sym
, 0))
9143 gfc_set_sym_referenced (fsym
);
9146 /* The dummy symbols get cleaned up, when the formal_namespace of the
9147 interface declaration is cleared. This allows us to add the
9148 explicit interface as is done for other type of procedure. */
9149 if (!gfc_add_explicit_interface (sym
, IFSRC_DECL
, head
,
9150 &gfc_current_locus
))
9153 if (gfc_match_eos () != MATCH_YES
)
9155 gfc_syntax_error (ST_MODULE_PROC
);
9162 gfc_free_formal_arglist (head
);
9167 /* Match a module procedure statement. Note that we have to modify
9168 symbols in the parent's namespace because the current one was there
9169 to receive symbols that are in an interface's formal argument list. */
9172 gfc_match_modproc (void)
9174 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9178 gfc_namespace
*module_ns
;
9179 gfc_interface
*old_interface_head
, *interface
;
9181 if (gfc_state_stack
->state
!= COMP_INTERFACE
9182 || gfc_state_stack
->previous
== NULL
9183 || current_interface
.type
== INTERFACE_NAMELESS
9184 || current_interface
.type
== INTERFACE_ABSTRACT
)
9186 gfc_error ("MODULE PROCEDURE at %C must be in a generic module "
9191 module_ns
= gfc_current_ns
->parent
;
9192 for (; module_ns
; module_ns
= module_ns
->parent
)
9193 if (module_ns
->proc_name
->attr
.flavor
== FL_MODULE
9194 || module_ns
->proc_name
->attr
.flavor
== FL_PROGRAM
9195 || (module_ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
9196 && !module_ns
->proc_name
->attr
.contained
))
9199 if (module_ns
== NULL
)
9202 /* Store the current state of the interface. We will need it if we
9203 end up with a syntax error and need to recover. */
9204 old_interface_head
= gfc_current_interface_head ();
9206 /* Check if the F2008 optional double colon appears. */
9207 gfc_gobble_whitespace ();
9208 old_locus
= gfc_current_locus
;
9209 if (gfc_match ("::") == MATCH_YES
)
9211 if (!gfc_notify_std (GFC_STD_F2008
, "double colon in "
9212 "MODULE PROCEDURE statement at %L", &old_locus
))
9216 gfc_current_locus
= old_locus
;
9221 old_locus
= gfc_current_locus
;
9223 m
= gfc_match_name (name
);
9229 /* Check for syntax error before starting to add symbols to the
9230 current namespace. */
9231 if (gfc_match_eos () == MATCH_YES
)
9234 if (!last
&& gfc_match_char (',') != MATCH_YES
)
9237 /* Now we're sure the syntax is valid, we process this item
9239 if (gfc_get_symbol (name
, module_ns
, &sym
))
9242 if (sym
->attr
.intrinsic
)
9244 gfc_error ("Intrinsic procedure at %L cannot be a MODULE "
9245 "PROCEDURE", &old_locus
);
9249 if (sym
->attr
.proc
!= PROC_MODULE
9250 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
9253 if (!gfc_add_interface (sym
))
9256 sym
->attr
.mod_proc
= 1;
9257 sym
->declared_at
= old_locus
;
9266 /* Restore the previous state of the interface. */
9267 interface
= gfc_current_interface_head ();
9268 gfc_set_current_interface_head (old_interface_head
);
9270 /* Free the new interfaces. */
9271 while (interface
!= old_interface_head
)
9273 gfc_interface
*i
= interface
->next
;
9278 /* And issue a syntax error. */
9279 gfc_syntax_error (ST_MODULE_PROC
);
9284 /* Check a derived type that is being extended. */
9287 check_extended_derived_type (char *name
)
9289 gfc_symbol
*extended
;
9291 if (gfc_find_symbol (name
, gfc_current_ns
, 1, &extended
))
9293 gfc_error ("Ambiguous symbol in TYPE definition at %C");
9297 extended
= gfc_find_dt_in_generic (extended
);
9302 gfc_error ("Symbol %qs at %C has not been previously defined", name
);
9306 if (extended
->attr
.flavor
!= FL_DERIVED
)
9308 gfc_error ("%qs in EXTENDS expression at %C is not a "
9309 "derived type", name
);
9313 if (extended
->attr
.is_bind_c
)
9315 gfc_error ("%qs cannot be extended at %C because it "
9316 "is BIND(C)", extended
->name
);
9320 if (extended
->attr
.sequence
)
9322 gfc_error ("%qs cannot be extended at %C because it "
9323 "is a SEQUENCE type", extended
->name
);
9331 /* Match the optional attribute specifiers for a type declaration.
9332 Return MATCH_ERROR if an error is encountered in one of the handled
9333 attributes (public, private, bind(c)), MATCH_NO if what's found is
9334 not a handled attribute, and MATCH_YES otherwise. TODO: More error
9335 checking on attribute conflicts needs to be done. */
9338 gfc_get_type_attr_spec (symbol_attribute
*attr
, char *name
)
9340 /* See if the derived type is marked as private. */
9341 if (gfc_match (" , private") == MATCH_YES
)
9343 if (gfc_current_state () != COMP_MODULE
)
9345 gfc_error ("Derived type at %C can only be PRIVATE in the "
9346 "specification part of a module");
9350 if (!gfc_add_access (attr
, ACCESS_PRIVATE
, NULL
, NULL
))
9353 else if (gfc_match (" , public") == MATCH_YES
)
9355 if (gfc_current_state () != COMP_MODULE
)
9357 gfc_error ("Derived type at %C can only be PUBLIC in the "
9358 "specification part of a module");
9362 if (!gfc_add_access (attr
, ACCESS_PUBLIC
, NULL
, NULL
))
9365 else if (gfc_match (" , bind ( c )") == MATCH_YES
)
9367 /* If the type is defined to be bind(c) it then needs to make
9368 sure that all fields are interoperable. This will
9369 need to be a semantic check on the finished derived type.
9370 See 15.2.3 (lines 9-12) of F2003 draft. */
9371 if (!gfc_add_is_bind_c (attr
, NULL
, &gfc_current_locus
, 0))
9374 /* TODO: attr conflicts need to be checked, probably in symbol.c. */
9376 else if (gfc_match (" , abstract") == MATCH_YES
)
9378 if (!gfc_notify_std (GFC_STD_F2003
, "ABSTRACT type at %C"))
9381 if (!gfc_add_abstract (attr
, &gfc_current_locus
))
9384 else if (name
&& gfc_match (" , extends ( %n )", name
) == MATCH_YES
)
9386 if (!gfc_add_extension (attr
, &gfc_current_locus
))
9392 /* If we get here, something matched. */
9397 /* Common function for type declaration blocks similar to derived types, such
9398 as STRUCTURES and MAPs. Unlike derived types, a structure type
9399 does NOT have a generic symbol matching the name given by the user.
9400 STRUCTUREs can share names with variables and PARAMETERs so we must allow
9401 for the creation of an independent symbol.
9402 Other parameters are a message to prefix errors with, the name of the new
9403 type to be created, and the flavor to add to the resulting symbol. */
9406 get_struct_decl (const char *name
, sym_flavor fl
, locus
*decl
,
9407 gfc_symbol
**result
)
9412 gcc_assert (name
[0] == (char) TOUPPER (name
[0]));
9417 where
= gfc_current_locus
;
9419 if (gfc_get_symbol (name
, NULL
, &sym
))
9424 gfc_internal_error ("Failed to create structure type '%s' at %C", name
);
9428 if (sym
->components
!= NULL
|| sym
->attr
.zero_comp
)
9430 gfc_error ("Type definition of %qs at %C was already defined at %L",
9431 sym
->name
, &sym
->declared_at
);
9435 sym
->declared_at
= where
;
9437 if (sym
->attr
.flavor
!= fl
9438 && !gfc_add_flavor (&sym
->attr
, fl
, sym
->name
, NULL
))
9441 if (!sym
->hash_value
)
9442 /* Set the hash for the compound name for this type. */
9443 sym
->hash_value
= gfc_hash_value (sym
);
9445 /* Normally the type is expected to have been completely parsed by the time
9446 a field declaration with this type is seen. For unions, maps, and nested
9447 structure declarations, we need to indicate that it is okay that we
9448 haven't seen any components yet. This will be updated after the structure
9450 sym
->attr
.zero_comp
= 0;
9452 /* Structures always act like derived-types with the SEQUENCE attribute */
9453 gfc_add_sequence (&sym
->attr
, sym
->name
, NULL
);
9455 if (result
) *result
= sym
;
9461 /* Match the opening of a MAP block. Like a struct within a union in C;
9462 behaves identical to STRUCTURE blocks. */
9465 gfc_match_map (void)
9467 /* Counter used to give unique internal names to map structures. */
9468 static unsigned int gfc_map_id
= 0;
9469 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9473 old_loc
= gfc_current_locus
;
9475 if (gfc_match_eos () != MATCH_YES
)
9477 gfc_error ("Junk after MAP statement at %C");
9478 gfc_current_locus
= old_loc
;
9482 /* Map blocks are anonymous so we make up unique names for the symbol table
9483 which are invalid Fortran identifiers. */
9484 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "MM$%u", gfc_map_id
++);
9486 if (!get_struct_decl (name
, FL_STRUCT
, &old_loc
, &sym
))
9489 gfc_new_block
= sym
;
9495 /* Match the opening of a UNION block. */
9498 gfc_match_union (void)
9500 /* Counter used to give unique internal names to union types. */
9501 static unsigned int gfc_union_id
= 0;
9502 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9506 old_loc
= gfc_current_locus
;
9508 if (gfc_match_eos () != MATCH_YES
)
9510 gfc_error ("Junk after UNION statement at %C");
9511 gfc_current_locus
= old_loc
;
9515 /* Unions are anonymous so we make up unique names for the symbol table
9516 which are invalid Fortran identifiers. */
9517 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "UU$%u", gfc_union_id
++);
9519 if (!get_struct_decl (name
, FL_UNION
, &old_loc
, &sym
))
9522 gfc_new_block
= sym
;
9528 /* Match the beginning of a STRUCTURE declaration. This is similar to
9529 matching the beginning of a derived type declaration with a few
9530 twists. The resulting type symbol has no access control or other
9531 interesting attributes. */
9534 gfc_match_structure_decl (void)
9536 /* Counter used to give unique internal names to anonymous structures. */
9537 static unsigned int gfc_structure_id
= 0;
9538 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9543 if (!flag_dec_structure
)
9545 gfc_error ("%s at %C is a DEC extension, enable with "
9546 "%<-fdec-structure%>",
9553 m
= gfc_match (" /%n/", name
);
9556 /* Non-nested structure declarations require a structure name. */
9557 if (!gfc_comp_struct (gfc_current_state ()))
9559 gfc_error ("Structure name expected in non-nested structure "
9560 "declaration at %C");
9563 /* This is an anonymous structure; make up a unique name for it
9564 (upper-case letters never make it to symbol names from the source).
9565 The important thing is initializing the type variable
9566 and setting gfc_new_symbol, which is immediately used by
9567 parse_structure () and variable_decl () to add components of
9569 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "SS$%u", gfc_structure_id
++);
9572 where
= gfc_current_locus
;
9573 /* No field list allowed after non-nested structure declaration. */
9574 if (!gfc_comp_struct (gfc_current_state ())
9575 && gfc_match_eos () != MATCH_YES
)
9577 gfc_error ("Junk after non-nested STRUCTURE statement at %C");
9581 /* Make sure the name is not the name of an intrinsic type. */
9582 if (gfc_is_intrinsic_typename (name
))
9584 gfc_error ("Structure name %qs at %C cannot be the same as an"
9585 " intrinsic type", name
);
9589 /* Store the actual type symbol for the structure with an upper-case first
9590 letter (an invalid Fortran identifier). */
9592 if (!get_struct_decl (gfc_dt_upper_string (name
), FL_STRUCT
, &where
, &sym
))
9595 gfc_new_block
= sym
;
9600 /* This function does some work to determine which matcher should be used to
9601 * match a statement beginning with "TYPE". This is used to disambiguate TYPE
9602 * as an alias for PRINT from derived type declarations, TYPE IS statements,
9603 * and derived type data declarations. */
9606 gfc_match_type (gfc_statement
*st
)
9608 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9612 /* Requires -fdec. */
9616 m
= gfc_match ("type");
9619 /* If we already have an error in the buffer, it is probably from failing to
9620 * match a derived type data declaration. Let it happen. */
9621 else if (gfc_error_flag_test ())
9624 old_loc
= gfc_current_locus
;
9627 /* If we see an attribute list before anything else it's definitely a derived
9628 * type declaration. */
9629 if (gfc_match (" ,") == MATCH_YES
|| gfc_match (" ::") == MATCH_YES
)
9631 gfc_current_locus
= old_loc
;
9632 *st
= ST_DERIVED_DECL
;
9633 return gfc_match_derived_decl ();
9636 /* By now "TYPE" has already been matched. If we do not see a name, this may
9637 * be something like "TYPE *" or "TYPE <fmt>". */
9638 m
= gfc_match_name (name
);
9641 /* Let print match if it can, otherwise throw an error from
9642 * gfc_match_derived_decl. */
9643 gfc_current_locus
= old_loc
;
9644 if (gfc_match_print () == MATCH_YES
)
9649 gfc_current_locus
= old_loc
;
9650 *st
= ST_DERIVED_DECL
;
9651 return gfc_match_derived_decl ();
9654 /* A derived type declaration requires an EOS. Without it, assume print. */
9655 m
= gfc_match_eos ();
9658 /* Check manually for TYPE IS (... - this is invalid print syntax. */
9659 if (strncmp ("is", name
, 3) == 0
9660 && gfc_match (" (", name
) == MATCH_YES
)
9662 gfc_current_locus
= old_loc
;
9663 gcc_assert (gfc_match (" is") == MATCH_YES
);
9665 return gfc_match_type_is ();
9667 gfc_current_locus
= old_loc
;
9669 return gfc_match_print ();
9673 /* By now we have "TYPE <name> <EOS>". Check first if the name is an
9674 * intrinsic typename - if so let gfc_match_derived_decl dump an error.
9675 * Otherwise if gfc_match_derived_decl fails it's probably an existing
9676 * symbol which can be printed. */
9677 gfc_current_locus
= old_loc
;
9678 m
= gfc_match_derived_decl ();
9679 if (gfc_is_intrinsic_typename (name
) || m
== MATCH_YES
)
9681 *st
= ST_DERIVED_DECL
;
9684 gfc_current_locus
= old_loc
;
9686 return gfc_match_print ();
9693 /* Match the beginning of a derived type declaration. If a type name
9694 was the result of a function, then it is possible to have a symbol
9695 already to be known as a derived type yet have no components. */
9698 gfc_match_derived_decl (void)
9700 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9701 char parent
[GFC_MAX_SYMBOL_LEN
+ 1];
9702 symbol_attribute attr
;
9703 gfc_symbol
*sym
, *gensym
;
9704 gfc_symbol
*extended
;
9706 match is_type_attr_spec
= MATCH_NO
;
9707 bool seen_attr
= false;
9708 gfc_interface
*intr
= NULL
, *head
;
9709 bool parameterized_type
= false;
9710 bool seen_colons
= false;
9712 if (gfc_comp_struct (gfc_current_state ()))
9717 gfc_clear_attr (&attr
);
9722 is_type_attr_spec
= gfc_get_type_attr_spec (&attr
, parent
);
9723 if (is_type_attr_spec
== MATCH_ERROR
)
9725 if (is_type_attr_spec
== MATCH_YES
)
9727 } while (is_type_attr_spec
== MATCH_YES
);
9729 /* Deal with derived type extensions. The extension attribute has
9730 been added to 'attr' but now the parent type must be found and
9733 extended
= check_extended_derived_type (parent
);
9735 if (parent
[0] && !extended
)
9738 m
= gfc_match (" ::");
9745 gfc_error ("Expected :: in TYPE definition at %C");
9749 m
= gfc_match (" %n ", name
);
9753 /* Make sure that we don't identify TYPE IS (...) as a parameterized
9754 derived type named 'is'.
9755 TODO Expand the check, when 'name' = "is" by matching " (tname) "
9756 and checking if this is a(n intrinsic) typename. his picks up
9757 misplaced TYPE IS statements such as in select_type_1.f03. */
9758 if (gfc_peek_ascii_char () == '(')
9760 if (gfc_current_state () == COMP_SELECT_TYPE
9761 || (!seen_colons
&& !strcmp (name
, "is")))
9763 parameterized_type
= true;
9766 m
= gfc_match_eos ();
9767 if (m
!= MATCH_YES
&& !parameterized_type
)
9770 /* Make sure the name is not the name of an intrinsic type. */
9771 if (gfc_is_intrinsic_typename (name
))
9773 gfc_error ("Type name %qs at %C cannot be the same as an intrinsic "
9778 if (gfc_get_symbol (name
, NULL
, &gensym
))
9781 if (!gensym
->attr
.generic
&& gensym
->ts
.type
!= BT_UNKNOWN
)
9783 gfc_error ("Derived type name %qs at %C already has a basic type "
9784 "of %s", gensym
->name
, gfc_typename (&gensym
->ts
));
9788 if (!gensym
->attr
.generic
9789 && !gfc_add_generic (&gensym
->attr
, gensym
->name
, NULL
))
9792 if (!gensym
->attr
.function
9793 && !gfc_add_function (&gensym
->attr
, gensym
->name
, NULL
))
9796 sym
= gfc_find_dt_in_generic (gensym
);
9798 if (sym
&& (sym
->components
!= NULL
|| sym
->attr
.zero_comp
))
9800 gfc_error ("Derived type definition of %qs at %C has already been "
9801 "defined", sym
->name
);
9807 /* Use upper case to save the actual derived-type symbol. */
9808 gfc_get_symbol (gfc_dt_upper_string (gensym
->name
), NULL
, &sym
);
9809 sym
->name
= gfc_get_string ("%s", gensym
->name
);
9810 head
= gensym
->generic
;
9811 intr
= gfc_get_interface ();
9813 intr
->where
= gfc_current_locus
;
9814 intr
->sym
->declared_at
= gfc_current_locus
;
9816 gensym
->generic
= intr
;
9817 gensym
->attr
.if_source
= IFSRC_DECL
;
9820 /* The symbol may already have the derived attribute without the
9821 components. The ways this can happen is via a function
9822 definition, an INTRINSIC statement or a subtype in another
9823 derived type that is a pointer. The first part of the AND clause
9824 is true if the symbol is not the return value of a function. */
9825 if (sym
->attr
.flavor
!= FL_DERIVED
9826 && !gfc_add_flavor (&sym
->attr
, FL_DERIVED
, sym
->name
, NULL
))
9829 if (attr
.access
!= ACCESS_UNKNOWN
9830 && !gfc_add_access (&sym
->attr
, attr
.access
, sym
->name
, NULL
))
9832 else if (sym
->attr
.access
== ACCESS_UNKNOWN
9833 && gensym
->attr
.access
!= ACCESS_UNKNOWN
9834 && !gfc_add_access (&sym
->attr
, gensym
->attr
.access
,
9838 if (sym
->attr
.access
!= ACCESS_UNKNOWN
9839 && gensym
->attr
.access
== ACCESS_UNKNOWN
)
9840 gensym
->attr
.access
= sym
->attr
.access
;
9842 /* See if the derived type was labeled as bind(c). */
9843 if (attr
.is_bind_c
!= 0)
9844 sym
->attr
.is_bind_c
= attr
.is_bind_c
;
9846 /* Construct the f2k_derived namespace if it is not yet there. */
9847 if (!sym
->f2k_derived
)
9848 sym
->f2k_derived
= gfc_get_namespace (NULL
, 0);
9850 if (parameterized_type
)
9852 /* Ignore error or mismatches by going to the end of the statement
9853 in order to avoid the component declarations causing problems. */
9854 m
= gfc_match_formal_arglist (sym
, 0, 0, true);
9856 gfc_error_recovery ();
9857 m
= gfc_match_eos ();
9860 sym
->attr
.pdt_template
= 1;
9863 if (extended
&& !sym
->components
)
9866 gfc_formal_arglist
*f
, *g
, *h
;
9868 /* Add the extended derived type as the first component. */
9869 gfc_add_component (sym
, parent
, &p
);
9871 gfc_set_sym_referenced (extended
);
9873 p
->ts
.type
= BT_DERIVED
;
9874 p
->ts
.u
.derived
= extended
;
9875 p
->initializer
= gfc_default_initializer (&p
->ts
);
9877 /* Set extension level. */
9878 if (extended
->attr
.extension
== 255)
9880 /* Since the extension field is 8 bit wide, we can only have
9881 up to 255 extension levels. */
9882 gfc_error ("Maximum extension level reached with type %qs at %L",
9883 extended
->name
, &extended
->declared_at
);
9886 sym
->attr
.extension
= extended
->attr
.extension
+ 1;
9888 /* Provide the links between the extended type and its extension. */
9889 if (!extended
->f2k_derived
)
9890 extended
->f2k_derived
= gfc_get_namespace (NULL
, 0);
9892 /* Copy the extended type-param-name-list from the extended type,
9893 append those of the extension and add the whole lot to the
9895 if (extended
->attr
.pdt_template
)
9898 sym
->attr
.pdt_template
= 1;
9899 for (f
= extended
->formal
; f
; f
= f
->next
)
9901 if (f
== extended
->formal
)
9903 g
= gfc_get_formal_arglist ();
9908 g
->next
= gfc_get_formal_arglist ();
9913 g
->next
= sym
->formal
;
9918 if (!sym
->hash_value
)
9919 /* Set the hash for the compound name for this type. */
9920 sym
->hash_value
= gfc_hash_value (sym
);
9922 /* Take over the ABSTRACT attribute. */
9923 sym
->attr
.abstract
= attr
.abstract
;
9925 gfc_new_block
= sym
;
9931 /* Cray Pointees can be declared as:
9932 pointer (ipt, a (n,m,...,*)) */
9935 gfc_mod_pointee_as (gfc_array_spec
*as
)
9937 as
->cray_pointee
= true; /* This will be useful to know later. */
9938 if (as
->type
== AS_ASSUMED_SIZE
)
9939 as
->cp_was_assumed
= true;
9940 else if (as
->type
== AS_ASSUMED_SHAPE
)
9942 gfc_error ("Cray Pointee at %C cannot be assumed shape array");
9949 /* Match the enum definition statement, here we are trying to match
9950 the first line of enum definition statement.
9951 Returns MATCH_YES if match is found. */
9954 gfc_match_enum (void)
9958 m
= gfc_match_eos ();
9962 if (!gfc_notify_std (GFC_STD_F2003
, "ENUM and ENUMERATOR at %C"))
9969 /* Returns an initializer whose value is one higher than the value of the
9970 LAST_INITIALIZER argument. If the argument is NULL, the
9971 initializers value will be set to zero. The initializer's kind
9972 will be set to gfc_c_int_kind.
9974 If -fshort-enums is given, the appropriate kind will be selected
9975 later after all enumerators have been parsed. A warning is issued
9976 here if an initializer exceeds gfc_c_int_kind. */
9979 enum_initializer (gfc_expr
*last_initializer
, locus where
)
9982 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_c_int_kind
, &where
);
9984 mpz_init (result
->value
.integer
);
9986 if (last_initializer
!= NULL
)
9988 mpz_add_ui (result
->value
.integer
, last_initializer
->value
.integer
, 1);
9989 result
->where
= last_initializer
->where
;
9991 if (gfc_check_integer_range (result
->value
.integer
,
9992 gfc_c_int_kind
) != ARITH_OK
)
9994 gfc_error ("Enumerator exceeds the C integer type at %C");
10000 /* Control comes here, if it's the very first enumerator and no
10001 initializer has been given. It will be initialized to zero. */
10002 mpz_set_si (result
->value
.integer
, 0);
10009 /* Match a variable name with an optional initializer. When this
10010 subroutine is called, a variable is expected to be parsed next.
10011 Depending on what is happening at the moment, updates either the
10012 symbol table or the current interface. */
10015 enumerator_decl (void)
10017 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10018 gfc_expr
*initializer
;
10019 gfc_array_spec
*as
= NULL
;
10026 initializer
= NULL
;
10027 old_locus
= gfc_current_locus
;
10029 /* When we get here, we've just matched a list of attributes and
10030 maybe a type and a double colon. The next thing we expect to see
10031 is the name of the symbol. */
10032 m
= gfc_match_name (name
);
10033 if (m
!= MATCH_YES
)
10036 var_locus
= gfc_current_locus
;
10038 /* OK, we've successfully matched the declaration. Now put the
10039 symbol in the current namespace. If we fail to create the symbol,
10041 if (!build_sym (name
, NULL
, false, &as
, &var_locus
))
10047 /* The double colon must be present in order to have initializers.
10048 Otherwise the statement is ambiguous with an assignment statement. */
10051 if (gfc_match_char ('=') == MATCH_YES
)
10053 m
= gfc_match_init_expr (&initializer
);
10056 gfc_error ("Expected an initialization expression at %C");
10060 if (m
!= MATCH_YES
)
10065 /* If we do not have an initializer, the initialization value of the
10066 previous enumerator (stored in last_initializer) is incremented
10067 by 1 and is used to initialize the current enumerator. */
10068 if (initializer
== NULL
)
10069 initializer
= enum_initializer (last_initializer
, old_locus
);
10071 if (initializer
== NULL
|| initializer
->ts
.type
!= BT_INTEGER
)
10073 gfc_error ("ENUMERATOR %L not initialized with integer expression",
10079 /* Store this current initializer, for the next enumerator variable
10080 to be parsed. add_init_expr_to_sym() zeros initializer, so we
10081 use last_initializer below. */
10082 last_initializer
= initializer
;
10083 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
10085 /* Maintain enumerator history. */
10086 gfc_find_symbol (name
, NULL
, 0, &sym
);
10087 create_enum_history (sym
, last_initializer
);
10089 return (t
) ? MATCH_YES
: MATCH_ERROR
;
10092 /* Free stuff up and return. */
10093 gfc_free_expr (initializer
);
10099 /* Match the enumerator definition statement. */
10102 gfc_match_enumerator_def (void)
10107 gfc_clear_ts (¤t_ts
);
10109 m
= gfc_match (" enumerator");
10110 if (m
!= MATCH_YES
)
10113 m
= gfc_match (" :: ");
10114 if (m
== MATCH_ERROR
)
10117 colon_seen
= (m
== MATCH_YES
);
10119 if (gfc_current_state () != COMP_ENUM
)
10121 gfc_error ("ENUM definition statement expected before %C");
10122 gfc_free_enum_history ();
10123 return MATCH_ERROR
;
10126 (¤t_ts
)->type
= BT_INTEGER
;
10127 (¤t_ts
)->kind
= gfc_c_int_kind
;
10129 gfc_clear_attr (¤t_attr
);
10130 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, NULL
);
10139 m
= enumerator_decl ();
10140 if (m
== MATCH_ERROR
)
10142 gfc_free_enum_history ();
10148 if (gfc_match_eos () == MATCH_YES
)
10150 if (gfc_match_char (',') != MATCH_YES
)
10154 if (gfc_current_state () == COMP_ENUM
)
10156 gfc_free_enum_history ();
10157 gfc_error ("Syntax error in ENUMERATOR definition at %C");
10162 gfc_free_array_spec (current_as
);
10169 /* Match binding attributes. */
10172 match_binding_attributes (gfc_typebound_proc
* ba
, bool generic
, bool ppc
)
10174 bool found_passing
= false;
10175 bool seen_ptr
= false;
10176 match m
= MATCH_YES
;
10178 /* Initialize to defaults. Do so even before the MATCH_NO check so that in
10179 this case the defaults are in there. */
10180 ba
->access
= ACCESS_UNKNOWN
;
10181 ba
->pass_arg
= NULL
;
10182 ba
->pass_arg_num
= 0;
10184 ba
->non_overridable
= 0;
10188 /* If we find a comma, we believe there are binding attributes. */
10189 m
= gfc_match_char (',');
10195 /* Access specifier. */
10197 m
= gfc_match (" public");
10198 if (m
== MATCH_ERROR
)
10200 if (m
== MATCH_YES
)
10202 if (ba
->access
!= ACCESS_UNKNOWN
)
10204 gfc_error ("Duplicate access-specifier at %C");
10208 ba
->access
= ACCESS_PUBLIC
;
10212 m
= gfc_match (" private");
10213 if (m
== MATCH_ERROR
)
10215 if (m
== MATCH_YES
)
10217 if (ba
->access
!= ACCESS_UNKNOWN
)
10219 gfc_error ("Duplicate access-specifier at %C");
10223 ba
->access
= ACCESS_PRIVATE
;
10227 /* If inside GENERIC, the following is not allowed. */
10232 m
= gfc_match (" nopass");
10233 if (m
== MATCH_ERROR
)
10235 if (m
== MATCH_YES
)
10239 gfc_error ("Binding attributes already specify passing,"
10240 " illegal NOPASS at %C");
10244 found_passing
= true;
10249 /* PASS possibly including argument. */
10250 m
= gfc_match (" pass");
10251 if (m
== MATCH_ERROR
)
10253 if (m
== MATCH_YES
)
10255 char arg
[GFC_MAX_SYMBOL_LEN
+ 1];
10259 gfc_error ("Binding attributes already specify passing,"
10260 " illegal PASS at %C");
10264 m
= gfc_match (" ( %n )", arg
);
10265 if (m
== MATCH_ERROR
)
10267 if (m
== MATCH_YES
)
10268 ba
->pass_arg
= gfc_get_string ("%s", arg
);
10269 gcc_assert ((m
== MATCH_YES
) == (ba
->pass_arg
!= NULL
));
10271 found_passing
= true;
10278 /* POINTER flag. */
10279 m
= gfc_match (" pointer");
10280 if (m
== MATCH_ERROR
)
10282 if (m
== MATCH_YES
)
10286 gfc_error ("Duplicate POINTER attribute at %C");
10296 /* NON_OVERRIDABLE flag. */
10297 m
= gfc_match (" non_overridable");
10298 if (m
== MATCH_ERROR
)
10300 if (m
== MATCH_YES
)
10302 if (ba
->non_overridable
)
10304 gfc_error ("Duplicate NON_OVERRIDABLE at %C");
10308 ba
->non_overridable
= 1;
10312 /* DEFERRED flag. */
10313 m
= gfc_match (" deferred");
10314 if (m
== MATCH_ERROR
)
10316 if (m
== MATCH_YES
)
10320 gfc_error ("Duplicate DEFERRED at %C");
10331 /* Nothing matching found. */
10333 gfc_error ("Expected access-specifier at %C");
10335 gfc_error ("Expected binding attribute at %C");
10338 while (gfc_match_char (',') == MATCH_YES
);
10340 /* NON_OVERRIDABLE and DEFERRED exclude themselves. */
10341 if (ba
->non_overridable
&& ba
->deferred
)
10343 gfc_error ("NON_OVERRIDABLE and DEFERRED can't both appear at %C");
10350 if (ba
->access
== ACCESS_UNKNOWN
)
10351 ba
->access
= gfc_typebound_default_access
;
10353 if (ppc
&& !seen_ptr
)
10355 gfc_error ("POINTER attribute is required for procedure pointer component"
10363 return MATCH_ERROR
;
10367 /* Match a PROCEDURE specific binding inside a derived type. */
10370 match_procedure_in_type (void)
10372 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10373 char target_buf
[GFC_MAX_SYMBOL_LEN
+ 1];
10374 char* target
= NULL
, *ifc
= NULL
;
10375 gfc_typebound_proc tb
;
10379 gfc_symtree
* stree
;
10384 /* Check current state. */
10385 gcc_assert (gfc_state_stack
->state
== COMP_DERIVED_CONTAINS
);
10386 block
= gfc_state_stack
->previous
->sym
;
10387 gcc_assert (block
);
10389 /* Try to match PROCEDURE(interface). */
10390 if (gfc_match (" (") == MATCH_YES
)
10392 m
= gfc_match_name (target_buf
);
10393 if (m
== MATCH_ERROR
)
10395 if (m
!= MATCH_YES
)
10397 gfc_error ("Interface-name expected after %<(%> at %C");
10398 return MATCH_ERROR
;
10401 if (gfc_match (" )") != MATCH_YES
)
10403 gfc_error ("%<)%> expected at %C");
10404 return MATCH_ERROR
;
10410 /* Construct the data structure. */
10411 memset (&tb
, 0, sizeof (tb
));
10412 tb
.where
= gfc_current_locus
;
10414 /* Match binding attributes. */
10415 m
= match_binding_attributes (&tb
, false, false);
10416 if (m
== MATCH_ERROR
)
10418 seen_attrs
= (m
== MATCH_YES
);
10420 /* Check that attribute DEFERRED is given if an interface is specified. */
10421 if (tb
.deferred
&& !ifc
)
10423 gfc_error ("Interface must be specified for DEFERRED binding at %C");
10424 return MATCH_ERROR
;
10426 if (ifc
&& !tb
.deferred
)
10428 gfc_error ("PROCEDURE(interface) at %C should be declared DEFERRED");
10429 return MATCH_ERROR
;
10432 /* Match the colons. */
10433 m
= gfc_match (" ::");
10434 if (m
== MATCH_ERROR
)
10436 seen_colons
= (m
== MATCH_YES
);
10437 if (seen_attrs
&& !seen_colons
)
10439 gfc_error ("Expected %<::%> after binding-attributes at %C");
10440 return MATCH_ERROR
;
10443 /* Match the binding names. */
10446 m
= gfc_match_name (name
);
10447 if (m
== MATCH_ERROR
)
10451 gfc_error ("Expected binding name at %C");
10452 return MATCH_ERROR
;
10455 if (num
>1 && !gfc_notify_std (GFC_STD_F2008
, "PROCEDURE list at %C"))
10456 return MATCH_ERROR
;
10458 /* Try to match the '=> target', if it's there. */
10460 m
= gfc_match (" =>");
10461 if (m
== MATCH_ERROR
)
10463 if (m
== MATCH_YES
)
10467 gfc_error ("%<=> target%> is invalid for DEFERRED binding at %C");
10468 return MATCH_ERROR
;
10473 gfc_error ("%<::%> needed in PROCEDURE binding with explicit target"
10475 return MATCH_ERROR
;
10478 m
= gfc_match_name (target_buf
);
10479 if (m
== MATCH_ERROR
)
10483 gfc_error ("Expected binding target after %<=>%> at %C");
10484 return MATCH_ERROR
;
10486 target
= target_buf
;
10489 /* If no target was found, it has the same name as the binding. */
10493 /* Get the namespace to insert the symbols into. */
10494 ns
= block
->f2k_derived
;
10497 /* If the binding is DEFERRED, check that the containing type is ABSTRACT. */
10498 if (tb
.deferred
&& !block
->attr
.abstract
)
10500 gfc_error ("Type %qs containing DEFERRED binding at %C "
10501 "is not ABSTRACT", block
->name
);
10502 return MATCH_ERROR
;
10505 /* See if we already have a binding with this name in the symtree which
10506 would be an error. If a GENERIC already targeted this binding, it may
10507 be already there but then typebound is still NULL. */
10508 stree
= gfc_find_symtree (ns
->tb_sym_root
, name
);
10509 if (stree
&& stree
->n
.tb
)
10511 gfc_error ("There is already a procedure with binding name %qs for "
10512 "the derived type %qs at %C", name
, block
->name
);
10513 return MATCH_ERROR
;
10516 /* Insert it and set attributes. */
10520 stree
= gfc_new_symtree (&ns
->tb_sym_root
, name
);
10521 gcc_assert (stree
);
10523 stree
->n
.tb
= gfc_get_typebound_proc (&tb
);
10525 if (gfc_get_sym_tree (target
, gfc_current_ns
, &stree
->n
.tb
->u
.specific
,
10527 return MATCH_ERROR
;
10528 gfc_set_sym_referenced (stree
->n
.tb
->u
.specific
->n
.sym
);
10529 gfc_add_flavor(&stree
->n
.tb
->u
.specific
->n
.sym
->attr
, FL_PROCEDURE
,
10530 target
, &stree
->n
.tb
->u
.specific
->n
.sym
->declared_at
);
10532 if (gfc_match_eos () == MATCH_YES
)
10534 if (gfc_match_char (',') != MATCH_YES
)
10539 gfc_error ("Syntax error in PROCEDURE statement at %C");
10540 return MATCH_ERROR
;
10544 /* Match a GENERIC procedure binding inside a derived type. */
10547 gfc_match_generic (void)
10549 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10550 char bind_name
[GFC_MAX_SYMBOL_LEN
+ 16]; /* Allow space for OPERATOR(...). */
10552 gfc_typebound_proc tbattr
; /* Used for match_binding_attributes. */
10553 gfc_typebound_proc
* tb
;
10555 interface_type op_type
;
10556 gfc_intrinsic_op op
;
10559 /* Check current state. */
10560 if (gfc_current_state () == COMP_DERIVED
)
10562 gfc_error ("GENERIC at %C must be inside a derived-type CONTAINS");
10563 return MATCH_ERROR
;
10565 if (gfc_current_state () != COMP_DERIVED_CONTAINS
)
10567 block
= gfc_state_stack
->previous
->sym
;
10568 ns
= block
->f2k_derived
;
10569 gcc_assert (block
&& ns
);
10571 memset (&tbattr
, 0, sizeof (tbattr
));
10572 tbattr
.where
= gfc_current_locus
;
10574 /* See if we get an access-specifier. */
10575 m
= match_binding_attributes (&tbattr
, true, false);
10576 if (m
== MATCH_ERROR
)
10579 /* Now the colons, those are required. */
10580 if (gfc_match (" ::") != MATCH_YES
)
10582 gfc_error ("Expected %<::%> at %C");
10586 /* Match the binding name; depending on type (operator / generic) format
10587 it for future error messages into bind_name. */
10589 m
= gfc_match_generic_spec (&op_type
, name
, &op
);
10590 if (m
== MATCH_ERROR
)
10591 return MATCH_ERROR
;
10594 gfc_error ("Expected generic name or operator descriptor at %C");
10600 case INTERFACE_GENERIC
:
10601 case INTERFACE_DTIO
:
10602 snprintf (bind_name
, sizeof (bind_name
), "%s", name
);
10605 case INTERFACE_USER_OP
:
10606 snprintf (bind_name
, sizeof (bind_name
), "OPERATOR(.%s.)", name
);
10609 case INTERFACE_INTRINSIC_OP
:
10610 snprintf (bind_name
, sizeof (bind_name
), "OPERATOR(%s)",
10611 gfc_op2string (op
));
10614 case INTERFACE_NAMELESS
:
10615 gfc_error ("Malformed GENERIC statement at %C");
10620 gcc_unreachable ();
10623 /* Match the required =>. */
10624 if (gfc_match (" =>") != MATCH_YES
)
10626 gfc_error ("Expected %<=>%> at %C");
10630 /* Try to find existing GENERIC binding with this name / for this operator;
10631 if there is something, check that it is another GENERIC and then extend
10632 it rather than building a new node. Otherwise, create it and put it
10633 at the right position. */
10637 case INTERFACE_DTIO
:
10638 case INTERFACE_USER_OP
:
10639 case INTERFACE_GENERIC
:
10641 const bool is_op
= (op_type
== INTERFACE_USER_OP
);
10644 st
= gfc_find_symtree (is_op
? ns
->tb_uop_root
: ns
->tb_sym_root
, name
);
10645 tb
= st
? st
->n
.tb
: NULL
;
10649 case INTERFACE_INTRINSIC_OP
:
10650 tb
= ns
->tb_op
[op
];
10654 gcc_unreachable ();
10659 if (!tb
->is_generic
)
10661 gcc_assert (op_type
== INTERFACE_GENERIC
);
10662 gfc_error ("There's already a non-generic procedure with binding name"
10663 " %qs for the derived type %qs at %C",
10664 bind_name
, block
->name
);
10668 if (tb
->access
!= tbattr
.access
)
10670 gfc_error ("Binding at %C must have the same access as already"
10671 " defined binding %qs", bind_name
);
10677 tb
= gfc_get_typebound_proc (NULL
);
10678 tb
->where
= gfc_current_locus
;
10679 tb
->access
= tbattr
.access
;
10680 tb
->is_generic
= 1;
10681 tb
->u
.generic
= NULL
;
10685 case INTERFACE_DTIO
:
10686 case INTERFACE_GENERIC
:
10687 case INTERFACE_USER_OP
:
10689 const bool is_op
= (op_type
== INTERFACE_USER_OP
);
10690 gfc_symtree
* st
= gfc_get_tbp_symtree (is_op
? &ns
->tb_uop_root
:
10691 &ns
->tb_sym_root
, name
);
10698 case INTERFACE_INTRINSIC_OP
:
10699 ns
->tb_op
[op
] = tb
;
10703 gcc_unreachable ();
10707 /* Now, match all following names as specific targets. */
10710 gfc_symtree
* target_st
;
10711 gfc_tbp_generic
* target
;
10713 m
= gfc_match_name (name
);
10714 if (m
== MATCH_ERROR
)
10718 gfc_error ("Expected specific binding name at %C");
10722 target_st
= gfc_get_tbp_symtree (&ns
->tb_sym_root
, name
);
10724 /* See if this is a duplicate specification. */
10725 for (target
= tb
->u
.generic
; target
; target
= target
->next
)
10726 if (target_st
== target
->specific_st
)
10728 gfc_error ("%qs already defined as specific binding for the"
10729 " generic %qs at %C", name
, bind_name
);
10733 target
= gfc_get_tbp_generic ();
10734 target
->specific_st
= target_st
;
10735 target
->specific
= NULL
;
10736 target
->next
= tb
->u
.generic
;
10737 target
->is_operator
= ((op_type
== INTERFACE_USER_OP
)
10738 || (op_type
== INTERFACE_INTRINSIC_OP
));
10739 tb
->u
.generic
= target
;
10741 while (gfc_match (" ,") == MATCH_YES
);
10743 /* Here should be the end. */
10744 if (gfc_match_eos () != MATCH_YES
)
10746 gfc_error ("Junk after GENERIC binding at %C");
10753 return MATCH_ERROR
;
10757 /* Match a FINAL declaration inside a derived type. */
10760 gfc_match_final_decl (void)
10762 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10765 gfc_namespace
* module_ns
;
10769 if (gfc_current_form
== FORM_FREE
)
10771 char c
= gfc_peek_ascii_char ();
10772 if (!gfc_is_whitespace (c
) && c
!= ':')
10776 if (gfc_state_stack
->state
!= COMP_DERIVED_CONTAINS
)
10778 if (gfc_current_form
== FORM_FIXED
)
10781 gfc_error ("FINAL declaration at %C must be inside a derived type "
10782 "CONTAINS section");
10783 return MATCH_ERROR
;
10786 block
= gfc_state_stack
->previous
->sym
;
10787 gcc_assert (block
);
10789 if (!gfc_state_stack
->previous
|| !gfc_state_stack
->previous
->previous
10790 || gfc_state_stack
->previous
->previous
->state
!= COMP_MODULE
)
10792 gfc_error ("Derived type declaration with FINAL at %C must be in the"
10793 " specification part of a MODULE");
10794 return MATCH_ERROR
;
10797 module_ns
= gfc_current_ns
;
10798 gcc_assert (module_ns
);
10799 gcc_assert (module_ns
->proc_name
->attr
.flavor
== FL_MODULE
);
10801 /* Match optional ::, don't care about MATCH_YES or MATCH_NO. */
10802 if (gfc_match (" ::") == MATCH_ERROR
)
10803 return MATCH_ERROR
;
10805 /* Match the sequence of procedure names. */
10812 if (first
&& gfc_match_eos () == MATCH_YES
)
10814 gfc_error ("Empty FINAL at %C");
10815 return MATCH_ERROR
;
10818 m
= gfc_match_name (name
);
10821 gfc_error ("Expected module procedure name at %C");
10822 return MATCH_ERROR
;
10824 else if (m
!= MATCH_YES
)
10825 return MATCH_ERROR
;
10827 if (gfc_match_eos () == MATCH_YES
)
10829 if (!last
&& gfc_match_char (',') != MATCH_YES
)
10831 gfc_error ("Expected %<,%> at %C");
10832 return MATCH_ERROR
;
10835 if (gfc_get_symbol (name
, module_ns
, &sym
))
10837 gfc_error ("Unknown procedure name %qs at %C", name
);
10838 return MATCH_ERROR
;
10841 /* Mark the symbol as module procedure. */
10842 if (sym
->attr
.proc
!= PROC_MODULE
10843 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
10844 return MATCH_ERROR
;
10846 /* Check if we already have this symbol in the list, this is an error. */
10847 for (f
= block
->f2k_derived
->finalizers
; f
; f
= f
->next
)
10848 if (f
->proc_sym
== sym
)
10850 gfc_error ("%qs at %C is already defined as FINAL procedure",
10852 return MATCH_ERROR
;
10855 /* Add this symbol to the list of finalizers. */
10856 gcc_assert (block
->f2k_derived
);
10858 f
= XCNEW (gfc_finalizer
);
10860 f
->proc_tree
= NULL
;
10861 f
->where
= gfc_current_locus
;
10862 f
->next
= block
->f2k_derived
->finalizers
;
10863 block
->f2k_derived
->finalizers
= f
;
10873 const ext_attr_t ext_attr_list
[] = {
10874 { "dllimport", EXT_ATTR_DLLIMPORT
, "dllimport" },
10875 { "dllexport", EXT_ATTR_DLLEXPORT
, "dllexport" },
10876 { "cdecl", EXT_ATTR_CDECL
, "cdecl" },
10877 { "stdcall", EXT_ATTR_STDCALL
, "stdcall" },
10878 { "fastcall", EXT_ATTR_FASTCALL
, "fastcall" },
10879 { "no_arg_check", EXT_ATTR_NO_ARG_CHECK
, NULL
},
10880 { NULL
, EXT_ATTR_LAST
, NULL
}
10883 /* Match a !GCC$ ATTRIBUTES statement of the form:
10884 !GCC$ ATTRIBUTES attribute-list :: var-name [, var-name] ...
10885 When we come here, we have already matched the !GCC$ ATTRIBUTES string.
10887 TODO: We should support all GCC attributes using the same syntax for
10888 the attribute list, i.e. the list in C
10889 __attributes(( attribute-list ))
10891 !GCC$ ATTRIBUTES attribute-list ::
10892 Cf. c-parser.c's c_parser_attributes; the data can then directly be
10895 As there is absolutely no risk of confusion, we should never return
10898 gfc_match_gcc_attributes (void)
10900 symbol_attribute attr
;
10901 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10906 gfc_clear_attr (&attr
);
10911 if (gfc_match_name (name
) != MATCH_YES
)
10912 return MATCH_ERROR
;
10914 for (id
= 0; id
< EXT_ATTR_LAST
; id
++)
10915 if (strcmp (name
, ext_attr_list
[id
].name
) == 0)
10918 if (id
== EXT_ATTR_LAST
)
10920 gfc_error ("Unknown attribute in !GCC$ ATTRIBUTES statement at %C");
10921 return MATCH_ERROR
;
10924 if (!gfc_add_ext_attribute (&attr
, (ext_attr_id_t
)id
, &gfc_current_locus
))
10925 return MATCH_ERROR
;
10927 gfc_gobble_whitespace ();
10928 ch
= gfc_next_ascii_char ();
10931 /* This is the successful exit condition for the loop. */
10932 if (gfc_next_ascii_char () == ':')
10942 if (gfc_match_eos () == MATCH_YES
)
10947 m
= gfc_match_name (name
);
10948 if (m
!= MATCH_YES
)
10951 if (find_special (name
, &sym
, true))
10952 return MATCH_ERROR
;
10954 sym
->attr
.ext_attr
|= attr
.ext_attr
;
10956 if (gfc_match_eos () == MATCH_YES
)
10959 if (gfc_match_char (',') != MATCH_YES
)
10966 gfc_error ("Syntax error in !GCC$ ATTRIBUTES statement at %C");
10967 return MATCH_ERROR
;
10971 /* Match a !GCC$ UNROLL statement of the form:
10974 The parameter n is the number of times we are supposed to unroll.
10976 When we come here, we have already matched the !GCC$ UNROLL string. */
10978 gfc_match_gcc_unroll (void)
10982 if (gfc_match_small_int (&value
) == MATCH_YES
)
10984 if (value
< 0 || value
> USHRT_MAX
)
10986 gfc_error ("%<GCC unroll%> directive requires a"
10987 " non-negative integral constant"
10988 " less than or equal to %u at %C",
10991 return MATCH_ERROR
;
10993 if (gfc_match_eos () == MATCH_YES
)
10995 directive_unroll
= value
== 0 ? 1 : value
;
11000 gfc_error ("Syntax error in !GCC$ UNROLL directive at %C");
11001 return MATCH_ERROR
;