1 /* Declaration statement matcher
2 Copyright (C) 2002-2023 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"
33 /* Macros to access allocate memory for gfc_data_variable,
34 gfc_data_value and gfc_data. */
35 #define gfc_get_data_variable() XCNEW (gfc_data_variable)
36 #define gfc_get_data_value() XCNEW (gfc_data_value)
37 #define gfc_get_data() XCNEW (gfc_data)
40 static bool set_binding_label (const char **, const char *, int);
43 /* This flag is set if an old-style length selector is matched
44 during a type-declaration statement. */
46 static int old_char_selector
;
48 /* When variables acquire types and attributes from a declaration
49 statement, they get them from the following static variables. The
50 first part of a declaration sets these variables and the second
51 part copies these into symbol structures. */
53 static gfc_typespec current_ts
;
55 static symbol_attribute current_attr
;
56 static gfc_array_spec
*current_as
;
57 static int colon_seen
;
60 /* The current binding label (if any). */
61 static const char* curr_binding_label
;
62 /* Need to know how many identifiers are on the current data declaration
63 line in case we're given the BIND(C) attribute with a NAME= specifier. */
64 static int num_idents_on_line
;
65 /* Need to know if a NAME= specifier was found during gfc_match_bind_c so we
66 can supply a name if the curr_binding_label is nil and NAME= was not. */
67 static int has_name_equals
= 0;
69 /* Initializer of the previous enumerator. */
71 static gfc_expr
*last_initializer
;
73 /* History of all the enumerators is maintained, so that
74 kind values of all the enumerators could be updated depending
75 upon the maximum initialized value. */
77 typedef struct enumerator_history
80 gfc_expr
*initializer
;
81 struct enumerator_history
*next
;
85 /* Header of enum history chain. */
87 static enumerator_history
*enum_history
= NULL
;
89 /* Pointer of enum history node containing largest initializer. */
91 static enumerator_history
*max_enum
= NULL
;
93 /* gfc_new_block points to the symbol of a newly matched block. */
95 gfc_symbol
*gfc_new_block
;
97 bool gfc_matching_function
;
99 /* Set upon parsing a !GCC$ unroll n directive for use in the next loop. */
100 int directive_unroll
= -1;
102 /* Set upon parsing supported !GCC$ pragmas for use in the next loop. */
103 bool directive_ivdep
= false;
104 bool directive_vector
= false;
105 bool directive_novector
= false;
107 /* Map of middle-end built-ins that should be vectorized. */
108 hash_map
<nofree_string_hash
, int> *gfc_vectorized_builtins
;
110 /* If a kind expression of a component of a parameterized derived type is
111 parameterized, temporarily store the expression here. */
112 static gfc_expr
*saved_kind_expr
= NULL
;
114 /* Used to store the parameter list arising in a PDT declaration and
115 in the typespec of a PDT variable or component. */
116 static gfc_actual_arglist
*decl_type_param_list
;
117 static gfc_actual_arglist
*type_param_spec_list
;
119 /********************* DATA statement subroutines *********************/
121 static bool in_match_data
= false;
124 gfc_in_match_data (void)
126 return in_match_data
;
130 set_in_match_data (bool set_value
)
132 in_match_data
= set_value
;
135 /* Free a gfc_data_variable structure and everything beneath it. */
138 free_variable (gfc_data_variable
*p
)
140 gfc_data_variable
*q
;
145 gfc_free_expr (p
->expr
);
146 gfc_free_iterator (&p
->iter
, 0);
147 free_variable (p
->list
);
153 /* Free a gfc_data_value structure and everything beneath it. */
156 free_value (gfc_data_value
*p
)
163 mpz_clear (p
->repeat
);
164 gfc_free_expr (p
->expr
);
170 /* Free a list of gfc_data structures. */
173 gfc_free_data (gfc_data
*p
)
180 free_variable (p
->var
);
181 free_value (p
->value
);
187 /* Free all data in a namespace. */
190 gfc_free_data_all (gfc_namespace
*ns
)
202 /* Reject data parsed since the last restore point was marked. */
205 gfc_reject_data (gfc_namespace
*ns
)
209 while (ns
->data
&& ns
->data
!= ns
->old_data
)
217 static match
var_element (gfc_data_variable
*);
219 /* Match a list of variables terminated by an iterator and a right
223 var_list (gfc_data_variable
*parent
)
225 gfc_data_variable
*tail
, var
;
228 m
= var_element (&var
);
229 if (m
== MATCH_ERROR
)
234 tail
= gfc_get_data_variable ();
241 if (gfc_match_char (',') != MATCH_YES
)
244 m
= gfc_match_iterator (&parent
->iter
, 1);
247 if (m
== MATCH_ERROR
)
250 m
= var_element (&var
);
251 if (m
== MATCH_ERROR
)
256 tail
->next
= gfc_get_data_variable ();
262 if (gfc_match_char (')') != MATCH_YES
)
267 gfc_syntax_error (ST_DATA
);
272 /* Match a single element in a data variable list, which can be a
273 variable-iterator list. */
276 var_element (gfc_data_variable
*new_var
)
281 memset (new_var
, 0, sizeof (gfc_data_variable
));
283 if (gfc_match_char ('(') == MATCH_YES
)
284 return var_list (new_var
);
286 m
= gfc_match_variable (&new_var
->expr
, 0);
290 if (new_var
->expr
->expr_type
== EXPR_CONSTANT
291 && new_var
->expr
->symtree
== NULL
)
293 gfc_error ("Inquiry parameter cannot appear in a "
294 "data-stmt-object-list at %C");
298 sym
= new_var
->expr
->symtree
->n
.sym
;
300 /* Symbol should already have an associated type. */
301 if (!gfc_check_symbol_typed (sym
, gfc_current_ns
, false, gfc_current_locus
))
304 if (!sym
->attr
.function
&& gfc_current_ns
->parent
305 && gfc_current_ns
->parent
== sym
->ns
)
307 gfc_error ("Host associated variable %qs may not be in the DATA "
308 "statement at %C", sym
->name
);
312 if (gfc_current_state () != COMP_BLOCK_DATA
313 && sym
->attr
.in_common
314 && !gfc_notify_std (GFC_STD_GNU
, "initialization of "
315 "common block variable %qs in DATA statement at %C",
319 if (!gfc_add_data (&sym
->attr
, sym
->name
, &new_var
->expr
->where
))
326 /* Match the top-level list of data variables. */
329 top_var_list (gfc_data
*d
)
331 gfc_data_variable var
, *tail
, *new_var
;
338 m
= var_element (&var
);
341 if (m
== MATCH_ERROR
)
344 new_var
= gfc_get_data_variable ();
347 new_var
->expr
->where
= gfc_current_locus
;
352 tail
->next
= new_var
;
356 if (gfc_match_char ('/') == MATCH_YES
)
358 if (gfc_match_char (',') != MATCH_YES
)
365 gfc_syntax_error (ST_DATA
);
366 gfc_free_data_all (gfc_current_ns
);
372 match_data_constant (gfc_expr
**result
)
374 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
375 gfc_symbol
*sym
, *dt_sym
= NULL
;
380 m
= gfc_match_literal_constant (&expr
, 1);
387 if (m
== MATCH_ERROR
)
390 m
= gfc_match_null (result
);
394 old_loc
= gfc_current_locus
;
396 /* Should this be a structure component, try to match it
397 before matching a name. */
398 m
= gfc_match_rvalue (result
);
399 if (m
== MATCH_ERROR
)
402 if (m
== MATCH_YES
&& (*result
)->expr_type
== EXPR_STRUCTURE
)
404 if (!gfc_simplify_expr (*result
, 0))
408 else if (m
== MATCH_YES
)
410 /* If a parameter inquiry ends up here, symtree is NULL but **result
411 contains the right constant expression. Check here. */
412 if ((*result
)->symtree
== NULL
413 && (*result
)->expr_type
== EXPR_CONSTANT
414 && ((*result
)->ts
.type
== BT_INTEGER
415 || (*result
)->ts
.type
== BT_REAL
))
418 /* F2018:R845 data-stmt-constant is initial-data-target.
419 A data-stmt-constant shall be ... initial-data-target if and
420 only if the corresponding data-stmt-object has the POINTER
421 attribute. ... If data-stmt-constant is initial-data-target
422 the corresponding data statement object shall be
423 data-pointer-initialization compatible (7.5.4.6) with the initial
424 data target; the data statement object is initially associated
426 if ((*result
)->symtree
427 && (*result
)->symtree
->n
.sym
->attr
.save
428 && (*result
)->symtree
->n
.sym
->attr
.target
)
430 gfc_free_expr (*result
);
433 gfc_current_locus
= old_loc
;
435 m
= gfc_match_name (name
);
439 if (gfc_find_symbol (name
, NULL
, 1, &sym
))
442 if (sym
&& sym
->attr
.generic
)
443 dt_sym
= gfc_find_dt_in_generic (sym
);
446 || (sym
->attr
.flavor
!= FL_PARAMETER
447 && (!dt_sym
|| !gfc_fl_struct (dt_sym
->attr
.flavor
))))
449 gfc_error ("Symbol %qs must be a PARAMETER in DATA statement at %C",
454 else if (dt_sym
&& gfc_fl_struct (dt_sym
->attr
.flavor
))
455 return gfc_match_structure_constructor (dt_sym
, result
);
457 /* Check to see if the value is an initialization array expression. */
458 if (sym
->value
->expr_type
== EXPR_ARRAY
)
460 gfc_current_locus
= old_loc
;
462 m
= gfc_match_init_expr (result
);
463 if (m
== MATCH_ERROR
)
468 if (!gfc_simplify_expr (*result
, 0))
471 if ((*result
)->expr_type
== EXPR_CONSTANT
)
475 gfc_error ("Invalid initializer %s in Data statement at %C", name
);
481 *result
= gfc_copy_expr (sym
->value
);
486 /* Match a list of values in a DATA statement. The leading '/' has
487 already been seen at this point. */
490 top_val_list (gfc_data
*data
)
492 gfc_data_value
*new_val
, *tail
;
500 m
= match_data_constant (&expr
);
503 if (m
== MATCH_ERROR
)
506 new_val
= gfc_get_data_value ();
507 mpz_init (new_val
->repeat
);
510 data
->value
= new_val
;
512 tail
->next
= new_val
;
516 if (expr
->ts
.type
!= BT_INTEGER
|| gfc_match_char ('*') != MATCH_YES
)
519 mpz_set_ui (tail
->repeat
, 1);
523 mpz_set (tail
->repeat
, expr
->value
.integer
);
524 gfc_free_expr (expr
);
526 m
= match_data_constant (&tail
->expr
);
529 if (m
== MATCH_ERROR
)
533 if (gfc_match_char ('/') == MATCH_YES
)
535 if (gfc_match_char (',') == MATCH_NO
)
542 gfc_syntax_error (ST_DATA
);
543 gfc_free_data_all (gfc_current_ns
);
548 /* Matches an old style initialization. */
551 match_old_style_init (const char *name
)
556 gfc_data
*newdata
, *nd
;
558 /* Set up data structure to hold initializers. */
559 gfc_find_sym_tree (name
, NULL
, 0, &st
);
562 newdata
= gfc_get_data ();
563 newdata
->var
= gfc_get_data_variable ();
564 newdata
->var
->expr
= gfc_get_variable_expr (st
);
565 newdata
->var
->expr
->where
= sym
->declared_at
;
566 newdata
->where
= gfc_current_locus
;
568 /* Match initial value list. This also eats the terminal '/'. */
569 m
= top_val_list (newdata
);
576 /* Check that a BOZ did not creep into an old-style initialization. */
577 for (nd
= newdata
; nd
; nd
= nd
->next
)
579 if (nd
->value
->expr
->ts
.type
== BT_BOZ
580 && gfc_invalid_boz (G_("BOZ at %L cannot appear in an old-style "
581 "initialization"), &nd
->value
->expr
->where
))
584 if (nd
->var
->expr
->ts
.type
!= BT_INTEGER
585 && nd
->var
->expr
->ts
.type
!= BT_REAL
586 && nd
->value
->expr
->ts
.type
== BT_BOZ
)
588 gfc_error (G_("BOZ literal constant near %L cannot be assigned to "
589 "a %qs variable in an old-style initialization"),
590 &nd
->value
->expr
->where
,
591 gfc_typename (&nd
->value
->expr
->ts
));
598 gfc_error ("Initialization at %C is not allowed in a PURE procedure");
602 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
604 /* Mark the variable as having appeared in a data statement. */
605 if (!gfc_add_data (&sym
->attr
, sym
->name
, &sym
->declared_at
))
611 /* Chain in namespace list of DATA initializers. */
612 newdata
->next
= gfc_current_ns
->data
;
613 gfc_current_ns
->data
= newdata
;
619 /* Match the stuff following a DATA statement. If ERROR_FLAG is set,
620 we are matching a DATA statement and are therefore issuing an error
621 if we encounter something unexpected, if not, we're trying to match
622 an old-style initialization expression of the form INTEGER I /2/. */
625 gfc_match_data (void)
633 /* DATA has been matched. In free form source code, the next character
634 needs to be whitespace or '(' from an implied do-loop. Check that
636 c
= gfc_peek_ascii_char ();
637 if (gfc_current_form
== FORM_FREE
&& !gfc_is_whitespace (c
) && c
!= '(')
640 /* Before parsing the rest of a DATA statement, check F2008:c1206. */
641 if ((gfc_current_state () == COMP_FUNCTION
642 || gfc_current_state () == COMP_SUBROUTINE
)
643 && gfc_state_stack
->previous
->state
== COMP_INTERFACE
)
645 gfc_error ("DATA statement at %C cannot appear within an INTERFACE");
649 set_in_match_data (true);
653 new_data
= gfc_get_data ();
654 new_data
->where
= gfc_current_locus
;
656 m
= top_var_list (new_data
);
660 if (new_data
->var
->iter
.var
661 && new_data
->var
->iter
.var
->ts
.type
== BT_INTEGER
662 && new_data
->var
->iter
.var
->symtree
->n
.sym
->attr
.implied_index
== 1
663 && new_data
->var
->list
664 && new_data
->var
->list
->expr
665 && new_data
->var
->list
->expr
->ts
.type
== BT_CHARACTER
666 && new_data
->var
->list
->expr
->ref
667 && new_data
->var
->list
->expr
->ref
->type
== REF_SUBSTRING
)
669 gfc_error ("Invalid substring in data-implied-do at %L in DATA "
670 "statement", &new_data
->var
->list
->expr
->where
);
674 /* Check for an entity with an allocatable component, which is not
676 e
= new_data
->var
->expr
;
682 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
683 if ((ref
->type
== REF_COMPONENT
684 && ref
->u
.c
.component
->attr
.allocatable
)
685 || (ref
->type
== REF_ARRAY
686 && e
->symtree
->n
.sym
->attr
.pointer
!= 1
687 && ref
->u
.ar
.as
&& ref
->u
.ar
.as
->type
== AS_DEFERRED
))
692 gfc_error ("Allocatable component or deferred-shaped array "
693 "near %C in DATA statement");
697 /* F2008:C567 (R536) A data-i-do-object or a variable that appears
698 as a data-stmt-object shall not be an object designator in which
699 a pointer appears other than as the entire rightmost part-ref. */
700 if (!e
->ref
&& e
->ts
.type
== BT_DERIVED
701 && e
->symtree
->n
.sym
->attr
.pointer
)
705 if (e
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
706 && e
->symtree
->n
.sym
->attr
.pointer
707 && ref
->type
== REF_COMPONENT
)
710 for (; ref
; ref
= ref
->next
)
711 if (ref
->type
== REF_COMPONENT
712 && ref
->u
.c
.component
->attr
.pointer
717 m
= top_val_list (new_data
);
721 new_data
->next
= gfc_current_ns
->data
;
722 gfc_current_ns
->data
= new_data
;
724 /* A BOZ literal constant cannot appear in a structure constructor.
725 Check for that here for a data statement value. */
726 if (new_data
->value
->expr
->ts
.type
== BT_DERIVED
727 && new_data
->value
->expr
->value
.constructor
)
730 c
= gfc_constructor_first (new_data
->value
->expr
->value
.constructor
);
731 for (; c
; c
= gfc_constructor_next (c
))
732 if (c
->expr
&& c
->expr
->ts
.type
== BT_BOZ
)
734 gfc_error ("BOZ literal constant at %L cannot appear in a "
735 "structure constructor", &c
->expr
->where
);
740 if (gfc_match_eos () == MATCH_YES
)
743 gfc_match_char (','); /* Optional comma */
746 set_in_match_data (false);
750 gfc_error ("DATA statement at %C is not allowed in a PURE procedure");
753 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
759 gfc_error ("part-ref with pointer attribute near %L is not "
760 "rightmost part-ref of data-stmt-object",
764 set_in_match_data (false);
765 gfc_free_data (new_data
);
770 /************************ Declaration statements *********************/
773 /* Like gfc_match_init_expr, but matches a 'clist' (old-style initialization
774 list). The difference here is the expression is a list of constants
775 and is surrounded by '/'.
776 The typespec ts must match the typespec of the variable which the
777 clist is initializing.
778 The arrayspec tells whether this should match a list of constants
779 corresponding to array elements or a scalar (as == NULL). */
782 match_clist_expr (gfc_expr
**result
, gfc_typespec
*ts
, gfc_array_spec
*as
)
784 gfc_constructor_base array_head
= NULL
;
785 gfc_expr
*expr
= NULL
;
786 match m
= MATCH_ERROR
;
788 mpz_t repeat
, cons_size
, as_size
;
794 /* We have already matched '/' - now look for a constant list, as with
795 top_val_list from decl.cc, but append the result to an array. */
796 if (gfc_match ("/") == MATCH_YES
)
798 gfc_error ("Empty old style initializer list at %C");
802 where
= gfc_current_locus
;
803 scalar
= !as
|| !as
->rank
;
805 if (!scalar
&& !spec_size (as
, &as_size
))
807 gfc_error ("Array in initializer list at %L must have an explicit shape",
808 as
->type
== AS_EXPLICIT
? &as
->upper
[0]->where
: &where
);
809 /* Nothing to cleanup yet. */
813 mpz_init_set_ui (repeat
, 0);
817 m
= match_data_constant (&expr
);
819 expr
= NULL
; /* match_data_constant may set expr to garbage */
822 if (m
== MATCH_ERROR
)
825 /* Found r in repeat spec r*c; look for the constant to repeat. */
826 if ( gfc_match_char ('*') == MATCH_YES
)
830 gfc_error ("Repeat spec invalid in scalar initializer at %C");
833 if (expr
->ts
.type
!= BT_INTEGER
)
835 gfc_error ("Repeat spec must be an integer at %C");
838 mpz_set (repeat
, expr
->value
.integer
);
839 gfc_free_expr (expr
);
842 m
= match_data_constant (&expr
);
846 gfc_error ("Expected data constant after repeat spec at %C");
851 /* No repeat spec, we matched the data constant itself. */
853 mpz_set_ui (repeat
, 1);
857 /* Add the constant initializer as many times as repeated. */
858 for (; mpz_cmp_ui (repeat
, 0) > 0; mpz_sub_ui (repeat
, repeat
, 1))
860 /* Make sure types of elements match */
861 if(ts
&& !gfc_compare_types (&expr
->ts
, ts
)
862 && !gfc_convert_type (expr
, ts
, 1))
865 gfc_constructor_append_expr (&array_head
,
866 gfc_copy_expr (expr
), &gfc_current_locus
);
869 gfc_free_expr (expr
);
873 /* For scalar initializers quit after one element. */
876 if(gfc_match_char ('/') != MATCH_YES
)
878 gfc_error ("End of scalar initializer expected at %C");
884 if (gfc_match_char ('/') == MATCH_YES
)
886 if (gfc_match_char (',') == MATCH_NO
)
890 /* If we break early from here out, we encountered an error. */
893 /* Set up expr as an array constructor. */
896 expr
= gfc_get_array_expr (ts
->type
, ts
->kind
, &where
);
898 expr
->value
.constructor
= array_head
;
900 /* Validate sizes. We built expr ourselves, so cons_size will be
901 constant (we fail above for non-constant expressions).
902 We still need to verify that the sizes match. */
903 gcc_assert (gfc_array_size (expr
, &cons_size
));
904 cmp
= mpz_cmp (cons_size
, as_size
);
906 gfc_error ("Not enough elements in array initializer at %C");
908 gfc_error ("Too many elements in array initializer at %C");
909 mpz_clear (cons_size
);
913 /* Set the rank/shape to match the LHS as auto-reshape is implied. */
914 expr
->rank
= as
->rank
;
915 expr
->shape
= gfc_get_shape (as
->rank
);
916 for (int i
= 0; i
< as
->rank
; ++i
)
917 spec_dimen_size (as
, i
, &expr
->shape
[i
]);
920 /* Make sure scalar types match. */
921 else if (!gfc_compare_types (&expr
->ts
, ts
)
922 && !gfc_convert_type (expr
, ts
, 1))
926 expr
->ts
.u
.cl
->length_from_typespec
= 1;
934 gfc_error ("Syntax error in old style initializer list at %C");
938 expr
->value
.constructor
= NULL
;
939 gfc_free_expr (expr
);
940 gfc_constructor_free (array_head
);
950 /* Auxiliary function to merge DIMENSION and CODIMENSION array specs. */
953 merge_array_spec (gfc_array_spec
*from
, gfc_array_spec
*to
, bool copy
)
955 if ((from
->type
== AS_ASSUMED_RANK
&& to
->corank
)
956 || (to
->type
== AS_ASSUMED_RANK
&& from
->corank
))
958 gfc_error ("The assumed-rank array at %C shall not have a codimension");
962 if (to
->rank
== 0 && from
->rank
> 0)
964 to
->rank
= from
->rank
;
965 to
->type
= from
->type
;
966 to
->cray_pointee
= from
->cray_pointee
;
967 to
->cp_was_assumed
= from
->cp_was_assumed
;
969 for (int i
= to
->corank
- 1; i
>= 0; i
--)
971 /* Do not exceed the limits on lower[] and upper[]. gfortran
972 cleans up elsewhere. */
973 int j
= from
->rank
+ i
;
974 if (j
>= GFC_MAX_DIMENSIONS
)
977 to
->lower
[j
] = to
->lower
[i
];
978 to
->upper
[j
] = to
->upper
[i
];
980 for (int i
= 0; i
< from
->rank
; i
++)
984 to
->lower
[i
] = gfc_copy_expr (from
->lower
[i
]);
985 to
->upper
[i
] = gfc_copy_expr (from
->upper
[i
]);
989 to
->lower
[i
] = from
->lower
[i
];
990 to
->upper
[i
] = from
->upper
[i
];
994 else if (to
->corank
== 0 && from
->corank
> 0)
996 to
->corank
= from
->corank
;
997 to
->cotype
= from
->cotype
;
999 for (int i
= 0; i
< from
->corank
; i
++)
1001 /* Do not exceed the limits on lower[] and upper[]. gfortran
1002 cleans up elsewhere. */
1003 int k
= from
->rank
+ i
;
1004 int j
= to
->rank
+ i
;
1005 if (j
>= GFC_MAX_DIMENSIONS
)
1010 to
->lower
[j
] = gfc_copy_expr (from
->lower
[k
]);
1011 to
->upper
[j
] = gfc_copy_expr (from
->upper
[k
]);
1015 to
->lower
[j
] = from
->lower
[k
];
1016 to
->upper
[j
] = from
->upper
[k
];
1021 if (to
->rank
+ to
->corank
> GFC_MAX_DIMENSIONS
)
1023 gfc_error ("Sum of array rank %d and corank %d at %C exceeds maximum "
1024 "allowed dimensions of %d",
1025 to
->rank
, to
->corank
, GFC_MAX_DIMENSIONS
);
1026 to
->corank
= GFC_MAX_DIMENSIONS
- to
->rank
;
1033 /* Match an intent specification. Since this can only happen after an
1034 INTENT word, a legal intent-spec must follow. */
1037 match_intent_spec (void)
1040 if (gfc_match (" ( in out )") == MATCH_YES
)
1041 return INTENT_INOUT
;
1042 if (gfc_match (" ( in )") == MATCH_YES
)
1044 if (gfc_match (" ( out )") == MATCH_YES
)
1047 gfc_error ("Bad INTENT specification at %C");
1048 return INTENT_UNKNOWN
;
1052 /* Matches a character length specification, which is either a
1053 specification expression, '*', or ':'. */
1056 char_len_param_value (gfc_expr
**expr
, bool *deferred
)
1064 if (gfc_match_char ('*') == MATCH_YES
)
1067 if (gfc_match_char (':') == MATCH_YES
)
1069 if (!gfc_notify_std (GFC_STD_F2003
, "deferred type parameter at %C"))
1077 m
= gfc_match_expr (expr
);
1079 if (m
== MATCH_NO
|| m
== MATCH_ERROR
)
1082 if (!gfc_expr_check_typed (*expr
, gfc_current_ns
, false))
1085 /* Try to simplify the expression to catch things like CHARACTER(([1])). */
1086 p
= gfc_copy_expr (*expr
);
1087 if (gfc_is_constant_expr (p
) && gfc_simplify_expr (p
, 1))
1088 gfc_replace_expr (*expr
, p
);
1092 if ((*expr
)->expr_type
== EXPR_FUNCTION
)
1094 if ((*expr
)->ts
.type
== BT_INTEGER
1095 || ((*expr
)->ts
.type
== BT_UNKNOWN
1096 && strcmp((*expr
)->symtree
->name
, "null") != 0))
1101 else if ((*expr
)->expr_type
== EXPR_CONSTANT
)
1103 /* F2008, 4.4.3.1: The length is a type parameter; its kind is
1104 processor dependent and its value is greater than or equal to zero.
1105 F2008, 4.4.3.2: If the character length parameter value evaluates
1106 to a negative value, the length of character entities declared
1109 if ((*expr
)->ts
.type
== BT_INTEGER
)
1111 if (mpz_cmp_si ((*expr
)->value
.integer
, 0) < 0)
1112 mpz_set_si ((*expr
)->value
.integer
, 0);
1117 else if ((*expr
)->expr_type
== EXPR_ARRAY
)
1119 else if ((*expr
)->expr_type
== EXPR_VARIABLE
)
1124 e
= gfc_copy_expr (*expr
);
1126 /* This catches the invalid code "[character(m(2:3)) :: 'x', 'y']",
1127 which causes an ICE if gfc_reduce_init_expr() is called. */
1128 if (e
->ref
&& e
->ref
->type
== REF_ARRAY
1129 && e
->ref
->u
.ar
.type
== AR_UNKNOWN
1130 && e
->ref
->u
.ar
.dimen_type
[0] == DIMEN_RANGE
)
1133 t
= gfc_reduce_init_expr (e
);
1135 if (!t
&& e
->ts
.type
== BT_UNKNOWN
1136 && e
->symtree
->n
.sym
->attr
.untyped
== 1
1137 && (flag_implicit_none
1138 || e
->symtree
->n
.sym
->ns
->seen_implicit_none
== 1
1139 || e
->symtree
->n
.sym
->ns
->parent
->seen_implicit_none
== 1))
1145 if ((e
->ref
&& e
->ref
->type
== REF_ARRAY
1146 && e
->ref
->u
.ar
.type
!= AR_ELEMENT
)
1147 || (!e
->ref
&& e
->expr_type
== EXPR_ARRAY
))
1162 gfc_error ("Scalar INTEGER expression expected at %L", &(*expr
)->where
);
1167 /* A character length is a '*' followed by a literal integer or a
1168 char_len_param_value in parenthesis. */
1171 match_char_length (gfc_expr
**expr
, bool *deferred
, bool obsolescent_check
)
1177 m
= gfc_match_char ('*');
1181 m
= gfc_match_small_literal_int (&length
, NULL
);
1182 if (m
== MATCH_ERROR
)
1187 if (obsolescent_check
1188 && !gfc_notify_std (GFC_STD_F95_OBS
, "Old-style character length at %C"))
1190 *expr
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
, length
);
1194 if (gfc_match_char ('(') == MATCH_NO
)
1197 m
= char_len_param_value (expr
, deferred
);
1198 if (m
!= MATCH_YES
&& gfc_matching_function
)
1200 gfc_undo_symbols ();
1204 if (m
== MATCH_ERROR
)
1209 if (gfc_match_char (')') == MATCH_NO
)
1211 gfc_free_expr (*expr
);
1219 gfc_error ("Syntax error in character length specification at %C");
1224 /* Special subroutine for finding a symbol. Check if the name is found
1225 in the current name space. If not, and we're compiling a function or
1226 subroutine and the parent compilation unit is an interface, then check
1227 to see if the name we've been given is the name of the interface
1228 (located in another namespace). */
1231 find_special (const char *name
, gfc_symbol
**result
, bool allow_subroutine
)
1237 i
= gfc_get_sym_tree (name
, NULL
, &st
, allow_subroutine
);
1240 *result
= st
? st
->n
.sym
: NULL
;
1244 if (gfc_current_state () != COMP_SUBROUTINE
1245 && gfc_current_state () != COMP_FUNCTION
)
1248 s
= gfc_state_stack
->previous
;
1252 if (s
->state
!= COMP_INTERFACE
)
1255 goto end
; /* Nameless interface. */
1257 if (strcmp (name
, s
->sym
->name
) == 0)
1268 /* Special subroutine for getting a symbol node associated with a
1269 procedure name, used in SUBROUTINE and FUNCTION statements. The
1270 symbol is created in the parent using with symtree node in the
1271 child unit pointing to the symbol. If the current namespace has no
1272 parent, then the symbol is just created in the current unit. */
1275 get_proc_name (const char *name
, gfc_symbol
**result
, bool module_fcn_entry
)
1281 /* Module functions have to be left in their own namespace because
1282 they have potentially (almost certainly!) already been referenced.
1283 In this sense, they are rather like external functions. This is
1284 fixed up in resolve.cc(resolve_entries), where the symbol name-
1285 space is set to point to the master function, so that the fake
1286 result mechanism can work. */
1287 if (module_fcn_entry
)
1289 /* Present if entry is declared to be a module procedure. */
1290 rc
= gfc_find_symbol (name
, gfc_current_ns
->parent
, 0, result
);
1292 if (*result
== NULL
)
1293 rc
= gfc_get_symbol (name
, NULL
, result
);
1294 else if (!gfc_get_symbol (name
, NULL
, &sym
) && sym
1295 && (*result
)->ts
.type
== BT_UNKNOWN
1296 && sym
->attr
.flavor
== FL_UNKNOWN
)
1297 /* Pick up the typespec for the entry, if declared in the function
1298 body. Note that this symbol is FL_UNKNOWN because it will
1299 only have appeared in a type declaration. The local symtree
1300 is set to point to the module symbol and a unique symtree
1301 to the local version. This latter ensures a correct clearing
1304 /* If the ENTRY proceeds its specification, we need to ensure
1305 that this does not raise a "has no IMPLICIT type" error. */
1306 if (sym
->ts
.type
== BT_UNKNOWN
)
1307 sym
->attr
.untyped
= 1;
1309 (*result
)->ts
= sym
->ts
;
1311 /* Put the symbol in the procedure namespace so that, should
1312 the ENTRY precede its specification, the specification
1314 (*result
)->ns
= gfc_current_ns
;
1316 gfc_find_sym_tree (name
, gfc_current_ns
, 0, &st
);
1317 st
->n
.sym
= *result
;
1318 st
= gfc_get_unique_symtree (gfc_current_ns
);
1324 rc
= gfc_get_symbol (name
, gfc_current_ns
->parent
, result
);
1330 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
1333 if (sym
->attr
.module_procedure
&& sym
->attr
.if_source
== IFSRC_IFBODY
)
1335 /* Create a partially populated interface symbol to carry the
1336 characteristics of the procedure and the result. */
1337 sym
->tlink
= gfc_new_symbol (name
, sym
->ns
);
1338 gfc_add_type (sym
->tlink
, &(sym
->ts
), &gfc_current_locus
);
1339 gfc_copy_attr (&sym
->tlink
->attr
, &sym
->attr
, NULL
);
1340 if (sym
->attr
.dimension
)
1341 sym
->tlink
->as
= gfc_copy_array_spec (sym
->as
);
1343 /* Ideally, at this point, a copy would be made of the formal
1344 arguments and their namespace. However, this does not appear
1345 to be necessary, albeit at the expense of not being able to
1346 use gfc_compare_interfaces directly. */
1348 if (sym
->result
&& sym
->result
!= sym
)
1350 sym
->tlink
->result
= sym
->result
;
1353 else if (sym
->result
)
1355 sym
->tlink
->result
= sym
->tlink
;
1358 else if (sym
&& !sym
->gfc_new
1359 && gfc_current_state () != COMP_INTERFACE
)
1361 /* Trap another encompassed procedure with the same name. All
1362 these conditions are necessary to avoid picking up an entry
1363 whose name clashes with that of the encompassing procedure;
1364 this is handled using gsymbols to register unique, globally
1365 accessible names. */
1366 if (sym
->attr
.flavor
!= 0
1367 && sym
->attr
.proc
!= 0
1368 && (sym
->attr
.subroutine
|| sym
->attr
.function
|| sym
->attr
.entry
)
1369 && sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
1371 gfc_error_now ("Procedure %qs at %C is already defined at %L",
1372 name
, &sym
->declared_at
);
1375 if (sym
->attr
.flavor
!= 0
1376 && sym
->attr
.entry
&& sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
1378 gfc_error_now ("Procedure %qs at %C is already defined at %L",
1379 name
, &sym
->declared_at
);
1383 if (sym
->attr
.external
&& sym
->attr
.procedure
1384 && gfc_current_state () == COMP_CONTAINS
)
1386 gfc_error_now ("Contained procedure %qs at %C clashes with "
1387 "procedure defined at %L",
1388 name
, &sym
->declared_at
);
1392 /* Trap a procedure with a name the same as interface in the
1393 encompassing scope. */
1394 if (sym
->attr
.generic
!= 0
1395 && (sym
->attr
.subroutine
|| sym
->attr
.function
)
1396 && !sym
->attr
.mod_proc
)
1398 gfc_error_now ("Name %qs at %C is already defined"
1399 " as a generic interface at %L",
1400 name
, &sym
->declared_at
);
1404 /* Trap declarations of attributes in encompassing scope. The
1405 signature for this is that ts.kind is nonzero for no-CLASS
1406 entity. For a CLASS entity, ts.kind is zero. */
1407 if ((sym
->ts
.kind
!= 0 || sym
->ts
.type
== BT_CLASS
)
1408 && !sym
->attr
.implicit_type
1409 && sym
->attr
.proc
== 0
1410 && gfc_current_ns
->parent
!= NULL
1411 && sym
->attr
.access
== 0
1412 && !module_fcn_entry
)
1414 gfc_error_now ("Procedure %qs at %C has an explicit interface "
1415 "from a previous declaration", name
);
1420 /* C1246 (R1225) MODULE shall appear only in the function-stmt or
1421 subroutine-stmt of a module subprogram or of a nonabstract interface
1422 body that is declared in the scoping unit of a module or submodule. */
1423 if (sym
->attr
.external
1424 && (sym
->attr
.subroutine
|| sym
->attr
.function
)
1425 && sym
->attr
.if_source
== IFSRC_IFBODY
1426 && !current_attr
.module_procedure
1427 && sym
->attr
.proc
== PROC_MODULE
1428 && gfc_state_stack
->state
== COMP_CONTAINS
)
1430 gfc_error_now ("Procedure %qs defined in interface body at %L "
1431 "clashes with internal procedure defined at %C",
1432 name
, &sym
->declared_at
);
1436 if (sym
&& !sym
->gfc_new
1437 && sym
->attr
.flavor
!= FL_UNKNOWN
1438 && sym
->attr
.referenced
== 0 && sym
->attr
.subroutine
== 1
1439 && gfc_state_stack
->state
== COMP_CONTAINS
1440 && gfc_state_stack
->previous
->state
== COMP_SUBROUTINE
)
1442 gfc_error_now ("Procedure %qs at %C is already defined at %L",
1443 name
, &sym
->declared_at
);
1447 if (gfc_current_ns
->parent
== NULL
|| *result
== NULL
)
1450 /* Module function entries will already have a symtree in
1451 the current namespace but will need one at module level. */
1452 if (module_fcn_entry
)
1454 /* Present if entry is declared to be a module procedure. */
1455 rc
= gfc_find_sym_tree (name
, gfc_current_ns
->parent
, 0, &st
);
1457 st
= gfc_new_symtree (&gfc_current_ns
->parent
->sym_root
, name
);
1460 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, name
);
1465 /* See if the procedure should be a module procedure. */
1467 if (((sym
->ns
->proc_name
!= NULL
1468 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
1469 && sym
->attr
.proc
!= PROC_MODULE
)
1470 || (module_fcn_entry
&& sym
->attr
.proc
!= PROC_MODULE
))
1471 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
1478 /* Verify that the given symbol representing a parameter is C
1479 interoperable, by checking to see if it was marked as such after
1480 its declaration. If the given symbol is not interoperable, a
1481 warning is reported, thus removing the need to return the status to
1482 the calling function. The standard does not require the user use
1483 one of the iso_c_binding named constants to declare an
1484 interoperable parameter, but we can't be sure if the param is C
1485 interop or not if the user doesn't. For example, integer(4) may be
1486 legal Fortran, but doesn't have meaning in C. It may interop with
1487 a number of the C types, which causes a problem because the
1488 compiler can't know which one. This code is almost certainly not
1489 portable, and the user will get what they deserve if the C type
1490 across platforms isn't always interoperable with integer(4). If
1491 the user had used something like integer(c_int) or integer(c_long),
1492 the compiler could have automatically handled the varying sizes
1493 across platforms. */
1496 gfc_verify_c_interop_param (gfc_symbol
*sym
)
1498 int is_c_interop
= 0;
1501 /* We check implicitly typed variables in symbol.cc:gfc_set_default_type().
1502 Don't repeat the checks here. */
1503 if (sym
->attr
.implicit_type
)
1506 /* For subroutines or functions that are passed to a BIND(C) procedure,
1507 they're interoperable if they're BIND(C) and their params are all
1509 if (sym
->attr
.flavor
== FL_PROCEDURE
)
1511 if (sym
->attr
.is_bind_c
== 0)
1513 gfc_error_now ("Procedure %qs at %L must have the BIND(C) "
1514 "attribute to be C interoperable", sym
->name
,
1515 &(sym
->declared_at
));
1520 if (sym
->attr
.is_c_interop
== 1)
1521 /* We've already checked this procedure; don't check it again. */
1524 return verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
1529 /* See if we've stored a reference to a procedure that owns sym. */
1530 if (sym
->ns
!= NULL
&& sym
->ns
->proc_name
!= NULL
)
1532 if (sym
->ns
->proc_name
->attr
.is_bind_c
== 1)
1534 is_c_interop
= (gfc_verify_c_interop(&(sym
->ts
)) ? 1 : 0);
1536 if (is_c_interop
!= 1)
1538 /* Make personalized messages to give better feedback. */
1539 if (sym
->ts
.type
== BT_DERIVED
)
1540 gfc_error ("Variable %qs at %L is a dummy argument to the "
1541 "BIND(C) procedure %qs but is not C interoperable "
1542 "because derived type %qs is not C interoperable",
1543 sym
->name
, &(sym
->declared_at
),
1544 sym
->ns
->proc_name
->name
,
1545 sym
->ts
.u
.derived
->name
);
1546 else if (sym
->ts
.type
== BT_CLASS
)
1547 gfc_error ("Variable %qs at %L is a dummy argument to the "
1548 "BIND(C) procedure %qs but is not C interoperable "
1549 "because it is polymorphic",
1550 sym
->name
, &(sym
->declared_at
),
1551 sym
->ns
->proc_name
->name
);
1552 else if (warn_c_binding_type
)
1553 gfc_warning (OPT_Wc_binding_type
,
1554 "Variable %qs at %L is a dummy argument of the "
1555 "BIND(C) procedure %qs but may not be C "
1557 sym
->name
, &(sym
->declared_at
),
1558 sym
->ns
->proc_name
->name
);
1561 /* Per F2018, 18.3.6 (5), pointer + contiguous is not permitted. */
1562 if (sym
->attr
.pointer
&& sym
->attr
.contiguous
)
1563 gfc_error ("Dummy argument %qs at %L may not be a pointer with "
1564 "CONTIGUOUS attribute as procedure %qs is BIND(C)",
1565 sym
->name
, &sym
->declared_at
, sym
->ns
->proc_name
->name
);
1567 /* Per F2018, C1557, pointer/allocatable dummies to a bind(c)
1568 procedure that are default-initialized are not permitted. */
1569 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
1570 && sym
->ts
.type
== BT_DERIVED
1571 && gfc_has_default_initializer (sym
->ts
.u
.derived
))
1573 gfc_error ("Default-initialized %s dummy argument %qs "
1574 "at %L is not permitted in BIND(C) procedure %qs",
1575 (sym
->attr
.pointer
? "pointer" : "allocatable"),
1576 sym
->name
, &sym
->declared_at
,
1577 sym
->ns
->proc_name
->name
);
1581 /* Character strings are only C interoperable if they have a
1582 length of 1. However, as an argument they are also interoperable
1583 when passed as descriptor (which requires len=: or len=*). */
1584 if (sym
->ts
.type
== BT_CHARACTER
)
1586 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
1588 if (sym
->attr
.allocatable
|| sym
->attr
.pointer
)
1590 /* F2018, 18.3.6 (6). */
1591 if (!sym
->ts
.deferred
)
1593 if (sym
->attr
.allocatable
)
1594 gfc_error ("Allocatable character dummy argument %qs "
1595 "at %L must have deferred length as "
1596 "procedure %qs is BIND(C)", sym
->name
,
1597 &sym
->declared_at
, sym
->ns
->proc_name
->name
);
1599 gfc_error ("Pointer character dummy argument %qs at %L "
1600 "must have deferred length as procedure %qs "
1601 "is BIND(C)", sym
->name
, &sym
->declared_at
,
1602 sym
->ns
->proc_name
->name
);
1605 else if (!gfc_notify_std (GFC_STD_F2018
,
1606 "Deferred-length character dummy "
1607 "argument %qs at %L of procedure "
1608 "%qs with BIND(C) attribute",
1609 sym
->name
, &sym
->declared_at
,
1610 sym
->ns
->proc_name
->name
))
1613 else if (sym
->attr
.value
1614 && (!cl
|| !cl
->length
1615 || cl
->length
->expr_type
!= EXPR_CONSTANT
1616 || mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0))
1618 gfc_error ("Character dummy argument %qs at %L must be "
1619 "of length 1 as it has the VALUE attribute",
1620 sym
->name
, &sym
->declared_at
);
1623 else if (!cl
|| !cl
->length
)
1625 /* Assumed length; F2018, 18.3.6 (5)(2).
1626 Uses the CFI array descriptor - also for scalars and
1627 explicit-size/assumed-size arrays. */
1628 if (!gfc_notify_std (GFC_STD_F2018
,
1629 "Assumed-length character dummy argument "
1630 "%qs at %L of procedure %qs with BIND(C) "
1631 "attribute", sym
->name
, &sym
->declared_at
,
1632 sym
->ns
->proc_name
->name
))
1635 else if (cl
->length
->expr_type
!= EXPR_CONSTANT
1636 || mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
1638 /* F2018, 18.3.6, (5), item 4. */
1639 if (!sym
->attr
.dimension
1640 || sym
->as
->type
== AS_ASSUMED_SIZE
1641 || sym
->as
->type
== AS_EXPLICIT
)
1643 gfc_error ("Character dummy argument %qs at %L must be "
1644 "of constant length of one or assumed length, "
1645 "unless it has assumed shape or assumed rank, "
1646 "as procedure %qs has the BIND(C) attribute",
1647 sym
->name
, &sym
->declared_at
,
1648 sym
->ns
->proc_name
->name
);
1651 /* else: valid only since F2018 - and an assumed-shape/rank
1652 array; however, gfc_notify_std is already called when
1653 those array types are used. Thus, silently accept F200x. */
1657 /* We have to make sure that any param to a bind(c) routine does
1658 not have the allocatable, pointer, or optional attributes,
1659 according to J3/04-007, section 5.1. */
1660 if (sym
->attr
.allocatable
== 1
1661 && !gfc_notify_std (GFC_STD_F2018
, "Variable %qs at %L with "
1662 "ALLOCATABLE attribute in procedure %qs "
1663 "with BIND(C)", sym
->name
,
1664 &(sym
->declared_at
),
1665 sym
->ns
->proc_name
->name
))
1668 if (sym
->attr
.pointer
== 1
1669 && !gfc_notify_std (GFC_STD_F2018
, "Variable %qs at %L with "
1670 "POINTER attribute in procedure %qs "
1671 "with BIND(C)", sym
->name
,
1672 &(sym
->declared_at
),
1673 sym
->ns
->proc_name
->name
))
1676 if (sym
->attr
.optional
== 1 && sym
->attr
.value
)
1678 gfc_error ("Variable %qs at %L cannot have both the OPTIONAL "
1679 "and the VALUE attribute because procedure %qs "
1680 "is BIND(C)", sym
->name
, &(sym
->declared_at
),
1681 sym
->ns
->proc_name
->name
);
1684 else if (sym
->attr
.optional
== 1
1685 && !gfc_notify_std (GFC_STD_F2018
, "Variable %qs "
1686 "at %L with OPTIONAL attribute in "
1687 "procedure %qs which is BIND(C)",
1688 sym
->name
, &(sym
->declared_at
),
1689 sym
->ns
->proc_name
->name
))
1692 /* Make sure that if it has the dimension attribute, that it is
1693 either assumed size or explicit shape. Deferred shape is already
1694 covered by the pointer/allocatable attribute. */
1695 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SHAPE
1696 && !gfc_notify_std (GFC_STD_F2018
, "Assumed-shape array %qs "
1697 "at %L as dummy argument to the BIND(C) "
1698 "procedure %qs at %L", sym
->name
,
1699 &(sym
->declared_at
),
1700 sym
->ns
->proc_name
->name
,
1701 &(sym
->ns
->proc_name
->declared_at
)))
1711 /* Function called by variable_decl() that adds a name to the symbol table. */
1714 build_sym (const char *name
, gfc_charlen
*cl
, bool cl_deferred
,
1715 gfc_array_spec
**as
, locus
*var_locus
)
1717 symbol_attribute attr
;
1722 /* Symbols in a submodule are host associated from the parent module or
1723 submodules. Therefore, they can be overridden by declarations in the
1724 submodule scope. Deal with this by attaching the existing symbol to
1725 a new symtree and recycling the old symtree with a new symbol... */
1726 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
1727 if (st
!= NULL
&& gfc_state_stack
->state
== COMP_SUBMODULE
1728 && st
->n
.sym
!= NULL
1729 && st
->n
.sym
->attr
.host_assoc
&& st
->n
.sym
->attr
.used_in_submodule
)
1731 gfc_symtree
*s
= gfc_get_unique_symtree (gfc_current_ns
);
1732 s
->n
.sym
= st
->n
.sym
;
1733 sym
= gfc_new_symbol (name
, gfc_current_ns
);
1738 gfc_set_sym_referenced (sym
);
1740 /* ...Otherwise generate a new symtree and new symbol. */
1741 else if (gfc_get_symbol (name
, NULL
, &sym
))
1744 /* Check if the name has already been defined as a type. The
1745 first letter of the symtree will be in upper case then. Of
1746 course, this is only necessary if the upper case letter is
1747 actually different. */
1749 upper
= TOUPPER(name
[0]);
1750 if (upper
!= name
[0])
1752 char u_name
[GFC_MAX_SYMBOL_LEN
+ 1];
1755 gcc_assert (strlen(name
) <= GFC_MAX_SYMBOL_LEN
);
1756 strcpy (u_name
, name
);
1759 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, u_name
);
1761 /* STRUCTURE types can alias symbol names */
1762 if (st
!= 0 && st
->n
.sym
->attr
.flavor
!= FL_STRUCT
)
1764 gfc_error ("Symbol %qs at %C also declared as a type at %L", name
,
1765 &st
->n
.sym
->declared_at
);
1770 /* Start updating the symbol table. Add basic type attribute if present. */
1771 if (current_ts
.type
!= BT_UNKNOWN
1772 && (sym
->attr
.implicit_type
== 0
1773 || !gfc_compare_types (&sym
->ts
, ¤t_ts
))
1774 && !gfc_add_type (sym
, ¤t_ts
, var_locus
))
1777 if (sym
->ts
.type
== BT_CHARACTER
)
1780 sym
->ts
.deferred
= cl_deferred
;
1783 /* Add dimension attribute if present. */
1784 if (!gfc_set_array_spec (sym
, *as
, var_locus
))
1788 /* Add attribute to symbol. The copy is so that we can reset the
1789 dimension attribute. */
1790 attr
= current_attr
;
1792 attr
.codimension
= 0;
1794 if (!gfc_copy_attr (&sym
->attr
, &attr
, var_locus
))
1797 /* Finish any work that may need to be done for the binding label,
1798 if it's a bind(c). The bind(c) attr is found before the symbol
1799 is made, and before the symbol name (for data decls), so the
1800 current_ts is holding the binding label, or nothing if the
1801 name= attr wasn't given. Therefore, test here if we're dealing
1802 with a bind(c) and make sure the binding label is set correctly. */
1803 if (sym
->attr
.is_bind_c
== 1)
1805 if (!sym
->binding_label
)
1807 /* Set the binding label and verify that if a NAME= was specified
1808 then only one identifier was in the entity-decl-list. */
1809 if (!set_binding_label (&sym
->binding_label
, sym
->name
,
1810 num_idents_on_line
))
1815 /* See if we know we're in a common block, and if it's a bind(c)
1816 common then we need to make sure we're an interoperable type. */
1817 if (sym
->attr
.in_common
== 1)
1819 /* Test the common block object. */
1820 if (sym
->common_block
!= NULL
&& sym
->common_block
->is_bind_c
== 1
1821 && sym
->ts
.is_c_interop
!= 1)
1823 gfc_error_now ("Variable %qs in common block %qs at %C "
1824 "must be declared with a C interoperable "
1825 "kind since common block %qs is BIND(C)",
1826 sym
->name
, sym
->common_block
->name
,
1827 sym
->common_block
->name
);
1832 sym
->attr
.implied_index
= 0;
1834 /* Use the parameter expressions for a parameterized derived type. */
1835 if ((sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
1836 && sym
->ts
.u
.derived
->attr
.pdt_type
&& type_param_spec_list
)
1837 sym
->param_list
= gfc_copy_actual_arglist (type_param_spec_list
);
1839 if (sym
->ts
.type
== BT_CLASS
)
1840 return gfc_build_class_symbol (&sym
->ts
, &sym
->attr
, &sym
->as
);
1846 /* Set character constant to the given length. The constant will be padded or
1847 truncated. If we're inside an array constructor without a typespec, we
1848 additionally check that all elements have the same length; check_len -1
1849 means no checking. */
1852 gfc_set_constant_character_len (gfc_charlen_t len
, gfc_expr
*expr
,
1853 gfc_charlen_t check_len
)
1858 if (expr
->ts
.type
!= BT_CHARACTER
)
1861 if (expr
->expr_type
!= EXPR_CONSTANT
)
1863 gfc_error_now ("CHARACTER length must be a constant at %L", &expr
->where
);
1867 slen
= expr
->value
.character
.length
;
1870 s
= gfc_get_wide_string (len
+ 1);
1871 memcpy (s
, expr
->value
.character
.string
,
1872 MIN (len
, slen
) * sizeof (gfc_char_t
));
1874 gfc_wide_memset (&s
[slen
], ' ', len
- slen
);
1876 if (warn_character_truncation
&& slen
> len
)
1877 gfc_warning_now (OPT_Wcharacter_truncation
,
1878 "CHARACTER expression at %L is being truncated "
1879 "(%ld/%ld)", &expr
->where
,
1880 (long) slen
, (long) len
);
1882 /* Apply the standard by 'hand' otherwise it gets cleared for
1884 if (check_len
!= -1 && slen
!= check_len
1885 && !(gfc_option
.allow_std
& GFC_STD_GNU
))
1886 gfc_error_now ("The CHARACTER elements of the array constructor "
1887 "at %L must have the same length (%ld/%ld)",
1888 &expr
->where
, (long) slen
,
1892 free (expr
->value
.character
.string
);
1893 expr
->value
.character
.string
= s
;
1894 expr
->value
.character
.length
= len
;
1895 /* If explicit representation was given, clear it
1896 as it is no longer needed after padding. */
1897 if (expr
->representation
.length
)
1899 expr
->representation
.length
= 0;
1900 free (expr
->representation
.string
);
1901 expr
->representation
.string
= NULL
;
1907 /* Function to create and update the enumerator history
1908 using the information passed as arguments.
1909 Pointer "max_enum" is also updated, to point to
1910 enum history node containing largest initializer.
1912 SYM points to the symbol node of enumerator.
1913 INIT points to its enumerator value. */
1916 create_enum_history (gfc_symbol
*sym
, gfc_expr
*init
)
1918 enumerator_history
*new_enum_history
;
1919 gcc_assert (sym
!= NULL
&& init
!= NULL
);
1921 new_enum_history
= XCNEW (enumerator_history
);
1923 new_enum_history
->sym
= sym
;
1924 new_enum_history
->initializer
= init
;
1925 new_enum_history
->next
= NULL
;
1927 if (enum_history
== NULL
)
1929 enum_history
= new_enum_history
;
1930 max_enum
= enum_history
;
1934 new_enum_history
->next
= enum_history
;
1935 enum_history
= new_enum_history
;
1937 if (mpz_cmp (max_enum
->initializer
->value
.integer
,
1938 new_enum_history
->initializer
->value
.integer
) < 0)
1939 max_enum
= new_enum_history
;
1944 /* Function to free enum kind history. */
1947 gfc_free_enum_history (void)
1949 enumerator_history
*current
= enum_history
;
1950 enumerator_history
*next
;
1952 while (current
!= NULL
)
1954 next
= current
->next
;
1959 enum_history
= NULL
;
1963 /* Function to fix initializer character length if the length of the
1964 symbol or component is constant. */
1967 fix_initializer_charlen (gfc_typespec
*ts
, gfc_expr
*init
)
1969 if (!gfc_specification_expr (ts
->u
.cl
->length
))
1972 int k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
1974 /* resolve_charlen will complain later on if the length
1975 is too large. Just skip the initialization in that case. */
1976 if (mpz_cmp (ts
->u
.cl
->length
->value
.integer
,
1977 gfc_integer_kinds
[k
].huge
) <= 0)
1980 = gfc_mpz_get_hwi (ts
->u
.cl
->length
->value
.integer
);
1982 if (init
->expr_type
== EXPR_CONSTANT
)
1983 gfc_set_constant_character_len (len
, init
, -1);
1984 else if (init
->expr_type
== EXPR_ARRAY
)
1986 gfc_constructor
*cons
;
1988 /* Build a new charlen to prevent simplification from
1989 deleting the length before it is resolved. */
1990 init
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1991 init
->ts
.u
.cl
->length
= gfc_copy_expr (ts
->u
.cl
->length
);
1992 cons
= gfc_constructor_first (init
->value
.constructor
);
1993 for (; cons
; cons
= gfc_constructor_next (cons
))
1994 gfc_set_constant_character_len (len
, cons
->expr
, -1);
2002 /* Function called by variable_decl() that adds an initialization
2003 expression to a symbol. */
2006 add_init_expr_to_sym (const char *name
, gfc_expr
**initp
, locus
*var_locus
)
2008 symbol_attribute attr
;
2013 if (find_special (name
, &sym
, false))
2018 /* If this symbol is confirming an implicit parameter type,
2019 then an initialization expression is not allowed. */
2020 if (attr
.flavor
== FL_PARAMETER
&& sym
->value
!= NULL
)
2024 gfc_error ("Initializer not allowed for PARAMETER %qs at %C",
2034 /* An initializer is required for PARAMETER declarations. */
2035 if (attr
.flavor
== FL_PARAMETER
)
2037 gfc_error ("PARAMETER at %L is missing an initializer", var_locus
);
2043 /* If a variable appears in a DATA block, it cannot have an
2047 gfc_error ("Variable %qs at %C with an initializer already "
2048 "appears in a DATA statement", sym
->name
);
2052 /* Check if the assignment can happen. This has to be put off
2053 until later for derived type variables and procedure pointers. */
2054 if (!gfc_bt_struct (sym
->ts
.type
) && !gfc_bt_struct (init
->ts
.type
)
2055 && sym
->ts
.type
!= BT_CLASS
&& init
->ts
.type
!= BT_CLASS
2056 && !sym
->attr
.proc_pointer
2057 && !gfc_check_assign_symbol (sym
, NULL
, init
))
2060 if (sym
->ts
.type
== BT_CHARACTER
&& sym
->ts
.u
.cl
2061 && init
->ts
.type
== BT_CHARACTER
)
2063 /* Update symbol character length according initializer. */
2064 if (!gfc_check_assign_symbol (sym
, NULL
, init
))
2067 if (sym
->ts
.u
.cl
->length
== NULL
)
2070 /* If there are multiple CHARACTER variables declared on the
2071 same line, we don't want them to share the same length. */
2072 sym
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2074 if (sym
->attr
.flavor
== FL_PARAMETER
)
2076 if (init
->expr_type
== EXPR_CONSTANT
)
2078 clen
= init
->value
.character
.length
;
2079 sym
->ts
.u
.cl
->length
2080 = gfc_get_int_expr (gfc_charlen_int_kind
,
2083 else if (init
->expr_type
== EXPR_ARRAY
)
2085 if (init
->ts
.u
.cl
&& init
->ts
.u
.cl
->length
)
2087 const gfc_expr
*length
= init
->ts
.u
.cl
->length
;
2088 if (length
->expr_type
!= EXPR_CONSTANT
)
2090 gfc_error ("Cannot initialize parameter array "
2092 "with variable length elements",
2096 clen
= mpz_get_si (length
->value
.integer
);
2098 else if (init
->value
.constructor
)
2101 c
= gfc_constructor_first (init
->value
.constructor
);
2102 clen
= c
->expr
->value
.character
.length
;
2106 sym
->ts
.u
.cl
->length
2107 = gfc_get_int_expr (gfc_charlen_int_kind
,
2110 else if (init
->ts
.u
.cl
&& init
->ts
.u
.cl
->length
)
2111 sym
->ts
.u
.cl
->length
=
2112 gfc_copy_expr (init
->ts
.u
.cl
->length
);
2115 /* Update initializer character length according to symbol. */
2116 else if (sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
2117 && !fix_initializer_charlen (&sym
->ts
, init
))
2121 if (sym
->attr
.flavor
== FL_PARAMETER
&& sym
->attr
.dimension
&& sym
->as
2122 && sym
->as
->rank
&& init
->rank
&& init
->rank
!= sym
->as
->rank
)
2124 gfc_error ("Rank mismatch of array at %L and its initializer "
2125 "(%d/%d)", &sym
->declared_at
, sym
->as
->rank
, init
->rank
);
2129 /* If sym is implied-shape, set its upper bounds from init. */
2130 if (sym
->attr
.flavor
== FL_PARAMETER
&& sym
->attr
.dimension
2131 && sym
->as
->type
== AS_IMPLIED_SHAPE
)
2135 if (init
->rank
== 0)
2137 gfc_error ("Cannot initialize implied-shape array at %L"
2138 " with scalar", &sym
->declared_at
);
2142 /* The shape may be NULL for EXPR_ARRAY, set it. */
2143 if (init
->shape
== NULL
)
2145 if (init
->expr_type
!= EXPR_ARRAY
)
2147 gfc_error ("Bad shape of initializer at %L", &init
->where
);
2151 init
->shape
= gfc_get_shape (1);
2152 if (!gfc_array_size (init
, &init
->shape
[0]))
2154 gfc_error ("Cannot determine shape of initializer at %L",
2162 for (dim
= 0; dim
< sym
->as
->rank
; ++dim
)
2165 gfc_expr
*e
, *lower
;
2167 lower
= sym
->as
->lower
[dim
];
2169 /* If the lower bound is an array element from another
2170 parameterized array, then it is marked with EXPR_VARIABLE and
2171 is an initialization expression. Try to reduce it. */
2172 if (lower
->expr_type
== EXPR_VARIABLE
)
2173 gfc_reduce_init_expr (lower
);
2175 if (lower
->expr_type
== EXPR_CONSTANT
)
2177 /* All dimensions must be without upper bound. */
2178 gcc_assert (!sym
->as
->upper
[dim
]);
2181 e
= gfc_get_constant_expr (BT_INTEGER
, k
, &sym
->declared_at
);
2182 mpz_add (e
->value
.integer
, lower
->value
.integer
,
2184 mpz_sub_ui (e
->value
.integer
, e
->value
.integer
, 1);
2185 sym
->as
->upper
[dim
] = e
;
2189 gfc_error ("Non-constant lower bound in implied-shape"
2190 " declaration at %L", &lower
->where
);
2195 sym
->as
->type
= AS_EXPLICIT
;
2198 /* Ensure that explicit bounds are simplified. */
2199 if (sym
->attr
.flavor
== FL_PARAMETER
&& sym
->attr
.dimension
2200 && sym
->as
->type
== AS_EXPLICIT
)
2202 for (int dim
= 0; dim
< sym
->as
->rank
; ++dim
)
2206 e
= sym
->as
->lower
[dim
];
2207 if (e
->expr_type
!= EXPR_CONSTANT
)
2208 gfc_reduce_init_expr (e
);
2210 e
= sym
->as
->upper
[dim
];
2211 if (e
->expr_type
!= EXPR_CONSTANT
)
2212 gfc_reduce_init_expr (e
);
2216 /* Need to check if the expression we initialized this
2217 to was one of the iso_c_binding named constants. If so,
2218 and we're a parameter (constant), let it be iso_c.
2220 integer(c_int), parameter :: my_int = c_int
2221 integer(my_int) :: my_int_2
2222 If we mark my_int as iso_c (since we can see it's value
2223 is equal to one of the named constants), then my_int_2
2224 will be considered C interoperable. */
2225 if (sym
->ts
.type
!= BT_CHARACTER
&& !gfc_bt_struct (sym
->ts
.type
))
2227 sym
->ts
.is_iso_c
|= init
->ts
.is_iso_c
;
2228 sym
->ts
.is_c_interop
|= init
->ts
.is_c_interop
;
2229 /* attr bits needed for module files. */
2230 sym
->attr
.is_iso_c
|= init
->ts
.is_iso_c
;
2231 sym
->attr
.is_c_interop
|= init
->ts
.is_c_interop
;
2232 if (init
->ts
.is_iso_c
)
2233 sym
->ts
.f90_type
= init
->ts
.f90_type
;
2236 /* Catch the case: type(t), parameter :: x = z'1'. */
2237 if (sym
->ts
.type
== BT_DERIVED
&& init
->ts
.type
== BT_BOZ
)
2239 gfc_error ("Entity %qs at %L is incompatible with a BOZ "
2240 "literal constant", name
, &sym
->declared_at
);
2244 /* Add initializer. Make sure we keep the ranks sane. */
2245 if (sym
->attr
.dimension
&& init
->rank
== 0)
2250 if (sym
->attr
.flavor
== FL_PARAMETER
2251 && gfc_is_constant_expr (init
)
2252 && (init
->expr_type
== EXPR_CONSTANT
2253 || init
->expr_type
== EXPR_STRUCTURE
)
2254 && spec_size (sym
->as
, &size
))
2256 array
= gfc_get_array_expr (init
->ts
.type
, init
->ts
.kind
,
2258 if (init
->ts
.type
== BT_DERIVED
)
2259 array
->ts
.u
.derived
= init
->ts
.u
.derived
;
2260 for (n
= 0; n
< (int)mpz_get_si (size
); n
++)
2261 gfc_constructor_append_expr (&array
->value
.constructor
,
2264 : gfc_copy_expr (init
),
2267 array
->shape
= gfc_get_shape (sym
->as
->rank
);
2268 for (n
= 0; n
< sym
->as
->rank
; n
++)
2269 spec_dimen_size (sym
->as
, n
, &array
->shape
[n
]);
2274 init
->rank
= sym
->as
->rank
;
2278 if (sym
->attr
.save
== SAVE_NONE
)
2279 sym
->attr
.save
= SAVE_IMPLICIT
;
2287 /* Function called by variable_decl() that adds a name to a structure
2291 build_struct (const char *name
, gfc_charlen
*cl
, gfc_expr
**init
,
2292 gfc_array_spec
**as
)
2297 /* F03:C438/C439. If the current symbol is of the same derived type that we're
2298 constructing, it must have the pointer attribute. */
2299 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
2300 && current_ts
.u
.derived
== gfc_current_block ()
2301 && current_attr
.pointer
== 0)
2303 if (current_attr
.allocatable
2304 && !gfc_notify_std(GFC_STD_F2008
, "Component at %C "
2305 "must have the POINTER attribute"))
2309 else if (current_attr
.allocatable
== 0)
2311 gfc_error ("Component at %C must have the POINTER attribute");
2317 if (current_ts
.type
== BT_CLASS
2318 && !(current_attr
.pointer
|| current_attr
.allocatable
))
2320 gfc_error ("Component %qs with CLASS at %C must be allocatable "
2321 "or pointer", name
);
2325 if (gfc_current_block ()->attr
.pointer
&& (*as
)->rank
!= 0)
2327 if ((*as
)->type
!= AS_DEFERRED
&& (*as
)->type
!= AS_EXPLICIT
)
2329 gfc_error ("Array component of structure at %C must have explicit "
2330 "or deferred shape");
2335 /* If we are in a nested union/map definition, gfc_add_component will not
2336 properly find repeated components because:
2337 (i) gfc_add_component does a flat search, where components of unions
2338 and maps are implicity chained so nested components may conflict.
2339 (ii) Unions and maps are not linked as components of their parent
2340 structures until after they are parsed.
2341 For (i) we use gfc_find_component which searches recursively, and for (ii)
2342 we search each block directly from the parse stack until we find the top
2345 s
= gfc_state_stack
;
2346 if (s
->state
== COMP_UNION
|| s
->state
== COMP_MAP
)
2348 while (s
->state
== COMP_UNION
|| gfc_comp_struct (s
->state
))
2350 c
= gfc_find_component (s
->sym
, name
, true, true, NULL
);
2353 gfc_error_now ("Component %qs at %C already declared at %L",
2357 /* Break after we've searched the entire chain. */
2358 if (s
->state
== COMP_DERIVED
|| s
->state
== COMP_STRUCTURE
)
2364 if (!gfc_add_component (gfc_current_block(), name
, &c
))
2368 if (c
->ts
.type
== BT_CHARACTER
)
2371 if (c
->ts
.type
!= BT_CLASS
&& c
->ts
.type
!= BT_DERIVED
2372 && (c
->ts
.kind
== 0 || c
->ts
.type
== BT_CHARACTER
)
2373 && saved_kind_expr
!= NULL
)
2374 c
->kind_expr
= gfc_copy_expr (saved_kind_expr
);
2376 c
->attr
= current_attr
;
2378 c
->initializer
= *init
;
2381 /* Update initializer character length according to component. */
2382 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.u
.cl
->length
2383 && c
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
2384 && c
->initializer
&& c
->initializer
->ts
.type
== BT_CHARACTER
2385 && !fix_initializer_charlen (&c
->ts
, c
->initializer
))
2392 c
->attr
.codimension
= 1;
2394 c
->attr
.dimension
= 1;
2398 gfc_apply_init (&c
->ts
, &c
->attr
, c
->initializer
);
2400 /* Check array components. */
2401 if (!c
->attr
.dimension
)
2404 if (c
->attr
.pointer
)
2406 if (c
->as
->type
!= AS_DEFERRED
)
2408 gfc_error ("Pointer array component of structure at %C must have a "
2413 else if (c
->attr
.allocatable
)
2415 if (c
->as
->type
!= AS_DEFERRED
)
2417 gfc_error ("Allocatable component of structure at %C must have a "
2424 if (c
->as
->type
!= AS_EXPLICIT
)
2426 gfc_error ("Array component of structure at %C must have an "
2433 if (c
->ts
.type
== BT_CLASS
)
2434 return gfc_build_class_symbol (&c
->ts
, &c
->attr
, &c
->as
);
2436 if (c
->attr
.pdt_kind
|| c
->attr
.pdt_len
)
2439 gfc_find_symbol (c
->name
, gfc_current_block ()->f2k_derived
,
2443 gfc_error ("Type parameter %qs at %C has no corresponding entry "
2444 "in the type parameter name list at %L",
2445 c
->name
, &gfc_current_block ()->declared_at
);
2449 sym
->attr
.pdt_kind
= c
->attr
.pdt_kind
;
2450 sym
->attr
.pdt_len
= c
->attr
.pdt_len
;
2452 sym
->value
= gfc_copy_expr (c
->initializer
);
2453 sym
->attr
.flavor
= FL_VARIABLE
;
2456 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
2457 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_template
2458 && decl_type_param_list
)
2459 c
->param_list
= gfc_copy_actual_arglist (decl_type_param_list
);
2465 /* Match a 'NULL()', and possibly take care of some side effects. */
2468 gfc_match_null (gfc_expr
**result
)
2471 match m
, m2
= MATCH_NO
;
2473 if ((m
= gfc_match (" null ( )")) == MATCH_ERROR
)
2479 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2481 if ((m2
= gfc_match (" null (")) != MATCH_YES
)
2484 old_loc
= gfc_current_locus
;
2485 if ((m2
= gfc_match (" %n ) ", name
)) == MATCH_ERROR
)
2488 && ((m2
= gfc_match (" mold = %n )", name
)) == MATCH_ERROR
))
2492 gfc_current_locus
= old_loc
;
2497 /* The NULL symbol now has to be/become an intrinsic function. */
2498 if (gfc_get_symbol ("null", NULL
, &sym
))
2500 gfc_error ("NULL() initialization at %C is ambiguous");
2504 gfc_intrinsic_symbol (sym
);
2506 if (sym
->attr
.proc
!= PROC_INTRINSIC
2507 && !(sym
->attr
.use_assoc
&& sym
->attr
.intrinsic
)
2508 && (!gfc_add_procedure(&sym
->attr
, PROC_INTRINSIC
, sym
->name
, NULL
)
2509 || !gfc_add_function (&sym
->attr
, sym
->name
, NULL
)))
2512 *result
= gfc_get_null_expr (&gfc_current_locus
);
2514 /* Invalid per F2008, C512. */
2515 if (m2
== MATCH_YES
)
2517 gfc_error ("NULL() initialization at %C may not have MOLD");
2525 /* Match the initialization expr for a data pointer or procedure pointer. */
2528 match_pointer_init (gfc_expr
**init
, int procptr
)
2532 if (gfc_pure (NULL
) && !gfc_comp_struct (gfc_state_stack
->state
))
2534 gfc_error ("Initialization of pointer at %C is not allowed in "
2535 "a PURE procedure");
2538 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
2540 /* Match NULL() initialization. */
2541 m
= gfc_match_null (init
);
2545 /* Match non-NULL initialization. */
2546 gfc_matching_ptr_assignment
= !procptr
;
2547 gfc_matching_procptr_assignment
= procptr
;
2548 m
= gfc_match_rvalue (init
);
2549 gfc_matching_ptr_assignment
= 0;
2550 gfc_matching_procptr_assignment
= 0;
2551 if (m
== MATCH_ERROR
)
2553 else if (m
== MATCH_NO
)
2555 gfc_error ("Error in pointer initialization at %C");
2559 if (!procptr
&& !gfc_resolve_expr (*init
))
2562 if (!gfc_notify_std (GFC_STD_F2008
, "non-NULL pointer "
2563 "initialization at %C"))
2571 check_function_name (char *name
)
2573 /* In functions that have a RESULT variable defined, the function name always
2574 refers to function calls. Therefore, the name is not allowed to appear in
2575 specification statements. When checking this, be careful about
2576 'hidden' procedure pointer results ('ppr@'). */
2578 if (gfc_current_state () == COMP_FUNCTION
)
2580 gfc_symbol
*block
= gfc_current_block ();
2581 if (block
&& block
->result
&& block
->result
!= block
2582 && strcmp (block
->result
->name
, "ppr@") != 0
2583 && strcmp (block
->name
, name
) == 0)
2585 gfc_error ("RESULT variable %qs at %L prohibits FUNCTION name %qs at %C "
2586 "from appearing in a specification statement",
2587 block
->result
->name
, &block
->result
->declared_at
, name
);
2596 /* Match a variable name with an optional initializer. When this
2597 subroutine is called, a variable is expected to be parsed next.
2598 Depending on what is happening at the moment, updates either the
2599 symbol table or the current interface. */
2602 variable_decl (int elem
)
2604 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2605 static unsigned int fill_id
= 0;
2606 gfc_expr
*initializer
, *char_len
;
2608 gfc_array_spec
*cp_as
; /* Extra copy for Cray Pointees. */
2621 /* When we get here, we've just matched a list of attributes and
2622 maybe a type and a double colon. The next thing we expect to see
2623 is the name of the symbol. */
2625 /* If we are parsing a structure with legacy support, we allow the symbol
2626 name to be '%FILL' which gives it an anonymous (inaccessible) name. */
2628 gfc_gobble_whitespace ();
2629 c
= gfc_peek_ascii_char ();
2632 gfc_next_ascii_char (); /* Burn % character. */
2633 m
= gfc_match ("fill");
2636 if (gfc_current_state () != COMP_STRUCTURE
)
2638 if (flag_dec_structure
)
2639 gfc_error ("%qs not allowed outside STRUCTURE at %C", "%FILL");
2641 gfc_error ("%qs at %C is a DEC extension, enable with "
2642 "%<-fdec-structure%>", "%FILL");
2649 gfc_error ("%qs entity cannot have attributes at %C", "%FILL");
2654 /* %FILL components are given invalid fortran names. */
2655 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "%%FILL%u", fill_id
++);
2659 gfc_error ("Invalid character %qc in variable name at %C", c
);
2665 m
= gfc_match_name (name
);
2670 var_locus
= gfc_current_locus
;
2672 /* Now we could see the optional array spec. or character length. */
2673 m
= gfc_match_array_spec (&as
, true, true);
2674 if (m
== MATCH_ERROR
)
2678 as
= gfc_copy_array_spec (current_as
);
2680 && !merge_array_spec (current_as
, as
, true))
2686 if (flag_cray_pointer
)
2687 cp_as
= gfc_copy_array_spec (as
);
2689 /* At this point, we know for sure if the symbol is PARAMETER and can thus
2690 determine (and check) whether it can be implied-shape. If it
2691 was parsed as assumed-size, change it because PARAMETERs cannot
2694 An explicit-shape-array cannot appear under several conditions.
2695 That check is done here as well. */
2698 if (as
->type
== AS_IMPLIED_SHAPE
&& current_attr
.flavor
!= FL_PARAMETER
)
2701 gfc_error ("Non-PARAMETER symbol %qs at %L cannot be implied-shape",
2706 if (as
->type
== AS_ASSUMED_SIZE
&& as
->rank
== 1
2707 && current_attr
.flavor
== FL_PARAMETER
)
2708 as
->type
= AS_IMPLIED_SHAPE
;
2710 if (as
->type
== AS_IMPLIED_SHAPE
2711 && !gfc_notify_std (GFC_STD_F2008
, "Implied-shape array at %L",
2718 gfc_seen_div0
= false;
2720 /* F2018:C830 (R816) An explicit-shape-spec whose bounds are not
2721 constant expressions shall appear only in a subprogram, derived
2722 type definition, BLOCK construct, or interface body. */
2723 if (as
->type
== AS_EXPLICIT
2724 && gfc_current_state () != COMP_BLOCK
2725 && gfc_current_state () != COMP_DERIVED
2726 && gfc_current_state () != COMP_FUNCTION
2727 && gfc_current_state () != COMP_INTERFACE
2728 && gfc_current_state () != COMP_SUBROUTINE
)
2731 bool not_constant
= false;
2733 for (int i
= 0; i
< as
->rank
; i
++)
2735 e
= gfc_copy_expr (as
->lower
[i
]);
2736 if (!gfc_resolve_expr (e
) && gfc_seen_div0
)
2742 gfc_simplify_expr (e
, 0);
2743 if (e
&& (e
->expr_type
!= EXPR_CONSTANT
))
2745 not_constant
= true;
2750 e
= gfc_copy_expr (as
->upper
[i
]);
2751 if (!gfc_resolve_expr (e
) && gfc_seen_div0
)
2757 gfc_simplify_expr (e
, 0);
2758 if (e
&& (e
->expr_type
!= EXPR_CONSTANT
))
2760 not_constant
= true;
2766 if (not_constant
&& e
->ts
.type
!= BT_INTEGER
)
2768 gfc_error ("Explicit array shape at %C must be constant of "
2769 "INTEGER type and not %s type",
2770 gfc_basic_typename (e
->ts
.type
));
2776 gfc_error ("Explicit shaped array with nonconstant bounds at %C");
2781 if (as
->type
== AS_EXPLICIT
)
2783 for (int i
= 0; i
< as
->rank
; i
++)
2787 if (e
->expr_type
!= EXPR_CONSTANT
)
2789 n
= gfc_copy_expr (e
);
2790 if (!gfc_simplify_expr (n
, 1) && gfc_seen_div0
)
2796 if (n
->expr_type
== EXPR_CONSTANT
)
2797 gfc_replace_expr (e
, n
);
2802 if (e
->expr_type
!= EXPR_CONSTANT
)
2804 n
= gfc_copy_expr (e
);
2805 if (!gfc_simplify_expr (n
, 1) && gfc_seen_div0
)
2811 if (n
->expr_type
== EXPR_CONSTANT
)
2812 gfc_replace_expr (e
, n
);
2816 /* For an explicit-shape spec with constant bounds, ensure
2817 that the effective upper bound is not lower than the
2818 respective lower bound minus one. Otherwise adjust it so
2819 that the extent is trivially derived to be zero. */
2820 if (as
->lower
[i
]->expr_type
== EXPR_CONSTANT
2821 && as
->upper
[i
]->expr_type
== EXPR_CONSTANT
2822 && as
->lower
[i
]->ts
.type
== BT_INTEGER
2823 && as
->upper
[i
]->ts
.type
== BT_INTEGER
2824 && mpz_cmp (as
->upper
[i
]->value
.integer
,
2825 as
->lower
[i
]->value
.integer
) < 0)
2826 mpz_sub_ui (as
->upper
[i
]->value
.integer
,
2827 as
->lower
[i
]->value
.integer
, 1);
2834 cl_deferred
= false;
2836 if (current_ts
.type
== BT_CHARACTER
)
2838 switch (match_char_length (&char_len
, &cl_deferred
, false))
2841 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2843 cl
->length
= char_len
;
2846 /* Non-constant lengths need to be copied after the first
2847 element. Also copy assumed lengths. */
2850 && (current_ts
.u
.cl
->length
== NULL
2851 || current_ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
2853 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2854 cl
->length
= gfc_copy_expr (current_ts
.u
.cl
->length
);
2857 cl
= current_ts
.u
.cl
;
2859 cl_deferred
= current_ts
.deferred
;
2868 /* The dummy arguments and result of the abbreviated form of MODULE
2869 PROCEDUREs, used in SUBMODULES should not be redefined. */
2870 if (gfc_current_ns
->proc_name
2871 && gfc_current_ns
->proc_name
->abr_modproc_decl
)
2873 gfc_find_symbol (name
, gfc_current_ns
, 1, &sym
);
2874 if (sym
!= NULL
&& (sym
->attr
.dummy
|| sym
->attr
.result
))
2877 gfc_error ("%qs at %C is a redefinition of the declaration "
2878 "in the corresponding interface for MODULE "
2879 "PROCEDURE %qs", sym
->name
,
2880 gfc_current_ns
->proc_name
->name
);
2885 /* %FILL components may not have initializers. */
2886 if (startswith (name
, "%FILL") && gfc_match_eos () != MATCH_YES
)
2888 gfc_error ("%qs entity cannot have an initializer at %C", "%FILL");
2893 /* If this symbol has already shown up in a Cray Pointer declaration,
2894 and this is not a component declaration,
2895 then we want to set the type & bail out. */
2896 if (flag_cray_pointer
&& !gfc_comp_struct (gfc_current_state ()))
2898 gfc_find_symbol (name
, gfc_current_ns
, 0, &sym
);
2899 if (sym
!= NULL
&& sym
->attr
.cray_pointee
)
2902 if (!gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
2908 /* Check to see if we have an array specification. */
2911 if (sym
->as
!= NULL
)
2913 gfc_error ("Duplicate array spec for Cray pointee at %C");
2914 gfc_free_array_spec (cp_as
);
2920 if (!gfc_set_array_spec (sym
, cp_as
, &var_locus
))
2921 gfc_internal_error ("Cannot set pointee array spec.");
2923 /* Fix the array spec. */
2924 m
= gfc_mod_pointee_as (sym
->as
);
2925 if (m
== MATCH_ERROR
)
2933 gfc_free_array_spec (cp_as
);
2937 /* Procedure pointer as function result. */
2938 if (gfc_current_state () == COMP_FUNCTION
2939 && strcmp ("ppr@", gfc_current_block ()->name
) == 0
2940 && strcmp (name
, gfc_current_block ()->ns
->proc_name
->name
) == 0)
2941 strcpy (name
, "ppr@");
2943 if (gfc_current_state () == COMP_FUNCTION
2944 && strcmp (name
, gfc_current_block ()->name
) == 0
2945 && gfc_current_block ()->result
2946 && strcmp ("ppr@", gfc_current_block ()->result
->name
) == 0)
2947 strcpy (name
, "ppr@");
2949 /* OK, we've successfully matched the declaration. Now put the
2950 symbol in the current namespace, because it might be used in the
2951 optional initialization expression for this symbol, e.g. this is
2954 integer, parameter :: i = huge(i)
2956 This is only true for parameters or variables of a basic type.
2957 For components of derived types, it is not true, so we don't
2958 create a symbol for those yet. If we fail to create the symbol,
2960 if (!gfc_comp_struct (gfc_current_state ())
2961 && !build_sym (name
, cl
, cl_deferred
, &as
, &var_locus
))
2967 if (!check_function_name (name
))
2973 /* We allow old-style initializations of the form
2974 integer i /2/, j(4) /3*3, 1/
2975 (if no colon has been seen). These are different from data
2976 statements in that initializers are only allowed to apply to the
2977 variable immediately preceding, i.e.
2979 is not allowed. Therefore we have to do some work manually, that
2980 could otherwise be left to the matchers for DATA statements. */
2982 if (!colon_seen
&& gfc_match (" /") == MATCH_YES
)
2984 if (!gfc_notify_std (GFC_STD_GNU
, "Old-style "
2985 "initialization at %C"))
2988 /* Allow old style initializations for components of STRUCTUREs and MAPs
2989 but not components of derived types. */
2990 else if (gfc_current_state () == COMP_DERIVED
)
2992 gfc_error ("Invalid old style initialization for derived type "
2998 /* For structure components, read the initializer as a special
2999 expression and let the rest of this function apply the initializer
3001 else if (gfc_comp_struct (gfc_current_state ()))
3003 m
= match_clist_expr (&initializer
, ¤t_ts
, as
);
3005 gfc_error ("Syntax error in old style initialization of %s at %C",
3011 /* Otherwise we treat the old style initialization just like a
3012 DATA declaration for the current variable. */
3014 return match_old_style_init (name
);
3017 /* The double colon must be present in order to have initializers.
3018 Otherwise the statement is ambiguous with an assignment statement. */
3021 if (gfc_match (" =>") == MATCH_YES
)
3023 if (!current_attr
.pointer
)
3025 gfc_error ("Initialization at %C isn't for a pointer variable");
3030 m
= match_pointer_init (&initializer
, 0);
3034 /* The target of a pointer initialization must have the SAVE
3035 attribute. A variable in PROGRAM, MODULE, or SUBMODULE scope
3036 is implicit SAVEd. Explicitly, set the SAVE_IMPLICIT value. */
3037 if (initializer
->expr_type
== EXPR_VARIABLE
3038 && initializer
->symtree
->n
.sym
->attr
.save
== SAVE_NONE
3039 && (gfc_current_state () == COMP_PROGRAM
3040 || gfc_current_state () == COMP_MODULE
3041 || gfc_current_state () == COMP_SUBMODULE
))
3042 initializer
->symtree
->n
.sym
->attr
.save
= SAVE_IMPLICIT
;
3044 else if (gfc_match_char ('=') == MATCH_YES
)
3046 if (current_attr
.pointer
)
3048 gfc_error ("Pointer initialization at %C requires %<=>%>, "
3054 m
= gfc_match_init_expr (&initializer
);
3057 gfc_error ("Expected an initialization expression at %C");
3061 if (current_attr
.flavor
!= FL_PARAMETER
&& gfc_pure (NULL
)
3062 && !gfc_comp_struct (gfc_state_stack
->state
))
3064 gfc_error ("Initialization of variable at %C is not allowed in "
3065 "a PURE procedure");
3069 if (current_attr
.flavor
!= FL_PARAMETER
3070 && !gfc_comp_struct (gfc_state_stack
->state
))
3071 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
3078 if (initializer
!= NULL
&& current_attr
.allocatable
3079 && gfc_comp_struct (gfc_current_state ()))
3081 gfc_error ("Initialization of allocatable component at %C is not "
3087 if (gfc_current_state () == COMP_DERIVED
3088 && initializer
&& initializer
->ts
.type
== BT_HOLLERITH
)
3090 gfc_error ("Initialization of structure component with a HOLLERITH "
3091 "constant at %L is not allowed", &initializer
->where
);
3096 if (gfc_current_state () == COMP_DERIVED
3097 && gfc_current_block ()->attr
.pdt_template
)
3100 gfc_find_symbol (name
, gfc_current_block ()->f2k_derived
,
3102 if (!param
&& (current_attr
.pdt_kind
|| current_attr
.pdt_len
))
3104 gfc_error ("The component with KIND or LEN attribute at %C does not "
3105 "not appear in the type parameter list at %L",
3106 &gfc_current_block ()->declared_at
);
3110 else if (param
&& !(current_attr
.pdt_kind
|| current_attr
.pdt_len
))
3112 gfc_error ("The component at %C that appears in the type parameter "
3113 "list at %L has neither the KIND nor LEN attribute",
3114 &gfc_current_block ()->declared_at
);
3118 else if (as
&& (current_attr
.pdt_kind
|| current_attr
.pdt_len
))
3120 gfc_error ("The component at %C which is a type parameter must be "
3125 else if (param
&& initializer
)
3127 if (initializer
->ts
.type
== BT_BOZ
)
3129 gfc_error ("BOZ literal constant at %L cannot appear as an "
3130 "initializer", &initializer
->where
);
3134 param
->value
= gfc_copy_expr (initializer
);
3138 /* Before adding a possible initializer, do a simple check for compatibility
3139 of lhs and rhs types. Assigning a REAL value to a derived type is not a
3141 if (current_ts
.type
== BT_DERIVED
&& initializer
3142 && (gfc_numeric_ts (&initializer
->ts
)
3143 || initializer
->ts
.type
== BT_LOGICAL
3144 || initializer
->ts
.type
== BT_CHARACTER
))
3146 gfc_error ("Incompatible initialization between a derived type "
3147 "entity and an entity with %qs type at %C",
3148 gfc_typename (initializer
));
3154 /* Add the initializer. Note that it is fine if initializer is
3155 NULL here, because we sometimes also need to check if a
3156 declaration *must* have an initialization expression. */
3157 if (!gfc_comp_struct (gfc_current_state ()))
3158 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
3161 if (current_ts
.type
== BT_DERIVED
3162 && !current_attr
.pointer
&& !initializer
)
3163 initializer
= gfc_default_initializer (¤t_ts
);
3164 t
= build_struct (name
, cl
, &initializer
, &as
);
3166 /* If we match a nested structure definition we expect to see the
3167 * body even if the variable declarations blow up, so we need to keep
3168 * the structure declaration around. */
3169 if (gfc_new_block
&& gfc_new_block
->attr
.flavor
== FL_STRUCT
)
3170 gfc_commit_symbol (gfc_new_block
);
3173 m
= (t
) ? MATCH_YES
: MATCH_ERROR
;
3176 /* Free stuff up and return. */
3177 gfc_seen_div0
= false;
3178 gfc_free_expr (initializer
);
3179 gfc_free_array_spec (as
);
3185 /* Match an extended-f77 "TYPESPEC*bytesize"-style kind specification.
3186 This assumes that the byte size is equal to the kind number for
3187 non-COMPLEX types, and equal to twice the kind number for COMPLEX. */
3190 gfc_match_old_kind_spec (gfc_typespec
*ts
)
3195 if (gfc_match_char ('*') != MATCH_YES
)
3198 m
= gfc_match_small_literal_int (&ts
->kind
, NULL
);
3202 original_kind
= ts
->kind
;
3204 /* Massage the kind numbers for complex types. */
3205 if (ts
->type
== BT_COMPLEX
)
3209 gfc_error ("Old-style type declaration %s*%d not supported at %C",
3210 gfc_basic_typename (ts
->type
), original_kind
);
3217 if (ts
->type
== BT_INTEGER
&& ts
->kind
== 4 && flag_integer4_kind
== 8)
3220 if (ts
->type
== BT_REAL
|| ts
->type
== BT_COMPLEX
)
3224 if (flag_real4_kind
== 8)
3226 if (flag_real4_kind
== 10)
3228 if (flag_real4_kind
== 16)
3231 else if (ts
->kind
== 8)
3233 if (flag_real8_kind
== 4)
3235 if (flag_real8_kind
== 10)
3237 if (flag_real8_kind
== 16)
3242 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
3244 gfc_error ("Old-style type declaration %s*%d not supported at %C",
3245 gfc_basic_typename (ts
->type
), original_kind
);
3249 if (!gfc_notify_std (GFC_STD_GNU
,
3250 "Nonstandard type declaration %s*%d at %C",
3251 gfc_basic_typename(ts
->type
), original_kind
))
3258 /* Match a kind specification. Since kinds are generally optional, we
3259 usually return MATCH_NO if something goes wrong. If a "kind="
3260 string is found, then we know we have an error. */
3263 gfc_match_kind_spec (gfc_typespec
*ts
, bool kind_expr_only
)
3273 saved_kind_expr
= NULL
;
3275 where
= loc
= gfc_current_locus
;
3280 if (gfc_match_char ('(') == MATCH_NO
)
3283 /* Also gobbles optional text. */
3284 if (gfc_match (" kind = ") == MATCH_YES
)
3287 loc
= gfc_current_locus
;
3291 n
= gfc_match_init_expr (&e
);
3293 if (gfc_derived_parameter_expr (e
))
3296 saved_kind_expr
= gfc_copy_expr (e
);
3297 goto close_brackets
;
3302 if (gfc_matching_function
)
3304 /* The function kind expression might include use associated or
3305 imported parameters and try again after the specification
3307 if (gfc_match_char (')') != MATCH_YES
)
3309 gfc_error ("Missing right parenthesis at %C");
3315 gfc_undo_symbols ();
3320 /* ....or else, the match is real. */
3322 gfc_error ("Expected initialization expression at %C");
3330 gfc_error ("Expected scalar initialization expression at %C");
3335 if (gfc_extract_int (e
, &ts
->kind
, 1))
3341 /* Before throwing away the expression, let's see if we had a
3342 C interoperable kind (and store the fact). */
3343 if (e
->ts
.is_c_interop
== 1)
3345 /* Mark this as C interoperable if being declared with one
3346 of the named constants from iso_c_binding. */
3347 ts
->is_c_interop
= e
->ts
.is_iso_c
;
3348 ts
->f90_type
= e
->ts
.f90_type
;
3350 ts
->interop_kind
= e
->symtree
->n
.sym
;
3356 /* Ignore errors to this point, if we've gotten here. This means
3357 we ignore the m=MATCH_ERROR from above. */
3358 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
3360 gfc_error ("Kind %d not supported for type %s at %C", ts
->kind
,
3361 gfc_basic_typename (ts
->type
));
3362 gfc_current_locus
= where
;
3366 /* Warn if, e.g., c_int is used for a REAL variable, but not
3367 if, e.g., c_double is used for COMPLEX as the standard
3368 explicitly says that the kind type parameter for complex and real
3369 variable is the same, i.e. c_float == c_float_complex. */
3370 if (ts
->f90_type
!= BT_UNKNOWN
&& ts
->f90_type
!= ts
->type
3371 && !((ts
->f90_type
== BT_REAL
&& ts
->type
== BT_COMPLEX
)
3372 || (ts
->f90_type
== BT_COMPLEX
&& ts
->type
== BT_REAL
)))
3373 gfc_warning_now (0, "C kind type parameter is for type %s but type at %L "
3374 "is %s", gfc_basic_typename (ts
->f90_type
), &where
,
3375 gfc_basic_typename (ts
->type
));
3379 gfc_gobble_whitespace ();
3380 if ((c
= gfc_next_ascii_char ()) != ')'
3381 && (ts
->type
!= BT_CHARACTER
|| c
!= ','))
3383 if (ts
->type
== BT_CHARACTER
)
3384 gfc_error ("Missing right parenthesis or comma at %C");
3386 gfc_error ("Missing right parenthesis at %C");
3391 /* All tests passed. */
3394 if(m
== MATCH_ERROR
)
3395 gfc_current_locus
= where
;
3397 if (ts
->type
== BT_INTEGER
&& ts
->kind
== 4 && flag_integer4_kind
== 8)
3400 if (ts
->type
== BT_REAL
|| ts
->type
== BT_COMPLEX
)
3404 if (flag_real4_kind
== 8)
3406 if (flag_real4_kind
== 10)
3408 if (flag_real4_kind
== 16)
3411 else if (ts
->kind
== 8)
3413 if (flag_real8_kind
== 4)
3415 if (flag_real8_kind
== 10)
3417 if (flag_real8_kind
== 16)
3422 /* Return what we know from the test(s). */
3427 gfc_current_locus
= where
;
3433 match_char_kind (int * kind
, int * is_iso_c
)
3442 where
= gfc_current_locus
;
3444 n
= gfc_match_init_expr (&e
);
3446 if (n
!= MATCH_YES
&& gfc_matching_function
)
3448 /* The expression might include use-associated or imported
3449 parameters and try again after the specification
3452 gfc_undo_symbols ();
3457 gfc_error ("Expected initialization expression at %C");
3463 gfc_error ("Expected scalar initialization expression at %C");
3468 if (gfc_derived_parameter_expr (e
))
3470 saved_kind_expr
= e
;
3475 fail
= gfc_extract_int (e
, kind
, 1);
3476 *is_iso_c
= e
->ts
.is_iso_c
;
3485 /* Ignore errors to this point, if we've gotten here. This means
3486 we ignore the m=MATCH_ERROR from above. */
3487 if (gfc_validate_kind (BT_CHARACTER
, *kind
, true) < 0)
3489 gfc_error ("Kind %d is not supported for CHARACTER at %C", *kind
);
3493 /* All tests passed. */
3496 if (m
== MATCH_ERROR
)
3497 gfc_current_locus
= where
;
3499 /* Return what we know from the test(s). */
3504 gfc_current_locus
= where
;
3509 /* Match the various kind/length specifications in a CHARACTER
3510 declaration. We don't return MATCH_NO. */
3513 gfc_match_char_spec (gfc_typespec
*ts
)
3515 int kind
, seen_length
, is_iso_c
;
3527 /* Try the old-style specification first. */
3528 old_char_selector
= 0;
3530 m
= match_char_length (&len
, &deferred
, true);
3534 old_char_selector
= 1;
3539 m
= gfc_match_char ('(');
3542 m
= MATCH_YES
; /* Character without length is a single char. */
3546 /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ). */
3547 if (gfc_match (" kind =") == MATCH_YES
)
3549 m
= match_char_kind (&kind
, &is_iso_c
);
3551 if (m
== MATCH_ERROR
)
3556 if (gfc_match (" , len =") == MATCH_NO
)
3559 m
= char_len_param_value (&len
, &deferred
);
3562 if (m
== MATCH_ERROR
)
3569 /* Try to match "LEN = <len-param>" or "LEN = <len-param>, KIND = <int>". */
3570 if (gfc_match (" len =") == MATCH_YES
)
3572 m
= char_len_param_value (&len
, &deferred
);
3575 if (m
== MATCH_ERROR
)
3579 if (gfc_match_char (')') == MATCH_YES
)
3582 if (gfc_match (" , kind =") != MATCH_YES
)
3585 if (match_char_kind (&kind
, &is_iso_c
) == MATCH_ERROR
)
3591 /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ). */
3592 m
= char_len_param_value (&len
, &deferred
);
3595 if (m
== MATCH_ERROR
)
3599 m
= gfc_match_char (')');
3603 if (gfc_match_char (',') != MATCH_YES
)
3606 gfc_match (" kind ="); /* Gobble optional text. */
3608 m
= match_char_kind (&kind
, &is_iso_c
);
3609 if (m
== MATCH_ERROR
)
3615 /* Require a right-paren at this point. */
3616 m
= gfc_match_char (')');
3621 gfc_error ("Syntax error in CHARACTER declaration at %C");
3623 gfc_free_expr (len
);
3627 /* Deal with character functions after USE and IMPORT statements. */
3628 if (gfc_matching_function
)
3630 gfc_free_expr (len
);
3631 gfc_undo_symbols ();
3637 gfc_free_expr (len
);
3641 /* Do some final massaging of the length values. */
3642 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
3644 if (seen_length
== 0)
3645 cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
, 1);
3648 /* If gfortran ends up here, then len may be reducible to a constant.
3649 Try to do that here. If it does not reduce, simply assign len to
3650 charlen. A complication occurs with user-defined generic functions,
3651 which are not resolved. Use a private namespace to deal with
3652 generic functions. */
3654 if (len
&& len
->expr_type
!= EXPR_CONSTANT
)
3656 gfc_namespace
*old_ns
;
3659 old_ns
= gfc_current_ns
;
3660 gfc_current_ns
= gfc_get_namespace (NULL
, 0);
3662 e
= gfc_copy_expr (len
);
3663 gfc_push_suppress_errors ();
3664 gfc_reduce_init_expr (e
);
3665 gfc_pop_suppress_errors ();
3666 if (e
->expr_type
== EXPR_CONSTANT
)
3668 gfc_replace_expr (len
, e
);
3669 if (mpz_cmp_si (len
->value
.integer
, 0) < 0)
3670 mpz_set_ui (len
->value
.integer
, 0);
3675 gfc_free_namespace (gfc_current_ns
);
3676 gfc_current_ns
= old_ns
;
3683 ts
->kind
= kind
== 0 ? gfc_default_character_kind
: kind
;
3684 ts
->deferred
= deferred
;
3686 /* We have to know if it was a C interoperable kind so we can
3687 do accurate type checking of bind(c) procs, etc. */
3689 /* Mark this as C interoperable if being declared with one
3690 of the named constants from iso_c_binding. */
3691 ts
->is_c_interop
= is_iso_c
;
3692 else if (len
!= NULL
)
3693 /* Here, we might have parsed something such as: character(c_char)
3694 In this case, the parsing code above grabs the c_char when
3695 looking for the length (line 1690, roughly). it's the last
3696 testcase for parsing the kind params of a character variable.
3697 However, it's not actually the length. this seems like it
3699 To see if the user used a C interop kind, test the expr
3700 of the so called length, and see if it's C interoperable. */
3701 ts
->is_c_interop
= len
->ts
.is_iso_c
;
3707 /* Matches a RECORD declaration. */
3710 match_record_decl (char *name
)
3713 old_loc
= gfc_current_locus
;
3716 m
= gfc_match (" record /");
3719 if (!flag_dec_structure
)
3721 gfc_current_locus
= old_loc
;
3722 gfc_error ("RECORD at %C is an extension, enable it with "
3723 "%<-fdec-structure%>");
3726 m
= gfc_match (" %n/", name
);
3731 gfc_current_locus
= old_loc
;
3732 if (flag_dec_structure
3733 && (gfc_match (" record% ") == MATCH_YES
3734 || gfc_match (" record%t") == MATCH_YES
))
3735 gfc_error ("Structure name expected after RECORD at %C");
3743 /* This function uses the gfc_actual_arglist 'type_param_spec_list' as a source
3744 of expressions to substitute into the possibly parameterized expression
3745 'e'. Using a list is inefficient but should not be too bad since the
3746 number of type parameters is not likely to be large. */
3748 insert_parameter_exprs (gfc_expr
* e
, gfc_symbol
* sym ATTRIBUTE_UNUSED
,
3751 gfc_actual_arglist
*param
;
3754 if (e
->expr_type
!= EXPR_VARIABLE
)
3757 gcc_assert (e
->symtree
);
3758 if (e
->symtree
->n
.sym
->attr
.pdt_kind
3759 || (*f
!= 0 && e
->symtree
->n
.sym
->attr
.pdt_len
))
3761 for (param
= type_param_spec_list
; param
; param
= param
->next
)
3762 if (strcmp (e
->symtree
->n
.sym
->name
, param
->name
) == 0)
3767 copy
= gfc_copy_expr (param
->expr
);
3778 gfc_insert_kind_parameter_exprs (gfc_expr
*e
)
3780 return gfc_traverse_expr (e
, NULL
, &insert_parameter_exprs
, 0);
3785 gfc_insert_parameter_exprs (gfc_expr
*e
, gfc_actual_arglist
*param_list
)
3787 gfc_actual_arglist
*old_param_spec_list
= type_param_spec_list
;
3788 type_param_spec_list
= param_list
;
3789 bool res
= gfc_traverse_expr (e
, NULL
, &insert_parameter_exprs
, 1);
3790 type_param_spec_list
= old_param_spec_list
;
3794 /* Determines the instance of a parameterized derived type to be used by
3795 matching determining the values of the kind parameters and using them
3796 in the name of the instance. If the instance exists, it is used, otherwise
3797 a new derived type is created. */
3799 gfc_get_pdt_instance (gfc_actual_arglist
*param_list
, gfc_symbol
**sym
,
3800 gfc_actual_arglist
**ext_param_list
)
3802 /* The PDT template symbol. */
3803 gfc_symbol
*pdt
= *sym
;
3804 /* The symbol for the parameter in the template f2k_namespace. */
3806 /* The hoped for instance of the PDT. */
3807 gfc_symbol
*instance
;
3808 /* The list of parameters appearing in the PDT declaration. */
3809 gfc_formal_arglist
*type_param_name_list
;
3810 /* Used to store the parameter specification list during recursive calls. */
3811 gfc_actual_arglist
*old_param_spec_list
;
3812 /* Pointers to the parameter specification being used. */
3813 gfc_actual_arglist
*actual_param
;
3814 gfc_actual_arglist
*tail
= NULL
;
3815 /* Used to build up the name of the PDT instance. The prefix uses 4
3816 characters and each KIND parameter 2 more. Allow 8 of the latter. */
3817 char name
[GFC_MAX_SYMBOL_LEN
+ 21];
3819 bool name_seen
= (param_list
== NULL
);
3820 bool assumed_seen
= false;
3821 bool deferred_seen
= false;
3822 bool spec_error
= false;
3824 gfc_expr
*kind_expr
;
3825 gfc_component
*c1
, *c2
;
3828 type_param_spec_list
= NULL
;
3830 type_param_name_list
= pdt
->formal
;
3831 actual_param
= param_list
;
3832 sprintf (name
, "Pdt%s", pdt
->name
);
3834 /* Run through the parameter name list and pick up the actual
3835 parameter values or use the default values in the PDT declaration. */
3836 for (; type_param_name_list
;
3837 type_param_name_list
= type_param_name_list
->next
)
3839 if (actual_param
&& actual_param
->spec_type
!= SPEC_EXPLICIT
)
3841 if (actual_param
->spec_type
== SPEC_ASSUMED
)
3842 spec_error
= deferred_seen
;
3844 spec_error
= assumed_seen
;
3848 gfc_error ("The type parameter spec list at %C cannot contain "
3849 "both ASSUMED and DEFERRED parameters");
3854 if (actual_param
&& actual_param
->name
)
3856 param
= type_param_name_list
->sym
;
3858 if (!param
|| !param
->name
)
3861 c1
= gfc_find_component (pdt
, param
->name
, false, true, NULL
);
3862 /* An error should already have been thrown in resolve.cc
3863 (resolve_fl_derived0). */
3864 if (!pdt
->attr
.use_assoc
&& !c1
)
3870 if (!actual_param
&& !(c1
&& c1
->initializer
))
3872 gfc_error ("The type parameter spec list at %C does not contain "
3873 "enough parameter expressions");
3876 else if (!actual_param
&& c1
&& c1
->initializer
)
3877 kind_expr
= gfc_copy_expr (c1
->initializer
);
3878 else if (actual_param
&& actual_param
->spec_type
== SPEC_EXPLICIT
)
3879 kind_expr
= gfc_copy_expr (actual_param
->expr
);
3883 actual_param
= param_list
;
3884 for (;actual_param
; actual_param
= actual_param
->next
)
3885 if (actual_param
->name
3886 && strcmp (actual_param
->name
, param
->name
) == 0)
3888 if (actual_param
&& actual_param
->spec_type
== SPEC_EXPLICIT
)
3889 kind_expr
= gfc_copy_expr (actual_param
->expr
);
3892 if (c1
->initializer
)
3893 kind_expr
= gfc_copy_expr (c1
->initializer
);
3894 else if (!(actual_param
&& param
->attr
.pdt_len
))
3896 gfc_error ("The derived parameter %qs at %C does not "
3897 "have a default value", param
->name
);
3903 /* Store the current parameter expressions in a temporary actual
3904 arglist 'list' so that they can be substituted in the corresponding
3905 expressions in the PDT instance. */
3906 if (type_param_spec_list
== NULL
)
3908 type_param_spec_list
= gfc_get_actual_arglist ();
3909 tail
= type_param_spec_list
;
3913 tail
->next
= gfc_get_actual_arglist ();
3916 tail
->name
= param
->name
;
3920 /* Try simplification even for LEN expressions. */
3922 gfc_resolve_expr (kind_expr
);
3923 ok
= gfc_simplify_expr (kind_expr
, 1);
3924 /* Variable expressions seem to default to BT_PROCEDURE.
3925 TODO find out why this is and fix it. */
3926 if (kind_expr
->ts
.type
!= BT_INTEGER
3927 && kind_expr
->ts
.type
!= BT_PROCEDURE
)
3929 gfc_error ("The parameter expression at %C must be of "
3930 "INTEGER type and not %s type",
3931 gfc_basic_typename (kind_expr
->ts
.type
));
3934 if (kind_expr
->ts
.type
== BT_INTEGER
&& !ok
)
3936 gfc_error ("The parameter expression at %C does not "
3937 "simplify to an INTEGER constant");
3941 tail
->expr
= gfc_copy_expr (kind_expr
);
3945 tail
->spec_type
= actual_param
->spec_type
;
3947 if (!param
->attr
.pdt_kind
)
3949 if (!name_seen
&& actual_param
)
3950 actual_param
= actual_param
->next
;
3953 gfc_free_expr (kind_expr
);
3960 && (actual_param
->spec_type
== SPEC_ASSUMED
3961 || actual_param
->spec_type
== SPEC_DEFERRED
))
3963 gfc_error ("The KIND parameter %qs at %C cannot either be "
3964 "ASSUMED or DEFERRED", param
->name
);
3968 if (!kind_expr
|| !gfc_is_constant_expr (kind_expr
))
3970 gfc_error ("The value for the KIND parameter %qs at %C does not "
3971 "reduce to a constant expression", param
->name
);
3975 gfc_extract_int (kind_expr
, &kind_value
);
3976 sprintf (name
+ strlen (name
), "_%d", kind_value
);
3978 if (!name_seen
&& actual_param
)
3979 actual_param
= actual_param
->next
;
3980 gfc_free_expr (kind_expr
);
3983 if (!name_seen
&& actual_param
)
3985 gfc_error ("The type parameter spec list at %C contains too many "
3986 "parameter expressions");
3990 /* Now we search for the PDT instance 'name'. If it doesn't exist, we
3991 build it, using 'pdt' as a template. */
3992 if (gfc_get_symbol (name
, pdt
->ns
, &instance
))
3994 gfc_error ("Parameterized derived type at %C is ambiguous");
4000 if (instance
->attr
.flavor
== FL_DERIVED
4001 && instance
->attr
.pdt_type
)
4005 *ext_param_list
= type_param_spec_list
;
4007 gfc_commit_symbols ();
4011 /* Start building the new instance of the parameterized type. */
4012 gfc_copy_attr (&instance
->attr
, &pdt
->attr
, &pdt
->declared_at
);
4013 instance
->attr
.pdt_template
= 0;
4014 instance
->attr
.pdt_type
= 1;
4015 instance
->declared_at
= gfc_current_locus
;
4017 /* Add the components, replacing the parameters in all expressions
4018 with the expressions for their values in 'type_param_spec_list'. */
4019 c1
= pdt
->components
;
4020 tail
= type_param_spec_list
;
4021 for (; c1
; c1
= c1
->next
)
4023 gfc_add_component (instance
, c1
->name
, &c2
);
4026 c2
->attr
= c1
->attr
;
4028 /* The order of declaration of the type_specs might not be the
4029 same as that of the components. */
4030 if (c1
->attr
.pdt_kind
|| c1
->attr
.pdt_len
)
4032 for (tail
= type_param_spec_list
; tail
; tail
= tail
->next
)
4033 if (strcmp (c1
->name
, tail
->name
) == 0)
4037 /* Deal with type extension by recursively calling this function
4038 to obtain the instance of the extended type. */
4039 if (gfc_current_state () != COMP_DERIVED
4040 && c1
== pdt
->components
4041 && (c1
->ts
.type
== BT_DERIVED
|| c1
->ts
.type
== BT_CLASS
)
4042 && c1
->ts
.u
.derived
&& c1
->ts
.u
.derived
->attr
.pdt_template
4043 && gfc_get_derived_super_type (*sym
) == c2
->ts
.u
.derived
)
4045 gfc_formal_arglist
*f
;
4047 old_param_spec_list
= type_param_spec_list
;
4049 /* Obtain a spec list appropriate to the extended type..*/
4050 actual_param
= gfc_copy_actual_arglist (type_param_spec_list
);
4051 type_param_spec_list
= actual_param
;
4052 for (f
= c1
->ts
.u
.derived
->formal
; f
&& f
->next
; f
= f
->next
)
4053 actual_param
= actual_param
->next
;
4056 gfc_free_actual_arglist (actual_param
->next
);
4057 actual_param
->next
= NULL
;
4060 /* Now obtain the PDT instance for the extended type. */
4061 c2
->param_list
= type_param_spec_list
;
4062 m
= gfc_get_pdt_instance (type_param_spec_list
, &c2
->ts
.u
.derived
,
4064 type_param_spec_list
= old_param_spec_list
;
4066 c2
->ts
.u
.derived
->refs
++;
4067 gfc_set_sym_referenced (c2
->ts
.u
.derived
);
4069 /* Set extension level. */
4070 if (c2
->ts
.u
.derived
->attr
.extension
== 255)
4072 /* Since the extension field is 8 bit wide, we can only have
4073 up to 255 extension levels. */
4074 gfc_error ("Maximum extension level reached with type %qs at %L",
4075 c2
->ts
.u
.derived
->name
,
4076 &c2
->ts
.u
.derived
->declared_at
);
4079 instance
->attr
.extension
= c2
->ts
.u
.derived
->attr
.extension
+ 1;
4084 /* Set the component kind using the parameterized expression. */
4085 if ((c1
->ts
.kind
== 0 || c1
->ts
.type
== BT_CHARACTER
)
4086 && c1
->kind_expr
!= NULL
)
4088 gfc_expr
*e
= gfc_copy_expr (c1
->kind_expr
);
4089 gfc_insert_kind_parameter_exprs (e
);
4090 gfc_simplify_expr (e
, 1);
4091 gfc_extract_int (e
, &c2
->ts
.kind
);
4093 if (gfc_validate_kind (c2
->ts
.type
, c2
->ts
.kind
, true) < 0)
4095 gfc_error ("Kind %d not supported for type %s at %C",
4096 c2
->ts
.kind
, gfc_basic_typename (c2
->ts
.type
));
4101 /* Similarly, set the string length if parameterized. */
4102 if (c1
->ts
.type
== BT_CHARACTER
4103 && c1
->ts
.u
.cl
->length
4104 && gfc_derived_parameter_expr (c1
->ts
.u
.cl
->length
))
4107 e
= gfc_copy_expr (c1
->ts
.u
.cl
->length
);
4108 gfc_insert_kind_parameter_exprs (e
);
4109 gfc_simplify_expr (e
, 1);
4110 c2
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4111 c2
->ts
.u
.cl
->length
= e
;
4112 c2
->attr
.pdt_string
= 1;
4115 /* Set up either the KIND/LEN initializer, if constant,
4116 or the parameterized expression. Use the template
4117 initializer if one is not already set in this instance. */
4118 if (c2
->attr
.pdt_kind
|| c2
->attr
.pdt_len
)
4120 if (tail
&& tail
->expr
&& gfc_is_constant_expr (tail
->expr
))
4121 c2
->initializer
= gfc_copy_expr (tail
->expr
);
4122 else if (tail
&& tail
->expr
)
4124 c2
->param_list
= gfc_get_actual_arglist ();
4125 c2
->param_list
->name
= tail
->name
;
4126 c2
->param_list
->expr
= gfc_copy_expr (tail
->expr
);
4127 c2
->param_list
->next
= NULL
;
4130 if (!c2
->initializer
&& c1
->initializer
)
4131 c2
->initializer
= gfc_copy_expr (c1
->initializer
);
4134 /* Copy the array spec. */
4135 c2
->as
= gfc_copy_array_spec (c1
->as
);
4136 if (c1
->ts
.type
== BT_CLASS
)
4137 CLASS_DATA (c2
)->as
= gfc_copy_array_spec (CLASS_DATA (c1
)->as
);
4139 /* Determine if an array spec is parameterized. If so, substitute
4140 in the parameter expressions for the bounds and set the pdt_array
4141 attribute. Notice that this attribute must be unconditionally set
4142 if this is an array of parameterized character length. */
4143 if (c1
->as
&& c1
->as
->type
== AS_EXPLICIT
)
4145 bool pdt_array
= false;
4147 /* Are the bounds of the array parameterized? */
4148 for (i
= 0; i
< c1
->as
->rank
; i
++)
4150 if (gfc_derived_parameter_expr (c1
->as
->lower
[i
]))
4152 if (gfc_derived_parameter_expr (c1
->as
->upper
[i
]))
4156 /* If they are, free the expressions for the bounds and
4157 replace them with the template expressions with substitute
4159 for (i
= 0; pdt_array
&& i
< c1
->as
->rank
; i
++)
4162 e
= gfc_copy_expr (c1
->as
->lower
[i
]);
4163 gfc_insert_kind_parameter_exprs (e
);
4164 gfc_simplify_expr (e
, 1);
4165 gfc_free_expr (c2
->as
->lower
[i
]);
4166 c2
->as
->lower
[i
] = e
;
4167 e
= gfc_copy_expr (c1
->as
->upper
[i
]);
4168 gfc_insert_kind_parameter_exprs (e
);
4169 gfc_simplify_expr (e
, 1);
4170 gfc_free_expr (c2
->as
->upper
[i
]);
4171 c2
->as
->upper
[i
] = e
;
4173 c2
->attr
.pdt_array
= pdt_array
? 1 : c2
->attr
.pdt_string
;
4174 if (c1
->initializer
)
4176 c2
->initializer
= gfc_copy_expr (c1
->initializer
);
4177 gfc_insert_kind_parameter_exprs (c2
->initializer
);
4178 gfc_simplify_expr (c2
->initializer
, 1);
4182 /* Recurse into this function for PDT components. */
4183 if ((c1
->ts
.type
== BT_DERIVED
|| c1
->ts
.type
== BT_CLASS
)
4184 && c1
->ts
.u
.derived
&& c1
->ts
.u
.derived
->attr
.pdt_template
)
4186 gfc_actual_arglist
*params
;
4187 /* The component in the template has a list of specification
4188 expressions derived from its declaration. */
4189 params
= gfc_copy_actual_arglist (c1
->param_list
);
4190 actual_param
= params
;
4191 /* Substitute the template parameters with the expressions
4192 from the specification list. */
4193 for (;actual_param
; actual_param
= actual_param
->next
)
4194 gfc_insert_parameter_exprs (actual_param
->expr
,
4195 type_param_spec_list
);
4197 /* Now obtain the PDT instance for the component. */
4198 old_param_spec_list
= type_param_spec_list
;
4199 m
= gfc_get_pdt_instance (params
, &c2
->ts
.u
.derived
, NULL
);
4200 type_param_spec_list
= old_param_spec_list
;
4202 c2
->param_list
= params
;
4203 if (!(c2
->attr
.pointer
|| c2
->attr
.allocatable
))
4204 c2
->initializer
= gfc_default_initializer (&c2
->ts
);
4206 if (c2
->attr
.allocatable
)
4207 instance
->attr
.alloc_comp
= 1;
4211 gfc_commit_symbol (instance
);
4213 *ext_param_list
= type_param_spec_list
;
4218 gfc_free_actual_arglist (type_param_spec_list
);
4223 /* Match a legacy nonstandard BYTE type-spec. */
4226 match_byte_typespec (gfc_typespec
*ts
)
4228 if (gfc_match (" byte") == MATCH_YES
)
4230 if (!gfc_notify_std (GFC_STD_GNU
, "BYTE type at %C"))
4233 if (gfc_current_form
== FORM_FREE
)
4235 char c
= gfc_peek_ascii_char ();
4236 if (!gfc_is_whitespace (c
) && c
!= ',')
4240 if (gfc_validate_kind (BT_INTEGER
, 1, true) < 0)
4242 gfc_error ("BYTE type used at %C "
4243 "is not available on the target machine");
4247 ts
->type
= BT_INTEGER
;
4255 /* Matches a declaration-type-spec (F03:R502). If successful, sets the ts
4256 structure to the matched specification. This is necessary for FUNCTION and
4257 IMPLICIT statements.
4259 If implicit_flag is nonzero, then we don't check for the optional
4260 kind specification. Not doing so is needed for matching an IMPLICIT
4261 statement correctly. */
4264 gfc_match_decl_type_spec (gfc_typespec
*ts
, int implicit_flag
)
4266 /* Provide sufficient space to hold "pdtsymbol". */
4267 char *name
= XALLOCAVEC (char, GFC_MAX_SYMBOL_LEN
+ 1);
4268 gfc_symbol
*sym
, *dt_sym
;
4271 bool seen_deferred_kind
, matched_type
;
4272 const char *dt_name
;
4274 decl_type_param_list
= NULL
;
4276 /* A belt and braces check that the typespec is correctly being treated
4277 as a deferred characteristic association. */
4278 seen_deferred_kind
= (gfc_current_state () == COMP_FUNCTION
)
4279 && (gfc_current_block ()->result
->ts
.kind
== -1)
4280 && (ts
->kind
== -1);
4282 if (seen_deferred_kind
)
4285 /* Clear the current binding label, in case one is given. */
4286 curr_binding_label
= NULL
;
4288 /* Match BYTE type-spec. */
4289 m
= match_byte_typespec (ts
);
4293 m
= gfc_match (" type (");
4294 matched_type
= (m
== MATCH_YES
);
4297 gfc_gobble_whitespace ();
4298 if (gfc_peek_ascii_char () == '*')
4300 if ((m
= gfc_match ("* ) ")) != MATCH_YES
)
4302 if (gfc_comp_struct (gfc_current_state ()))
4304 gfc_error ("Assumed type at %C is not allowed for components");
4307 if (!gfc_notify_std (GFC_STD_F2018
, "Assumed type at %C"))
4309 ts
->type
= BT_ASSUMED
;
4313 m
= gfc_match ("%n", name
);
4314 matched_type
= (m
== MATCH_YES
);
4317 if ((matched_type
&& strcmp ("integer", name
) == 0)
4318 || (!matched_type
&& gfc_match (" integer") == MATCH_YES
))
4320 ts
->type
= BT_INTEGER
;
4321 ts
->kind
= gfc_default_integer_kind
;
4325 if ((matched_type
&& strcmp ("character", name
) == 0)
4326 || (!matched_type
&& gfc_match (" character") == MATCH_YES
))
4329 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
4330 "intrinsic-type-spec at %C"))
4333 ts
->type
= BT_CHARACTER
;
4334 if (implicit_flag
== 0)
4335 m
= gfc_match_char_spec (ts
);
4339 if (matched_type
&& m
== MATCH_YES
&& gfc_match_char (')') != MATCH_YES
)
4341 gfc_error ("Malformed type-spec at %C");
4348 if ((matched_type
&& strcmp ("real", name
) == 0)
4349 || (!matched_type
&& gfc_match (" real") == MATCH_YES
))
4352 ts
->kind
= gfc_default_real_kind
;
4357 && (strcmp ("doubleprecision", name
) == 0
4358 || (strcmp ("double", name
) == 0
4359 && gfc_match (" precision") == MATCH_YES
)))
4360 || (!matched_type
&& gfc_match (" double precision") == MATCH_YES
))
4363 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
4364 "intrinsic-type-spec at %C"))
4367 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
4369 gfc_error ("Malformed type-spec at %C");
4374 ts
->kind
= gfc_default_double_kind
;
4378 if ((matched_type
&& strcmp ("complex", name
) == 0)
4379 || (!matched_type
&& gfc_match (" complex") == MATCH_YES
))
4381 ts
->type
= BT_COMPLEX
;
4382 ts
->kind
= gfc_default_complex_kind
;
4387 && (strcmp ("doublecomplex", name
) == 0
4388 || (strcmp ("double", name
) == 0
4389 && gfc_match (" complex") == MATCH_YES
)))
4390 || (!matched_type
&& gfc_match (" double complex") == MATCH_YES
))
4392 if (!gfc_notify_std (GFC_STD_GNU
, "DOUBLE COMPLEX at %C"))
4396 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
4397 "intrinsic-type-spec at %C"))
4400 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
4402 gfc_error ("Malformed type-spec at %C");
4406 ts
->type
= BT_COMPLEX
;
4407 ts
->kind
= gfc_default_double_kind
;
4411 if ((matched_type
&& strcmp ("logical", name
) == 0)
4412 || (!matched_type
&& gfc_match (" logical") == MATCH_YES
))
4414 ts
->type
= BT_LOGICAL
;
4415 ts
->kind
= gfc_default_logical_kind
;
4421 m
= gfc_match_actual_arglist (1, &decl_type_param_list
, true);
4422 if (m
== MATCH_ERROR
)
4425 gfc_gobble_whitespace ();
4426 if (gfc_peek_ascii_char () != ')')
4428 gfc_error ("Malformed type-spec at %C");
4431 m
= gfc_match_char (')'); /* Burn closing ')'. */
4435 m
= match_record_decl (name
);
4437 if (matched_type
|| m
== MATCH_YES
)
4439 ts
->type
= BT_DERIVED
;
4440 /* We accept record/s/ or type(s) where s is a structure, but we
4441 * don't need all the extra derived-type stuff for structures. */
4442 if (gfc_find_symbol (gfc_dt_upper_string (name
), NULL
, 1, &sym
))
4444 gfc_error ("Type name %qs at %C is ambiguous", name
);
4448 if (sym
&& sym
->attr
.flavor
== FL_DERIVED
4449 && sym
->attr
.pdt_template
4450 && gfc_current_state () != COMP_DERIVED
)
4452 m
= gfc_get_pdt_instance (decl_type_param_list
, &sym
, NULL
);
4455 gcc_assert (!sym
->attr
.pdt_template
&& sym
->attr
.pdt_type
);
4456 ts
->u
.derived
= sym
;
4457 const char* lower
= gfc_dt_lower_string (sym
->name
);
4458 size_t len
= strlen (lower
);
4459 /* Reallocate with sufficient size. */
4460 if (len
> GFC_MAX_SYMBOL_LEN
)
4461 name
= XALLOCAVEC (char, len
+ 1);
4462 memcpy (name
, lower
, len
);
4466 if (sym
&& sym
->attr
.flavor
== FL_STRUCT
)
4468 ts
->u
.derived
= sym
;
4471 /* Actually a derived type. */
4476 /* Match nested STRUCTURE declarations; only valid within another
4477 structure declaration. */
4478 if (flag_dec_structure
4479 && (gfc_current_state () == COMP_STRUCTURE
4480 || gfc_current_state () == COMP_MAP
))
4482 m
= gfc_match (" structure");
4485 m
= gfc_match_structure_decl ();
4488 /* gfc_new_block is updated by match_structure_decl. */
4489 ts
->type
= BT_DERIVED
;
4490 ts
->u
.derived
= gfc_new_block
;
4494 if (m
== MATCH_ERROR
)
4498 /* Match CLASS declarations. */
4499 m
= gfc_match (" class ( * )");
4500 if (m
== MATCH_ERROR
)
4502 else if (m
== MATCH_YES
)
4506 ts
->type
= BT_CLASS
;
4507 gfc_find_symbol ("STAR", gfc_current_ns
, 1, &upe
);
4510 upe
= gfc_new_symbol ("STAR", gfc_current_ns
);
4511 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "STAR");
4513 gfc_set_sym_referenced (upe
);
4515 upe
->ts
.type
= BT_VOID
;
4516 upe
->attr
.unlimited_polymorphic
= 1;
4517 /* This is essential to force the construction of
4518 unlimited polymorphic component class containers. */
4519 upe
->attr
.zero_comp
= 1;
4520 if (!gfc_add_flavor (&upe
->attr
, FL_DERIVED
, NULL
,
4521 &gfc_current_locus
))
4526 st
= gfc_get_tbp_symtree (&gfc_current_ns
->sym_root
, "STAR");
4530 ts
->u
.derived
= upe
;
4534 m
= gfc_match (" class (");
4537 m
= gfc_match ("%n", name
);
4543 ts
->type
= BT_CLASS
;
4545 if (!gfc_notify_std (GFC_STD_F2003
, "CLASS statement at %C"))
4548 m
= gfc_match_actual_arglist (1, &decl_type_param_list
, true);
4549 if (m
== MATCH_ERROR
)
4552 m
= gfc_match_char (')');
4557 /* Defer association of the derived type until the end of the
4558 specification block. However, if the derived type can be
4559 found, add it to the typespec. */
4560 if (gfc_matching_function
)
4562 ts
->u
.derived
= NULL
;
4563 if (gfc_current_state () != COMP_INTERFACE
4564 && !gfc_find_symbol (name
, NULL
, 1, &sym
) && sym
)
4566 sym
= gfc_find_dt_in_generic (sym
);
4567 ts
->u
.derived
= sym
;
4572 /* Search for the name but allow the components to be defined later. If
4573 type = -1, this typespec has been seen in a function declaration but
4574 the type could not be accessed at that point. The actual derived type is
4575 stored in a symtree with the first letter of the name capitalized; the
4576 symtree with the all lower-case name contains the associated
4577 generic function. */
4578 dt_name
= gfc_dt_upper_string (name
);
4583 gfc_get_ha_symbol (name
, &sym
);
4584 if (sym
->generic
&& gfc_find_symbol (dt_name
, NULL
, 0, &dt_sym
))
4586 gfc_error ("Type name %qs at %C is ambiguous", name
);
4589 if (sym
->generic
&& !dt_sym
)
4590 dt_sym
= gfc_find_dt_in_generic (sym
);
4592 /* Host associated PDTs can get confused with their constructors
4593 because they ar instantiated in the template's namespace. */
4596 if (gfc_find_symbol (dt_name
, NULL
, 1, &dt_sym
))
4598 gfc_error ("Type name %qs at %C is ambiguous", name
);
4601 if (dt_sym
&& !dt_sym
->attr
.pdt_type
)
4605 else if (ts
->kind
== -1)
4607 int iface
= gfc_state_stack
->previous
->state
!= COMP_INTERFACE
4608 || gfc_current_ns
->has_import_set
;
4609 gfc_find_symbol (name
, NULL
, iface
, &sym
);
4610 if (sym
&& sym
->generic
&& gfc_find_symbol (dt_name
, NULL
, 1, &dt_sym
))
4612 gfc_error ("Type name %qs at %C is ambiguous", name
);
4615 if (sym
&& sym
->generic
&& !dt_sym
)
4616 dt_sym
= gfc_find_dt_in_generic (sym
);
4623 if ((sym
->attr
.flavor
!= FL_UNKNOWN
&& sym
->attr
.flavor
!= FL_STRUCT
4624 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.generic
))
4625 || sym
->attr
.subroutine
)
4627 gfc_error ("Type name %qs at %C conflicts with previously declared "
4628 "entity at %L, which has the same name", name
,
4633 if (sym
&& sym
->attr
.flavor
== FL_DERIVED
4634 && sym
->attr
.pdt_template
4635 && gfc_current_state () != COMP_DERIVED
)
4637 m
= gfc_get_pdt_instance (decl_type_param_list
, &sym
, NULL
);
4640 gcc_assert (!sym
->attr
.pdt_template
&& sym
->attr
.pdt_type
);
4641 ts
->u
.derived
= sym
;
4642 strcpy (name
, gfc_dt_lower_string (sym
->name
));
4645 gfc_save_symbol_data (sym
);
4646 gfc_set_sym_referenced (sym
);
4647 if (!sym
->attr
.generic
4648 && !gfc_add_generic (&sym
->attr
, sym
->name
, NULL
))
4651 if (!sym
->attr
.function
4652 && !gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
4655 if (dt_sym
&& dt_sym
->attr
.flavor
== FL_DERIVED
4656 && dt_sym
->attr
.pdt_template
4657 && gfc_current_state () != COMP_DERIVED
)
4659 m
= gfc_get_pdt_instance (decl_type_param_list
, &dt_sym
, NULL
);
4662 gcc_assert (!dt_sym
->attr
.pdt_template
&& dt_sym
->attr
.pdt_type
);
4667 gfc_interface
*intr
, *head
;
4669 /* Use upper case to save the actual derived-type symbol. */
4670 gfc_get_symbol (dt_name
, NULL
, &dt_sym
);
4671 dt_sym
->name
= gfc_get_string ("%s", sym
->name
);
4672 head
= sym
->generic
;
4673 intr
= gfc_get_interface ();
4675 intr
->where
= gfc_current_locus
;
4677 sym
->generic
= intr
;
4678 sym
->attr
.if_source
= IFSRC_DECL
;
4681 gfc_save_symbol_data (dt_sym
);
4683 gfc_set_sym_referenced (dt_sym
);
4685 if (dt_sym
->attr
.flavor
!= FL_DERIVED
&& dt_sym
->attr
.flavor
!= FL_STRUCT
4686 && !gfc_add_flavor (&dt_sym
->attr
, FL_DERIVED
, sym
->name
, NULL
))
4689 ts
->u
.derived
= dt_sym
;
4695 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
4696 "intrinsic-type-spec at %C"))
4699 /* For all types except double, derived and character, look for an
4700 optional kind specifier. MATCH_NO is actually OK at this point. */
4701 if (implicit_flag
== 1)
4703 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
4709 if (gfc_current_form
== FORM_FREE
)
4711 c
= gfc_peek_ascii_char ();
4712 if (!gfc_is_whitespace (c
) && c
!= '*' && c
!= '('
4713 && c
!= ':' && c
!= ',')
4715 if (matched_type
&& c
== ')')
4717 gfc_next_ascii_char ();
4720 gfc_error ("Malformed type-spec at %C");
4725 m
= gfc_match_kind_spec (ts
, false);
4726 if (m
== MATCH_ERROR
)
4729 if (m
== MATCH_NO
&& ts
->type
!= BT_CHARACTER
)
4731 m
= gfc_match_old_kind_spec (ts
);
4732 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) == -1)
4736 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
4738 gfc_error ("Malformed type-spec at %C");
4742 /* Defer association of the KIND expression of function results
4743 until after USE and IMPORT statements. */
4744 if ((gfc_current_state () == COMP_NONE
&& gfc_error_flag_test ())
4745 || gfc_matching_function
)
4749 m
= MATCH_YES
; /* No kind specifier found. */
4755 /* Match an IMPLICIT NONE statement. Actually, this statement is
4756 already matched in parse.cc, or we would not end up here in the
4757 first place. So the only thing we need to check, is if there is
4758 trailing garbage. If not, the match is successful. */
4761 gfc_match_implicit_none (void)
4765 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4767 bool external
= false;
4768 locus cur_loc
= gfc_current_locus
;
4770 if (gfc_current_ns
->seen_implicit_none
4771 || gfc_current_ns
->has_implicit_none_export
)
4773 gfc_error ("Duplicate IMPLICIT NONE statement at %C");
4777 gfc_gobble_whitespace ();
4778 c
= gfc_peek_ascii_char ();
4781 (void) gfc_next_ascii_char ();
4782 if (!gfc_notify_std (GFC_STD_F2018
, "IMPLICIT NONE with spec list at %C"))
4785 gfc_gobble_whitespace ();
4786 if (gfc_peek_ascii_char () == ')')
4788 (void) gfc_next_ascii_char ();
4794 m
= gfc_match (" %n", name
);
4798 if (strcmp (name
, "type") == 0)
4800 else if (strcmp (name
, "external") == 0)
4805 gfc_gobble_whitespace ();
4806 c
= gfc_next_ascii_char ();
4817 if (gfc_match_eos () != MATCH_YES
)
4820 gfc_set_implicit_none (type
, external
, &cur_loc
);
4826 /* Match the letter range(s) of an IMPLICIT statement. */
4829 match_implicit_range (void)
4835 cur_loc
= gfc_current_locus
;
4837 gfc_gobble_whitespace ();
4838 c
= gfc_next_ascii_char ();
4841 gfc_error ("Missing character range in IMPLICIT at %C");
4848 gfc_gobble_whitespace ();
4849 c1
= gfc_next_ascii_char ();
4853 gfc_gobble_whitespace ();
4854 c
= gfc_next_ascii_char ();
4859 inner
= 0; /* Fall through. */
4866 gfc_gobble_whitespace ();
4867 c2
= gfc_next_ascii_char ();
4871 gfc_gobble_whitespace ();
4872 c
= gfc_next_ascii_char ();
4874 if ((c
!= ',') && (c
!= ')'))
4887 gfc_error ("Letters must be in alphabetic order in "
4888 "IMPLICIT statement at %C");
4892 /* See if we can add the newly matched range to the pending
4893 implicits from this IMPLICIT statement. We do not check for
4894 conflicts with whatever earlier IMPLICIT statements may have
4895 set. This is done when we've successfully finished matching
4897 if (!gfc_add_new_implicit_range (c1
, c2
))
4904 gfc_syntax_error (ST_IMPLICIT
);
4906 gfc_current_locus
= cur_loc
;
4911 /* Match an IMPLICIT statement, storing the types for
4912 gfc_set_implicit() if the statement is accepted by the parser.
4913 There is a strange looking, but legal syntactic construction
4914 possible. It looks like:
4916 IMPLICIT INTEGER (a-b) (c-d)
4918 This is legal if "a-b" is a constant expression that happens to
4919 equal one of the legal kinds for integers. The real problem
4920 happens with an implicit specification that looks like:
4922 IMPLICIT INTEGER (a-b)
4924 In this case, a typespec matcher that is "greedy" (as most of the
4925 matchers are) gobbles the character range as a kindspec, leaving
4926 nothing left. We therefore have to go a bit more slowly in the
4927 matching process by inhibiting the kindspec checking during
4928 typespec matching and checking for a kind later. */
4931 gfc_match_implicit (void)
4938 if (gfc_current_ns
->seen_implicit_none
)
4940 gfc_error ("IMPLICIT statement at %C following an IMPLICIT NONE (type) "
4947 /* We don't allow empty implicit statements. */
4948 if (gfc_match_eos () == MATCH_YES
)
4950 gfc_error ("Empty IMPLICIT statement at %C");
4956 /* First cleanup. */
4957 gfc_clear_new_implicit ();
4959 /* A basic type is mandatory here. */
4960 m
= gfc_match_decl_type_spec (&ts
, 1);
4961 if (m
== MATCH_ERROR
)
4966 cur_loc
= gfc_current_locus
;
4967 m
= match_implicit_range ();
4971 /* We may have <TYPE> (<RANGE>). */
4972 gfc_gobble_whitespace ();
4973 c
= gfc_peek_ascii_char ();
4974 if (c
== ',' || c
== '\n' || c
== ';' || c
== '!')
4976 /* Check for CHARACTER with no length parameter. */
4977 if (ts
.type
== BT_CHARACTER
&& !ts
.u
.cl
)
4979 ts
.kind
= gfc_default_character_kind
;
4980 ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4981 ts
.u
.cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
,
4985 /* Record the Successful match. */
4986 if (!gfc_merge_new_implicit (&ts
))
4989 c
= gfc_next_ascii_char ();
4990 else if (gfc_match_eos () == MATCH_ERROR
)
4995 gfc_current_locus
= cur_loc
;
4998 /* Discard the (incorrectly) matched range. */
4999 gfc_clear_new_implicit ();
5001 /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
5002 if (ts
.type
== BT_CHARACTER
)
5003 m
= gfc_match_char_spec (&ts
);
5004 else if (gfc_numeric_ts(&ts
) || ts
.type
== BT_LOGICAL
)
5006 m
= gfc_match_kind_spec (&ts
, false);
5009 m
= gfc_match_old_kind_spec (&ts
);
5010 if (m
== MATCH_ERROR
)
5016 if (m
== MATCH_ERROR
)
5019 m
= match_implicit_range ();
5020 if (m
== MATCH_ERROR
)
5025 gfc_gobble_whitespace ();
5026 c
= gfc_next_ascii_char ();
5027 if (c
!= ',' && gfc_match_eos () != MATCH_YES
)
5030 if (!gfc_merge_new_implicit (&ts
))
5038 gfc_syntax_error (ST_IMPLICIT
);
5046 gfc_match_import (void)
5048 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5053 if (gfc_current_ns
->proc_name
== NULL
5054 || gfc_current_ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
5056 gfc_error ("IMPORT statement at %C only permitted in "
5057 "an INTERFACE body");
5061 if (gfc_current_ns
->proc_name
->attr
.module_procedure
)
5063 gfc_error ("F2008: C1210 IMPORT statement at %C is not permitted "
5064 "in a module procedure interface body");
5068 if (!gfc_notify_std (GFC_STD_F2003
, "IMPORT statement at %C"))
5071 if (gfc_match_eos () == MATCH_YES
)
5073 /* All host variables should be imported. */
5074 gfc_current_ns
->has_import_set
= 1;
5078 if (gfc_match (" ::") == MATCH_YES
)
5080 if (gfc_match_eos () == MATCH_YES
)
5082 gfc_error ("Expecting list of named entities at %C");
5090 m
= gfc_match (" %n", name
);
5094 if (gfc_current_ns
->parent
!= NULL
5095 && gfc_find_symbol (name
, gfc_current_ns
->parent
, 1, &sym
))
5097 gfc_error ("Type name %qs at %C is ambiguous", name
);
5100 else if (!sym
&& gfc_current_ns
->proc_name
->ns
->parent
!= NULL
5101 && gfc_find_symbol (name
,
5102 gfc_current_ns
->proc_name
->ns
->parent
,
5105 gfc_error ("Type name %qs at %C is ambiguous", name
);
5111 gfc_error ("Cannot IMPORT %qs from host scoping unit "
5112 "at %C - does not exist.", name
);
5116 if (gfc_find_symtree (gfc_current_ns
->sym_root
, name
))
5118 gfc_warning (0, "%qs is already IMPORTed from host scoping unit "
5123 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, name
);
5126 sym
->attr
.imported
= 1;
5128 if (sym
->attr
.generic
&& (sym
= gfc_find_dt_in_generic (sym
)))
5130 /* The actual derived type is stored in a symtree with the first
5131 letter of the name capitalized; the symtree with the all
5132 lower-case name contains the associated generic function. */
5133 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
,
5134 gfc_dt_upper_string (name
));
5137 sym
->attr
.imported
= 1;
5150 if (gfc_match_eos () == MATCH_YES
)
5152 if (gfc_match_char (',') != MATCH_YES
)
5159 gfc_error ("Syntax error in IMPORT statement at %C");
5164 /* A minimal implementation of gfc_match without whitespace, escape
5165 characters or variable arguments. Returns true if the next
5166 characters match the TARGET template exactly. */
5169 match_string_p (const char *target
)
5173 for (p
= target
; *p
; p
++)
5174 if ((char) gfc_next_ascii_char () != *p
)
5179 /* Matches an attribute specification including array specs. If
5180 successful, leaves the variables current_attr and current_as
5181 holding the specification. Also sets the colon_seen variable for
5182 later use by matchers associated with initializations.
5184 This subroutine is a little tricky in the sense that we don't know
5185 if we really have an attr-spec until we hit the double colon.
5186 Until that time, we can only return MATCH_NO. This forces us to
5187 check for duplicate specification at this level. */
5190 match_attr_spec (void)
5192 /* Modifiers that can exist in a type statement. */
5194 { GFC_DECL_BEGIN
= 0, DECL_ALLOCATABLE
= GFC_DECL_BEGIN
,
5195 DECL_IN
= INTENT_IN
, DECL_OUT
= INTENT_OUT
, DECL_INOUT
= INTENT_INOUT
,
5196 DECL_DIMENSION
, DECL_EXTERNAL
,
5197 DECL_INTRINSIC
, DECL_OPTIONAL
,
5198 DECL_PARAMETER
, DECL_POINTER
, DECL_PROTECTED
, DECL_PRIVATE
,
5199 DECL_STATIC
, DECL_AUTOMATIC
,
5200 DECL_PUBLIC
, DECL_SAVE
, DECL_TARGET
, DECL_VALUE
, DECL_VOLATILE
,
5201 DECL_IS_BIND_C
, DECL_CODIMENSION
, DECL_ASYNCHRONOUS
, DECL_CONTIGUOUS
,
5202 DECL_LEN
, DECL_KIND
, DECL_NONE
, GFC_DECL_END
/* Sentinel */
5205 /* GFC_DECL_END is the sentinel, index starts at 0. */
5206 #define NUM_DECL GFC_DECL_END
5208 /* Make sure that values from sym_intent are safe to be used here. */
5209 gcc_assert (INTENT_IN
> 0);
5211 locus start
, seen_at
[NUM_DECL
];
5218 gfc_clear_attr (¤t_attr
);
5219 start
= gfc_current_locus
;
5225 /* See if we get all of the keywords up to the final double colon. */
5226 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
5234 gfc_gobble_whitespace ();
5236 ch
= gfc_next_ascii_char ();
5239 /* This is the successful exit condition for the loop. */
5240 if (gfc_next_ascii_char () == ':')
5245 gfc_gobble_whitespace ();
5246 switch (gfc_peek_ascii_char ())
5249 gfc_next_ascii_char ();
5250 switch (gfc_next_ascii_char ())
5253 if (match_string_p ("locatable"))
5255 /* Matched "allocatable". */
5256 d
= DECL_ALLOCATABLE
;
5261 if (match_string_p ("ynchronous"))
5263 /* Matched "asynchronous". */
5264 d
= DECL_ASYNCHRONOUS
;
5269 if (match_string_p ("tomatic"))
5271 /* Matched "automatic". */
5279 /* Try and match the bind(c). */
5280 m
= gfc_match_bind_c (NULL
, true);
5283 else if (m
== MATCH_ERROR
)
5288 gfc_next_ascii_char ();
5289 if ('o' != gfc_next_ascii_char ())
5291 switch (gfc_next_ascii_char ())
5294 if (match_string_p ("imension"))
5296 d
= DECL_CODIMENSION
;
5301 if (match_string_p ("tiguous"))
5303 d
= DECL_CONTIGUOUS
;
5310 if (match_string_p ("dimension"))
5315 if (match_string_p ("external"))
5320 if (match_string_p ("int"))
5322 ch
= gfc_next_ascii_char ();
5325 if (match_string_p ("nt"))
5327 /* Matched "intent". */
5328 d
= match_intent_spec ();
5329 if (d
== INTENT_UNKNOWN
)
5338 if (match_string_p ("insic"))
5340 /* Matched "intrinsic". */
5348 if (match_string_p ("kind"))
5353 if (match_string_p ("len"))
5358 if (match_string_p ("optional"))
5363 gfc_next_ascii_char ();
5364 switch (gfc_next_ascii_char ())
5367 if (match_string_p ("rameter"))
5369 /* Matched "parameter". */
5375 if (match_string_p ("inter"))
5377 /* Matched "pointer". */
5383 ch
= gfc_next_ascii_char ();
5386 if (match_string_p ("vate"))
5388 /* Matched "private". */
5394 if (match_string_p ("tected"))
5396 /* Matched "protected". */
5403 if (match_string_p ("blic"))
5405 /* Matched "public". */
5413 gfc_next_ascii_char ();
5414 switch (gfc_next_ascii_char ())
5417 if (match_string_p ("ve"))
5419 /* Matched "save". */
5425 if (match_string_p ("atic"))
5427 /* Matched "static". */
5435 if (match_string_p ("target"))
5440 gfc_next_ascii_char ();
5441 ch
= gfc_next_ascii_char ();
5444 if (match_string_p ("lue"))
5446 /* Matched "value". */
5452 if (match_string_p ("latile"))
5454 /* Matched "volatile". */
5462 /* No double colon and no recognizable decl_type, so assume that
5463 we've been looking at something else the whole time. */
5470 /* Check to make sure any parens are paired up correctly. */
5471 if (gfc_match_parens () == MATCH_ERROR
)
5478 seen_at
[d
] = gfc_current_locus
;
5480 if (d
== DECL_DIMENSION
|| d
== DECL_CODIMENSION
)
5482 gfc_array_spec
*as
= NULL
;
5484 m
= gfc_match_array_spec (&as
, d
== DECL_DIMENSION
,
5485 d
== DECL_CODIMENSION
);
5487 if (current_as
== NULL
)
5489 else if (m
== MATCH_YES
)
5491 if (!merge_array_spec (as
, current_as
, false))
5498 if (d
== DECL_CODIMENSION
)
5499 gfc_error ("Missing codimension specification at %C");
5501 gfc_error ("Missing dimension specification at %C");
5505 if (m
== MATCH_ERROR
)
5510 /* Since we've seen a double colon, we have to be looking at an
5511 attr-spec. This means that we can now issue errors. */
5512 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
5517 case DECL_ALLOCATABLE
:
5518 attr
= "ALLOCATABLE";
5520 case DECL_ASYNCHRONOUS
:
5521 attr
= "ASYNCHRONOUS";
5523 case DECL_CODIMENSION
:
5524 attr
= "CODIMENSION";
5526 case DECL_CONTIGUOUS
:
5527 attr
= "CONTIGUOUS";
5529 case DECL_DIMENSION
:
5536 attr
= "INTENT (IN)";
5539 attr
= "INTENT (OUT)";
5542 attr
= "INTENT (IN OUT)";
5544 case DECL_INTRINSIC
:
5556 case DECL_PARAMETER
:
5562 case DECL_PROTECTED
:
5577 case DECL_AUTOMATIC
:
5583 case DECL_IS_BIND_C
:
5593 attr
= NULL
; /* This shouldn't happen. */
5596 gfc_error ("Duplicate %s attribute at %L", attr
, &seen_at
[d
]);
5601 /* Now that we've dealt with duplicate attributes, add the attributes
5602 to the current attribute. */
5603 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
5610 if ((d
== DECL_STATIC
|| d
== DECL_AUTOMATIC
)
5611 && !flag_dec_static
)
5613 gfc_error ("%s at %L is a DEC extension, enable with "
5615 d
== DECL_STATIC
? "STATIC" : "AUTOMATIC", &seen_at
[d
]);
5619 /* Allow SAVE with STATIC, but don't complain. */
5620 if (d
== DECL_STATIC
&& seen
[DECL_SAVE
])
5623 if (gfc_comp_struct (gfc_current_state ())
5624 && d
!= DECL_DIMENSION
&& d
!= DECL_CODIMENSION
5625 && d
!= DECL_POINTER
&& d
!= DECL_PRIVATE
5626 && d
!= DECL_PUBLIC
&& d
!= DECL_CONTIGUOUS
&& d
!= DECL_NONE
)
5628 bool is_derived
= gfc_current_state () == COMP_DERIVED
;
5629 if (d
== DECL_ALLOCATABLE
)
5631 if (!gfc_notify_std (GFC_STD_F2003
, is_derived
5632 ? G_("ALLOCATABLE attribute at %C in a "
5634 : G_("ALLOCATABLE attribute at %C in a "
5635 "STRUCTURE definition")))
5641 else if (d
== DECL_KIND
)
5643 if (!gfc_notify_std (GFC_STD_F2003
, is_derived
5644 ? G_("KIND attribute at %C in a "
5646 : G_("KIND attribute at %C in a "
5647 "STRUCTURE definition")))
5652 if (current_ts
.type
!= BT_INTEGER
)
5654 gfc_error ("Component with KIND attribute at %C must be "
5660 else if (d
== DECL_LEN
)
5662 if (!gfc_notify_std (GFC_STD_F2003
, is_derived
5663 ? G_("LEN attribute at %C in a "
5665 : G_("LEN attribute at %C in a "
5666 "STRUCTURE definition")))
5671 if (current_ts
.type
!= BT_INTEGER
)
5673 gfc_error ("Component with LEN attribute at %C must be "
5681 gfc_error (is_derived
? G_("Attribute at %L is not allowed in a "
5683 : G_("Attribute at %L is not allowed in a "
5684 "STRUCTURE definition"), &seen_at
[d
]);
5690 if ((d
== DECL_PRIVATE
|| d
== DECL_PUBLIC
)
5691 && gfc_current_state () != COMP_MODULE
)
5693 if (d
== DECL_PRIVATE
)
5697 if (gfc_current_state () == COMP_DERIVED
5698 && gfc_state_stack
->previous
5699 && gfc_state_stack
->previous
->state
== COMP_MODULE
)
5701 if (!gfc_notify_std (GFC_STD_F2003
, "Attribute %s "
5702 "at %L in a TYPE definition", attr
,
5711 gfc_error ("%s attribute at %L is not allowed outside of the "
5712 "specification part of a module", attr
, &seen_at
[d
]);
5718 if (gfc_current_state () != COMP_DERIVED
5719 && (d
== DECL_KIND
|| d
== DECL_LEN
))
5721 gfc_error ("Attribute at %L is not allowed outside a TYPE "
5722 "definition", &seen_at
[d
]);
5729 case DECL_ALLOCATABLE
:
5730 t
= gfc_add_allocatable (¤t_attr
, &seen_at
[d
]);
5733 case DECL_ASYNCHRONOUS
:
5734 if (!gfc_notify_std (GFC_STD_F2003
, "ASYNCHRONOUS attribute at %C"))
5737 t
= gfc_add_asynchronous (¤t_attr
, NULL
, &seen_at
[d
]);
5740 case DECL_CODIMENSION
:
5741 t
= gfc_add_codimension (¤t_attr
, NULL
, &seen_at
[d
]);
5744 case DECL_CONTIGUOUS
:
5745 if (!gfc_notify_std (GFC_STD_F2008
, "CONTIGUOUS attribute at %C"))
5748 t
= gfc_add_contiguous (¤t_attr
, NULL
, &seen_at
[d
]);
5751 case DECL_DIMENSION
:
5752 t
= gfc_add_dimension (¤t_attr
, NULL
, &seen_at
[d
]);
5756 t
= gfc_add_external (¤t_attr
, &seen_at
[d
]);
5760 t
= gfc_add_intent (¤t_attr
, INTENT_IN
, &seen_at
[d
]);
5764 t
= gfc_add_intent (¤t_attr
, INTENT_OUT
, &seen_at
[d
]);
5768 t
= gfc_add_intent (¤t_attr
, INTENT_INOUT
, &seen_at
[d
]);
5771 case DECL_INTRINSIC
:
5772 t
= gfc_add_intrinsic (¤t_attr
, &seen_at
[d
]);
5776 t
= gfc_add_optional (¤t_attr
, &seen_at
[d
]);
5780 t
= gfc_add_kind (¤t_attr
, &seen_at
[d
]);
5784 t
= gfc_add_len (¤t_attr
, &seen_at
[d
]);
5787 case DECL_PARAMETER
:
5788 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, &seen_at
[d
]);
5792 t
= gfc_add_pointer (¤t_attr
, &seen_at
[d
]);
5795 case DECL_PROTECTED
:
5796 if (gfc_current_state () != COMP_MODULE
5797 || (gfc_current_ns
->proc_name
5798 && gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
))
5800 gfc_error ("PROTECTED at %C only allowed in specification "
5801 "part of a module");
5806 if (!gfc_notify_std (GFC_STD_F2003
, "PROTECTED attribute at %C"))
5809 t
= gfc_add_protected (¤t_attr
, NULL
, &seen_at
[d
]);
5813 t
= gfc_add_access (¤t_attr
, ACCESS_PRIVATE
, NULL
,
5818 t
= gfc_add_access (¤t_attr
, ACCESS_PUBLIC
, NULL
,
5824 t
= gfc_add_save (¤t_attr
, SAVE_EXPLICIT
, NULL
, &seen_at
[d
]);
5827 case DECL_AUTOMATIC
:
5828 t
= gfc_add_automatic (¤t_attr
, NULL
, &seen_at
[d
]);
5832 t
= gfc_add_target (¤t_attr
, &seen_at
[d
]);
5835 case DECL_IS_BIND_C
:
5836 t
= gfc_add_is_bind_c(¤t_attr
, NULL
, &seen_at
[d
], 0);
5840 if (!gfc_notify_std (GFC_STD_F2003
, "VALUE attribute at %C"))
5843 t
= gfc_add_value (¤t_attr
, NULL
, &seen_at
[d
]);
5847 if (!gfc_notify_std (GFC_STD_F2003
, "VOLATILE attribute at %C"))
5850 t
= gfc_add_volatile (¤t_attr
, NULL
, &seen_at
[d
]);
5854 gfc_internal_error ("match_attr_spec(): Bad attribute");
5864 /* Since Fortran 2008 module variables implicitly have the SAVE attribute. */
5865 if ((gfc_current_state () == COMP_MODULE
5866 || gfc_current_state () == COMP_SUBMODULE
)
5867 && !current_attr
.save
5868 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
5869 current_attr
.save
= SAVE_IMPLICIT
;
5875 gfc_current_locus
= start
;
5876 gfc_free_array_spec (current_as
);
5883 /* Set the binding label, dest_label, either with the binding label
5884 stored in the given gfc_typespec, ts, or if none was provided, it
5885 will be the symbol name in all lower case, as required by the draft
5886 (J3/04-007, section 15.4.1). If a binding label was given and
5887 there is more than one argument (num_idents), it is an error. */
5890 set_binding_label (const char **dest_label
, const char *sym_name
,
5893 if (num_idents
> 1 && has_name_equals
)
5895 gfc_error ("Multiple identifiers provided with "
5896 "single NAME= specifier at %C");
5900 if (curr_binding_label
)
5901 /* Binding label given; store in temp holder till have sym. */
5902 *dest_label
= curr_binding_label
;
5905 /* No binding label given, and the NAME= specifier did not exist,
5906 which means there was no NAME="". */
5907 if (sym_name
!= NULL
&& has_name_equals
== 0)
5908 *dest_label
= IDENTIFIER_POINTER (get_identifier (sym_name
));
5915 /* Set the status of the given common block as being BIND(C) or not,
5916 depending on the given parameter, is_bind_c. */
5919 set_com_block_bind_c (gfc_common_head
*com_block
, int is_bind_c
)
5921 com_block
->is_bind_c
= is_bind_c
;
5926 /* Verify that the given gfc_typespec is for a C interoperable type. */
5929 gfc_verify_c_interop (gfc_typespec
*ts
)
5931 if (ts
->type
== BT_DERIVED
&& ts
->u
.derived
!= NULL
)
5932 return (ts
->u
.derived
->ts
.is_c_interop
|| ts
->u
.derived
->attr
.is_bind_c
)
5934 else if (ts
->type
== BT_CLASS
)
5936 else if (ts
->is_c_interop
!= 1 && ts
->type
!= BT_ASSUMED
)
5943 /* Verify that the variables of a given common block, which has been
5944 defined with the attribute specifier bind(c), to be of a C
5945 interoperable type. Errors will be reported here, if
5949 verify_com_block_vars_c_interop (gfc_common_head
*com_block
)
5951 gfc_symbol
*curr_sym
= NULL
;
5954 curr_sym
= com_block
->head
;
5956 /* Make sure we have at least one symbol. */
5957 if (curr_sym
== NULL
)
5960 /* Here we know we have a symbol, so we'll execute this loop
5964 /* The second to last param, 1, says this is in a common block. */
5965 retval
= verify_bind_c_sym (curr_sym
, &(curr_sym
->ts
), 1, com_block
);
5966 curr_sym
= curr_sym
->common_next
;
5967 } while (curr_sym
!= NULL
);
5973 /* Verify that a given BIND(C) symbol is C interoperable. If it is not,
5974 an appropriate error message is reported. */
5977 verify_bind_c_sym (gfc_symbol
*tmp_sym
, gfc_typespec
*ts
,
5978 int is_in_common
, gfc_common_head
*com_block
)
5980 bool bind_c_function
= false;
5983 if (tmp_sym
->attr
.function
&& tmp_sym
->attr
.is_bind_c
)
5984 bind_c_function
= true;
5986 if (tmp_sym
->attr
.function
&& tmp_sym
->result
!= NULL
)
5988 tmp_sym
= tmp_sym
->result
;
5989 /* Make sure it wasn't an implicitly typed result. */
5990 if (tmp_sym
->attr
.implicit_type
&& warn_c_binding_type
)
5992 gfc_warning (OPT_Wc_binding_type
,
5993 "Implicitly declared BIND(C) function %qs at "
5994 "%L may not be C interoperable", tmp_sym
->name
,
5995 &tmp_sym
->declared_at
);
5996 tmp_sym
->ts
.f90_type
= tmp_sym
->ts
.type
;
5997 /* Mark it as C interoperable to prevent duplicate warnings. */
5998 tmp_sym
->ts
.is_c_interop
= 1;
5999 tmp_sym
->attr
.is_c_interop
= 1;
6003 /* Here, we know we have the bind(c) attribute, so if we have
6004 enough type info, then verify that it's a C interop kind.
6005 The info could be in the symbol already, or possibly still in
6006 the given ts (current_ts), so look in both. */
6007 if (tmp_sym
->ts
.type
!= BT_UNKNOWN
|| ts
->type
!= BT_UNKNOWN
)
6009 if (!gfc_verify_c_interop (&(tmp_sym
->ts
)))
6011 /* See if we're dealing with a sym in a common block or not. */
6012 if (is_in_common
== 1 && warn_c_binding_type
)
6014 gfc_warning (OPT_Wc_binding_type
,
6015 "Variable %qs in common block %qs at %L "
6016 "may not be a C interoperable "
6017 "kind though common block %qs is BIND(C)",
6018 tmp_sym
->name
, com_block
->name
,
6019 &(tmp_sym
->declared_at
), com_block
->name
);
6023 if (tmp_sym
->ts
.type
== BT_DERIVED
|| ts
->type
== BT_DERIVED
6024 || tmp_sym
->ts
.type
== BT_CLASS
|| ts
->type
== BT_CLASS
)
6026 gfc_error ("Type declaration %qs at %L is not C "
6027 "interoperable but it is BIND(C)",
6028 tmp_sym
->name
, &(tmp_sym
->declared_at
));
6031 else if (warn_c_binding_type
)
6032 gfc_warning (OPT_Wc_binding_type
, "Variable %qs at %L "
6033 "may not be a C interoperable "
6034 "kind but it is BIND(C)",
6035 tmp_sym
->name
, &(tmp_sym
->declared_at
));
6039 /* Variables declared w/in a common block can't be bind(c)
6040 since there's no way for C to see these variables, so there's
6041 semantically no reason for the attribute. */
6042 if (is_in_common
== 1 && tmp_sym
->attr
.is_bind_c
== 1)
6044 gfc_error ("Variable %qs in common block %qs at "
6045 "%L cannot be declared with BIND(C) "
6046 "since it is not a global",
6047 tmp_sym
->name
, com_block
->name
,
6048 &(tmp_sym
->declared_at
));
6052 /* Scalar variables that are bind(c) cannot have the pointer
6053 or allocatable attributes. */
6054 if (tmp_sym
->attr
.is_bind_c
== 1)
6056 if (tmp_sym
->attr
.pointer
== 1)
6058 gfc_error ("Variable %qs at %L cannot have both the "
6059 "POINTER and BIND(C) attributes",
6060 tmp_sym
->name
, &(tmp_sym
->declared_at
));
6064 if (tmp_sym
->attr
.allocatable
== 1)
6066 gfc_error ("Variable %qs at %L cannot have both the "
6067 "ALLOCATABLE and BIND(C) attributes",
6068 tmp_sym
->name
, &(tmp_sym
->declared_at
));
6074 /* If it is a BIND(C) function, make sure the return value is a
6075 scalar value. The previous tests in this function made sure
6076 the type is interoperable. */
6077 if (bind_c_function
&& tmp_sym
->as
!= NULL
)
6078 gfc_error ("Return type of BIND(C) function %qs at %L cannot "
6079 "be an array", tmp_sym
->name
, &(tmp_sym
->declared_at
));
6081 /* BIND(C) functions cannot return a character string. */
6082 if (bind_c_function
&& tmp_sym
->ts
.type
== BT_CHARACTER
)
6083 if (!gfc_length_one_character_type_p (&tmp_sym
->ts
))
6084 gfc_error ("Return type of BIND(C) function %qs of character "
6085 "type at %L must have length 1", tmp_sym
->name
,
6086 &(tmp_sym
->declared_at
));
6089 /* See if the symbol has been marked as private. If it has, make sure
6090 there is no binding label and warn the user if there is one. */
6091 if (tmp_sym
->attr
.access
== ACCESS_PRIVATE
6092 && tmp_sym
->binding_label
)
6093 /* Use gfc_warning_now because we won't say that the symbol fails
6094 just because of this. */
6095 gfc_warning_now (0, "Symbol %qs at %L is marked PRIVATE but has been "
6096 "given the binding label %qs", tmp_sym
->name
,
6097 &(tmp_sym
->declared_at
), tmp_sym
->binding_label
);
6103 /* Set the appropriate fields for a symbol that's been declared as
6104 BIND(C) (the is_bind_c flag and the binding label), and verify that
6105 the type is C interoperable. Errors are reported by the functions
6106 used to set/test these fields. */
6109 set_verify_bind_c_sym (gfc_symbol
*tmp_sym
, int num_idents
)
6113 /* TODO: Do we need to make sure the vars aren't marked private? */
6115 /* Set the is_bind_c bit in symbol_attribute. */
6116 gfc_add_is_bind_c (&(tmp_sym
->attr
), tmp_sym
->name
, &gfc_current_locus
, 0);
6118 if (!set_binding_label (&tmp_sym
->binding_label
, tmp_sym
->name
, num_idents
))
6125 /* Set the fields marking the given common block as BIND(C), including
6126 a binding label, and report any errors encountered. */
6129 set_verify_bind_c_com_block (gfc_common_head
*com_block
, int num_idents
)
6133 /* destLabel, common name, typespec (which may have binding label). */
6134 if (!set_binding_label (&com_block
->binding_label
, com_block
->name
,
6138 /* Set the given common block (com_block) to being bind(c) (1). */
6139 set_com_block_bind_c (com_block
, 1);
6145 /* Retrieve the list of one or more identifiers that the given bind(c)
6146 attribute applies to. */
6149 get_bind_c_idents (void)
6151 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6153 gfc_symbol
*tmp_sym
= NULL
;
6155 gfc_common_head
*com_block
= NULL
;
6157 if (gfc_match_name (name
) == MATCH_YES
)
6159 found_id
= MATCH_YES
;
6160 gfc_get_ha_symbol (name
, &tmp_sym
);
6162 else if (gfc_match_common_name (name
) == MATCH_YES
)
6164 found_id
= MATCH_YES
;
6165 com_block
= gfc_get_common (name
, 0);
6169 gfc_error ("Need either entity or common block name for "
6170 "attribute specification statement at %C");
6174 /* Save the current identifier and look for more. */
6177 /* Increment the number of identifiers found for this spec stmt. */
6180 /* Make sure we have a sym or com block, and verify that it can
6181 be bind(c). Set the appropriate field(s) and look for more
6183 if (tmp_sym
!= NULL
|| com_block
!= NULL
)
6185 if (tmp_sym
!= NULL
)
6187 if (!set_verify_bind_c_sym (tmp_sym
, num_idents
))
6192 if (!set_verify_bind_c_com_block (com_block
, num_idents
))
6196 /* Look to see if we have another identifier. */
6198 if (gfc_match_eos () == MATCH_YES
)
6199 found_id
= MATCH_NO
;
6200 else if (gfc_match_char (',') != MATCH_YES
)
6201 found_id
= MATCH_NO
;
6202 else if (gfc_match_name (name
) == MATCH_YES
)
6204 found_id
= MATCH_YES
;
6205 gfc_get_ha_symbol (name
, &tmp_sym
);
6207 else if (gfc_match_common_name (name
) == MATCH_YES
)
6209 found_id
= MATCH_YES
;
6210 com_block
= gfc_get_common (name
, 0);
6214 gfc_error ("Missing entity or common block name for "
6215 "attribute specification statement at %C");
6221 gfc_internal_error ("Missing symbol");
6223 } while (found_id
== MATCH_YES
);
6225 /* if we get here we were successful */
6230 /* Try and match a BIND(C) attribute specification statement. */
6233 gfc_match_bind_c_stmt (void)
6235 match found_match
= MATCH_NO
;
6240 /* This may not be necessary. */
6242 /* Clear the temporary binding label holder. */
6243 curr_binding_label
= NULL
;
6245 /* Look for the bind(c). */
6246 found_match
= gfc_match_bind_c (NULL
, true);
6248 if (found_match
== MATCH_YES
)
6250 if (!gfc_notify_std (GFC_STD_F2003
, "BIND(C) statement at %C"))
6253 /* Look for the :: now, but it is not required. */
6256 /* Get the identifier(s) that needs to be updated. This may need to
6257 change to hand the flag(s) for the attr specified so all identifiers
6258 found can have all appropriate parts updated (assuming that the same
6259 spec stmt can have multiple attrs, such as both bind(c) and
6261 if (!get_bind_c_idents ())
6262 /* Error message should have printed already. */
6270 /* Match a data declaration statement. */
6273 gfc_match_data_decl (void)
6279 type_param_spec_list
= NULL
;
6280 decl_type_param_list
= NULL
;
6282 num_idents_on_line
= 0;
6284 m
= gfc_match_decl_type_spec (¤t_ts
, 0);
6288 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
6289 && !gfc_comp_struct (gfc_current_state ()))
6291 sym
= gfc_use_derived (current_ts
.u
.derived
);
6299 current_ts
.u
.derived
= sym
;
6302 m
= match_attr_spec ();
6303 if (m
== MATCH_ERROR
)
6310 if (current_ts
.type
== BT_CLASS
&& current_attr
.flavor
== FL_PARAMETER
)
6312 gfc_error ("CLASS entity at %C cannot have the PARAMETER attribute");
6317 if (current_ts
.type
== BT_CLASS
6318 && current_ts
.u
.derived
->attr
.unlimited_polymorphic
)
6321 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
6322 && current_ts
.u
.derived
->components
== NULL
6323 && !current_ts
.u
.derived
->attr
.zero_comp
)
6326 if (current_attr
.pointer
&& gfc_comp_struct (gfc_current_state ()))
6329 if (current_attr
.allocatable
&& gfc_current_state () == COMP_DERIVED
)
6332 gfc_find_symbol (current_ts
.u
.derived
->name
,
6333 current_ts
.u
.derived
->ns
, 1, &sym
);
6335 /* Any symbol that we find had better be a type definition
6336 which has its components defined, or be a structure definition
6337 actively being parsed. */
6338 if (sym
!= NULL
&& gfc_fl_struct (sym
->attr
.flavor
)
6339 && (current_ts
.u
.derived
->components
!= NULL
6340 || current_ts
.u
.derived
->attr
.zero_comp
6341 || current_ts
.u
.derived
== gfc_new_block
))
6344 gfc_error ("Derived type at %C has not been previously defined "
6345 "and so cannot appear in a derived type definition");
6351 /* If we have an old-style character declaration, and no new-style
6352 attribute specifications, then there a comma is optional between
6353 the type specification and the variable list. */
6354 if (m
== MATCH_NO
&& current_ts
.type
== BT_CHARACTER
&& old_char_selector
)
6355 gfc_match_char (',');
6357 /* Give the types/attributes to symbols that follow. Give the element
6358 a number so that repeat character length expressions can be copied. */
6362 num_idents_on_line
++;
6363 m
= variable_decl (elem
++);
6364 if (m
== MATCH_ERROR
)
6369 if (gfc_match_eos () == MATCH_YES
)
6371 if (gfc_match_char (',') != MATCH_YES
)
6375 if (!gfc_error_flag_test ())
6377 /* An anonymous structure declaration is unambiguous; if we matched one
6378 according to gfc_match_structure_decl, we need to return MATCH_YES
6379 here to avoid confusing the remaining matchers, even if there was an
6380 error during variable_decl. We must flush any such errors. Note this
6381 causes the parser to gracefully continue parsing the remaining input
6382 as a structure body, which likely follows. */
6383 if (current_ts
.type
== BT_DERIVED
&& current_ts
.u
.derived
6384 && gfc_fl_struct (current_ts
.u
.derived
->attr
.flavor
))
6386 gfc_error_now ("Syntax error in anonymous structure declaration"
6388 /* Skip the bad variable_decl and line up for the start of the
6390 gfc_error_recovery ();
6395 gfc_error ("Syntax error in data declaration at %C");
6400 gfc_free_data_all (gfc_current_ns
);
6403 if (saved_kind_expr
)
6404 gfc_free_expr (saved_kind_expr
);
6405 if (type_param_spec_list
)
6406 gfc_free_actual_arglist (type_param_spec_list
);
6407 if (decl_type_param_list
)
6408 gfc_free_actual_arglist (decl_type_param_list
);
6409 saved_kind_expr
= NULL
;
6410 gfc_free_array_spec (current_as
);
6416 in_module_or_interface(void)
6418 if (gfc_current_state () == COMP_MODULE
6419 || gfc_current_state () == COMP_SUBMODULE
6420 || gfc_current_state () == COMP_INTERFACE
)
6423 if (gfc_state_stack
->state
== COMP_CONTAINS
6424 || gfc_state_stack
->state
== COMP_FUNCTION
6425 || gfc_state_stack
->state
== COMP_SUBROUTINE
)
6428 for (p
= gfc_state_stack
->previous
; p
; p
= p
->previous
)
6430 if (p
->state
== COMP_MODULE
|| p
->state
== COMP_SUBMODULE
6431 || p
->state
== COMP_INTERFACE
)
6438 /* Match a prefix associated with a function or subroutine
6439 declaration. If the typespec pointer is nonnull, then a typespec
6440 can be matched. Note that if nothing matches, MATCH_YES is
6441 returned (the null string was matched). */
6444 gfc_match_prefix (gfc_typespec
*ts
)
6450 gfc_clear_attr (¤t_attr
);
6452 seen_impure
= false;
6454 gcc_assert (!gfc_matching_prefix
);
6455 gfc_matching_prefix
= true;
6459 found_prefix
= false;
6461 /* MODULE is a prefix like PURE, ELEMENTAL, etc., having a
6462 corresponding attribute seems natural and distinguishes these
6463 procedures from procedure types of PROC_MODULE, which these are
6465 if (gfc_match ("module% ") == MATCH_YES
)
6467 if (!gfc_notify_std (GFC_STD_F2008
, "MODULE prefix at %C"))
6470 if (!in_module_or_interface ())
6472 gfc_error ("MODULE prefix at %C found outside of a module, "
6473 "submodule, or interface");
6477 current_attr
.module_procedure
= 1;
6478 found_prefix
= true;
6481 if (!seen_type
&& ts
!= NULL
)
6484 m
= gfc_match_decl_type_spec (ts
, 0);
6485 if (m
== MATCH_ERROR
)
6487 if (m
== MATCH_YES
&& gfc_match_space () == MATCH_YES
)
6490 found_prefix
= true;
6494 if (gfc_match ("elemental% ") == MATCH_YES
)
6496 if (!gfc_add_elemental (¤t_attr
, NULL
))
6499 found_prefix
= true;
6502 if (gfc_match ("pure% ") == MATCH_YES
)
6504 if (!gfc_add_pure (¤t_attr
, NULL
))
6507 found_prefix
= true;
6510 if (gfc_match ("recursive% ") == MATCH_YES
)
6512 if (!gfc_add_recursive (¤t_attr
, NULL
))
6515 found_prefix
= true;
6518 /* IMPURE is a somewhat special case, as it needs not set an actual
6519 attribute but rather only prevents ELEMENTAL routines from being
6520 automatically PURE. */
6521 if (gfc_match ("impure% ") == MATCH_YES
)
6523 if (!gfc_notify_std (GFC_STD_F2008
, "IMPURE procedure at %C"))
6527 found_prefix
= true;
6530 while (found_prefix
);
6532 /* IMPURE and PURE must not both appear, of course. */
6533 if (seen_impure
&& current_attr
.pure
)
6535 gfc_error ("PURE and IMPURE must not appear both at %C");
6539 /* If IMPURE it not seen but the procedure is ELEMENTAL, mark it as PURE. */
6540 if (!seen_impure
&& current_attr
.elemental
&& !current_attr
.pure
)
6542 if (!gfc_add_pure (¤t_attr
, NULL
))
6546 /* At this point, the next item is not a prefix. */
6547 gcc_assert (gfc_matching_prefix
);
6549 gfc_matching_prefix
= false;
6553 gcc_assert (gfc_matching_prefix
);
6554 gfc_matching_prefix
= false;
6559 /* Copy attributes matched by gfc_match_prefix() to attributes on a symbol. */
6562 copy_prefix (symbol_attribute
*dest
, locus
*where
)
6564 if (dest
->module_procedure
)
6566 if (current_attr
.elemental
)
6567 dest
->elemental
= 1;
6569 if (current_attr
.pure
)
6572 if (current_attr
.recursive
)
6573 dest
->recursive
= 1;
6575 /* Module procedures are unusual in that the 'dest' is copied from
6576 the interface declaration. However, this is an oportunity to
6577 check that the submodule declaration is compliant with the
6579 if (dest
->elemental
&& !current_attr
.elemental
)
6581 gfc_error ("ELEMENTAL prefix in MODULE PROCEDURE interface is "
6582 "missing at %L", where
);
6586 if (dest
->pure
&& !current_attr
.pure
)
6588 gfc_error ("PURE prefix in MODULE PROCEDURE interface is "
6589 "missing at %L", where
);
6593 if (dest
->recursive
&& !current_attr
.recursive
)
6595 gfc_error ("RECURSIVE prefix in MODULE PROCEDURE interface is "
6596 "missing at %L", where
);
6603 if (current_attr
.elemental
&& !gfc_add_elemental (dest
, where
))
6606 if (current_attr
.pure
&& !gfc_add_pure (dest
, where
))
6609 if (current_attr
.recursive
&& !gfc_add_recursive (dest
, where
))
6616 /* Match a formal argument list or, if typeparam is true, a
6617 type_param_name_list. */
6620 gfc_match_formal_arglist (gfc_symbol
*progname
, int st_flag
,
6621 int null_flag
, bool typeparam
)
6623 gfc_formal_arglist
*head
, *tail
, *p
, *q
;
6624 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6627 gfc_formal_arglist
*formal
= NULL
;
6631 /* Keep the interface formal argument list and null it so that the
6632 matching for the new declaration can be done. The numbers and
6633 names of the arguments are checked here. The interface formal
6634 arguments are retained in formal_arglist and the characteristics
6635 are compared in resolve.cc(resolve_fl_procedure). See the remark
6636 in get_proc_name about the eventual need to copy the formal_arglist
6637 and populate the formal namespace of the interface symbol. */
6638 if (progname
->attr
.module_procedure
6639 && progname
->attr
.host_assoc
)
6641 formal
= progname
->formal
;
6642 progname
->formal
= NULL
;
6645 if (gfc_match_char ('(') != MATCH_YES
)
6652 if (gfc_match_char (')') == MATCH_YES
)
6656 gfc_error_now ("A type parameter list is required at %C");
6666 if (gfc_match_char ('*') == MATCH_YES
)
6669 if (!typeparam
&& !gfc_notify_std (GFC_STD_F95_OBS
,
6670 "Alternate-return argument at %C"))
6676 gfc_error_now ("A parameter name is required at %C");
6680 m
= gfc_match_name (name
);
6684 gfc_error_now ("A parameter name is required at %C");
6688 if (!typeparam
&& gfc_get_symbol (name
, NULL
, &sym
))
6691 && gfc_get_symbol (name
, progname
->f2k_derived
, &sym
))
6695 p
= gfc_get_formal_arglist ();
6707 /* We don't add the VARIABLE flavor because the name could be a
6708 dummy procedure. We don't apply these attributes to formal
6709 arguments of statement functions. */
6710 if (sym
!= NULL
&& !st_flag
6711 && (!gfc_add_dummy(&sym
->attr
, sym
->name
, NULL
)
6712 || !gfc_missing_attr (&sym
->attr
, NULL
)))
6718 /* The name of a program unit can be in a different namespace,
6719 so check for it explicitly. After the statement is accepted,
6720 the name is checked for especially in gfc_get_symbol(). */
6721 if (gfc_new_block
!= NULL
&& sym
!= NULL
&& !typeparam
6722 && strcmp (sym
->name
, gfc_new_block
->name
) == 0)
6724 gfc_error ("Name %qs at %C is the name of the procedure",
6730 if (gfc_match_char (')') == MATCH_YES
)
6733 m
= gfc_match_char (',');
6737 gfc_error_now ("Expected parameter list in type declaration "
6740 gfc_error ("Unexpected junk in formal argument list at %C");
6746 /* Check for duplicate symbols in the formal argument list. */
6749 for (p
= head
; p
->next
; p
= p
->next
)
6754 for (q
= p
->next
; q
; q
= q
->next
)
6755 if (p
->sym
== q
->sym
)
6758 gfc_error_now ("Duplicate name %qs in parameter "
6759 "list at %C", p
->sym
->name
);
6761 gfc_error ("Duplicate symbol %qs in formal argument "
6762 "list at %C", p
->sym
->name
);
6770 if (!gfc_add_explicit_interface (progname
, IFSRC_DECL
, head
, NULL
))
6776 /* gfc_error_now used in following and return with MATCH_YES because
6777 doing otherwise results in a cascade of extraneous errors and in
6778 some cases an ICE in symbol.cc(gfc_release_symbol). */
6779 if (progname
->attr
.module_procedure
&& progname
->attr
.host_assoc
)
6781 bool arg_count_mismatch
= false;
6783 if (!formal
&& head
)
6784 arg_count_mismatch
= true;
6786 /* Abbreviated module procedure declaration is not meant to have any
6787 formal arguments! */
6788 if (!progname
->abr_modproc_decl
&& formal
&& !head
)
6789 arg_count_mismatch
= true;
6791 for (p
= formal
, q
= head
; p
&& q
; p
= p
->next
, q
= q
->next
)
6793 if ((p
->next
!= NULL
&& q
->next
== NULL
)
6794 || (p
->next
== NULL
&& q
->next
!= NULL
))
6795 arg_count_mismatch
= true;
6796 else if ((p
->sym
== NULL
&& q
->sym
== NULL
)
6797 || strcmp (p
->sym
->name
, q
->sym
->name
) == 0)
6800 gfc_error_now ("Mismatch in MODULE PROCEDURE formal "
6801 "argument names (%s/%s) at %C",
6802 p
->sym
->name
, q
->sym
->name
);
6805 if (arg_count_mismatch
)
6806 gfc_error_now ("Mismatch in number of MODULE PROCEDURE "
6807 "formal arguments at %C");
6813 gfc_free_formal_arglist (head
);
6818 /* Match a RESULT specification following a function declaration or
6819 ENTRY statement. Also matches the end-of-statement. */
6822 match_result (gfc_symbol
*function
, gfc_symbol
**result
)
6824 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6828 if (gfc_match (" result (") != MATCH_YES
)
6831 m
= gfc_match_name (name
);
6835 /* Get the right paren, and that's it because there could be the
6836 bind(c) attribute after the result clause. */
6837 if (gfc_match_char (')') != MATCH_YES
)
6839 /* TODO: should report the missing right paren here. */
6843 if (strcmp (function
->name
, name
) == 0)
6845 gfc_error ("RESULT variable at %C must be different than function name");
6849 if (gfc_get_symbol (name
, NULL
, &r
))
6852 if (!gfc_add_result (&r
->attr
, r
->name
, NULL
))
6861 /* Match a function suffix, which could be a combination of a result
6862 clause and BIND(C), either one, or neither. The draft does not
6863 require them to come in a specific order. */
6866 gfc_match_suffix (gfc_symbol
*sym
, gfc_symbol
**result
)
6868 match is_bind_c
; /* Found bind(c). */
6869 match is_result
; /* Found result clause. */
6870 match found_match
; /* Status of whether we've found a good match. */
6871 char peek_char
; /* Character we're going to peek at. */
6872 bool allow_binding_name
;
6874 /* Initialize to having found nothing. */
6875 found_match
= MATCH_NO
;
6876 is_bind_c
= MATCH_NO
;
6877 is_result
= MATCH_NO
;
6879 /* Get the next char to narrow between result and bind(c). */
6880 gfc_gobble_whitespace ();
6881 peek_char
= gfc_peek_ascii_char ();
6883 /* C binding names are not allowed for internal procedures. */
6884 if (gfc_current_state () == COMP_CONTAINS
6885 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
6886 allow_binding_name
= false;
6888 allow_binding_name
= true;
6893 /* Look for result clause. */
6894 is_result
= match_result (sym
, result
);
6895 if (is_result
== MATCH_YES
)
6897 /* Now see if there is a bind(c) after it. */
6898 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
6899 /* We've found the result clause and possibly bind(c). */
6900 found_match
= MATCH_YES
;
6903 /* This should only be MATCH_ERROR. */
6904 found_match
= is_result
;
6907 /* Look for bind(c) first. */
6908 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
6909 if (is_bind_c
== MATCH_YES
)
6911 /* Now see if a result clause followed it. */
6912 is_result
= match_result (sym
, result
);
6913 found_match
= MATCH_YES
;
6917 /* Should only be a MATCH_ERROR if we get here after seeing 'b'. */
6918 found_match
= MATCH_ERROR
;
6922 gfc_error ("Unexpected junk after function declaration at %C");
6923 found_match
= MATCH_ERROR
;
6927 if (is_bind_c
== MATCH_YES
)
6929 /* Fortran 2008 draft allows BIND(C) for internal procedures. */
6930 if (gfc_current_state () == COMP_CONTAINS
6931 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
6932 && !gfc_notify_std (GFC_STD_F2008
, "BIND(C) attribute "
6933 "at %L may not be specified for an internal "
6934 "procedure", &gfc_current_locus
))
6937 if (!gfc_add_is_bind_c (&(sym
->attr
), sym
->name
, &gfc_current_locus
, 1))
6945 /* Procedure pointer return value without RESULT statement:
6946 Add "hidden" result variable named "ppr@". */
6949 add_hidden_procptr_result (gfc_symbol
*sym
)
6953 if (gfc_notification_std (GFC_STD_F2003
) == ERROR
)
6956 /* First usage case: PROCEDURE and EXTERNAL statements. */
6957 case1
= gfc_current_state () == COMP_FUNCTION
&& gfc_current_block ()
6958 && strcmp (gfc_current_block ()->name
, sym
->name
) == 0
6959 && sym
->attr
.external
;
6960 /* Second usage case: INTERFACE statements. */
6961 case2
= gfc_current_state () == COMP_INTERFACE
&& gfc_state_stack
->previous
6962 && gfc_state_stack
->previous
->state
== COMP_FUNCTION
6963 && strcmp (gfc_state_stack
->previous
->sym
->name
, sym
->name
) == 0;
6969 gfc_get_sym_tree ("ppr@", gfc_current_ns
, &stree
, false);
6973 gfc_get_sym_tree ("ppr@", gfc_current_ns
->parent
, &stree
, false);
6974 st2
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "ppr@");
6975 st2
->n
.sym
= stree
->n
.sym
;
6976 stree
->n
.sym
->refs
++;
6978 sym
->result
= stree
->n
.sym
;
6980 sym
->result
->attr
.proc_pointer
= sym
->attr
.proc_pointer
;
6981 sym
->result
->attr
.pointer
= sym
->attr
.pointer
;
6982 sym
->result
->attr
.external
= sym
->attr
.external
;
6983 sym
->result
->attr
.referenced
= sym
->attr
.referenced
;
6984 sym
->result
->ts
= sym
->ts
;
6985 sym
->attr
.proc_pointer
= 0;
6986 sym
->attr
.pointer
= 0;
6987 sym
->attr
.external
= 0;
6988 if (sym
->result
->attr
.external
&& sym
->result
->attr
.pointer
)
6990 sym
->result
->attr
.pointer
= 0;
6991 sym
->result
->attr
.proc_pointer
= 1;
6994 return gfc_add_result (&sym
->result
->attr
, sym
->result
->name
, NULL
);
6996 /* POINTER after PROCEDURE/EXTERNAL/INTERFACE statement. */
6997 else if (sym
->attr
.function
&& !sym
->attr
.external
&& sym
->attr
.pointer
6998 && sym
->result
&& sym
->result
!= sym
&& sym
->result
->attr
.external
6999 && sym
== gfc_current_ns
->proc_name
7000 && sym
== sym
->result
->ns
->proc_name
7001 && strcmp ("ppr@", sym
->result
->name
) == 0)
7003 sym
->result
->attr
.proc_pointer
= 1;
7004 sym
->attr
.pointer
= 0;
7012 /* Match the interface for a PROCEDURE declaration,
7013 including brackets (R1212). */
7016 match_procedure_interface (gfc_symbol
**proc_if
)
7020 locus old_loc
, entry_loc
;
7021 gfc_namespace
*old_ns
= gfc_current_ns
;
7022 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7024 old_loc
= entry_loc
= gfc_current_locus
;
7025 gfc_clear_ts (¤t_ts
);
7027 if (gfc_match (" (") != MATCH_YES
)
7029 gfc_current_locus
= entry_loc
;
7033 /* Get the type spec. for the procedure interface. */
7034 old_loc
= gfc_current_locus
;
7035 m
= gfc_match_decl_type_spec (¤t_ts
, 0);
7036 gfc_gobble_whitespace ();
7037 if (m
== MATCH_YES
|| (m
== MATCH_NO
&& gfc_peek_ascii_char () == ')'))
7040 if (m
== MATCH_ERROR
)
7043 /* Procedure interface is itself a procedure. */
7044 gfc_current_locus
= old_loc
;
7045 m
= gfc_match_name (name
);
7047 /* First look to see if it is already accessible in the current
7048 namespace because it is use associated or contained. */
7050 if (gfc_find_sym_tree (name
, NULL
, 0, &st
))
7053 /* If it is still not found, then try the parent namespace, if it
7054 exists and create the symbol there if it is still not found. */
7055 if (gfc_current_ns
->parent
)
7056 gfc_current_ns
= gfc_current_ns
->parent
;
7057 if (st
== NULL
&& gfc_get_ha_sym_tree (name
, &st
))
7060 gfc_current_ns
= old_ns
;
7061 *proc_if
= st
->n
.sym
;
7066 /* Resolve interface if possible. That way, attr.procedure is only set
7067 if it is declared by a later procedure-declaration-stmt, which is
7068 invalid per F08:C1216 (cf. resolve_procedure_interface). */
7069 while ((*proc_if
)->ts
.interface
7070 && *proc_if
!= (*proc_if
)->ts
.interface
)
7071 *proc_if
= (*proc_if
)->ts
.interface
;
7073 if ((*proc_if
)->attr
.flavor
== FL_UNKNOWN
7074 && (*proc_if
)->ts
.type
== BT_UNKNOWN
7075 && !gfc_add_flavor (&(*proc_if
)->attr
, FL_PROCEDURE
,
7076 (*proc_if
)->name
, NULL
))
7081 if (gfc_match (" )") != MATCH_YES
)
7083 gfc_current_locus
= entry_loc
;
7091 /* Match a PROCEDURE declaration (R1211). */
7094 match_procedure_decl (void)
7097 gfc_symbol
*sym
, *proc_if
= NULL
;
7099 gfc_expr
*initializer
= NULL
;
7101 /* Parse interface (with brackets). */
7102 m
= match_procedure_interface (&proc_if
);
7106 /* Parse attributes (with colons). */
7107 m
= match_attr_spec();
7108 if (m
== MATCH_ERROR
)
7111 if (proc_if
&& proc_if
->attr
.is_bind_c
&& !current_attr
.is_bind_c
)
7113 current_attr
.is_bind_c
= 1;
7114 has_name_equals
= 0;
7115 curr_binding_label
= NULL
;
7118 /* Get procedure symbols. */
7121 m
= gfc_match_symbol (&sym
, 0);
7124 else if (m
== MATCH_ERROR
)
7127 /* Add current_attr to the symbol attributes. */
7128 if (!gfc_copy_attr (&sym
->attr
, ¤t_attr
, NULL
))
7131 if (sym
->attr
.is_bind_c
)
7133 /* Check for C1218. */
7134 if (!proc_if
|| !proc_if
->attr
.is_bind_c
)
7136 gfc_error ("BIND(C) attribute at %C requires "
7137 "an interface with BIND(C)");
7140 /* Check for C1217. */
7141 if (has_name_equals
&& sym
->attr
.pointer
)
7143 gfc_error ("BIND(C) procedure with NAME may not have "
7144 "POINTER attribute at %C");
7147 if (has_name_equals
&& sym
->attr
.dummy
)
7149 gfc_error ("Dummy procedure at %C may not have "
7150 "BIND(C) attribute with NAME");
7153 /* Set binding label for BIND(C). */
7154 if (!set_binding_label (&sym
->binding_label
, sym
->name
, num
))
7158 if (!gfc_add_external (&sym
->attr
, NULL
))
7161 if (add_hidden_procptr_result (sym
))
7164 if (!gfc_add_proc (&sym
->attr
, sym
->name
, NULL
))
7167 /* Set interface. */
7168 if (proc_if
!= NULL
)
7170 if (sym
->ts
.type
!= BT_UNKNOWN
)
7172 gfc_error ("Procedure %qs at %L already has basic type of %s",
7173 sym
->name
, &gfc_current_locus
,
7174 gfc_basic_typename (sym
->ts
.type
));
7177 sym
->ts
.interface
= proc_if
;
7178 sym
->attr
.untyped
= 1;
7179 sym
->attr
.if_source
= IFSRC_IFBODY
;
7181 else if (current_ts
.type
!= BT_UNKNOWN
)
7183 if (!gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
7185 sym
->ts
.interface
= gfc_new_symbol ("", gfc_current_ns
);
7186 sym
->ts
.interface
->ts
= current_ts
;
7187 sym
->ts
.interface
->attr
.flavor
= FL_PROCEDURE
;
7188 sym
->ts
.interface
->attr
.function
= 1;
7189 sym
->attr
.function
= 1;
7190 sym
->attr
.if_source
= IFSRC_UNKNOWN
;
7193 if (gfc_match (" =>") == MATCH_YES
)
7195 if (!current_attr
.pointer
)
7197 gfc_error ("Initialization at %C isn't for a pointer variable");
7202 m
= match_pointer_init (&initializer
, 1);
7206 if (!add_init_expr_to_sym (sym
->name
, &initializer
, &gfc_current_locus
))
7211 if (gfc_match_eos () == MATCH_YES
)
7213 if (gfc_match_char (',') != MATCH_YES
)
7218 gfc_error ("Syntax error in PROCEDURE statement at %C");
7222 /* Free stuff up and return. */
7223 gfc_free_expr (initializer
);
7229 match_binding_attributes (gfc_typebound_proc
* ba
, bool generic
, bool ppc
);
7232 /* Match a procedure pointer component declaration (R445). */
7235 match_ppc_decl (void)
7238 gfc_symbol
*proc_if
= NULL
;
7242 gfc_expr
*initializer
= NULL
;
7243 gfc_typebound_proc
* tb
;
7244 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7246 /* Parse interface (with brackets). */
7247 m
= match_procedure_interface (&proc_if
);
7251 /* Parse attributes. */
7252 tb
= XCNEW (gfc_typebound_proc
);
7253 tb
->where
= gfc_current_locus
;
7254 m
= match_binding_attributes (tb
, false, true);
7255 if (m
== MATCH_ERROR
)
7258 gfc_clear_attr (¤t_attr
);
7259 current_attr
.procedure
= 1;
7260 current_attr
.proc_pointer
= 1;
7261 current_attr
.access
= tb
->access
;
7262 current_attr
.flavor
= FL_PROCEDURE
;
7264 /* Match the colons (required). */
7265 if (gfc_match (" ::") != MATCH_YES
)
7267 gfc_error ("Expected %<::%> after binding-attributes at %C");
7271 /* Check for C450. */
7272 if (!tb
->nopass
&& proc_if
== NULL
)
7274 gfc_error("NOPASS or explicit interface required at %C");
7278 if (!gfc_notify_std (GFC_STD_F2003
, "Procedure pointer component at %C"))
7281 /* Match PPC names. */
7285 m
= gfc_match_name (name
);
7288 else if (m
== MATCH_ERROR
)
7291 if (!gfc_add_component (gfc_current_block(), name
, &c
))
7294 /* Add current_attr to the symbol attributes. */
7295 if (!gfc_copy_attr (&c
->attr
, ¤t_attr
, NULL
))
7298 if (!gfc_add_external (&c
->attr
, NULL
))
7301 if (!gfc_add_proc (&c
->attr
, name
, NULL
))
7308 c
->tb
= XCNEW (gfc_typebound_proc
);
7309 c
->tb
->where
= gfc_current_locus
;
7313 /* Set interface. */
7314 if (proc_if
!= NULL
)
7316 c
->ts
.interface
= proc_if
;
7317 c
->attr
.untyped
= 1;
7318 c
->attr
.if_source
= IFSRC_IFBODY
;
7320 else if (ts
.type
!= BT_UNKNOWN
)
7323 c
->ts
.interface
= gfc_new_symbol ("", gfc_current_ns
);
7324 c
->ts
.interface
->result
= c
->ts
.interface
;
7325 c
->ts
.interface
->ts
= ts
;
7326 c
->ts
.interface
->attr
.flavor
= FL_PROCEDURE
;
7327 c
->ts
.interface
->attr
.function
= 1;
7328 c
->attr
.function
= 1;
7329 c
->attr
.if_source
= IFSRC_UNKNOWN
;
7332 if (gfc_match (" =>") == MATCH_YES
)
7334 m
= match_pointer_init (&initializer
, 1);
7337 gfc_free_expr (initializer
);
7340 c
->initializer
= initializer
;
7343 if (gfc_match_eos () == MATCH_YES
)
7345 if (gfc_match_char (',') != MATCH_YES
)
7350 gfc_error ("Syntax error in procedure pointer component at %C");
7355 /* Match a PROCEDURE declaration inside an interface (R1206). */
7358 match_procedure_in_interface (void)
7362 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7365 if (current_interface
.type
== INTERFACE_NAMELESS
7366 || current_interface
.type
== INTERFACE_ABSTRACT
)
7368 gfc_error ("PROCEDURE at %C must be in a generic interface");
7372 /* Check if the F2008 optional double colon appears. */
7373 gfc_gobble_whitespace ();
7374 old_locus
= gfc_current_locus
;
7375 if (gfc_match ("::") == MATCH_YES
)
7377 if (!gfc_notify_std (GFC_STD_F2008
, "double colon in "
7378 "MODULE PROCEDURE statement at %L", &old_locus
))
7382 gfc_current_locus
= old_locus
;
7386 m
= gfc_match_name (name
);
7389 else if (m
== MATCH_ERROR
)
7391 if (gfc_get_symbol (name
, gfc_current_ns
->parent
, &sym
))
7394 if (!gfc_add_interface (sym
))
7397 if (gfc_match_eos () == MATCH_YES
)
7399 if (gfc_match_char (',') != MATCH_YES
)
7406 gfc_error ("Syntax error in PROCEDURE statement at %C");
7411 /* General matcher for PROCEDURE declarations. */
7413 static match
match_procedure_in_type (void);
7416 gfc_match_procedure (void)
7420 switch (gfc_current_state ())
7425 case COMP_SUBMODULE
:
7426 case COMP_SUBROUTINE
:
7429 m
= match_procedure_decl ();
7431 case COMP_INTERFACE
:
7432 m
= match_procedure_in_interface ();
7435 m
= match_ppc_decl ();
7437 case COMP_DERIVED_CONTAINS
:
7438 m
= match_procedure_in_type ();
7447 if (!gfc_notify_std (GFC_STD_F2003
, "PROCEDURE statement at %C"))
7454 /* Warn if a matched procedure has the same name as an intrinsic; this is
7455 simply a wrapper around gfc_warn_intrinsic_shadow that interprets the current
7456 parser-state-stack to find out whether we're in a module. */
7459 do_warn_intrinsic_shadow (const gfc_symbol
* sym
, bool func
)
7463 in_module
= (gfc_state_stack
->previous
7464 && (gfc_state_stack
->previous
->state
== COMP_MODULE
7465 || gfc_state_stack
->previous
->state
== COMP_SUBMODULE
));
7467 gfc_warn_intrinsic_shadow (sym
, in_module
, func
);
7471 /* Match a function declaration. */
7474 gfc_match_function_decl (void)
7476 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7477 gfc_symbol
*sym
, *result
;
7481 match found_match
; /* Status returned by match func. */
7483 if (gfc_current_state () != COMP_NONE
7484 && gfc_current_state () != COMP_INTERFACE
7485 && gfc_current_state () != COMP_CONTAINS
)
7488 gfc_clear_ts (¤t_ts
);
7490 old_loc
= gfc_current_locus
;
7492 m
= gfc_match_prefix (¤t_ts
);
7495 gfc_current_locus
= old_loc
;
7499 if (gfc_match ("function% %n", name
) != MATCH_YES
)
7501 gfc_current_locus
= old_loc
;
7505 if (get_proc_name (name
, &sym
, false))
7508 if (add_hidden_procptr_result (sym
))
7511 if (current_attr
.module_procedure
)
7512 sym
->attr
.module_procedure
= 1;
7514 gfc_new_block
= sym
;
7516 m
= gfc_match_formal_arglist (sym
, 0, 0);
7519 gfc_error ("Expected formal argument list in function "
7520 "definition at %C");
7524 else if (m
== MATCH_ERROR
)
7529 /* According to the draft, the bind(c) and result clause can
7530 come in either order after the formal_arg_list (i.e., either
7531 can be first, both can exist together or by themselves or neither
7532 one). Therefore, the match_result can't match the end of the
7533 string, and check for the bind(c) or result clause in either order. */
7534 found_match
= gfc_match_eos ();
7536 /* Make sure that it isn't already declared as BIND(C). If it is, it
7537 must have been marked BIND(C) with a BIND(C) attribute and that is
7538 not allowed for procedures. */
7539 if (sym
->attr
.is_bind_c
== 1)
7541 sym
->attr
.is_bind_c
= 0;
7543 if (gfc_state_stack
->previous
7544 && gfc_state_stack
->previous
->state
!= COMP_SUBMODULE
)
7547 loc
= sym
->old_symbol
!= NULL
7548 ? sym
->old_symbol
->declared_at
: gfc_current_locus
;
7549 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7550 "variables or common blocks", &loc
);
7554 if (found_match
!= MATCH_YES
)
7556 /* If we haven't found the end-of-statement, look for a suffix. */
7557 suffix_match
= gfc_match_suffix (sym
, &result
);
7558 if (suffix_match
== MATCH_YES
)
7559 /* Need to get the eos now. */
7560 found_match
= gfc_match_eos ();
7562 found_match
= suffix_match
;
7565 /* F2018 C1550 (R1526) If MODULE appears in the prefix of a module
7566 subprogram and a binding label is specified, it shall be the
7567 same as the binding label specified in the corresponding module
7568 procedure interface body. */
7569 if (sym
->attr
.is_bind_c
&& sym
->attr
.module_procedure
&& sym
->old_symbol
7570 && strcmp (sym
->name
, sym
->old_symbol
->name
) == 0
7571 && sym
->binding_label
&& sym
->old_symbol
->binding_label
7572 && strcmp (sym
->binding_label
, sym
->old_symbol
->binding_label
) != 0)
7574 const char *null
= "NULL", *s1
, *s2
;
7575 s1
= sym
->binding_label
;
7577 s2
= sym
->old_symbol
->binding_label
;
7579 gfc_error ("Mismatch in BIND(C) names (%qs/%qs) at %C", s1
, s2
);
7580 sym
->refs
++; /* Needed to avoid an ICE in gfc_release_symbol */
7584 if(found_match
!= MATCH_YES
)
7588 /* Make changes to the symbol. */
7591 if (!gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
7594 if (!gfc_missing_attr (&sym
->attr
, NULL
))
7597 if (!copy_prefix (&sym
->attr
, &sym
->declared_at
))
7599 if(!sym
->attr
.module_procedure
)
7605 /* Delay matching the function characteristics until after the
7606 specification block by signalling kind=-1. */
7607 sym
->declared_at
= old_loc
;
7608 if (current_ts
.type
!= BT_UNKNOWN
)
7609 current_ts
.kind
= -1;
7611 current_ts
.kind
= 0;
7615 if (current_ts
.type
!= BT_UNKNOWN
7616 && !gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
7622 if (current_ts
.type
!= BT_UNKNOWN
7623 && !gfc_add_type (result
, ¤t_ts
, &gfc_current_locus
))
7625 sym
->result
= result
;
7628 /* Warn if this procedure has the same name as an intrinsic. */
7629 do_warn_intrinsic_shadow (sym
, true);
7635 gfc_current_locus
= old_loc
;
7640 /* This is mostly a copy of parse.cc(add_global_procedure) but modified to
7641 pass the name of the entry, rather than the gfc_current_block name, and
7642 to return false upon finding an existing global entry. */
7645 add_global_entry (const char *name
, const char *binding_label
, bool sub
,
7649 enum gfc_symbol_type type
;
7651 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
7653 /* Only in Fortran 2003: For procedures with a binding label also the Fortran
7654 name is a global identifier. */
7655 if (!binding_label
|| gfc_notification_std (GFC_STD_F2008
))
7657 s
= gfc_get_gsymbol (name
, false);
7659 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= type
))
7661 gfc_global_used (s
, where
);
7670 s
->ns
= gfc_current_ns
;
7674 /* Don't add the symbol multiple times. */
7676 && (!gfc_notification_std (GFC_STD_F2008
)
7677 || strcmp (name
, binding_label
) != 0))
7679 s
= gfc_get_gsymbol (binding_label
, true);
7681 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= type
))
7683 gfc_global_used (s
, where
);
7690 s
->binding_label
= binding_label
;
7693 s
->ns
= gfc_current_ns
;
7701 /* Match an ENTRY statement. */
7704 gfc_match_entry (void)
7709 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7710 gfc_compile_state state
;
7714 bool module_procedure
;
7718 m
= gfc_match_name (name
);
7722 if (!gfc_notify_std (GFC_STD_F2008_OBS
, "ENTRY statement at %C"))
7725 state
= gfc_current_state ();
7726 if (state
!= COMP_SUBROUTINE
&& state
!= COMP_FUNCTION
)
7731 gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
7734 gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
7736 case COMP_SUBMODULE
:
7737 gfc_error ("ENTRY statement at %C cannot appear within a SUBMODULE");
7739 case COMP_BLOCK_DATA
:
7740 gfc_error ("ENTRY statement at %C cannot appear within "
7743 case COMP_INTERFACE
:
7744 gfc_error ("ENTRY statement at %C cannot appear within "
7747 case COMP_STRUCTURE
:
7748 gfc_error ("ENTRY statement at %C cannot appear within "
7749 "a STRUCTURE block");
7752 gfc_error ("ENTRY statement at %C cannot appear within "
7753 "a DERIVED TYPE block");
7756 gfc_error ("ENTRY statement at %C cannot appear within "
7757 "an IF-THEN block");
7760 case COMP_DO_CONCURRENT
:
7761 gfc_error ("ENTRY statement at %C cannot appear within "
7765 gfc_error ("ENTRY statement at %C cannot appear within "
7769 gfc_error ("ENTRY statement at %C cannot appear within "
7773 gfc_error ("ENTRY statement at %C cannot appear within "
7777 gfc_error ("ENTRY statement at %C cannot appear within "
7778 "a contained subprogram");
7781 gfc_error ("Unexpected ENTRY statement at %C");
7786 if ((state
== COMP_SUBROUTINE
|| state
== COMP_FUNCTION
)
7787 && gfc_state_stack
->previous
->state
== COMP_INTERFACE
)
7789 gfc_error ("ENTRY statement at %C cannot appear within an INTERFACE");
7793 module_procedure
= gfc_current_ns
->parent
!= NULL
7794 && gfc_current_ns
->parent
->proc_name
7795 && gfc_current_ns
->parent
->proc_name
->attr
.flavor
7798 if (gfc_current_ns
->parent
!= NULL
7799 && gfc_current_ns
->parent
->proc_name
7800 && !module_procedure
)
7802 gfc_error("ENTRY statement at %C cannot appear in a "
7803 "contained procedure");
7807 /* Module function entries need special care in get_proc_name
7808 because previous references within the function will have
7809 created symbols attached to the current namespace. */
7810 if (get_proc_name (name
, &entry
,
7811 gfc_current_ns
->parent
!= NULL
7812 && module_procedure
))
7815 proc
= gfc_current_block ();
7817 /* Make sure that it isn't already declared as BIND(C). If it is, it
7818 must have been marked BIND(C) with a BIND(C) attribute and that is
7819 not allowed for procedures. */
7820 if (entry
->attr
.is_bind_c
== 1)
7824 entry
->attr
.is_bind_c
= 0;
7826 loc
= entry
->old_symbol
!= NULL
7827 ? entry
->old_symbol
->declared_at
: gfc_current_locus
;
7828 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7829 "variables or common blocks", &loc
);
7832 /* Check what next non-whitespace character is so we can tell if there
7833 is the required parens if we have a BIND(C). */
7834 old_loc
= gfc_current_locus
;
7835 gfc_gobble_whitespace ();
7836 peek_char
= gfc_peek_ascii_char ();
7838 if (state
== COMP_SUBROUTINE
)
7840 m
= gfc_match_formal_arglist (entry
, 0, 1);
7844 /* Call gfc_match_bind_c with allow_binding_name = true as ENTRY can
7845 never be an internal procedure. */
7846 is_bind_c
= gfc_match_bind_c (entry
, true);
7847 if (is_bind_c
== MATCH_ERROR
)
7849 if (is_bind_c
== MATCH_YES
)
7851 if (peek_char
!= '(')
7853 gfc_error ("Missing required parentheses before BIND(C) at %C");
7857 if (!gfc_add_is_bind_c (&(entry
->attr
), entry
->name
,
7858 &(entry
->declared_at
), 1))
7863 if (!gfc_current_ns
->parent
7864 && !add_global_entry (name
, entry
->binding_label
, true,
7868 /* An entry in a subroutine. */
7869 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
7870 || !gfc_add_subroutine (&entry
->attr
, entry
->name
, NULL
))
7875 /* An entry in a function.
7876 We need to take special care because writing
7881 ENTRY f() RESULT (r)
7883 ENTRY f RESULT (r). */
7884 if (gfc_match_eos () == MATCH_YES
)
7886 gfc_current_locus
= old_loc
;
7887 /* Match the empty argument list, and add the interface to
7889 m
= gfc_match_formal_arglist (entry
, 0, 1);
7892 m
= gfc_match_formal_arglist (entry
, 0, 0);
7899 if (gfc_match_eos () == MATCH_YES
)
7901 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
7902 || !gfc_add_function (&entry
->attr
, entry
->name
, NULL
))
7905 entry
->result
= entry
;
7909 m
= gfc_match_suffix (entry
, &result
);
7911 gfc_syntax_error (ST_ENTRY
);
7917 if (!gfc_add_result (&result
->attr
, result
->name
, NULL
)
7918 || !gfc_add_entry (&entry
->attr
, result
->name
, NULL
)
7919 || !gfc_add_function (&entry
->attr
, result
->name
, NULL
))
7921 entry
->result
= result
;
7925 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
7926 || !gfc_add_function (&entry
->attr
, entry
->name
, NULL
))
7928 entry
->result
= entry
;
7932 if (!gfc_current_ns
->parent
7933 && !add_global_entry (name
, entry
->binding_label
, false,
7938 if (gfc_match_eos () != MATCH_YES
)
7940 gfc_syntax_error (ST_ENTRY
);
7944 /* F2018:C1546 An elemental procedure shall not have the BIND attribute. */
7945 if (proc
->attr
.elemental
&& entry
->attr
.is_bind_c
)
7947 gfc_error ("ENTRY statement at %L with BIND(C) prohibited in an "
7948 "elemental procedure", &entry
->declared_at
);
7952 entry
->attr
.recursive
= proc
->attr
.recursive
;
7953 entry
->attr
.elemental
= proc
->attr
.elemental
;
7954 entry
->attr
.pure
= proc
->attr
.pure
;
7956 el
= gfc_get_entry_list ();
7958 el
->next
= gfc_current_ns
->entries
;
7959 gfc_current_ns
->entries
= el
;
7961 el
->id
= el
->next
->id
+ 1;
7965 new_st
.op
= EXEC_ENTRY
;
7966 new_st
.ext
.entry
= el
;
7972 /* Match a subroutine statement, including optional prefixes. */
7975 gfc_match_subroutine (void)
7977 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7982 bool allow_binding_name
;
7985 if (gfc_current_state () != COMP_NONE
7986 && gfc_current_state () != COMP_INTERFACE
7987 && gfc_current_state () != COMP_CONTAINS
)
7990 m
= gfc_match_prefix (NULL
);
7994 m
= gfc_match ("subroutine% %n", name
);
7998 if (get_proc_name (name
, &sym
, false))
8001 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
8002 the symbol existed before. */
8003 sym
->declared_at
= gfc_current_locus
;
8005 if (current_attr
.module_procedure
)
8006 sym
->attr
.module_procedure
= 1;
8008 if (add_hidden_procptr_result (sym
))
8011 gfc_new_block
= sym
;
8013 /* Check what next non-whitespace character is so we can tell if there
8014 is the required parens if we have a BIND(C). */
8015 gfc_gobble_whitespace ();
8016 peek_char
= gfc_peek_ascii_char ();
8018 if (!gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
))
8021 if (gfc_match_formal_arglist (sym
, 0, 1) != MATCH_YES
)
8024 /* Make sure that it isn't already declared as BIND(C). If it is, it
8025 must have been marked BIND(C) with a BIND(C) attribute and that is
8026 not allowed for procedures. */
8027 if (sym
->attr
.is_bind_c
== 1)
8029 sym
->attr
.is_bind_c
= 0;
8031 if (gfc_state_stack
->previous
8032 && gfc_state_stack
->previous
->state
!= COMP_SUBMODULE
)
8035 loc
= sym
->old_symbol
!= NULL
8036 ? sym
->old_symbol
->declared_at
: gfc_current_locus
;
8037 gfc_error_now ("BIND(C) attribute at %L can only be used for "
8038 "variables or common blocks", &loc
);
8042 /* C binding names are not allowed for internal procedures. */
8043 if (gfc_current_state () == COMP_CONTAINS
8044 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
8045 allow_binding_name
= false;
8047 allow_binding_name
= true;
8049 /* Here, we are just checking if it has the bind(c) attribute, and if
8050 so, then we need to make sure it's all correct. If it doesn't,
8051 we still need to continue matching the rest of the subroutine line. */
8052 gfc_gobble_whitespace ();
8053 loc
= gfc_current_locus
;
8054 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
8055 if (is_bind_c
== MATCH_ERROR
)
8057 /* There was an attempt at the bind(c), but it was wrong. An
8058 error message should have been printed w/in the gfc_match_bind_c
8059 so here we'll just return the MATCH_ERROR. */
8063 if (is_bind_c
== MATCH_YES
)
8065 gfc_formal_arglist
*arg
;
8067 /* The following is allowed in the Fortran 2008 draft. */
8068 if (gfc_current_state () == COMP_CONTAINS
8069 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
8070 && !gfc_notify_std (GFC_STD_F2008
, "BIND(C) attribute "
8071 "at %L may not be specified for an internal "
8072 "procedure", &gfc_current_locus
))
8075 if (peek_char
!= '(')
8077 gfc_error ("Missing required parentheses before BIND(C) at %C");
8081 /* F2018 C1550 (R1526) If MODULE appears in the prefix of a module
8082 subprogram and a binding label is specified, it shall be the
8083 same as the binding label specified in the corresponding module
8084 procedure interface body. */
8085 if (sym
->attr
.module_procedure
&& sym
->old_symbol
8086 && strcmp (sym
->name
, sym
->old_symbol
->name
) == 0
8087 && sym
->binding_label
&& sym
->old_symbol
->binding_label
8088 && strcmp (sym
->binding_label
, sym
->old_symbol
->binding_label
) != 0)
8090 const char *null
= "NULL", *s1
, *s2
;
8091 s1
= sym
->binding_label
;
8093 s2
= sym
->old_symbol
->binding_label
;
8095 gfc_error ("Mismatch in BIND(C) names (%qs/%qs) at %C", s1
, s2
);
8096 sym
->refs
++; /* Needed to avoid an ICE in gfc_release_symbol */
8100 /* Scan the dummy arguments for an alternate return. */
8101 for (arg
= sym
->formal
; arg
; arg
= arg
->next
)
8104 gfc_error ("Alternate return dummy argument cannot appear in a "
8105 "SUBROUTINE with the BIND(C) attribute at %L", &loc
);
8109 if (!gfc_add_is_bind_c (&(sym
->attr
), sym
->name
, &(sym
->declared_at
), 1))
8113 if (gfc_match_eos () != MATCH_YES
)
8115 gfc_syntax_error (ST_SUBROUTINE
);
8119 if (!copy_prefix (&sym
->attr
, &sym
->declared_at
))
8121 if(!sym
->attr
.module_procedure
)
8127 /* Warn if it has the same name as an intrinsic. */
8128 do_warn_intrinsic_shadow (sym
, false);
8134 /* Check that the NAME identifier in a BIND attribute or statement
8135 is conform to C identifier rules. */
8138 check_bind_name_identifier (char **name
)
8140 char *n
= *name
, *p
;
8142 /* Remove leading spaces. */
8146 /* On an empty string, free memory and set name to NULL. */
8154 /* Remove trailing spaces. */
8155 p
= n
+ strlen(n
) - 1;
8159 /* Insert the identifier into the symbol table. */
8164 /* Now check that identifier is valid under C rules. */
8167 gfc_error ("Invalid C identifier in NAME= specifier at %C");
8172 if (!(ISALNUM (*p
) || *p
== '_' || *p
== '$'))
8174 gfc_error ("Invalid C identifier in NAME= specifier at %C");
8182 /* Match a BIND(C) specifier, with the optional 'name=' specifier if
8183 given, and set the binding label in either the given symbol (if not
8184 NULL), or in the current_ts. The symbol may be NULL because we may
8185 encounter the BIND(C) before the declaration itself. Return
8186 MATCH_NO if what we're looking at isn't a BIND(C) specifier,
8187 MATCH_ERROR if it is a BIND(C) clause but an error was encountered,
8188 or MATCH_YES if the specifier was correct and the binding label and
8189 bind(c) fields were set correctly for the given symbol or the
8190 current_ts. If allow_binding_name is false, no binding name may be
8194 gfc_match_bind_c (gfc_symbol
*sym
, bool allow_binding_name
)
8196 char *binding_label
= NULL
;
8199 /* Initialize the flag that specifies whether we encountered a NAME=
8200 specifier or not. */
8201 has_name_equals
= 0;
8203 /* This much we have to be able to match, in this order, if
8204 there is a bind(c) label. */
8205 if (gfc_match (" bind ( c ") != MATCH_YES
)
8208 /* Now see if there is a binding label, or if we've reached the
8209 end of the bind(c) attribute without one. */
8210 if (gfc_match_char (',') == MATCH_YES
)
8212 if (gfc_match (" name = ") != MATCH_YES
)
8214 gfc_error ("Syntax error in NAME= specifier for binding label "
8216 /* should give an error message here */
8220 has_name_equals
= 1;
8222 if (gfc_match_init_expr (&e
) != MATCH_YES
)
8228 if (!gfc_simplify_expr(e
, 0))
8230 gfc_error ("NAME= specifier at %C should be a constant expression");
8235 if (e
->expr_type
!= EXPR_CONSTANT
|| e
->ts
.type
!= BT_CHARACTER
8236 || e
->ts
.kind
!= gfc_default_character_kind
|| e
->rank
!= 0)
8238 gfc_error ("NAME= specifier at %C should be a scalar of "
8239 "default character kind");
8244 // Get a C string from the Fortran string constant
8245 binding_label
= gfc_widechar_to_char (e
->value
.character
.string
,
8246 e
->value
.character
.length
);
8249 // Check that it is valid (old gfc_match_name_C)
8250 if (check_bind_name_identifier (&binding_label
) != MATCH_YES
)
8254 /* Get the required right paren. */
8255 if (gfc_match_char (')') != MATCH_YES
)
8257 gfc_error ("Missing closing paren for binding label at %C");
8261 if (has_name_equals
&& !allow_binding_name
)
8263 gfc_error ("No binding name is allowed in BIND(C) at %C");
8267 if (has_name_equals
&& sym
!= NULL
&& sym
->attr
.dummy
)
8269 gfc_error ("For dummy procedure %s, no binding name is "
8270 "allowed in BIND(C) at %C", sym
->name
);
8275 /* Save the binding label to the symbol. If sym is null, we're
8276 probably matching the typespec attributes of a declaration and
8277 haven't gotten the name yet, and therefore, no symbol yet. */
8281 sym
->binding_label
= binding_label
;
8283 curr_binding_label
= binding_label
;
8285 else if (allow_binding_name
)
8287 /* No binding label, but if symbol isn't null, we
8288 can set the label for it here.
8289 If name="" or allow_binding_name is false, no C binding name is
8291 if (sym
!= NULL
&& sym
->name
!= NULL
&& has_name_equals
== 0)
8292 sym
->binding_label
= IDENTIFIER_POINTER (get_identifier (sym
->name
));
8295 if (has_name_equals
&& gfc_current_state () == COMP_INTERFACE
8296 && current_interface
.type
== INTERFACE_ABSTRACT
)
8298 gfc_error ("NAME not allowed on BIND(C) for ABSTRACT INTERFACE at %C");
8306 /* Return nonzero if we're currently compiling a contained procedure. */
8309 contained_procedure (void)
8311 gfc_state_data
*s
= gfc_state_stack
;
8313 if ((s
->state
== COMP_SUBROUTINE
|| s
->state
== COMP_FUNCTION
)
8314 && s
->previous
!= NULL
&& s
->previous
->state
== COMP_CONTAINS
)
8320 /* Set the kind of each enumerator. The kind is selected such that it is
8321 interoperable with the corresponding C enumeration type, making
8322 sure that -fshort-enums is honored. */
8327 enumerator_history
*current_history
= NULL
;
8331 if (max_enum
== NULL
|| enum_history
== NULL
)
8334 if (!flag_short_enums
)
8340 kind
= gfc_integer_kinds
[i
++].kind
;
8342 while (kind
< gfc_c_int_kind
8343 && gfc_check_integer_range (max_enum
->initializer
->value
.integer
,
8346 current_history
= enum_history
;
8347 while (current_history
!= NULL
)
8349 current_history
->sym
->ts
.kind
= kind
;
8350 current_history
= current_history
->next
;
8355 /* Match any of the various end-block statements. Returns the type of
8356 END to the caller. The END INTERFACE, END IF, END DO, END SELECT
8357 and END BLOCK statements cannot be replaced by a single END statement. */
8360 gfc_match_end (gfc_statement
*st
)
8362 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8363 gfc_compile_state state
;
8365 const char *block_name
;
8369 gfc_namespace
*parent_ns
, *ns
, *prev_ns
;
8370 gfc_namespace
**nsp
;
8371 bool abbreviated_modproc_decl
= false;
8372 bool got_matching_end
= false;
8374 old_loc
= gfc_current_locus
;
8375 if (gfc_match ("end") != MATCH_YES
)
8378 state
= gfc_current_state ();
8379 block_name
= gfc_current_block () == NULL
8380 ? NULL
: gfc_current_block ()->name
;
8384 case COMP_ASSOCIATE
:
8386 if (startswith (block_name
, "block@"))
8391 case COMP_DERIVED_CONTAINS
:
8392 state
= gfc_state_stack
->previous
->state
;
8393 block_name
= gfc_state_stack
->previous
->sym
== NULL
8394 ? NULL
: gfc_state_stack
->previous
->sym
->name
;
8395 abbreviated_modproc_decl
= gfc_state_stack
->previous
->sym
8396 && gfc_state_stack
->previous
->sym
->abr_modproc_decl
;
8403 if (!abbreviated_modproc_decl
)
8404 abbreviated_modproc_decl
= gfc_current_block ()
8405 && gfc_current_block ()->abr_modproc_decl
;
8411 *st
= ST_END_PROGRAM
;
8412 target
= " program";
8416 case COMP_SUBROUTINE
:
8417 *st
= ST_END_SUBROUTINE
;
8418 if (!abbreviated_modproc_decl
)
8419 target
= " subroutine";
8421 target
= " procedure";
8422 eos_ok
= !contained_procedure ();
8426 *st
= ST_END_FUNCTION
;
8427 if (!abbreviated_modproc_decl
)
8428 target
= " function";
8430 target
= " procedure";
8431 eos_ok
= !contained_procedure ();
8434 case COMP_BLOCK_DATA
:
8435 *st
= ST_END_BLOCK_DATA
;
8436 target
= " block data";
8441 *st
= ST_END_MODULE
;
8446 case COMP_SUBMODULE
:
8447 *st
= ST_END_SUBMODULE
;
8448 target
= " submodule";
8452 case COMP_INTERFACE
:
8453 *st
= ST_END_INTERFACE
;
8454 target
= " interface";
8470 case COMP_STRUCTURE
:
8471 *st
= ST_END_STRUCTURE
;
8472 target
= " structure";
8477 case COMP_DERIVED_CONTAINS
:
8483 case COMP_ASSOCIATE
:
8484 *st
= ST_END_ASSOCIATE
;
8485 target
= " associate";
8490 case COMP_OMP_STRICTLY_STRUCTURED_BLOCK
:
8503 case COMP_DO_CONCURRENT
:
8510 *st
= ST_END_CRITICAL
;
8511 target
= " critical";
8516 case COMP_SELECT_TYPE
:
8517 case COMP_SELECT_RANK
:
8518 *st
= ST_END_SELECT
;
8524 *st
= ST_END_FORALL
;
8539 last_initializer
= NULL
;
8541 gfc_free_enum_history ();
8545 gfc_error ("Unexpected END statement at %C");
8549 old_loc
= gfc_current_locus
;
8550 if (gfc_match_eos () == MATCH_YES
)
8552 if (!eos_ok
&& (*st
== ST_END_SUBROUTINE
|| *st
== ST_END_FUNCTION
))
8554 if (!gfc_notify_std (GFC_STD_F2008
, "END statement "
8555 "instead of %s statement at %L",
8556 abbreviated_modproc_decl
? "END PROCEDURE"
8557 : gfc_ascii_statement(*st
), &old_loc
))
8562 /* We would have required END [something]. */
8563 gfc_error ("%s statement expected at %L",
8564 gfc_ascii_statement (*st
), &old_loc
);
8571 /* Verify that we've got the sort of end-block that we're expecting. */
8572 if (gfc_match (target
) != MATCH_YES
)
8574 gfc_error ("Expecting %s statement at %L", abbreviated_modproc_decl
8575 ? "END PROCEDURE" : gfc_ascii_statement(*st
), &old_loc
);
8579 got_matching_end
= true;
8581 old_loc
= gfc_current_locus
;
8582 /* If we're at the end, make sure a block name wasn't required. */
8583 if (gfc_match_eos () == MATCH_YES
)
8586 if (*st
!= ST_ENDDO
&& *st
!= ST_ENDIF
&& *st
!= ST_END_SELECT
8587 && *st
!= ST_END_FORALL
&& *st
!= ST_END_WHERE
&& *st
!= ST_END_BLOCK
8588 && *st
!= ST_END_ASSOCIATE
&& *st
!= ST_END_CRITICAL
)
8594 gfc_error ("Expected block name of %qs in %s statement at %L",
8595 block_name
, gfc_ascii_statement (*st
), &old_loc
);
8600 /* END INTERFACE has a special handler for its several possible endings. */
8601 if (*st
== ST_END_INTERFACE
)
8602 return gfc_match_end_interface ();
8604 /* We haven't hit the end of statement, so what is left must be an
8606 m
= gfc_match_space ();
8608 m
= gfc_match_name (name
);
8611 gfc_error ("Expected terminating name at %C");
8615 if (block_name
== NULL
)
8618 /* We have to pick out the declared submodule name from the composite
8619 required by F2008:11.2.3 para 2, which ends in the declared name. */
8620 if (state
== COMP_SUBMODULE
)
8621 block_name
= strchr (block_name
, '.') + 1;
8623 if (strcmp (name
, block_name
) != 0 && strcmp (block_name
, "ppr@") != 0)
8625 gfc_error ("Expected label %qs for %s statement at %C", block_name
,
8626 gfc_ascii_statement (*st
));
8629 /* Procedure pointer as function result. */
8630 else if (strcmp (block_name
, "ppr@") == 0
8631 && strcmp (name
, gfc_current_block ()->ns
->proc_name
->name
) != 0)
8633 gfc_error ("Expected label %qs for %s statement at %C",
8634 gfc_current_block ()->ns
->proc_name
->name
,
8635 gfc_ascii_statement (*st
));
8639 if (gfc_match_eos () == MATCH_YES
)
8643 gfc_syntax_error (*st
);
8646 gfc_current_locus
= old_loc
;
8648 /* If we are missing an END BLOCK, we created a half-ready namespace.
8649 Remove it from the parent namespace's sibling list. */
8651 while (state
== COMP_BLOCK
&& !got_matching_end
)
8653 parent_ns
= gfc_current_ns
->parent
;
8655 nsp
= &(gfc_state_stack
->previous
->tail
->ext
.block
.ns
);
8661 if (ns
== gfc_current_ns
)
8663 if (prev_ns
== NULL
)
8666 prev_ns
->sibling
= ns
->sibling
;
8672 gfc_free_namespace (gfc_current_ns
);
8673 gfc_current_ns
= parent_ns
;
8674 gfc_state_stack
= gfc_state_stack
->previous
;
8675 state
= gfc_current_state ();
8683 /***************** Attribute declaration statements ****************/
8685 /* Set the attribute of a single variable. */
8690 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8693 /* Workaround -Wmaybe-uninitialized false positive during
8694 profiledbootstrap by initializing them. */
8695 gfc_symbol
*sym
= NULL
;
8701 m
= gfc_match_name (name
);
8705 if (find_special (name
, &sym
, false))
8708 if (!check_function_name (name
))
8714 var_locus
= gfc_current_locus
;
8716 /* Deal with possible array specification for certain attributes. */
8717 if (current_attr
.dimension
8718 || current_attr
.codimension
8719 || current_attr
.allocatable
8720 || current_attr
.pointer
8721 || current_attr
.target
)
8723 m
= gfc_match_array_spec (&as
, !current_attr
.codimension
,
8724 !current_attr
.dimension
8725 && !current_attr
.pointer
8726 && !current_attr
.target
);
8727 if (m
== MATCH_ERROR
)
8730 if (current_attr
.dimension
&& m
== MATCH_NO
)
8732 gfc_error ("Missing array specification at %L in DIMENSION "
8733 "statement", &var_locus
);
8738 if (current_attr
.dimension
&& sym
->value
)
8740 gfc_error ("Dimensions specified for %s at %L after its "
8741 "initialization", sym
->name
, &var_locus
);
8746 if (current_attr
.codimension
&& m
== MATCH_NO
)
8748 gfc_error ("Missing array specification at %L in CODIMENSION "
8749 "statement", &var_locus
);
8754 if ((current_attr
.allocatable
|| current_attr
.pointer
)
8755 && (m
== MATCH_YES
) && (as
->type
!= AS_DEFERRED
))
8757 gfc_error ("Array specification must be deferred at %L", &var_locus
);
8763 if (sym
->ts
.type
== BT_CLASS
8764 && sym
->ts
.u
.derived
8765 && sym
->ts
.u
.derived
->attr
.is_class
)
8767 sym
->attr
.pointer
= CLASS_DATA(sym
)->attr
.class_pointer
;
8768 sym
->attr
.allocatable
= CLASS_DATA(sym
)->attr
.allocatable
;
8769 sym
->attr
.dimension
= CLASS_DATA(sym
)->attr
.dimension
;
8770 sym
->attr
.codimension
= CLASS_DATA(sym
)->attr
.codimension
;
8771 if (CLASS_DATA (sym
)->as
)
8772 sym
->as
= gfc_copy_array_spec (CLASS_DATA (sym
)->as
);
8774 if (current_attr
.dimension
== 0 && current_attr
.codimension
== 0
8775 && !gfc_copy_attr (&sym
->attr
, ¤t_attr
, &var_locus
))
8780 if (!gfc_set_array_spec (sym
, as
, &var_locus
))
8786 if (sym
->attr
.cray_pointee
&& sym
->as
!= NULL
)
8788 /* Fix the array spec. */
8789 m
= gfc_mod_pointee_as (sym
->as
);
8790 if (m
== MATCH_ERROR
)
8794 if (!gfc_add_attribute (&sym
->attr
, &var_locus
))
8800 if ((current_attr
.external
|| current_attr
.intrinsic
)
8801 && sym
->attr
.flavor
!= FL_PROCEDURE
8802 && !gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, NULL
))
8808 if (sym
->ts
.type
== BT_CLASS
&& sym
->ts
.u
.derived
->attr
.is_class
8809 && !as
&& !current_attr
.pointer
&& !current_attr
.allocatable
8810 && !current_attr
.external
)
8812 sym
->attr
.pointer
= 0;
8813 sym
->attr
.allocatable
= 0;
8814 sym
->attr
.dimension
= 0;
8815 sym
->attr
.codimension
= 0;
8816 gfc_free_array_spec (sym
->as
);
8819 else if (sym
->ts
.type
== BT_CLASS
8820 && !gfc_build_class_symbol (&sym
->ts
, &sym
->attr
, &sym
->as
))
8826 add_hidden_procptr_result (sym
);
8831 gfc_free_array_spec (as
);
8836 /* Generic attribute declaration subroutine. Used for attributes that
8837 just have a list of names. */
8844 /* Gobble the optional double colon, by simply ignoring the result
8854 if (gfc_match_eos () == MATCH_YES
)
8860 if (gfc_match_char (',') != MATCH_YES
)
8862 gfc_error ("Unexpected character in variable list at %C");
8872 /* This routine matches Cray Pointer declarations of the form:
8873 pointer ( <pointer>, <pointee> )
8875 pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...
8876 The pointer, if already declared, should be an integer. Otherwise, we
8877 set it as BT_INTEGER with kind gfc_index_integer_kind. The pointee may
8878 be either a scalar, or an array declaration. No space is allocated for
8879 the pointee. For the statement
8880 pointer (ipt, ar(10))
8881 any subsequent uses of ar will be translated (in C-notation) as
8882 ar(i) => ((<type> *) ipt)(i)
8883 After gimplification, pointee variable will disappear in the code. */
8886 cray_pointer_decl (void)
8889 gfc_array_spec
*as
= NULL
;
8890 gfc_symbol
*cptr
; /* Pointer symbol. */
8891 gfc_symbol
*cpte
; /* Pointee symbol. */
8897 if (gfc_match_char ('(') != MATCH_YES
)
8899 gfc_error ("Expected %<(%> at %C");
8903 /* Match pointer. */
8904 var_locus
= gfc_current_locus
;
8905 gfc_clear_attr (¤t_attr
);
8906 gfc_add_cray_pointer (¤t_attr
, &var_locus
);
8907 current_ts
.type
= BT_INTEGER
;
8908 current_ts
.kind
= gfc_index_integer_kind
;
8910 m
= gfc_match_symbol (&cptr
, 0);
8913 gfc_error ("Expected variable name at %C");
8917 if (!gfc_add_cray_pointer (&cptr
->attr
, &var_locus
))
8920 gfc_set_sym_referenced (cptr
);
8922 if (cptr
->ts
.type
== BT_UNKNOWN
) /* Override the type, if necessary. */
8924 cptr
->ts
.type
= BT_INTEGER
;
8925 cptr
->ts
.kind
= gfc_index_integer_kind
;
8927 else if (cptr
->ts
.type
!= BT_INTEGER
)
8929 gfc_error ("Cray pointer at %C must be an integer");
8932 else if (cptr
->ts
.kind
< gfc_index_integer_kind
)
8933 gfc_warning (0, "Cray pointer at %C has %d bytes of precision;"
8934 " memory addresses require %d bytes",
8935 cptr
->ts
.kind
, gfc_index_integer_kind
);
8937 if (gfc_match_char (',') != MATCH_YES
)
8939 gfc_error ("Expected \",\" at %C");
8943 /* Match Pointee. */
8944 var_locus
= gfc_current_locus
;
8945 gfc_clear_attr (¤t_attr
);
8946 gfc_add_cray_pointee (¤t_attr
, &var_locus
);
8947 current_ts
.type
= BT_UNKNOWN
;
8948 current_ts
.kind
= 0;
8950 m
= gfc_match_symbol (&cpte
, 0);
8953 gfc_error ("Expected variable name at %C");
8957 /* Check for an optional array spec. */
8958 m
= gfc_match_array_spec (&as
, true, false);
8959 if (m
== MATCH_ERROR
)
8961 gfc_free_array_spec (as
);
8964 else if (m
== MATCH_NO
)
8966 gfc_free_array_spec (as
);
8970 if (!gfc_add_cray_pointee (&cpte
->attr
, &var_locus
))
8973 gfc_set_sym_referenced (cpte
);
8975 if (cpte
->as
== NULL
)
8977 if (!gfc_set_array_spec (cpte
, as
, &var_locus
))
8978 gfc_internal_error ("Cannot set Cray pointee array spec.");
8980 else if (as
!= NULL
)
8982 gfc_error ("Duplicate array spec for Cray pointee at %C");
8983 gfc_free_array_spec (as
);
8989 if (cpte
->as
!= NULL
)
8991 /* Fix array spec. */
8992 m
= gfc_mod_pointee_as (cpte
->as
);
8993 if (m
== MATCH_ERROR
)
8997 /* Point the Pointee at the Pointer. */
8998 cpte
->cp_pointer
= cptr
;
9000 if (gfc_match_char (')') != MATCH_YES
)
9002 gfc_error ("Expected \")\" at %C");
9005 m
= gfc_match_char (',');
9007 done
= true; /* Stop searching for more declarations. */
9011 if (m
== MATCH_ERROR
/* Failed when trying to find ',' above. */
9012 || gfc_match_eos () != MATCH_YES
)
9014 gfc_error ("Expected %<,%> or end of statement at %C");
9022 gfc_match_external (void)
9025 gfc_clear_attr (¤t_attr
);
9026 current_attr
.external
= 1;
9028 return attr_decl ();
9033 gfc_match_intent (void)
9037 /* This is not allowed within a BLOCK construct! */
9038 if (gfc_current_state () == COMP_BLOCK
)
9040 gfc_error ("INTENT is not allowed inside of BLOCK at %C");
9044 intent
= match_intent_spec ();
9045 if (intent
== INTENT_UNKNOWN
)
9048 gfc_clear_attr (¤t_attr
);
9049 current_attr
.intent
= intent
;
9051 return attr_decl ();
9056 gfc_match_intrinsic (void)
9059 gfc_clear_attr (¤t_attr
);
9060 current_attr
.intrinsic
= 1;
9062 return attr_decl ();
9067 gfc_match_optional (void)
9069 /* This is not allowed within a BLOCK construct! */
9070 if (gfc_current_state () == COMP_BLOCK
)
9072 gfc_error ("OPTIONAL is not allowed inside of BLOCK at %C");
9076 gfc_clear_attr (¤t_attr
);
9077 current_attr
.optional
= 1;
9079 return attr_decl ();
9084 gfc_match_pointer (void)
9086 gfc_gobble_whitespace ();
9087 if (gfc_peek_ascii_char () == '(')
9089 if (!flag_cray_pointer
)
9091 gfc_error ("Cray pointer declaration at %C requires "
9092 "%<-fcray-pointer%> flag");
9095 return cray_pointer_decl ();
9099 gfc_clear_attr (¤t_attr
);
9100 current_attr
.pointer
= 1;
9102 return attr_decl ();
9108 gfc_match_allocatable (void)
9110 gfc_clear_attr (¤t_attr
);
9111 current_attr
.allocatable
= 1;
9113 return attr_decl ();
9118 gfc_match_codimension (void)
9120 gfc_clear_attr (¤t_attr
);
9121 current_attr
.codimension
= 1;
9123 return attr_decl ();
9128 gfc_match_contiguous (void)
9130 if (!gfc_notify_std (GFC_STD_F2008
, "CONTIGUOUS statement at %C"))
9133 gfc_clear_attr (¤t_attr
);
9134 current_attr
.contiguous
= 1;
9136 return attr_decl ();
9141 gfc_match_dimension (void)
9143 gfc_clear_attr (¤t_attr
);
9144 current_attr
.dimension
= 1;
9146 return attr_decl ();
9151 gfc_match_target (void)
9153 gfc_clear_attr (¤t_attr
);
9154 current_attr
.target
= 1;
9156 return attr_decl ();
9160 /* Match the list of entities being specified in a PUBLIC or PRIVATE
9164 access_attr_decl (gfc_statement st
)
9166 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9167 interface_type type
;
9169 gfc_symbol
*sym
, *dt_sym
;
9170 gfc_intrinsic_op op
;
9172 gfc_access access
= (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
9174 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
9179 m
= gfc_match_generic_spec (&type
, name
, &op
);
9182 if (m
== MATCH_ERROR
)
9187 case INTERFACE_NAMELESS
:
9188 case INTERFACE_ABSTRACT
:
9191 case INTERFACE_GENERIC
:
9192 case INTERFACE_DTIO
:
9194 if (gfc_get_symbol (name
, NULL
, &sym
))
9197 if (type
== INTERFACE_DTIO
9198 && gfc_current_ns
->proc_name
9199 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
9200 && sym
->attr
.flavor
== FL_UNKNOWN
)
9201 sym
->attr
.flavor
= FL_PROCEDURE
;
9203 if (!gfc_add_access (&sym
->attr
, access
, sym
->name
, NULL
))
9206 if (sym
->attr
.generic
&& (dt_sym
= gfc_find_dt_in_generic (sym
))
9207 && !gfc_add_access (&dt_sym
->attr
, access
, sym
->name
, NULL
))
9212 case INTERFACE_INTRINSIC_OP
:
9213 if (gfc_current_ns
->operator_access
[op
] == ACCESS_UNKNOWN
)
9215 gfc_intrinsic_op other_op
;
9217 gfc_current_ns
->operator_access
[op
] = access
;
9219 /* Handle the case if there is another op with the same
9220 function, for INTRINSIC_EQ vs. INTRINSIC_EQ_OS and so on. */
9221 other_op
= gfc_equivalent_op (op
);
9223 if (other_op
!= INTRINSIC_NONE
)
9224 gfc_current_ns
->operator_access
[other_op
] = access
;
9228 gfc_error ("Access specification of the %s operator at %C has "
9229 "already been specified", gfc_op2string (op
));
9235 case INTERFACE_USER_OP
:
9236 uop
= gfc_get_uop (name
);
9238 if (uop
->access
== ACCESS_UNKNOWN
)
9240 uop
->access
= access
;
9244 gfc_error ("Access specification of the .%s. operator at %C "
9245 "has already been specified", uop
->name
);
9252 if (gfc_match_char (',') == MATCH_NO
)
9256 if (gfc_match_eos () != MATCH_YES
)
9261 gfc_syntax_error (st
);
9269 gfc_match_protected (void)
9275 /* PROTECTED has already been seen, but must be followed by whitespace
9277 c
= gfc_peek_ascii_char ();
9278 if (!gfc_is_whitespace (c
) && c
!= ':')
9281 if (!gfc_current_ns
->proc_name
9282 || gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
9284 gfc_error ("PROTECTED at %C only allowed in specification "
9285 "part of a module");
9292 if (!gfc_notify_std (GFC_STD_F2003
, "PROTECTED statement at %C"))
9295 /* PROTECTED has an entity-list. */
9296 if (gfc_match_eos () == MATCH_YES
)
9301 m
= gfc_match_symbol (&sym
, 0);
9305 if (!gfc_add_protected (&sym
->attr
, sym
->name
, &gfc_current_locus
))
9317 if (gfc_match_eos () == MATCH_YES
)
9319 if (gfc_match_char (',') != MATCH_YES
)
9326 gfc_error ("Syntax error in PROTECTED statement at %C");
9331 /* The PRIVATE statement is a bit weird in that it can be an attribute
9332 declaration, but also works as a standalone statement inside of a
9333 type declaration or a module. */
9336 gfc_match_private (gfc_statement
*st
)
9338 gfc_state_data
*prev
;
9340 if (gfc_match ("private") != MATCH_YES
)
9343 /* Try matching PRIVATE without an access-list. */
9344 if (gfc_match_eos () == MATCH_YES
)
9346 prev
= gfc_state_stack
->previous
;
9347 if (gfc_current_state () != COMP_MODULE
9348 && !(gfc_current_state () == COMP_DERIVED
9349 && prev
&& prev
->state
== COMP_MODULE
)
9350 && !(gfc_current_state () == COMP_DERIVED_CONTAINS
9351 && prev
->previous
&& prev
->previous
->state
== COMP_MODULE
))
9353 gfc_error ("PRIVATE statement at %C is only allowed in the "
9354 "specification part of a module");
9362 /* At this point in free-form source code, PRIVATE must be followed
9363 by whitespace or ::. */
9364 if (gfc_current_form
== FORM_FREE
)
9366 char c
= gfc_peek_ascii_char ();
9367 if (!gfc_is_whitespace (c
) && c
!= ':')
9371 prev
= gfc_state_stack
->previous
;
9372 if (gfc_current_state () != COMP_MODULE
9373 && !(gfc_current_state () == COMP_DERIVED
9374 && prev
&& prev
->state
== COMP_MODULE
)
9375 && !(gfc_current_state () == COMP_DERIVED_CONTAINS
9376 && prev
->previous
&& prev
->previous
->state
== COMP_MODULE
))
9378 gfc_error ("PRIVATE statement at %C is only allowed in the "
9379 "specification part of a module");
9384 return access_attr_decl (ST_PRIVATE
);
9389 gfc_match_public (gfc_statement
*st
)
9391 if (gfc_match ("public") != MATCH_YES
)
9394 /* Try matching PUBLIC without an access-list. */
9395 if (gfc_match_eos () == MATCH_YES
)
9397 if (gfc_current_state () != COMP_MODULE
)
9399 gfc_error ("PUBLIC statement at %C is only allowed in the "
9400 "specification part of a module");
9408 /* At this point in free-form source code, PUBLIC must be followed
9409 by whitespace or ::. */
9410 if (gfc_current_form
== FORM_FREE
)
9412 char c
= gfc_peek_ascii_char ();
9413 if (!gfc_is_whitespace (c
) && c
!= ':')
9417 if (gfc_current_state () != COMP_MODULE
)
9419 gfc_error ("PUBLIC statement at %C is only allowed in the "
9420 "specification part of a module");
9425 return access_attr_decl (ST_PUBLIC
);
9429 /* Workhorse for gfc_match_parameter. */
9439 m
= gfc_match_symbol (&sym
, 0);
9441 gfc_error ("Expected variable name at %C in PARAMETER statement");
9446 if (gfc_match_char ('=') == MATCH_NO
)
9448 gfc_error ("Expected = sign in PARAMETER statement at %C");
9452 m
= gfc_match_init_expr (&init
);
9454 gfc_error ("Expected expression at %C in PARAMETER statement");
9458 if (sym
->ts
.type
== BT_UNKNOWN
9459 && !gfc_set_default_type (sym
, 1, NULL
))
9465 if (!gfc_check_assign_symbol (sym
, NULL
, init
)
9466 || !gfc_add_flavor (&sym
->attr
, FL_PARAMETER
, sym
->name
, NULL
))
9474 gfc_error ("Initializing already initialized variable at %C");
9479 t
= add_init_expr_to_sym (sym
->name
, &init
, &gfc_current_locus
);
9480 return (t
) ? MATCH_YES
: MATCH_ERROR
;
9483 gfc_free_expr (init
);
9488 /* Match a parameter statement, with the weird syntax that these have. */
9491 gfc_match_parameter (void)
9493 const char *term
= " )%t";
9496 if (gfc_match_char ('(') == MATCH_NO
)
9498 /* With legacy PARAMETER statements, don't expect a terminating ')'. */
9499 if (!gfc_notify_std (GFC_STD_LEGACY
, "PARAMETER without '()' at %C"))
9510 if (gfc_match (term
) == MATCH_YES
)
9513 if (gfc_match_char (',') != MATCH_YES
)
9515 gfc_error ("Unexpected characters in PARAMETER statement at %C");
9526 gfc_match_automatic (void)
9530 bool seen_symbol
= false;
9532 if (!flag_dec_static
)
9534 gfc_error ("%s at %C is a DEC extension, enable with "
9545 m
= gfc_match_symbol (&sym
, 0);
9555 if (!gfc_add_automatic (&sym
->attr
, sym
->name
, &gfc_current_locus
))
9561 if (gfc_match_eos () == MATCH_YES
)
9563 if (gfc_match_char (',') != MATCH_YES
)
9569 gfc_error ("Expected entity-list in AUTOMATIC statement at %C");
9576 gfc_error ("Syntax error in AUTOMATIC statement at %C");
9582 gfc_match_static (void)
9586 bool seen_symbol
= false;
9588 if (!flag_dec_static
)
9590 gfc_error ("%s at %C is a DEC extension, enable with "
9600 m
= gfc_match_symbol (&sym
, 0);
9610 if (!gfc_add_save (&sym
->attr
, SAVE_EXPLICIT
, sym
->name
,
9611 &gfc_current_locus
))
9617 if (gfc_match_eos () == MATCH_YES
)
9619 if (gfc_match_char (',') != MATCH_YES
)
9625 gfc_error ("Expected entity-list in STATIC statement at %C");
9632 gfc_error ("Syntax error in STATIC statement at %C");
9637 /* Save statements have a special syntax. */
9640 gfc_match_save (void)
9642 char n
[GFC_MAX_SYMBOL_LEN
+1];
9647 if (gfc_match_eos () == MATCH_YES
)
9649 if (gfc_current_ns
->seen_save
)
9651 if (!gfc_notify_std (GFC_STD_LEGACY
, "Blanket SAVE statement at %C "
9652 "follows previous SAVE statement"))
9656 gfc_current_ns
->save_all
= gfc_current_ns
->seen_save
= 1;
9660 if (gfc_current_ns
->save_all
)
9662 if (!gfc_notify_std (GFC_STD_LEGACY
, "SAVE statement at %C follows "
9663 "blanket SAVE statement"))
9671 m
= gfc_match_symbol (&sym
, 0);
9675 if (!gfc_add_save (&sym
->attr
, SAVE_EXPLICIT
, sym
->name
,
9676 &gfc_current_locus
))
9687 m
= gfc_match (" / %n /", &n
);
9688 if (m
== MATCH_ERROR
)
9693 c
= gfc_get_common (n
, 0);
9696 gfc_current_ns
->seen_save
= 1;
9699 if (gfc_match_eos () == MATCH_YES
)
9701 if (gfc_match_char (',') != MATCH_YES
)
9708 if (gfc_current_ns
->seen_save
)
9710 gfc_error ("Syntax error in SAVE statement at %C");
9719 gfc_match_value (void)
9724 /* This is not allowed within a BLOCK construct! */
9725 if (gfc_current_state () == COMP_BLOCK
)
9727 gfc_error ("VALUE is not allowed inside of BLOCK at %C");
9731 if (!gfc_notify_std (GFC_STD_F2003
, "VALUE statement at %C"))
9734 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
9739 if (gfc_match_eos () == MATCH_YES
)
9744 m
= gfc_match_symbol (&sym
, 0);
9748 if (!gfc_add_value (&sym
->attr
, sym
->name
, &gfc_current_locus
))
9760 if (gfc_match_eos () == MATCH_YES
)
9762 if (gfc_match_char (',') != MATCH_YES
)
9769 gfc_error ("Syntax error in VALUE statement at %C");
9775 gfc_match_volatile (void)
9781 if (!gfc_notify_std (GFC_STD_F2003
, "VOLATILE statement at %C"))
9784 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
9789 if (gfc_match_eos () == MATCH_YES
)
9794 /* VOLATILE is special because it can be added to host-associated
9795 symbols locally. Except for coarrays. */
9796 m
= gfc_match_symbol (&sym
, 1);
9800 name
= XCNEWVAR (char, strlen (sym
->name
) + 1);
9801 strcpy (name
, sym
->name
);
9802 if (!check_function_name (name
))
9804 /* F2008, C560+C561. VOLATILE for host-/use-associated variable or
9805 for variable in a BLOCK which is defined outside of the BLOCK. */
9806 if (sym
->ns
!= gfc_current_ns
&& sym
->attr
.codimension
)
9808 gfc_error ("Specifying VOLATILE for coarray variable %qs at "
9809 "%C, which is use-/host-associated", sym
->name
);
9812 if (!gfc_add_volatile (&sym
->attr
, sym
->name
, &gfc_current_locus
))
9824 if (gfc_match_eos () == MATCH_YES
)
9826 if (gfc_match_char (',') != MATCH_YES
)
9833 gfc_error ("Syntax error in VOLATILE statement at %C");
9839 gfc_match_asynchronous (void)
9845 if (!gfc_notify_std (GFC_STD_F2003
, "ASYNCHRONOUS statement at %C"))
9848 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
9853 if (gfc_match_eos () == MATCH_YES
)
9858 /* ASYNCHRONOUS is special because it can be added to host-associated
9860 m
= gfc_match_symbol (&sym
, 1);
9864 name
= XCNEWVAR (char, strlen (sym
->name
) + 1);
9865 strcpy (name
, sym
->name
);
9866 if (!check_function_name (name
))
9868 if (!gfc_add_asynchronous (&sym
->attr
, sym
->name
, &gfc_current_locus
))
9880 if (gfc_match_eos () == MATCH_YES
)
9882 if (gfc_match_char (',') != MATCH_YES
)
9889 gfc_error ("Syntax error in ASYNCHRONOUS statement at %C");
9894 /* Match a module procedure statement in a submodule. */
9897 gfc_match_submod_proc (void)
9899 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9900 gfc_symbol
*sym
, *fsym
;
9902 gfc_formal_arglist
*formal
, *head
, *tail
;
9904 if (gfc_current_state () != COMP_CONTAINS
9905 || !(gfc_state_stack
->previous
9906 && (gfc_state_stack
->previous
->state
== COMP_SUBMODULE
9907 || gfc_state_stack
->previous
->state
== COMP_MODULE
)))
9910 m
= gfc_match (" module% procedure% %n", name
);
9914 if (!gfc_notify_std (GFC_STD_F2008
, "MODULE PROCEDURE declaration "
9918 if (get_proc_name (name
, &sym
, false))
9921 /* Make sure that the result field is appropriately filled. */
9922 if (sym
->tlink
&& sym
->tlink
->attr
.function
)
9924 if (sym
->tlink
->result
&& sym
->tlink
->result
!= sym
->tlink
)
9926 sym
->result
= sym
->tlink
->result
;
9927 if (!sym
->result
->attr
.use_assoc
)
9929 gfc_symtree
*st
= gfc_new_symtree (&gfc_current_ns
->sym_root
,
9931 st
->n
.sym
= sym
->result
;
9932 sym
->result
->refs
++;
9939 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
9940 the symbol existed before. */
9941 sym
->declared_at
= gfc_current_locus
;
9943 if (!sym
->attr
.module_procedure
)
9946 /* Signal match_end to expect "end procedure". */
9947 sym
->abr_modproc_decl
= 1;
9949 /* Change from IFSRC_IFBODY coming from the interface declaration. */
9950 sym
->attr
.if_source
= IFSRC_DECL
;
9952 gfc_new_block
= sym
;
9954 /* Make a new formal arglist with the symbols in the procedure
9957 for (formal
= sym
->formal
; formal
&& formal
->sym
; formal
= formal
->next
)
9959 if (formal
== sym
->formal
)
9960 head
= tail
= gfc_get_formal_arglist ();
9963 tail
->next
= gfc_get_formal_arglist ();
9967 if (gfc_copy_dummy_sym (&fsym
, formal
->sym
, 0))
9971 gfc_set_sym_referenced (fsym
);
9974 /* The dummy symbols get cleaned up, when the formal_namespace of the
9975 interface declaration is cleared. This allows us to add the
9976 explicit interface as is done for other type of procedure. */
9977 if (!gfc_add_explicit_interface (sym
, IFSRC_DECL
, head
,
9978 &gfc_current_locus
))
9981 if (gfc_match_eos () != MATCH_YES
)
9983 /* Unset st->n.sym. Note: in reject_statement (), the symbol changes are
9984 undone, such that the st->n.sym->formal points to the original symbol;
9985 if now this namespace is finalized, the formal namespace is freed,
9986 but it might be still needed in the parent namespace. */
9987 gfc_symtree
*st
= gfc_find_symtree (gfc_current_ns
->sym_root
, sym
->name
);
9989 gfc_free_symbol (sym
->tlink
);
9992 gfc_syntax_error (ST_MODULE_PROC
);
9999 gfc_free_formal_arglist (head
);
10000 return MATCH_ERROR
;
10004 /* Match a module procedure statement. Note that we have to modify
10005 symbols in the parent's namespace because the current one was there
10006 to receive symbols that are in an interface's formal argument list. */
10009 gfc_match_modproc (void)
10011 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10015 gfc_namespace
*module_ns
;
10016 gfc_interface
*old_interface_head
, *interface
;
10018 if (gfc_state_stack
->previous
== NULL
10019 || (gfc_state_stack
->state
!= COMP_INTERFACE
10020 && (gfc_state_stack
->state
!= COMP_CONTAINS
10021 || gfc_state_stack
->previous
->state
!= COMP_INTERFACE
))
10022 || current_interface
.type
== INTERFACE_NAMELESS
10023 || current_interface
.type
== INTERFACE_ABSTRACT
)
10025 gfc_error ("MODULE PROCEDURE at %C must be in a generic module "
10027 return MATCH_ERROR
;
10030 module_ns
= gfc_current_ns
->parent
;
10031 for (; module_ns
; module_ns
= module_ns
->parent
)
10032 if (module_ns
->proc_name
->attr
.flavor
== FL_MODULE
10033 || module_ns
->proc_name
->attr
.flavor
== FL_PROGRAM
10034 || (module_ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
10035 && !module_ns
->proc_name
->attr
.contained
))
10038 if (module_ns
== NULL
)
10039 return MATCH_ERROR
;
10041 /* Store the current state of the interface. We will need it if we
10042 end up with a syntax error and need to recover. */
10043 old_interface_head
= gfc_current_interface_head ();
10045 /* Check if the F2008 optional double colon appears. */
10046 gfc_gobble_whitespace ();
10047 old_locus
= gfc_current_locus
;
10048 if (gfc_match ("::") == MATCH_YES
)
10050 if (!gfc_notify_std (GFC_STD_F2008
, "double colon in "
10051 "MODULE PROCEDURE statement at %L", &old_locus
))
10052 return MATCH_ERROR
;
10055 gfc_current_locus
= old_locus
;
10060 old_locus
= gfc_current_locus
;
10062 m
= gfc_match_name (name
);
10065 if (m
!= MATCH_YES
)
10066 return MATCH_ERROR
;
10068 /* Check for syntax error before starting to add symbols to the
10069 current namespace. */
10070 if (gfc_match_eos () == MATCH_YES
)
10073 if (!last
&& gfc_match_char (',') != MATCH_YES
)
10076 /* Now we're sure the syntax is valid, we process this item
10078 if (gfc_get_symbol (name
, module_ns
, &sym
))
10079 return MATCH_ERROR
;
10081 if (sym
->attr
.intrinsic
)
10083 gfc_error ("Intrinsic procedure at %L cannot be a MODULE "
10084 "PROCEDURE", &old_locus
);
10085 return MATCH_ERROR
;
10088 if (sym
->attr
.proc
!= PROC_MODULE
10089 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
10090 return MATCH_ERROR
;
10092 if (!gfc_add_interface (sym
))
10093 return MATCH_ERROR
;
10095 sym
->attr
.mod_proc
= 1;
10096 sym
->declared_at
= old_locus
;
10105 /* Restore the previous state of the interface. */
10106 interface
= gfc_current_interface_head ();
10107 gfc_set_current_interface_head (old_interface_head
);
10109 /* Free the new interfaces. */
10110 while (interface
!= old_interface_head
)
10112 gfc_interface
*i
= interface
->next
;
10117 /* And issue a syntax error. */
10118 gfc_syntax_error (ST_MODULE_PROC
);
10119 return MATCH_ERROR
;
10123 /* Check a derived type that is being extended. */
10126 check_extended_derived_type (char *name
)
10128 gfc_symbol
*extended
;
10130 if (gfc_find_symbol (name
, gfc_current_ns
, 1, &extended
))
10132 gfc_error ("Ambiguous symbol in TYPE definition at %C");
10136 extended
= gfc_find_dt_in_generic (extended
);
10141 gfc_error ("Symbol %qs at %C has not been previously defined", name
);
10145 if (extended
->attr
.flavor
!= FL_DERIVED
)
10147 gfc_error ("%qs in EXTENDS expression at %C is not a "
10148 "derived type", name
);
10152 if (extended
->attr
.is_bind_c
)
10154 gfc_error ("%qs cannot be extended at %C because it "
10155 "is BIND(C)", extended
->name
);
10159 if (extended
->attr
.sequence
)
10161 gfc_error ("%qs cannot be extended at %C because it "
10162 "is a SEQUENCE type", extended
->name
);
10170 /* Match the optional attribute specifiers for a type declaration.
10171 Return MATCH_ERROR if an error is encountered in one of the handled
10172 attributes (public, private, bind(c)), MATCH_NO if what's found is
10173 not a handled attribute, and MATCH_YES otherwise. TODO: More error
10174 checking on attribute conflicts needs to be done. */
10177 gfc_get_type_attr_spec (symbol_attribute
*attr
, char *name
)
10179 /* See if the derived type is marked as private. */
10180 if (gfc_match (" , private") == MATCH_YES
)
10182 if (gfc_current_state () != COMP_MODULE
)
10184 gfc_error ("Derived type at %C can only be PRIVATE in the "
10185 "specification part of a module");
10186 return MATCH_ERROR
;
10189 if (!gfc_add_access (attr
, ACCESS_PRIVATE
, NULL
, NULL
))
10190 return MATCH_ERROR
;
10192 else if (gfc_match (" , public") == MATCH_YES
)
10194 if (gfc_current_state () != COMP_MODULE
)
10196 gfc_error ("Derived type at %C can only be PUBLIC in the "
10197 "specification part of a module");
10198 return MATCH_ERROR
;
10201 if (!gfc_add_access (attr
, ACCESS_PUBLIC
, NULL
, NULL
))
10202 return MATCH_ERROR
;
10204 else if (gfc_match (" , bind ( c )") == MATCH_YES
)
10206 /* If the type is defined to be bind(c) it then needs to make
10207 sure that all fields are interoperable. This will
10208 need to be a semantic check on the finished derived type.
10209 See 15.2.3 (lines 9-12) of F2003 draft. */
10210 if (!gfc_add_is_bind_c (attr
, NULL
, &gfc_current_locus
, 0))
10211 return MATCH_ERROR
;
10213 /* TODO: attr conflicts need to be checked, probably in symbol.cc. */
10215 else if (gfc_match (" , abstract") == MATCH_YES
)
10217 if (!gfc_notify_std (GFC_STD_F2003
, "ABSTRACT type at %C"))
10218 return MATCH_ERROR
;
10220 if (!gfc_add_abstract (attr
, &gfc_current_locus
))
10221 return MATCH_ERROR
;
10223 else if (name
&& gfc_match (" , extends ( %n )", name
) == MATCH_YES
)
10225 if (!gfc_add_extension (attr
, &gfc_current_locus
))
10226 return MATCH_ERROR
;
10231 /* If we get here, something matched. */
10236 /* Common function for type declaration blocks similar to derived types, such
10237 as STRUCTURES and MAPs. Unlike derived types, a structure type
10238 does NOT have a generic symbol matching the name given by the user.
10239 STRUCTUREs can share names with variables and PARAMETERs so we must allow
10240 for the creation of an independent symbol.
10241 Other parameters are a message to prefix errors with, the name of the new
10242 type to be created, and the flavor to add to the resulting symbol. */
10245 get_struct_decl (const char *name
, sym_flavor fl
, locus
*decl
,
10246 gfc_symbol
**result
)
10251 gcc_assert (name
[0] == (char) TOUPPER (name
[0]));
10256 where
= gfc_current_locus
;
10258 if (gfc_get_symbol (name
, NULL
, &sym
))
10263 gfc_internal_error ("Failed to create structure type '%s' at %C", name
);
10267 if (sym
->components
!= NULL
|| sym
->attr
.zero_comp
)
10269 gfc_error ("Type definition of %qs at %C was already defined at %L",
10270 sym
->name
, &sym
->declared_at
);
10274 sym
->declared_at
= where
;
10276 if (sym
->attr
.flavor
!= fl
10277 && !gfc_add_flavor (&sym
->attr
, fl
, sym
->name
, NULL
))
10280 if (!sym
->hash_value
)
10281 /* Set the hash for the compound name for this type. */
10282 sym
->hash_value
= gfc_hash_value (sym
);
10284 /* Normally the type is expected to have been completely parsed by the time
10285 a field declaration with this type is seen. For unions, maps, and nested
10286 structure declarations, we need to indicate that it is okay that we
10287 haven't seen any components yet. This will be updated after the structure
10288 is fully parsed. */
10289 sym
->attr
.zero_comp
= 0;
10291 /* Structures always act like derived-types with the SEQUENCE attribute */
10292 gfc_add_sequence (&sym
->attr
, sym
->name
, NULL
);
10294 if (result
) *result
= sym
;
10300 /* Match the opening of a MAP block. Like a struct within a union in C;
10301 behaves identical to STRUCTURE blocks. */
10304 gfc_match_map (void)
10306 /* Counter used to give unique internal names to map structures. */
10307 static unsigned int gfc_map_id
= 0;
10308 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10312 old_loc
= gfc_current_locus
;
10314 if (gfc_match_eos () != MATCH_YES
)
10316 gfc_error ("Junk after MAP statement at %C");
10317 gfc_current_locus
= old_loc
;
10318 return MATCH_ERROR
;
10321 /* Map blocks are anonymous so we make up unique names for the symbol table
10322 which are invalid Fortran identifiers. */
10323 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "MM$%u", gfc_map_id
++);
10325 if (!get_struct_decl (name
, FL_STRUCT
, &old_loc
, &sym
))
10326 return MATCH_ERROR
;
10328 gfc_new_block
= sym
;
10334 /* Match the opening of a UNION block. */
10337 gfc_match_union (void)
10339 /* Counter used to give unique internal names to union types. */
10340 static unsigned int gfc_union_id
= 0;
10341 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10345 old_loc
= gfc_current_locus
;
10347 if (gfc_match_eos () != MATCH_YES
)
10349 gfc_error ("Junk after UNION statement at %C");
10350 gfc_current_locus
= old_loc
;
10351 return MATCH_ERROR
;
10354 /* Unions are anonymous so we make up unique names for the symbol table
10355 which are invalid Fortran identifiers. */
10356 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "UU$%u", gfc_union_id
++);
10358 if (!get_struct_decl (name
, FL_UNION
, &old_loc
, &sym
))
10359 return MATCH_ERROR
;
10361 gfc_new_block
= sym
;
10367 /* Match the beginning of a STRUCTURE declaration. This is similar to
10368 matching the beginning of a derived type declaration with a few
10369 twists. The resulting type symbol has no access control or other
10370 interesting attributes. */
10373 gfc_match_structure_decl (void)
10375 /* Counter used to give unique internal names to anonymous structures. */
10376 static unsigned int gfc_structure_id
= 0;
10377 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10382 if (!flag_dec_structure
)
10384 gfc_error ("%s at %C is a DEC extension, enable with "
10385 "%<-fdec-structure%>",
10387 return MATCH_ERROR
;
10392 m
= gfc_match (" /%n/", name
);
10393 if (m
!= MATCH_YES
)
10395 /* Non-nested structure declarations require a structure name. */
10396 if (!gfc_comp_struct (gfc_current_state ()))
10398 gfc_error ("Structure name expected in non-nested structure "
10399 "declaration at %C");
10400 return MATCH_ERROR
;
10402 /* This is an anonymous structure; make up a unique name for it
10403 (upper-case letters never make it to symbol names from the source).
10404 The important thing is initializing the type variable
10405 and setting gfc_new_symbol, which is immediately used by
10406 parse_structure () and variable_decl () to add components of
10408 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "SS$%u", gfc_structure_id
++);
10411 where
= gfc_current_locus
;
10412 /* No field list allowed after non-nested structure declaration. */
10413 if (!gfc_comp_struct (gfc_current_state ())
10414 && gfc_match_eos () != MATCH_YES
)
10416 gfc_error ("Junk after non-nested STRUCTURE statement at %C");
10417 return MATCH_ERROR
;
10420 /* Make sure the name is not the name of an intrinsic type. */
10421 if (gfc_is_intrinsic_typename (name
))
10423 gfc_error ("Structure name %qs at %C cannot be the same as an"
10424 " intrinsic type", name
);
10425 return MATCH_ERROR
;
10428 /* Store the actual type symbol for the structure with an upper-case first
10429 letter (an invalid Fortran identifier). */
10431 if (!get_struct_decl (gfc_dt_upper_string (name
), FL_STRUCT
, &where
, &sym
))
10432 return MATCH_ERROR
;
10434 gfc_new_block
= sym
;
10439 /* This function does some work to determine which matcher should be used to
10440 * match a statement beginning with "TYPE". This is used to disambiguate TYPE
10441 * as an alias for PRINT from derived type declarations, TYPE IS statements,
10442 * and [parameterized] derived type declarations. */
10445 gfc_match_type (gfc_statement
*st
)
10447 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10451 /* Requires -fdec. */
10455 m
= gfc_match ("type");
10456 if (m
!= MATCH_YES
)
10458 /* If we already have an error in the buffer, it is probably from failing to
10459 * match a derived type data declaration. Let it happen. */
10460 else if (gfc_error_flag_test ())
10463 old_loc
= gfc_current_locus
;
10466 /* If we see an attribute list before anything else it's definitely a derived
10467 * type declaration. */
10468 if (gfc_match (" ,") == MATCH_YES
|| gfc_match (" ::") == MATCH_YES
)
10471 /* By now "TYPE" has already been matched. If we do not see a name, this may
10472 * be something like "TYPE *" or "TYPE <fmt>". */
10473 m
= gfc_match_name (name
);
10474 if (m
!= MATCH_YES
)
10476 /* Let print match if it can, otherwise throw an error from
10477 * gfc_match_derived_decl. */
10478 gfc_current_locus
= old_loc
;
10479 if (gfc_match_print () == MATCH_YES
)
10487 /* Check for EOS. */
10488 if (gfc_match_eos () == MATCH_YES
)
10490 /* By now we have "TYPE <name> <EOS>". Check first if the name is an
10491 * intrinsic typename - if so let gfc_match_derived_decl dump an error.
10492 * Otherwise if gfc_match_derived_decl fails it's probably an existing
10493 * symbol which can be printed. */
10494 gfc_current_locus
= old_loc
;
10495 m
= gfc_match_derived_decl ();
10496 if (gfc_is_intrinsic_typename (name
) || m
== MATCH_YES
)
10498 *st
= ST_DERIVED_DECL
;
10504 /* Here we have "TYPE <name>". Check for <TYPE IS (> or a PDT declaration
10505 like <type name(parameter)>. */
10506 gfc_gobble_whitespace ();
10507 bool paren
= gfc_peek_ascii_char () == '(';
10510 if (strcmp ("is", name
) == 0)
10517 /* Treat TYPE... like PRINT... */
10518 gfc_current_locus
= old_loc
;
10520 return gfc_match_print ();
10523 gfc_current_locus
= old_loc
;
10524 *st
= ST_DERIVED_DECL
;
10525 return gfc_match_derived_decl ();
10528 gfc_current_locus
= old_loc
;
10530 return gfc_match_type_is ();
10534 /* Match the beginning of a derived type declaration. If a type name
10535 was the result of a function, then it is possible to have a symbol
10536 already to be known as a derived type yet have no components. */
10539 gfc_match_derived_decl (void)
10541 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10542 char parent
[GFC_MAX_SYMBOL_LEN
+ 1];
10543 symbol_attribute attr
;
10544 gfc_symbol
*sym
, *gensym
;
10545 gfc_symbol
*extended
;
10547 match is_type_attr_spec
= MATCH_NO
;
10548 bool seen_attr
= false;
10549 gfc_interface
*intr
= NULL
, *head
;
10550 bool parameterized_type
= false;
10551 bool seen_colons
= false;
10553 if (gfc_comp_struct (gfc_current_state ()))
10558 gfc_clear_attr (&attr
);
10563 is_type_attr_spec
= gfc_get_type_attr_spec (&attr
, parent
);
10564 if (is_type_attr_spec
== MATCH_ERROR
)
10565 return MATCH_ERROR
;
10566 if (is_type_attr_spec
== MATCH_YES
)
10568 } while (is_type_attr_spec
== MATCH_YES
);
10570 /* Deal with derived type extensions. The extension attribute has
10571 been added to 'attr' but now the parent type must be found and
10574 extended
= check_extended_derived_type (parent
);
10576 if (parent
[0] && !extended
)
10577 return MATCH_ERROR
;
10579 m
= gfc_match (" ::");
10580 if (m
== MATCH_YES
)
10582 seen_colons
= true;
10584 else if (seen_attr
)
10586 gfc_error ("Expected :: in TYPE definition at %C");
10587 return MATCH_ERROR
;
10590 /* In free source form, need to check for TYPE XXX as oppose to TYPEXXX.
10591 But, we need to simply return for TYPE(. */
10592 if (m
== MATCH_NO
&& gfc_current_form
== FORM_FREE
)
10594 char c
= gfc_peek_ascii_char ();
10597 if (!gfc_is_whitespace (c
))
10599 gfc_error ("Mangled derived type definition at %C");
10604 m
= gfc_match (" %n ", name
);
10605 if (m
!= MATCH_YES
)
10608 /* Make sure that we don't identify TYPE IS (...) as a parameterized
10609 derived type named 'is'.
10610 TODO Expand the check, when 'name' = "is" by matching " (tname) "
10611 and checking if this is a(n intrinsic) typename. This picks up
10612 misplaced TYPE IS statements such as in select_type_1.f03. */
10613 if (gfc_peek_ascii_char () == '(')
10615 if (gfc_current_state () == COMP_SELECT_TYPE
10616 || (!seen_colons
&& !strcmp (name
, "is")))
10618 parameterized_type
= true;
10621 m
= gfc_match_eos ();
10622 if (m
!= MATCH_YES
&& !parameterized_type
)
10625 /* Make sure the name is not the name of an intrinsic type. */
10626 if (gfc_is_intrinsic_typename (name
))
10628 gfc_error ("Type name %qs at %C cannot be the same as an intrinsic "
10630 return MATCH_ERROR
;
10633 if (gfc_get_symbol (name
, NULL
, &gensym
))
10634 return MATCH_ERROR
;
10636 if (!gensym
->attr
.generic
&& gensym
->ts
.type
!= BT_UNKNOWN
)
10638 if (gensym
->ts
.u
.derived
)
10639 gfc_error ("Derived type name %qs at %C already has a basic type "
10640 "of %s", gensym
->name
, gfc_typename (&gensym
->ts
));
10642 gfc_error ("Derived type name %qs at %C already has a basic type",
10644 return MATCH_ERROR
;
10647 if (!gensym
->attr
.generic
10648 && !gfc_add_generic (&gensym
->attr
, gensym
->name
, NULL
))
10649 return MATCH_ERROR
;
10651 if (!gensym
->attr
.function
10652 && !gfc_add_function (&gensym
->attr
, gensym
->name
, NULL
))
10653 return MATCH_ERROR
;
10655 if (gensym
->attr
.dummy
)
10657 gfc_error ("Dummy argument %qs at %L cannot be a derived type at %C",
10658 name
, &gensym
->declared_at
);
10659 return MATCH_ERROR
;
10662 sym
= gfc_find_dt_in_generic (gensym
);
10664 if (sym
&& (sym
->components
!= NULL
|| sym
->attr
.zero_comp
))
10666 gfc_error ("Derived type definition of %qs at %C has already been "
10667 "defined", sym
->name
);
10668 return MATCH_ERROR
;
10673 /* Use upper case to save the actual derived-type symbol. */
10674 gfc_get_symbol (gfc_dt_upper_string (gensym
->name
), NULL
, &sym
);
10675 sym
->name
= gfc_get_string ("%s", gensym
->name
);
10676 head
= gensym
->generic
;
10677 intr
= gfc_get_interface ();
10679 intr
->where
= gfc_current_locus
;
10680 intr
->sym
->declared_at
= gfc_current_locus
;
10682 gensym
->generic
= intr
;
10683 gensym
->attr
.if_source
= IFSRC_DECL
;
10686 /* The symbol may already have the derived attribute without the
10687 components. The ways this can happen is via a function
10688 definition, an INTRINSIC statement or a subtype in another
10689 derived type that is a pointer. The first part of the AND clause
10690 is true if the symbol is not the return value of a function. */
10691 if (sym
->attr
.flavor
!= FL_DERIVED
10692 && !gfc_add_flavor (&sym
->attr
, FL_DERIVED
, sym
->name
, NULL
))
10693 return MATCH_ERROR
;
10695 if (attr
.access
!= ACCESS_UNKNOWN
10696 && !gfc_add_access (&sym
->attr
, attr
.access
, sym
->name
, NULL
))
10697 return MATCH_ERROR
;
10698 else if (sym
->attr
.access
== ACCESS_UNKNOWN
10699 && gensym
->attr
.access
!= ACCESS_UNKNOWN
10700 && !gfc_add_access (&sym
->attr
, gensym
->attr
.access
,
10702 return MATCH_ERROR
;
10704 if (sym
->attr
.access
!= ACCESS_UNKNOWN
10705 && gensym
->attr
.access
== ACCESS_UNKNOWN
)
10706 gensym
->attr
.access
= sym
->attr
.access
;
10708 /* See if the derived type was labeled as bind(c). */
10709 if (attr
.is_bind_c
!= 0)
10710 sym
->attr
.is_bind_c
= attr
.is_bind_c
;
10712 /* Construct the f2k_derived namespace if it is not yet there. */
10713 if (!sym
->f2k_derived
)
10714 sym
->f2k_derived
= gfc_get_namespace (NULL
, 0);
10716 if (parameterized_type
)
10718 /* Ignore error or mismatches by going to the end of the statement
10719 in order to avoid the component declarations causing problems. */
10720 m
= gfc_match_formal_arglist (sym
, 0, 0, true);
10721 if (m
!= MATCH_YES
)
10722 gfc_error_recovery ();
10724 sym
->attr
.pdt_template
= 1;
10725 m
= gfc_match_eos ();
10726 if (m
!= MATCH_YES
)
10728 gfc_error_recovery ();
10729 gfc_error_now ("Garbage after PARAMETERIZED TYPE declaration at %C");
10733 if (extended
&& !sym
->components
)
10736 gfc_formal_arglist
*f
, *g
, *h
;
10738 /* Add the extended derived type as the first component. */
10739 gfc_add_component (sym
, parent
, &p
);
10741 gfc_set_sym_referenced (extended
);
10743 p
->ts
.type
= BT_DERIVED
;
10744 p
->ts
.u
.derived
= extended
;
10745 p
->initializer
= gfc_default_initializer (&p
->ts
);
10747 /* Set extension level. */
10748 if (extended
->attr
.extension
== 255)
10750 /* Since the extension field is 8 bit wide, we can only have
10751 up to 255 extension levels. */
10752 gfc_error ("Maximum extension level reached with type %qs at %L",
10753 extended
->name
, &extended
->declared_at
);
10754 return MATCH_ERROR
;
10756 sym
->attr
.extension
= extended
->attr
.extension
+ 1;
10758 /* Provide the links between the extended type and its extension. */
10759 if (!extended
->f2k_derived
)
10760 extended
->f2k_derived
= gfc_get_namespace (NULL
, 0);
10762 /* Copy the extended type-param-name-list from the extended type,
10763 append those of the extension and add the whole lot to the
10765 if (extended
->attr
.pdt_template
)
10768 sym
->attr
.pdt_template
= 1;
10769 for (f
= extended
->formal
; f
; f
= f
->next
)
10771 if (f
== extended
->formal
)
10773 g
= gfc_get_formal_arglist ();
10778 g
->next
= gfc_get_formal_arglist ();
10783 g
->next
= sym
->formal
;
10788 if (!sym
->hash_value
)
10789 /* Set the hash for the compound name for this type. */
10790 sym
->hash_value
= gfc_hash_value (sym
);
10792 /* Take over the ABSTRACT attribute. */
10793 sym
->attr
.abstract
= attr
.abstract
;
10795 gfc_new_block
= sym
;
10801 /* Cray Pointees can be declared as:
10802 pointer (ipt, a (n,m,...,*)) */
10805 gfc_mod_pointee_as (gfc_array_spec
*as
)
10807 as
->cray_pointee
= true; /* This will be useful to know later. */
10808 if (as
->type
== AS_ASSUMED_SIZE
)
10809 as
->cp_was_assumed
= true;
10810 else if (as
->type
== AS_ASSUMED_SHAPE
)
10812 gfc_error ("Cray Pointee at %C cannot be assumed shape array");
10813 return MATCH_ERROR
;
10819 /* Match the enum definition statement, here we are trying to match
10820 the first line of enum definition statement.
10821 Returns MATCH_YES if match is found. */
10824 gfc_match_enum (void)
10828 m
= gfc_match_eos ();
10829 if (m
!= MATCH_YES
)
10832 if (!gfc_notify_std (GFC_STD_F2003
, "ENUM and ENUMERATOR at %C"))
10833 return MATCH_ERROR
;
10839 /* Returns an initializer whose value is one higher than the value of the
10840 LAST_INITIALIZER argument. If the argument is NULL, the
10841 initializers value will be set to zero. The initializer's kind
10842 will be set to gfc_c_int_kind.
10844 If -fshort-enums is given, the appropriate kind will be selected
10845 later after all enumerators have been parsed. A warning is issued
10846 here if an initializer exceeds gfc_c_int_kind. */
10849 enum_initializer (gfc_expr
*last_initializer
, locus where
)
10852 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_c_int_kind
, &where
);
10854 mpz_init (result
->value
.integer
);
10856 if (last_initializer
!= NULL
)
10858 mpz_add_ui (result
->value
.integer
, last_initializer
->value
.integer
, 1);
10859 result
->where
= last_initializer
->where
;
10861 if (gfc_check_integer_range (result
->value
.integer
,
10862 gfc_c_int_kind
) != ARITH_OK
)
10864 gfc_error ("Enumerator exceeds the C integer type at %C");
10870 /* Control comes here, if it's the very first enumerator and no
10871 initializer has been given. It will be initialized to zero. */
10872 mpz_set_si (result
->value
.integer
, 0);
10879 /* Match a variable name with an optional initializer. When this
10880 subroutine is called, a variable is expected to be parsed next.
10881 Depending on what is happening at the moment, updates either the
10882 symbol table or the current interface. */
10885 enumerator_decl (void)
10887 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10888 gfc_expr
*initializer
;
10889 gfc_array_spec
*as
= NULL
;
10896 initializer
= NULL
;
10897 old_locus
= gfc_current_locus
;
10899 /* When we get here, we've just matched a list of attributes and
10900 maybe a type and a double colon. The next thing we expect to see
10901 is the name of the symbol. */
10902 m
= gfc_match_name (name
);
10903 if (m
!= MATCH_YES
)
10906 var_locus
= gfc_current_locus
;
10908 /* OK, we've successfully matched the declaration. Now put the
10909 symbol in the current namespace. If we fail to create the symbol,
10911 if (!build_sym (name
, NULL
, false, &as
, &var_locus
))
10917 /* The double colon must be present in order to have initializers.
10918 Otherwise the statement is ambiguous with an assignment statement. */
10921 if (gfc_match_char ('=') == MATCH_YES
)
10923 m
= gfc_match_init_expr (&initializer
);
10926 gfc_error ("Expected an initialization expression at %C");
10930 if (m
!= MATCH_YES
)
10935 /* If we do not have an initializer, the initialization value of the
10936 previous enumerator (stored in last_initializer) is incremented
10937 by 1 and is used to initialize the current enumerator. */
10938 if (initializer
== NULL
)
10939 initializer
= enum_initializer (last_initializer
, old_locus
);
10941 if (initializer
== NULL
|| initializer
->ts
.type
!= BT_INTEGER
)
10943 gfc_error ("ENUMERATOR %L not initialized with integer expression",
10949 /* Store this current initializer, for the next enumerator variable
10950 to be parsed. add_init_expr_to_sym() zeros initializer, so we
10951 use last_initializer below. */
10952 last_initializer
= initializer
;
10953 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
10955 /* Maintain enumerator history. */
10956 gfc_find_symbol (name
, NULL
, 0, &sym
);
10957 create_enum_history (sym
, last_initializer
);
10959 return (t
) ? MATCH_YES
: MATCH_ERROR
;
10962 /* Free stuff up and return. */
10963 gfc_free_expr (initializer
);
10969 /* Match the enumerator definition statement. */
10972 gfc_match_enumerator_def (void)
10977 gfc_clear_ts (¤t_ts
);
10979 m
= gfc_match (" enumerator");
10980 if (m
!= MATCH_YES
)
10983 m
= gfc_match (" :: ");
10984 if (m
== MATCH_ERROR
)
10987 colon_seen
= (m
== MATCH_YES
);
10989 if (gfc_current_state () != COMP_ENUM
)
10991 gfc_error ("ENUM definition statement expected before %C");
10992 gfc_free_enum_history ();
10993 return MATCH_ERROR
;
10996 (¤t_ts
)->type
= BT_INTEGER
;
10997 (¤t_ts
)->kind
= gfc_c_int_kind
;
10999 gfc_clear_attr (¤t_attr
);
11000 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, NULL
);
11009 m
= enumerator_decl ();
11010 if (m
== MATCH_ERROR
)
11012 gfc_free_enum_history ();
11018 if (gfc_match_eos () == MATCH_YES
)
11020 if (gfc_match_char (',') != MATCH_YES
)
11024 if (gfc_current_state () == COMP_ENUM
)
11026 gfc_free_enum_history ();
11027 gfc_error ("Syntax error in ENUMERATOR definition at %C");
11032 gfc_free_array_spec (current_as
);
11039 /* Match binding attributes. */
11042 match_binding_attributes (gfc_typebound_proc
* ba
, bool generic
, bool ppc
)
11044 bool found_passing
= false;
11045 bool seen_ptr
= false;
11046 match m
= MATCH_YES
;
11048 /* Initialize to defaults. Do so even before the MATCH_NO check so that in
11049 this case the defaults are in there. */
11050 ba
->access
= ACCESS_UNKNOWN
;
11051 ba
->pass_arg
= NULL
;
11052 ba
->pass_arg_num
= 0;
11054 ba
->non_overridable
= 0;
11058 /* If we find a comma, we believe there are binding attributes. */
11059 m
= gfc_match_char (',');
11065 /* Access specifier. */
11067 m
= gfc_match (" public");
11068 if (m
== MATCH_ERROR
)
11070 if (m
== MATCH_YES
)
11072 if (ba
->access
!= ACCESS_UNKNOWN
)
11074 gfc_error ("Duplicate access-specifier at %C");
11078 ba
->access
= ACCESS_PUBLIC
;
11082 m
= gfc_match (" private");
11083 if (m
== MATCH_ERROR
)
11085 if (m
== MATCH_YES
)
11087 if (ba
->access
!= ACCESS_UNKNOWN
)
11089 gfc_error ("Duplicate access-specifier at %C");
11093 ba
->access
= ACCESS_PRIVATE
;
11097 /* If inside GENERIC, the following is not allowed. */
11102 m
= gfc_match (" nopass");
11103 if (m
== MATCH_ERROR
)
11105 if (m
== MATCH_YES
)
11109 gfc_error ("Binding attributes already specify passing,"
11110 " illegal NOPASS at %C");
11114 found_passing
= true;
11119 /* PASS possibly including argument. */
11120 m
= gfc_match (" pass");
11121 if (m
== MATCH_ERROR
)
11123 if (m
== MATCH_YES
)
11125 char arg
[GFC_MAX_SYMBOL_LEN
+ 1];
11129 gfc_error ("Binding attributes already specify passing,"
11130 " illegal PASS at %C");
11134 m
= gfc_match (" ( %n )", arg
);
11135 if (m
== MATCH_ERROR
)
11137 if (m
== MATCH_YES
)
11138 ba
->pass_arg
= gfc_get_string ("%s", arg
);
11139 gcc_assert ((m
== MATCH_YES
) == (ba
->pass_arg
!= NULL
));
11141 found_passing
= true;
11148 /* POINTER flag. */
11149 m
= gfc_match (" pointer");
11150 if (m
== MATCH_ERROR
)
11152 if (m
== MATCH_YES
)
11156 gfc_error ("Duplicate POINTER attribute at %C");
11166 /* NON_OVERRIDABLE flag. */
11167 m
= gfc_match (" non_overridable");
11168 if (m
== MATCH_ERROR
)
11170 if (m
== MATCH_YES
)
11172 if (ba
->non_overridable
)
11174 gfc_error ("Duplicate NON_OVERRIDABLE at %C");
11178 ba
->non_overridable
= 1;
11182 /* DEFERRED flag. */
11183 m
= gfc_match (" deferred");
11184 if (m
== MATCH_ERROR
)
11186 if (m
== MATCH_YES
)
11190 gfc_error ("Duplicate DEFERRED at %C");
11201 /* Nothing matching found. */
11203 gfc_error ("Expected access-specifier at %C");
11205 gfc_error ("Expected binding attribute at %C");
11208 while (gfc_match_char (',') == MATCH_YES
);
11210 /* NON_OVERRIDABLE and DEFERRED exclude themselves. */
11211 if (ba
->non_overridable
&& ba
->deferred
)
11213 gfc_error ("NON_OVERRIDABLE and DEFERRED cannot both appear at %C");
11220 if (ba
->access
== ACCESS_UNKNOWN
)
11221 ba
->access
= ppc
? gfc_current_block()->component_access
11222 : gfc_typebound_default_access
;
11224 if (ppc
&& !seen_ptr
)
11226 gfc_error ("POINTER attribute is required for procedure pointer component"
11234 return MATCH_ERROR
;
11238 /* Match a PROCEDURE specific binding inside a derived type. */
11241 match_procedure_in_type (void)
11243 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
11244 char target_buf
[GFC_MAX_SYMBOL_LEN
+ 1];
11245 char* target
= NULL
, *ifc
= NULL
;
11246 gfc_typebound_proc tb
;
11250 gfc_symtree
* stree
;
11255 /* Check current state. */
11256 gcc_assert (gfc_state_stack
->state
== COMP_DERIVED_CONTAINS
);
11257 block
= gfc_state_stack
->previous
->sym
;
11258 gcc_assert (block
);
11260 /* Try to match PROCEDURE(interface). */
11261 if (gfc_match (" (") == MATCH_YES
)
11263 m
= gfc_match_name (target_buf
);
11264 if (m
== MATCH_ERROR
)
11266 if (m
!= MATCH_YES
)
11268 gfc_error ("Interface-name expected after %<(%> at %C");
11269 return MATCH_ERROR
;
11272 if (gfc_match (" )") != MATCH_YES
)
11274 gfc_error ("%<)%> expected at %C");
11275 return MATCH_ERROR
;
11281 /* Construct the data structure. */
11282 memset (&tb
, 0, sizeof (tb
));
11283 tb
.where
= gfc_current_locus
;
11285 /* Match binding attributes. */
11286 m
= match_binding_attributes (&tb
, false, false);
11287 if (m
== MATCH_ERROR
)
11289 seen_attrs
= (m
== MATCH_YES
);
11291 /* Check that attribute DEFERRED is given if an interface is specified. */
11292 if (tb
.deferred
&& !ifc
)
11294 gfc_error ("Interface must be specified for DEFERRED binding at %C");
11295 return MATCH_ERROR
;
11297 if (ifc
&& !tb
.deferred
)
11299 gfc_error ("PROCEDURE(interface) at %C should be declared DEFERRED");
11300 return MATCH_ERROR
;
11303 /* Match the colons. */
11304 m
= gfc_match (" ::");
11305 if (m
== MATCH_ERROR
)
11307 seen_colons
= (m
== MATCH_YES
);
11308 if (seen_attrs
&& !seen_colons
)
11310 gfc_error ("Expected %<::%> after binding-attributes at %C");
11311 return MATCH_ERROR
;
11314 /* Match the binding names. */
11317 m
= gfc_match_name (name
);
11318 if (m
== MATCH_ERROR
)
11322 gfc_error ("Expected binding name at %C");
11323 return MATCH_ERROR
;
11326 if (num
>1 && !gfc_notify_std (GFC_STD_F2008
, "PROCEDURE list at %C"))
11327 return MATCH_ERROR
;
11329 /* Try to match the '=> target', if it's there. */
11331 m
= gfc_match (" =>");
11332 if (m
== MATCH_ERROR
)
11334 if (m
== MATCH_YES
)
11338 gfc_error ("%<=> target%> is invalid for DEFERRED binding at %C");
11339 return MATCH_ERROR
;
11344 gfc_error ("%<::%> needed in PROCEDURE binding with explicit target"
11346 return MATCH_ERROR
;
11349 m
= gfc_match_name (target_buf
);
11350 if (m
== MATCH_ERROR
)
11354 gfc_error ("Expected binding target after %<=>%> at %C");
11355 return MATCH_ERROR
;
11357 target
= target_buf
;
11360 /* If no target was found, it has the same name as the binding. */
11364 /* Get the namespace to insert the symbols into. */
11365 ns
= block
->f2k_derived
;
11368 /* If the binding is DEFERRED, check that the containing type is ABSTRACT. */
11369 if (tb
.deferred
&& !block
->attr
.abstract
)
11371 gfc_error ("Type %qs containing DEFERRED binding at %C "
11372 "is not ABSTRACT", block
->name
);
11373 return MATCH_ERROR
;
11376 /* See if we already have a binding with this name in the symtree which
11377 would be an error. If a GENERIC already targeted this binding, it may
11378 be already there but then typebound is still NULL. */
11379 stree
= gfc_find_symtree (ns
->tb_sym_root
, name
);
11380 if (stree
&& stree
->n
.tb
)
11382 gfc_error ("There is already a procedure with binding name %qs for "
11383 "the derived type %qs at %C", name
, block
->name
);
11384 return MATCH_ERROR
;
11387 /* Insert it and set attributes. */
11391 stree
= gfc_new_symtree (&ns
->tb_sym_root
, name
);
11392 gcc_assert (stree
);
11394 stree
->n
.tb
= gfc_get_typebound_proc (&tb
);
11396 if (gfc_get_sym_tree (target
, gfc_current_ns
, &stree
->n
.tb
->u
.specific
,
11398 return MATCH_ERROR
;
11399 gfc_set_sym_referenced (stree
->n
.tb
->u
.specific
->n
.sym
);
11400 gfc_add_flavor(&stree
->n
.tb
->u
.specific
->n
.sym
->attr
, FL_PROCEDURE
,
11401 target
, &stree
->n
.tb
->u
.specific
->n
.sym
->declared_at
);
11403 if (gfc_match_eos () == MATCH_YES
)
11405 if (gfc_match_char (',') != MATCH_YES
)
11410 gfc_error ("Syntax error in PROCEDURE statement at %C");
11411 return MATCH_ERROR
;
11415 /* Match a GENERIC procedure binding inside a derived type. */
11418 gfc_match_generic (void)
11420 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
11421 char bind_name
[GFC_MAX_SYMBOL_LEN
+ 16]; /* Allow space for OPERATOR(...). */
11423 gfc_typebound_proc tbattr
; /* Used for match_binding_attributes. */
11424 gfc_typebound_proc
* tb
;
11426 interface_type op_type
;
11427 gfc_intrinsic_op op
;
11430 /* Check current state. */
11431 if (gfc_current_state () == COMP_DERIVED
)
11433 gfc_error ("GENERIC at %C must be inside a derived-type CONTAINS");
11434 return MATCH_ERROR
;
11436 if (gfc_current_state () != COMP_DERIVED_CONTAINS
)
11438 block
= gfc_state_stack
->previous
->sym
;
11439 ns
= block
->f2k_derived
;
11440 gcc_assert (block
&& ns
);
11442 memset (&tbattr
, 0, sizeof (tbattr
));
11443 tbattr
.where
= gfc_current_locus
;
11445 /* See if we get an access-specifier. */
11446 m
= match_binding_attributes (&tbattr
, true, false);
11447 if (m
== MATCH_ERROR
)
11450 /* Now the colons, those are required. */
11451 if (gfc_match (" ::") != MATCH_YES
)
11453 gfc_error ("Expected %<::%> at %C");
11457 /* Match the binding name; depending on type (operator / generic) format
11458 it for future error messages into bind_name. */
11460 m
= gfc_match_generic_spec (&op_type
, name
, &op
);
11461 if (m
== MATCH_ERROR
)
11462 return MATCH_ERROR
;
11465 gfc_error ("Expected generic name or operator descriptor at %C");
11471 case INTERFACE_GENERIC
:
11472 case INTERFACE_DTIO
:
11473 snprintf (bind_name
, sizeof (bind_name
), "%s", name
);
11476 case INTERFACE_USER_OP
:
11477 snprintf (bind_name
, sizeof (bind_name
), "OPERATOR(.%s.)", name
);
11480 case INTERFACE_INTRINSIC_OP
:
11481 snprintf (bind_name
, sizeof (bind_name
), "OPERATOR(%s)",
11482 gfc_op2string (op
));
11485 case INTERFACE_NAMELESS
:
11486 gfc_error ("Malformed GENERIC statement at %C");
11491 gcc_unreachable ();
11494 /* Match the required =>. */
11495 if (gfc_match (" =>") != MATCH_YES
)
11497 gfc_error ("Expected %<=>%> at %C");
11501 /* Try to find existing GENERIC binding with this name / for this operator;
11502 if there is something, check that it is another GENERIC and then extend
11503 it rather than building a new node. Otherwise, create it and put it
11504 at the right position. */
11508 case INTERFACE_DTIO
:
11509 case INTERFACE_USER_OP
:
11510 case INTERFACE_GENERIC
:
11512 const bool is_op
= (op_type
== INTERFACE_USER_OP
);
11515 st
= gfc_find_symtree (is_op
? ns
->tb_uop_root
: ns
->tb_sym_root
, name
);
11516 tb
= st
? st
->n
.tb
: NULL
;
11520 case INTERFACE_INTRINSIC_OP
:
11521 tb
= ns
->tb_op
[op
];
11525 gcc_unreachable ();
11530 if (!tb
->is_generic
)
11532 gcc_assert (op_type
== INTERFACE_GENERIC
);
11533 gfc_error ("There's already a non-generic procedure with binding name"
11534 " %qs for the derived type %qs at %C",
11535 bind_name
, block
->name
);
11539 if (tb
->access
!= tbattr
.access
)
11541 gfc_error ("Binding at %C must have the same access as already"
11542 " defined binding %qs", bind_name
);
11548 tb
= gfc_get_typebound_proc (NULL
);
11549 tb
->where
= gfc_current_locus
;
11550 tb
->access
= tbattr
.access
;
11551 tb
->is_generic
= 1;
11552 tb
->u
.generic
= NULL
;
11556 case INTERFACE_DTIO
:
11557 case INTERFACE_GENERIC
:
11558 case INTERFACE_USER_OP
:
11560 const bool is_op
= (op_type
== INTERFACE_USER_OP
);
11561 gfc_symtree
* st
= gfc_get_tbp_symtree (is_op
? &ns
->tb_uop_root
:
11562 &ns
->tb_sym_root
, name
);
11569 case INTERFACE_INTRINSIC_OP
:
11570 ns
->tb_op
[op
] = tb
;
11574 gcc_unreachable ();
11578 /* Now, match all following names as specific targets. */
11581 gfc_symtree
* target_st
;
11582 gfc_tbp_generic
* target
;
11584 m
= gfc_match_name (name
);
11585 if (m
== MATCH_ERROR
)
11589 gfc_error ("Expected specific binding name at %C");
11593 target_st
= gfc_get_tbp_symtree (&ns
->tb_sym_root
, name
);
11595 /* See if this is a duplicate specification. */
11596 for (target
= tb
->u
.generic
; target
; target
= target
->next
)
11597 if (target_st
== target
->specific_st
)
11599 gfc_error ("%qs already defined as specific binding for the"
11600 " generic %qs at %C", name
, bind_name
);
11604 target
= gfc_get_tbp_generic ();
11605 target
->specific_st
= target_st
;
11606 target
->specific
= NULL
;
11607 target
->next
= tb
->u
.generic
;
11608 target
->is_operator
= ((op_type
== INTERFACE_USER_OP
)
11609 || (op_type
== INTERFACE_INTRINSIC_OP
));
11610 tb
->u
.generic
= target
;
11612 while (gfc_match (" ,") == MATCH_YES
);
11614 /* Here should be the end. */
11615 if (gfc_match_eos () != MATCH_YES
)
11617 gfc_error ("Junk after GENERIC binding at %C");
11624 return MATCH_ERROR
;
11628 /* Match a FINAL declaration inside a derived type. */
11631 gfc_match_final_decl (void)
11633 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
11636 gfc_namespace
* module_ns
;
11640 if (gfc_current_form
== FORM_FREE
)
11642 char c
= gfc_peek_ascii_char ();
11643 if (!gfc_is_whitespace (c
) && c
!= ':')
11647 if (gfc_state_stack
->state
!= COMP_DERIVED_CONTAINS
)
11649 if (gfc_current_form
== FORM_FIXED
)
11652 gfc_error ("FINAL declaration at %C must be inside a derived type "
11653 "CONTAINS section");
11654 return MATCH_ERROR
;
11657 block
= gfc_state_stack
->previous
->sym
;
11658 gcc_assert (block
);
11660 if (gfc_state_stack
->previous
->previous
11661 && gfc_state_stack
->previous
->previous
->state
!= COMP_MODULE
11662 && gfc_state_stack
->previous
->previous
->state
!= COMP_SUBMODULE
)
11664 gfc_error ("Derived type declaration with FINAL at %C must be in the"
11665 " specification part of a MODULE");
11666 return MATCH_ERROR
;
11669 module_ns
= gfc_current_ns
;
11670 gcc_assert (module_ns
);
11671 gcc_assert (module_ns
->proc_name
->attr
.flavor
== FL_MODULE
);
11673 /* Match optional ::, don't care about MATCH_YES or MATCH_NO. */
11674 if (gfc_match (" ::") == MATCH_ERROR
)
11675 return MATCH_ERROR
;
11677 /* Match the sequence of procedure names. */
11684 if (first
&& gfc_match_eos () == MATCH_YES
)
11686 gfc_error ("Empty FINAL at %C");
11687 return MATCH_ERROR
;
11690 m
= gfc_match_name (name
);
11693 gfc_error ("Expected module procedure name at %C");
11694 return MATCH_ERROR
;
11696 else if (m
!= MATCH_YES
)
11697 return MATCH_ERROR
;
11699 if (gfc_match_eos () == MATCH_YES
)
11701 if (!last
&& gfc_match_char (',') != MATCH_YES
)
11703 gfc_error ("Expected %<,%> at %C");
11704 return MATCH_ERROR
;
11707 if (gfc_get_symbol (name
, module_ns
, &sym
))
11709 gfc_error ("Unknown procedure name %qs at %C", name
);
11710 return MATCH_ERROR
;
11713 /* Mark the symbol as module procedure. */
11714 if (sym
->attr
.proc
!= PROC_MODULE
11715 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
11716 return MATCH_ERROR
;
11718 /* Check if we already have this symbol in the list, this is an error. */
11719 for (f
= block
->f2k_derived
->finalizers
; f
; f
= f
->next
)
11720 if (f
->proc_sym
== sym
)
11722 gfc_error ("%qs at %C is already defined as FINAL procedure",
11724 return MATCH_ERROR
;
11727 /* Add this symbol to the list of finalizers. */
11728 gcc_assert (block
->f2k_derived
);
11730 f
= XCNEW (gfc_finalizer
);
11732 f
->proc_tree
= NULL
;
11733 f
->where
= gfc_current_locus
;
11734 f
->next
= block
->f2k_derived
->finalizers
;
11735 block
->f2k_derived
->finalizers
= f
;
11745 const ext_attr_t ext_attr_list
[] = {
11746 { "dllimport", EXT_ATTR_DLLIMPORT
, "dllimport" },
11747 { "dllexport", EXT_ATTR_DLLEXPORT
, "dllexport" },
11748 { "cdecl", EXT_ATTR_CDECL
, "cdecl" },
11749 { "stdcall", EXT_ATTR_STDCALL
, "stdcall" },
11750 { "fastcall", EXT_ATTR_FASTCALL
, "fastcall" },
11751 { "no_arg_check", EXT_ATTR_NO_ARG_CHECK
, NULL
},
11752 { "deprecated", EXT_ATTR_DEPRECATED
, NULL
},
11753 { "noinline", EXT_ATTR_NOINLINE
, NULL
},
11754 { "noreturn", EXT_ATTR_NORETURN
, NULL
},
11755 { "weak", EXT_ATTR_WEAK
, NULL
},
11756 { NULL
, EXT_ATTR_LAST
, NULL
}
11759 /* Match a !GCC$ ATTRIBUTES statement of the form:
11760 !GCC$ ATTRIBUTES attribute-list :: var-name [, var-name] ...
11761 When we come here, we have already matched the !GCC$ ATTRIBUTES string.
11763 TODO: We should support all GCC attributes using the same syntax for
11764 the attribute list, i.e. the list in C
11765 __attributes(( attribute-list ))
11767 !GCC$ ATTRIBUTES attribute-list ::
11768 Cf. c-parser.cc's c_parser_attributes; the data can then directly be
11771 As there is absolutely no risk of confusion, we should never return
11774 gfc_match_gcc_attributes (void)
11776 symbol_attribute attr
;
11777 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
11782 gfc_clear_attr (&attr
);
11787 if (gfc_match_name (name
) != MATCH_YES
)
11788 return MATCH_ERROR
;
11790 for (id
= 0; id
< EXT_ATTR_LAST
; id
++)
11791 if (strcmp (name
, ext_attr_list
[id
].name
) == 0)
11794 if (id
== EXT_ATTR_LAST
)
11796 gfc_error ("Unknown attribute in !GCC$ ATTRIBUTES statement at %C");
11797 return MATCH_ERROR
;
11800 if (!gfc_add_ext_attribute (&attr
, (ext_attr_id_t
)id
, &gfc_current_locus
))
11801 return MATCH_ERROR
;
11803 gfc_gobble_whitespace ();
11804 ch
= gfc_next_ascii_char ();
11807 /* This is the successful exit condition for the loop. */
11808 if (gfc_next_ascii_char () == ':')
11818 if (gfc_match_eos () == MATCH_YES
)
11823 m
= gfc_match_name (name
);
11824 if (m
!= MATCH_YES
)
11827 if (find_special (name
, &sym
, true))
11828 return MATCH_ERROR
;
11830 sym
->attr
.ext_attr
|= attr
.ext_attr
;
11832 if (gfc_match_eos () == MATCH_YES
)
11835 if (gfc_match_char (',') != MATCH_YES
)
11842 gfc_error ("Syntax error in !GCC$ ATTRIBUTES statement at %C");
11843 return MATCH_ERROR
;
11847 /* Match a !GCC$ UNROLL statement of the form:
11850 The parameter n is the number of times we are supposed to unroll.
11852 When we come here, we have already matched the !GCC$ UNROLL string. */
11854 gfc_match_gcc_unroll (void)
11858 /* FIXME: use gfc_match_small_literal_int instead, delete small_int */
11859 if (gfc_match_small_int (&value
) == MATCH_YES
)
11861 if (value
< 0 || value
> USHRT_MAX
)
11863 gfc_error ("%<GCC unroll%> directive requires a"
11864 " non-negative integral constant"
11865 " less than or equal to %u at %C",
11868 return MATCH_ERROR
;
11870 if (gfc_match_eos () == MATCH_YES
)
11872 directive_unroll
= value
== 0 ? 1 : value
;
11877 gfc_error ("Syntax error in !GCC$ UNROLL directive at %C");
11878 return MATCH_ERROR
;
11881 /* Match a !GCC$ builtin (b) attributes simd flags if('target') form:
11883 The parameter b is name of a middle-end built-in.
11884 FLAGS is optional and must be one of:
11888 IF('target') is optional and TARGET is a name of a multilib ABI.
11890 When we come here, we have already matched the !GCC$ builtin string. */
11893 gfc_match_gcc_builtin (void)
11895 char builtin
[GFC_MAX_SYMBOL_LEN
+ 1];
11896 char target
[GFC_MAX_SYMBOL_LEN
+ 1];
11898 if (gfc_match (" ( %n ) attributes simd", builtin
) != MATCH_YES
)
11899 return MATCH_ERROR
;
11901 gfc_simd_clause clause
= SIMD_NONE
;
11902 if (gfc_match (" ( notinbranch ) ") == MATCH_YES
)
11903 clause
= SIMD_NOTINBRANCH
;
11904 else if (gfc_match (" ( inbranch ) ") == MATCH_YES
)
11905 clause
= SIMD_INBRANCH
;
11907 if (gfc_match (" if ( '%n' ) ", target
) == MATCH_YES
)
11909 const char *abi
= targetm
.get_multilib_abi_name ();
11910 if (abi
== NULL
|| strcmp (abi
, target
) != 0)
11914 if (gfc_vectorized_builtins
== NULL
)
11915 gfc_vectorized_builtins
= new hash_map
<nofree_string_hash
, int> ();
11917 char *r
= XNEWVEC (char, strlen (builtin
) + 32);
11918 sprintf (r
, "__builtin_%s", builtin
);
11921 int &value
= gfc_vectorized_builtins
->get_or_insert (r
, &existed
);
11929 /* Match an !GCC$ IVDEP statement.
11930 When we come here, we have already matched the !GCC$ IVDEP string. */
11933 gfc_match_gcc_ivdep (void)
11935 if (gfc_match_eos () == MATCH_YES
)
11937 directive_ivdep
= true;
11941 gfc_error ("Syntax error in !GCC$ IVDEP directive at %C");
11942 return MATCH_ERROR
;
11945 /* Match an !GCC$ VECTOR statement.
11946 When we come here, we have already matched the !GCC$ VECTOR string. */
11949 gfc_match_gcc_vector (void)
11951 if (gfc_match_eos () == MATCH_YES
)
11953 directive_vector
= true;
11954 directive_novector
= false;
11958 gfc_error ("Syntax error in !GCC$ VECTOR directive at %C");
11959 return MATCH_ERROR
;
11962 /* Match an !GCC$ NOVECTOR statement.
11963 When we come here, we have already matched the !GCC$ NOVECTOR string. */
11966 gfc_match_gcc_novector (void)
11968 if (gfc_match_eos () == MATCH_YES
)
11970 directive_novector
= true;
11971 directive_vector
= false;
11975 gfc_error ("Syntax error in !GCC$ NOVECTOR directive at %C");
11976 return MATCH_ERROR
;