1 /* Declaration statement matcher
2 Copyright (C) 2002-2024 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
1408 || sym
->ts
.type
== BT_CLASS
1409 || sym
->ts
.type
== BT_DERIVED
)
1410 && !sym
->attr
.implicit_type
1411 && sym
->attr
.proc
== 0
1412 && gfc_current_ns
->parent
!= NULL
1413 && sym
->attr
.access
== 0
1414 && !module_fcn_entry
)
1416 gfc_error_now ("Procedure %qs at %C has an explicit interface "
1417 "from a previous declaration", name
);
1422 /* C1246 (R1225) MODULE shall appear only in the function-stmt or
1423 subroutine-stmt of a module subprogram or of a nonabstract interface
1424 body that is declared in the scoping unit of a module or submodule. */
1425 if (sym
->attr
.external
1426 && (sym
->attr
.subroutine
|| sym
->attr
.function
)
1427 && sym
->attr
.if_source
== IFSRC_IFBODY
1428 && !current_attr
.module_procedure
1429 && sym
->attr
.proc
== PROC_MODULE
1430 && gfc_state_stack
->state
== COMP_CONTAINS
)
1432 gfc_error_now ("Procedure %qs defined in interface body at %L "
1433 "clashes with internal procedure defined at %C",
1434 name
, &sym
->declared_at
);
1438 if (sym
&& !sym
->gfc_new
1439 && sym
->attr
.flavor
!= FL_UNKNOWN
1440 && sym
->attr
.referenced
== 0 && sym
->attr
.subroutine
== 1
1441 && gfc_state_stack
->state
== COMP_CONTAINS
1442 && gfc_state_stack
->previous
->state
== COMP_SUBROUTINE
)
1444 gfc_error_now ("Procedure %qs at %C is already defined at %L",
1445 name
, &sym
->declared_at
);
1449 if (gfc_current_ns
->parent
== NULL
|| *result
== NULL
)
1452 /* Module function entries will already have a symtree in
1453 the current namespace but will need one at module level. */
1454 if (module_fcn_entry
)
1456 /* Present if entry is declared to be a module procedure. */
1457 rc
= gfc_find_sym_tree (name
, gfc_current_ns
->parent
, 0, &st
);
1459 st
= gfc_new_symtree (&gfc_current_ns
->parent
->sym_root
, name
);
1462 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, name
);
1467 /* See if the procedure should be a module procedure. */
1469 if (((sym
->ns
->proc_name
!= NULL
1470 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
1471 && sym
->attr
.proc
!= PROC_MODULE
)
1472 || (module_fcn_entry
&& sym
->attr
.proc
!= PROC_MODULE
))
1473 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
1480 /* Verify that the given symbol representing a parameter is C
1481 interoperable, by checking to see if it was marked as such after
1482 its declaration. If the given symbol is not interoperable, a
1483 warning is reported, thus removing the need to return the status to
1484 the calling function. The standard does not require the user use
1485 one of the iso_c_binding named constants to declare an
1486 interoperable parameter, but we can't be sure if the param is C
1487 interop or not if the user doesn't. For example, integer(4) may be
1488 legal Fortran, but doesn't have meaning in C. It may interop with
1489 a number of the C types, which causes a problem because the
1490 compiler can't know which one. This code is almost certainly not
1491 portable, and the user will get what they deserve if the C type
1492 across platforms isn't always interoperable with integer(4). If
1493 the user had used something like integer(c_int) or integer(c_long),
1494 the compiler could have automatically handled the varying sizes
1495 across platforms. */
1498 gfc_verify_c_interop_param (gfc_symbol
*sym
)
1500 int is_c_interop
= 0;
1503 /* We check implicitly typed variables in symbol.cc:gfc_set_default_type().
1504 Don't repeat the checks here. */
1505 if (sym
->attr
.implicit_type
)
1508 /* For subroutines or functions that are passed to a BIND(C) procedure,
1509 they're interoperable if they're BIND(C) and their params are all
1511 if (sym
->attr
.flavor
== FL_PROCEDURE
)
1513 if (sym
->attr
.is_bind_c
== 0)
1515 gfc_error_now ("Procedure %qs at %L must have the BIND(C) "
1516 "attribute to be C interoperable", sym
->name
,
1517 &(sym
->declared_at
));
1522 if (sym
->attr
.is_c_interop
== 1)
1523 /* We've already checked this procedure; don't check it again. */
1526 return verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
1531 /* See if we've stored a reference to a procedure that owns sym. */
1532 if (sym
->ns
!= NULL
&& sym
->ns
->proc_name
!= NULL
)
1534 if (sym
->ns
->proc_name
->attr
.is_bind_c
== 1)
1536 is_c_interop
= (gfc_verify_c_interop(&(sym
->ts
)) ? 1 : 0);
1538 if (is_c_interop
!= 1)
1540 /* Make personalized messages to give better feedback. */
1541 if (sym
->ts
.type
== BT_DERIVED
)
1542 gfc_error ("Variable %qs at %L is a dummy argument to the "
1543 "BIND(C) procedure %qs but is not C interoperable "
1544 "because derived type %qs is not C interoperable",
1545 sym
->name
, &(sym
->declared_at
),
1546 sym
->ns
->proc_name
->name
,
1547 sym
->ts
.u
.derived
->name
);
1548 else if (sym
->ts
.type
== BT_CLASS
)
1549 gfc_error ("Variable %qs at %L is a dummy argument to the "
1550 "BIND(C) procedure %qs but is not C interoperable "
1551 "because it is polymorphic",
1552 sym
->name
, &(sym
->declared_at
),
1553 sym
->ns
->proc_name
->name
);
1554 else if (warn_c_binding_type
)
1555 gfc_warning (OPT_Wc_binding_type
,
1556 "Variable %qs at %L is a dummy argument of the "
1557 "BIND(C) procedure %qs but may not be C "
1559 sym
->name
, &(sym
->declared_at
),
1560 sym
->ns
->proc_name
->name
);
1563 /* Per F2018, 18.3.6 (5), pointer + contiguous is not permitted. */
1564 if (sym
->attr
.pointer
&& sym
->attr
.contiguous
)
1565 gfc_error ("Dummy argument %qs at %L may not be a pointer with "
1566 "CONTIGUOUS attribute as procedure %qs is BIND(C)",
1567 sym
->name
, &sym
->declared_at
, sym
->ns
->proc_name
->name
);
1569 /* Per F2018, C1557, pointer/allocatable dummies to a bind(c)
1570 procedure that are default-initialized are not permitted. */
1571 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
1572 && sym
->ts
.type
== BT_DERIVED
1573 && gfc_has_default_initializer (sym
->ts
.u
.derived
))
1575 gfc_error ("Default-initialized %s dummy argument %qs "
1576 "at %L is not permitted in BIND(C) procedure %qs",
1577 (sym
->attr
.pointer
? "pointer" : "allocatable"),
1578 sym
->name
, &sym
->declared_at
,
1579 sym
->ns
->proc_name
->name
);
1583 /* Character strings are only C interoperable if they have a
1584 length of 1. However, as an argument they are also interoperable
1585 when passed as descriptor (which requires len=: or len=*). */
1586 if (sym
->ts
.type
== BT_CHARACTER
)
1588 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
1590 if (sym
->attr
.allocatable
|| sym
->attr
.pointer
)
1592 /* F2018, 18.3.6 (6). */
1593 if (!sym
->ts
.deferred
)
1595 if (sym
->attr
.allocatable
)
1596 gfc_error ("Allocatable character dummy argument %qs "
1597 "at %L must have deferred length as "
1598 "procedure %qs is BIND(C)", sym
->name
,
1599 &sym
->declared_at
, sym
->ns
->proc_name
->name
);
1601 gfc_error ("Pointer character dummy argument %qs at %L "
1602 "must have deferred length as procedure %qs "
1603 "is BIND(C)", sym
->name
, &sym
->declared_at
,
1604 sym
->ns
->proc_name
->name
);
1607 else if (!gfc_notify_std (GFC_STD_F2018
,
1608 "Deferred-length character dummy "
1609 "argument %qs at %L of procedure "
1610 "%qs with BIND(C) attribute",
1611 sym
->name
, &sym
->declared_at
,
1612 sym
->ns
->proc_name
->name
))
1615 else if (sym
->attr
.value
1616 && (!cl
|| !cl
->length
1617 || cl
->length
->expr_type
!= EXPR_CONSTANT
1618 || mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0))
1620 gfc_error ("Character dummy argument %qs at %L must be "
1621 "of length 1 as it has the VALUE attribute",
1622 sym
->name
, &sym
->declared_at
);
1625 else if (!cl
|| !cl
->length
)
1627 /* Assumed length; F2018, 18.3.6 (5)(2).
1628 Uses the CFI array descriptor - also for scalars and
1629 explicit-size/assumed-size arrays. */
1630 if (!gfc_notify_std (GFC_STD_F2018
,
1631 "Assumed-length character dummy argument "
1632 "%qs at %L of procedure %qs with BIND(C) "
1633 "attribute", sym
->name
, &sym
->declared_at
,
1634 sym
->ns
->proc_name
->name
))
1637 else if (cl
->length
->expr_type
!= EXPR_CONSTANT
1638 || mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
1640 /* F2018, 18.3.6, (5), item 4. */
1641 if (!sym
->attr
.dimension
1642 || sym
->as
->type
== AS_ASSUMED_SIZE
1643 || sym
->as
->type
== AS_EXPLICIT
)
1645 gfc_error ("Character dummy argument %qs at %L must be "
1646 "of constant length of one or assumed length, "
1647 "unless it has assumed shape or assumed rank, "
1648 "as procedure %qs has the BIND(C) attribute",
1649 sym
->name
, &sym
->declared_at
,
1650 sym
->ns
->proc_name
->name
);
1653 /* else: valid only since F2018 - and an assumed-shape/rank
1654 array; however, gfc_notify_std is already called when
1655 those array types are used. Thus, silently accept F200x. */
1659 /* We have to make sure that any param to a bind(c) routine does
1660 not have the allocatable, pointer, or optional attributes,
1661 according to J3/04-007, section 5.1. */
1662 if (sym
->attr
.allocatable
== 1
1663 && !gfc_notify_std (GFC_STD_F2018
, "Variable %qs at %L with "
1664 "ALLOCATABLE attribute in procedure %qs "
1665 "with BIND(C)", sym
->name
,
1666 &(sym
->declared_at
),
1667 sym
->ns
->proc_name
->name
))
1670 if (sym
->attr
.pointer
== 1
1671 && !gfc_notify_std (GFC_STD_F2018
, "Variable %qs at %L with "
1672 "POINTER attribute in procedure %qs "
1673 "with BIND(C)", sym
->name
,
1674 &(sym
->declared_at
),
1675 sym
->ns
->proc_name
->name
))
1678 if (sym
->attr
.optional
== 1 && sym
->attr
.value
)
1680 gfc_error ("Variable %qs at %L cannot have both the OPTIONAL "
1681 "and the VALUE attribute because procedure %qs "
1682 "is BIND(C)", sym
->name
, &(sym
->declared_at
),
1683 sym
->ns
->proc_name
->name
);
1686 else if (sym
->attr
.optional
== 1
1687 && !gfc_notify_std (GFC_STD_F2018
, "Variable %qs "
1688 "at %L with OPTIONAL attribute in "
1689 "procedure %qs which is BIND(C)",
1690 sym
->name
, &(sym
->declared_at
),
1691 sym
->ns
->proc_name
->name
))
1694 /* Make sure that if it has the dimension attribute, that it is
1695 either assumed size or explicit shape. Deferred shape is already
1696 covered by the pointer/allocatable attribute. */
1697 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SHAPE
1698 && !gfc_notify_std (GFC_STD_F2018
, "Assumed-shape array %qs "
1699 "at %L as dummy argument to the BIND(C) "
1700 "procedure %qs at %L", sym
->name
,
1701 &(sym
->declared_at
),
1702 sym
->ns
->proc_name
->name
,
1703 &(sym
->ns
->proc_name
->declared_at
)))
1713 /* Function called by variable_decl() that adds a name to the symbol table. */
1716 build_sym (const char *name
, gfc_charlen
*cl
, bool cl_deferred
,
1717 gfc_array_spec
**as
, locus
*var_locus
)
1719 symbol_attribute attr
;
1724 /* Symbols in a submodule are host associated from the parent module or
1725 submodules. Therefore, they can be overridden by declarations in the
1726 submodule scope. Deal with this by attaching the existing symbol to
1727 a new symtree and recycling the old symtree with a new symbol... */
1728 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
1729 if (st
!= NULL
&& gfc_state_stack
->state
== COMP_SUBMODULE
1730 && st
->n
.sym
!= NULL
1731 && st
->n
.sym
->attr
.host_assoc
&& st
->n
.sym
->attr
.used_in_submodule
)
1733 gfc_symtree
*s
= gfc_get_unique_symtree (gfc_current_ns
);
1734 s
->n
.sym
= st
->n
.sym
;
1735 sym
= gfc_new_symbol (name
, gfc_current_ns
);
1740 gfc_set_sym_referenced (sym
);
1742 /* ...Otherwise generate a new symtree and new symbol. */
1743 else if (gfc_get_symbol (name
, NULL
, &sym
))
1746 /* Check if the name has already been defined as a type. The
1747 first letter of the symtree will be in upper case then. Of
1748 course, this is only necessary if the upper case letter is
1749 actually different. */
1751 upper
= TOUPPER(name
[0]);
1752 if (upper
!= name
[0])
1754 char u_name
[GFC_MAX_SYMBOL_LEN
+ 1];
1757 gcc_assert (strlen(name
) <= GFC_MAX_SYMBOL_LEN
);
1758 strcpy (u_name
, name
);
1761 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, u_name
);
1763 /* STRUCTURE types can alias symbol names */
1764 if (st
!= 0 && st
->n
.sym
->attr
.flavor
!= FL_STRUCT
)
1766 gfc_error ("Symbol %qs at %C also declared as a type at %L", name
,
1767 &st
->n
.sym
->declared_at
);
1772 /* Start updating the symbol table. Add basic type attribute if present. */
1773 if (current_ts
.type
!= BT_UNKNOWN
1774 && (sym
->attr
.implicit_type
== 0
1775 || !gfc_compare_types (&sym
->ts
, ¤t_ts
))
1776 && !gfc_add_type (sym
, ¤t_ts
, var_locus
))
1779 if (sym
->ts
.type
== BT_CHARACTER
)
1782 sym
->ts
.deferred
= cl_deferred
;
1785 /* Add dimension attribute if present. */
1786 if (!gfc_set_array_spec (sym
, *as
, var_locus
))
1790 /* Add attribute to symbol. The copy is so that we can reset the
1791 dimension attribute. */
1792 attr
= current_attr
;
1794 attr
.codimension
= 0;
1796 if (!gfc_copy_attr (&sym
->attr
, &attr
, var_locus
))
1799 /* Finish any work that may need to be done for the binding label,
1800 if it's a bind(c). The bind(c) attr is found before the symbol
1801 is made, and before the symbol name (for data decls), so the
1802 current_ts is holding the binding label, or nothing if the
1803 name= attr wasn't given. Therefore, test here if we're dealing
1804 with a bind(c) and make sure the binding label is set correctly. */
1805 if (sym
->attr
.is_bind_c
== 1)
1807 if (!sym
->binding_label
)
1809 /* Set the binding label and verify that if a NAME= was specified
1810 then only one identifier was in the entity-decl-list. */
1811 if (!set_binding_label (&sym
->binding_label
, sym
->name
,
1812 num_idents_on_line
))
1817 /* See if we know we're in a common block, and if it's a bind(c)
1818 common then we need to make sure we're an interoperable type. */
1819 if (sym
->attr
.in_common
== 1)
1821 /* Test the common block object. */
1822 if (sym
->common_block
!= NULL
&& sym
->common_block
->is_bind_c
== 1
1823 && sym
->ts
.is_c_interop
!= 1)
1825 gfc_error_now ("Variable %qs in common block %qs at %C "
1826 "must be declared with a C interoperable "
1827 "kind since common block %qs is BIND(C)",
1828 sym
->name
, sym
->common_block
->name
,
1829 sym
->common_block
->name
);
1834 sym
->attr
.implied_index
= 0;
1836 /* Use the parameter expressions for a parameterized derived type. */
1837 if ((sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
1838 && sym
->ts
.u
.derived
->attr
.pdt_type
&& type_param_spec_list
)
1839 sym
->param_list
= gfc_copy_actual_arglist (type_param_spec_list
);
1841 if (sym
->ts
.type
== BT_CLASS
)
1842 return gfc_build_class_symbol (&sym
->ts
, &sym
->attr
, &sym
->as
);
1848 /* Set character constant to the given length. The constant will be padded or
1849 truncated. If we're inside an array constructor without a typespec, we
1850 additionally check that all elements have the same length; check_len -1
1851 means no checking. */
1854 gfc_set_constant_character_len (gfc_charlen_t len
, gfc_expr
*expr
,
1855 gfc_charlen_t check_len
)
1860 if (expr
->ts
.type
!= BT_CHARACTER
)
1863 if (expr
->expr_type
!= EXPR_CONSTANT
)
1865 gfc_error_now ("CHARACTER length must be a constant at %L", &expr
->where
);
1869 slen
= expr
->value
.character
.length
;
1872 s
= gfc_get_wide_string (len
+ 1);
1873 memcpy (s
, expr
->value
.character
.string
,
1874 MIN (len
, slen
) * sizeof (gfc_char_t
));
1876 gfc_wide_memset (&s
[slen
], ' ', len
- slen
);
1878 if (warn_character_truncation
&& slen
> len
)
1879 gfc_warning_now (OPT_Wcharacter_truncation
,
1880 "CHARACTER expression at %L is being truncated "
1881 "(%ld/%ld)", &expr
->where
,
1882 (long) slen
, (long) len
);
1884 /* Apply the standard by 'hand' otherwise it gets cleared for
1886 if (check_len
!= -1 && slen
!= check_len
1887 && !(gfc_option
.allow_std
& GFC_STD_GNU
))
1888 gfc_error_now ("The CHARACTER elements of the array constructor "
1889 "at %L must have the same length (%ld/%ld)",
1890 &expr
->where
, (long) slen
,
1894 free (expr
->value
.character
.string
);
1895 expr
->value
.character
.string
= s
;
1896 expr
->value
.character
.length
= len
;
1897 /* If explicit representation was given, clear it
1898 as it is no longer needed after padding. */
1899 if (expr
->representation
.length
)
1901 expr
->representation
.length
= 0;
1902 free (expr
->representation
.string
);
1903 expr
->representation
.string
= NULL
;
1909 /* Function to create and update the enumerator history
1910 using the information passed as arguments.
1911 Pointer "max_enum" is also updated, to point to
1912 enum history node containing largest initializer.
1914 SYM points to the symbol node of enumerator.
1915 INIT points to its enumerator value. */
1918 create_enum_history (gfc_symbol
*sym
, gfc_expr
*init
)
1920 enumerator_history
*new_enum_history
;
1921 gcc_assert (sym
!= NULL
&& init
!= NULL
);
1923 new_enum_history
= XCNEW (enumerator_history
);
1925 new_enum_history
->sym
= sym
;
1926 new_enum_history
->initializer
= init
;
1927 new_enum_history
->next
= NULL
;
1929 if (enum_history
== NULL
)
1931 enum_history
= new_enum_history
;
1932 max_enum
= enum_history
;
1936 new_enum_history
->next
= enum_history
;
1937 enum_history
= new_enum_history
;
1939 if (mpz_cmp (max_enum
->initializer
->value
.integer
,
1940 new_enum_history
->initializer
->value
.integer
) < 0)
1941 max_enum
= new_enum_history
;
1946 /* Function to free enum kind history. */
1949 gfc_free_enum_history (void)
1951 enumerator_history
*current
= enum_history
;
1952 enumerator_history
*next
;
1954 while (current
!= NULL
)
1956 next
= current
->next
;
1961 enum_history
= NULL
;
1965 /* Function to fix initializer character length if the length of the
1966 symbol or component is constant. */
1969 fix_initializer_charlen (gfc_typespec
*ts
, gfc_expr
*init
)
1971 if (!gfc_specification_expr (ts
->u
.cl
->length
))
1974 int k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
1976 /* resolve_charlen will complain later on if the length
1977 is too large. Just skip the initialization in that case. */
1978 if (mpz_cmp (ts
->u
.cl
->length
->value
.integer
,
1979 gfc_integer_kinds
[k
].huge
) <= 0)
1982 = gfc_mpz_get_hwi (ts
->u
.cl
->length
->value
.integer
);
1984 if (init
->expr_type
== EXPR_CONSTANT
)
1985 gfc_set_constant_character_len (len
, init
, -1);
1986 else if (init
->expr_type
== EXPR_ARRAY
)
1988 gfc_constructor
*cons
;
1990 /* Build a new charlen to prevent simplification from
1991 deleting the length before it is resolved. */
1992 init
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1993 init
->ts
.u
.cl
->length
= gfc_copy_expr (ts
->u
.cl
->length
);
1994 cons
= gfc_constructor_first (init
->value
.constructor
);
1995 for (; cons
; cons
= gfc_constructor_next (cons
))
1996 gfc_set_constant_character_len (len
, cons
->expr
, -1);
2004 /* Function called by variable_decl() that adds an initialization
2005 expression to a symbol. */
2008 add_init_expr_to_sym (const char *name
, gfc_expr
**initp
, locus
*var_locus
)
2010 symbol_attribute attr
;
2015 if (find_special (name
, &sym
, false))
2020 /* If this symbol is confirming an implicit parameter type,
2021 then an initialization expression is not allowed. */
2022 if (attr
.flavor
== FL_PARAMETER
&& sym
->value
!= NULL
)
2026 gfc_error ("Initializer not allowed for PARAMETER %qs at %C",
2036 /* An initializer is required for PARAMETER declarations. */
2037 if (attr
.flavor
== FL_PARAMETER
)
2039 gfc_error ("PARAMETER at %L is missing an initializer", var_locus
);
2045 /* If a variable appears in a DATA block, it cannot have an
2049 gfc_error ("Variable %qs at %C with an initializer already "
2050 "appears in a DATA statement", sym
->name
);
2054 /* Check if the assignment can happen. This has to be put off
2055 until later for derived type variables and procedure pointers. */
2056 if (!gfc_bt_struct (sym
->ts
.type
) && !gfc_bt_struct (init
->ts
.type
)
2057 && sym
->ts
.type
!= BT_CLASS
&& init
->ts
.type
!= BT_CLASS
2058 && !sym
->attr
.proc_pointer
2059 && !gfc_check_assign_symbol (sym
, NULL
, init
))
2062 if (sym
->ts
.type
== BT_CHARACTER
&& sym
->ts
.u
.cl
2063 && init
->ts
.type
== BT_CHARACTER
)
2065 /* Update symbol character length according initializer. */
2066 if (!gfc_check_assign_symbol (sym
, NULL
, init
))
2069 if (sym
->ts
.u
.cl
->length
== NULL
)
2072 /* If there are multiple CHARACTER variables declared on the
2073 same line, we don't want them to share the same length. */
2074 sym
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2076 if (sym
->attr
.flavor
== FL_PARAMETER
)
2078 if (init
->expr_type
== EXPR_CONSTANT
)
2080 clen
= init
->value
.character
.length
;
2081 sym
->ts
.u
.cl
->length
2082 = gfc_get_int_expr (gfc_charlen_int_kind
,
2085 else if (init
->expr_type
== EXPR_ARRAY
)
2087 if (init
->ts
.u
.cl
&& init
->ts
.u
.cl
->length
)
2089 const gfc_expr
*length
= init
->ts
.u
.cl
->length
;
2090 if (length
->expr_type
!= EXPR_CONSTANT
)
2092 gfc_error ("Cannot initialize parameter array "
2094 "with variable length elements",
2098 clen
= mpz_get_si (length
->value
.integer
);
2100 else if (init
->value
.constructor
)
2103 c
= gfc_constructor_first (init
->value
.constructor
);
2104 clen
= c
->expr
->value
.character
.length
;
2108 sym
->ts
.u
.cl
->length
2109 = gfc_get_int_expr (gfc_charlen_int_kind
,
2112 else if (init
->ts
.u
.cl
&& init
->ts
.u
.cl
->length
)
2113 sym
->ts
.u
.cl
->length
=
2114 gfc_copy_expr (init
->ts
.u
.cl
->length
);
2117 /* Update initializer character length according to symbol. */
2118 else if (sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
2119 && !fix_initializer_charlen (&sym
->ts
, init
))
2123 if (sym
->attr
.flavor
== FL_PARAMETER
&& sym
->attr
.dimension
&& sym
->as
2124 && sym
->as
->rank
&& init
->rank
&& init
->rank
!= sym
->as
->rank
)
2126 gfc_error ("Rank mismatch of array at %L and its initializer "
2127 "(%d/%d)", &sym
->declared_at
, sym
->as
->rank
, init
->rank
);
2131 /* If sym is implied-shape, set its upper bounds from init. */
2132 if (sym
->attr
.flavor
== FL_PARAMETER
&& sym
->attr
.dimension
2133 && sym
->as
->type
== AS_IMPLIED_SHAPE
)
2137 if (init
->rank
== 0)
2139 gfc_error ("Cannot initialize implied-shape array at %L"
2140 " with scalar", &sym
->declared_at
);
2144 /* The shape may be NULL for EXPR_ARRAY, set it. */
2145 if (init
->shape
== NULL
)
2147 if (init
->expr_type
!= EXPR_ARRAY
)
2149 gfc_error ("Bad shape of initializer at %L", &init
->where
);
2153 init
->shape
= gfc_get_shape (1);
2154 if (!gfc_array_size (init
, &init
->shape
[0]))
2156 gfc_error ("Cannot determine shape of initializer at %L",
2164 for (dim
= 0; dim
< sym
->as
->rank
; ++dim
)
2167 gfc_expr
*e
, *lower
;
2169 lower
= sym
->as
->lower
[dim
];
2171 /* If the lower bound is an array element from another
2172 parameterized array, then it is marked with EXPR_VARIABLE and
2173 is an initialization expression. Try to reduce it. */
2174 if (lower
->expr_type
== EXPR_VARIABLE
)
2175 gfc_reduce_init_expr (lower
);
2177 if (lower
->expr_type
== EXPR_CONSTANT
)
2179 /* All dimensions must be without upper bound. */
2180 gcc_assert (!sym
->as
->upper
[dim
]);
2183 e
= gfc_get_constant_expr (BT_INTEGER
, k
, &sym
->declared_at
);
2184 mpz_add (e
->value
.integer
, lower
->value
.integer
,
2186 mpz_sub_ui (e
->value
.integer
, e
->value
.integer
, 1);
2187 sym
->as
->upper
[dim
] = e
;
2191 gfc_error ("Non-constant lower bound in implied-shape"
2192 " declaration at %L", &lower
->where
);
2197 sym
->as
->type
= AS_EXPLICIT
;
2200 /* Ensure that explicit bounds are simplified. */
2201 if (sym
->attr
.flavor
== FL_PARAMETER
&& sym
->attr
.dimension
2202 && sym
->as
->type
== AS_EXPLICIT
)
2204 for (int dim
= 0; dim
< sym
->as
->rank
; ++dim
)
2208 e
= sym
->as
->lower
[dim
];
2209 if (e
->expr_type
!= EXPR_CONSTANT
)
2210 gfc_reduce_init_expr (e
);
2212 e
= sym
->as
->upper
[dim
];
2213 if (e
->expr_type
!= EXPR_CONSTANT
)
2214 gfc_reduce_init_expr (e
);
2218 /* Need to check if the expression we initialized this
2219 to was one of the iso_c_binding named constants. If so,
2220 and we're a parameter (constant), let it be iso_c.
2222 integer(c_int), parameter :: my_int = c_int
2223 integer(my_int) :: my_int_2
2224 If we mark my_int as iso_c (since we can see it's value
2225 is equal to one of the named constants), then my_int_2
2226 will be considered C interoperable. */
2227 if (sym
->ts
.type
!= BT_CHARACTER
&& !gfc_bt_struct (sym
->ts
.type
))
2229 sym
->ts
.is_iso_c
|= init
->ts
.is_iso_c
;
2230 sym
->ts
.is_c_interop
|= init
->ts
.is_c_interop
;
2231 /* attr bits needed for module files. */
2232 sym
->attr
.is_iso_c
|= init
->ts
.is_iso_c
;
2233 sym
->attr
.is_c_interop
|= init
->ts
.is_c_interop
;
2234 if (init
->ts
.is_iso_c
)
2235 sym
->ts
.f90_type
= init
->ts
.f90_type
;
2238 /* Catch the case: type(t), parameter :: x = z'1'. */
2239 if (sym
->ts
.type
== BT_DERIVED
&& init
->ts
.type
== BT_BOZ
)
2241 gfc_error ("Entity %qs at %L is incompatible with a BOZ "
2242 "literal constant", name
, &sym
->declared_at
);
2246 /* Add initializer. Make sure we keep the ranks sane. */
2247 if (sym
->attr
.dimension
&& init
->rank
== 0)
2252 if (sym
->attr
.flavor
== FL_PARAMETER
2253 && gfc_is_constant_expr (init
)
2254 && (init
->expr_type
== EXPR_CONSTANT
2255 || init
->expr_type
== EXPR_STRUCTURE
)
2256 && spec_size (sym
->as
, &size
))
2258 array
= gfc_get_array_expr (init
->ts
.type
, init
->ts
.kind
,
2260 if (init
->ts
.type
== BT_DERIVED
)
2261 array
->ts
.u
.derived
= init
->ts
.u
.derived
;
2262 for (n
= 0; n
< (int)mpz_get_si (size
); n
++)
2263 gfc_constructor_append_expr (&array
->value
.constructor
,
2266 : gfc_copy_expr (init
),
2269 array
->shape
= gfc_get_shape (sym
->as
->rank
);
2270 for (n
= 0; n
< sym
->as
->rank
; n
++)
2271 spec_dimen_size (sym
->as
, n
, &array
->shape
[n
]);
2276 init
->rank
= sym
->as
->rank
;
2280 if (sym
->attr
.save
== SAVE_NONE
)
2281 sym
->attr
.save
= SAVE_IMPLICIT
;
2289 /* Function called by variable_decl() that adds a name to a structure
2293 build_struct (const char *name
, gfc_charlen
*cl
, gfc_expr
**init
,
2294 gfc_array_spec
**as
)
2299 /* F03:C438/C439. If the current symbol is of the same derived type that we're
2300 constructing, it must have the pointer attribute. */
2301 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
2302 && current_ts
.u
.derived
== gfc_current_block ()
2303 && current_attr
.pointer
== 0)
2305 if (current_attr
.allocatable
2306 && !gfc_notify_std(GFC_STD_F2008
, "Component at %C "
2307 "must have the POINTER attribute"))
2311 else if (current_attr
.allocatable
== 0)
2313 gfc_error ("Component at %C must have the POINTER attribute");
2319 if (current_ts
.type
== BT_CLASS
2320 && !(current_attr
.pointer
|| current_attr
.allocatable
))
2322 gfc_error ("Component %qs with CLASS at %C must be allocatable "
2323 "or pointer", name
);
2327 if (gfc_current_block ()->attr
.pointer
&& (*as
)->rank
!= 0)
2329 if ((*as
)->type
!= AS_DEFERRED
&& (*as
)->type
!= AS_EXPLICIT
)
2331 gfc_error ("Array component of structure at %C must have explicit "
2332 "or deferred shape");
2337 /* If we are in a nested union/map definition, gfc_add_component will not
2338 properly find repeated components because:
2339 (i) gfc_add_component does a flat search, where components of unions
2340 and maps are implicity chained so nested components may conflict.
2341 (ii) Unions and maps are not linked as components of their parent
2342 structures until after they are parsed.
2343 For (i) we use gfc_find_component which searches recursively, and for (ii)
2344 we search each block directly from the parse stack until we find the top
2347 s
= gfc_state_stack
;
2348 if (s
->state
== COMP_UNION
|| s
->state
== COMP_MAP
)
2350 while (s
->state
== COMP_UNION
|| gfc_comp_struct (s
->state
))
2352 c
= gfc_find_component (s
->sym
, name
, true, true, NULL
);
2355 gfc_error_now ("Component %qs at %C already declared at %L",
2359 /* Break after we've searched the entire chain. */
2360 if (s
->state
== COMP_DERIVED
|| s
->state
== COMP_STRUCTURE
)
2366 if (!gfc_add_component (gfc_current_block(), name
, &c
))
2370 if (c
->ts
.type
== BT_CHARACTER
)
2373 if (c
->ts
.type
!= BT_CLASS
&& c
->ts
.type
!= BT_DERIVED
2374 && (c
->ts
.kind
== 0 || c
->ts
.type
== BT_CHARACTER
)
2375 && saved_kind_expr
!= NULL
)
2376 c
->kind_expr
= gfc_copy_expr (saved_kind_expr
);
2378 c
->attr
= current_attr
;
2380 c
->initializer
= *init
;
2383 /* Update initializer character length according to component. */
2384 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.u
.cl
->length
2385 && c
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
2386 && c
->initializer
&& c
->initializer
->ts
.type
== BT_CHARACTER
2387 && !fix_initializer_charlen (&c
->ts
, c
->initializer
))
2394 c
->attr
.codimension
= 1;
2396 c
->attr
.dimension
= 1;
2400 gfc_apply_init (&c
->ts
, &c
->attr
, c
->initializer
);
2402 /* Check array components. */
2403 if (!c
->attr
.dimension
)
2406 if (c
->attr
.pointer
)
2408 if (c
->as
->type
!= AS_DEFERRED
)
2410 gfc_error ("Pointer array component of structure at %C must have a "
2415 else if (c
->attr
.allocatable
)
2417 if (c
->as
->type
!= AS_DEFERRED
)
2419 gfc_error ("Allocatable component of structure at %C must have a "
2426 if (c
->as
->type
!= AS_EXPLICIT
)
2428 gfc_error ("Array component of structure at %C must have an "
2435 if (c
->ts
.type
== BT_CLASS
)
2436 return gfc_build_class_symbol (&c
->ts
, &c
->attr
, &c
->as
);
2438 if (c
->attr
.pdt_kind
|| c
->attr
.pdt_len
)
2441 gfc_find_symbol (c
->name
, gfc_current_block ()->f2k_derived
,
2445 gfc_error ("Type parameter %qs at %C has no corresponding entry "
2446 "in the type parameter name list at %L",
2447 c
->name
, &gfc_current_block ()->declared_at
);
2451 sym
->attr
.pdt_kind
= c
->attr
.pdt_kind
;
2452 sym
->attr
.pdt_len
= c
->attr
.pdt_len
;
2454 sym
->value
= gfc_copy_expr (c
->initializer
);
2455 sym
->attr
.flavor
= FL_VARIABLE
;
2458 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
2459 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_template
2460 && decl_type_param_list
)
2461 c
->param_list
= gfc_copy_actual_arglist (decl_type_param_list
);
2467 /* Match a 'NULL()', and possibly take care of some side effects. */
2470 gfc_match_null (gfc_expr
**result
)
2473 match m
, m2
= MATCH_NO
;
2475 if ((m
= gfc_match (" null ( )")) == MATCH_ERROR
)
2481 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2483 if ((m2
= gfc_match (" null (")) != MATCH_YES
)
2486 old_loc
= gfc_current_locus
;
2487 if ((m2
= gfc_match (" %n ) ", name
)) == MATCH_ERROR
)
2490 && ((m2
= gfc_match (" mold = %n )", name
)) == MATCH_ERROR
))
2494 gfc_current_locus
= old_loc
;
2499 /* The NULL symbol now has to be/become an intrinsic function. */
2500 if (gfc_get_symbol ("null", NULL
, &sym
))
2502 gfc_error ("NULL() initialization at %C is ambiguous");
2506 gfc_intrinsic_symbol (sym
);
2508 if (sym
->attr
.proc
!= PROC_INTRINSIC
2509 && !(sym
->attr
.use_assoc
&& sym
->attr
.intrinsic
)
2510 && (!gfc_add_procedure(&sym
->attr
, PROC_INTRINSIC
, sym
->name
, NULL
)
2511 || !gfc_add_function (&sym
->attr
, sym
->name
, NULL
)))
2514 *result
= gfc_get_null_expr (&gfc_current_locus
);
2516 /* Invalid per F2008, C512. */
2517 if (m2
== MATCH_YES
)
2519 gfc_error ("NULL() initialization at %C may not have MOLD");
2527 /* Match the initialization expr for a data pointer or procedure pointer. */
2530 match_pointer_init (gfc_expr
**init
, int procptr
)
2534 if (gfc_pure (NULL
) && !gfc_comp_struct (gfc_state_stack
->state
))
2536 gfc_error ("Initialization of pointer at %C is not allowed in "
2537 "a PURE procedure");
2540 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
2542 /* Match NULL() initialization. */
2543 m
= gfc_match_null (init
);
2547 /* Match non-NULL initialization. */
2548 gfc_matching_ptr_assignment
= !procptr
;
2549 gfc_matching_procptr_assignment
= procptr
;
2550 m
= gfc_match_rvalue (init
);
2551 gfc_matching_ptr_assignment
= 0;
2552 gfc_matching_procptr_assignment
= 0;
2553 if (m
== MATCH_ERROR
)
2555 else if (m
== MATCH_NO
)
2557 gfc_error ("Error in pointer initialization at %C");
2561 if (!procptr
&& !gfc_resolve_expr (*init
))
2564 if (!gfc_notify_std (GFC_STD_F2008
, "non-NULL pointer "
2565 "initialization at %C"))
2573 check_function_name (char *name
)
2575 /* In functions that have a RESULT variable defined, the function name always
2576 refers to function calls. Therefore, the name is not allowed to appear in
2577 specification statements. When checking this, be careful about
2578 'hidden' procedure pointer results ('ppr@'). */
2580 if (gfc_current_state () == COMP_FUNCTION
)
2582 gfc_symbol
*block
= gfc_current_block ();
2583 if (block
&& block
->result
&& block
->result
!= block
2584 && strcmp (block
->result
->name
, "ppr@") != 0
2585 && strcmp (block
->name
, name
) == 0)
2587 gfc_error ("RESULT variable %qs at %L prohibits FUNCTION name %qs at %C "
2588 "from appearing in a specification statement",
2589 block
->result
->name
, &block
->result
->declared_at
, name
);
2598 /* Match a variable name with an optional initializer. When this
2599 subroutine is called, a variable is expected to be parsed next.
2600 Depending on what is happening at the moment, updates either the
2601 symbol table or the current interface. */
2604 variable_decl (int elem
)
2606 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2607 static unsigned int fill_id
= 0;
2608 gfc_expr
*initializer
, *char_len
;
2610 gfc_array_spec
*cp_as
; /* Extra copy for Cray Pointees. */
2623 /* When we get here, we've just matched a list of attributes and
2624 maybe a type and a double colon. The next thing we expect to see
2625 is the name of the symbol. */
2627 /* If we are parsing a structure with legacy support, we allow the symbol
2628 name to be '%FILL' which gives it an anonymous (inaccessible) name. */
2630 gfc_gobble_whitespace ();
2631 c
= gfc_peek_ascii_char ();
2634 gfc_next_ascii_char (); /* Burn % character. */
2635 m
= gfc_match ("fill");
2638 if (gfc_current_state () != COMP_STRUCTURE
)
2640 if (flag_dec_structure
)
2641 gfc_error ("%qs not allowed outside STRUCTURE at %C", "%FILL");
2643 gfc_error ("%qs at %C is a DEC extension, enable with "
2644 "%<-fdec-structure%>", "%FILL");
2651 gfc_error ("%qs entity cannot have attributes at %C", "%FILL");
2656 /* %FILL components are given invalid fortran names. */
2657 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "%%FILL%u", fill_id
++);
2661 gfc_error ("Invalid character %qc in variable name at %C", c
);
2667 m
= gfc_match_name (name
);
2672 var_locus
= gfc_current_locus
;
2674 /* Now we could see the optional array spec. or character length. */
2675 m
= gfc_match_array_spec (&as
, true, true);
2676 if (m
== MATCH_ERROR
)
2680 as
= gfc_copy_array_spec (current_as
);
2682 && !merge_array_spec (current_as
, as
, true))
2688 if (flag_cray_pointer
)
2689 cp_as
= gfc_copy_array_spec (as
);
2691 /* At this point, we know for sure if the symbol is PARAMETER and can thus
2692 determine (and check) whether it can be implied-shape. If it
2693 was parsed as assumed-size, change it because PARAMETERs cannot
2696 An explicit-shape-array cannot appear under several conditions.
2697 That check is done here as well. */
2700 if (as
->type
== AS_IMPLIED_SHAPE
&& current_attr
.flavor
!= FL_PARAMETER
)
2703 gfc_error ("Non-PARAMETER symbol %qs at %L cannot be implied-shape",
2708 if (as
->type
== AS_ASSUMED_SIZE
&& as
->rank
== 1
2709 && current_attr
.flavor
== FL_PARAMETER
)
2710 as
->type
= AS_IMPLIED_SHAPE
;
2712 if (as
->type
== AS_IMPLIED_SHAPE
2713 && !gfc_notify_std (GFC_STD_F2008
, "Implied-shape array at %L",
2720 gfc_seen_div0
= false;
2722 /* F2018:C830 (R816) An explicit-shape-spec whose bounds are not
2723 constant expressions shall appear only in a subprogram, derived
2724 type definition, BLOCK construct, or interface body. */
2725 if (as
->type
== AS_EXPLICIT
2726 && gfc_current_state () != COMP_BLOCK
2727 && gfc_current_state () != COMP_DERIVED
2728 && gfc_current_state () != COMP_FUNCTION
2729 && gfc_current_state () != COMP_INTERFACE
2730 && gfc_current_state () != COMP_SUBROUTINE
)
2733 bool not_constant
= false;
2735 for (int i
= 0; i
< as
->rank
; i
++)
2737 e
= gfc_copy_expr (as
->lower
[i
]);
2738 if (!gfc_resolve_expr (e
) && gfc_seen_div0
)
2744 gfc_simplify_expr (e
, 0);
2745 if (e
&& (e
->expr_type
!= EXPR_CONSTANT
))
2747 not_constant
= true;
2752 e
= gfc_copy_expr (as
->upper
[i
]);
2753 if (!gfc_resolve_expr (e
) && gfc_seen_div0
)
2759 gfc_simplify_expr (e
, 0);
2760 if (e
&& (e
->expr_type
!= EXPR_CONSTANT
))
2762 not_constant
= true;
2768 if (not_constant
&& e
->ts
.type
!= BT_INTEGER
)
2770 gfc_error ("Explicit array shape at %C must be constant of "
2771 "INTEGER type and not %s type",
2772 gfc_basic_typename (e
->ts
.type
));
2778 gfc_error ("Explicit shaped array with nonconstant bounds at %C");
2783 if (as
->type
== AS_EXPLICIT
)
2785 for (int i
= 0; i
< as
->rank
; i
++)
2789 if (e
->expr_type
!= EXPR_CONSTANT
)
2791 n
= gfc_copy_expr (e
);
2792 if (!gfc_simplify_expr (n
, 1) && gfc_seen_div0
)
2798 if (n
->expr_type
== EXPR_CONSTANT
)
2799 gfc_replace_expr (e
, n
);
2804 if (e
->expr_type
!= EXPR_CONSTANT
)
2806 n
= gfc_copy_expr (e
);
2807 if (!gfc_simplify_expr (n
, 1) && gfc_seen_div0
)
2813 if (n
->expr_type
== EXPR_CONSTANT
)
2814 gfc_replace_expr (e
, n
);
2818 /* For an explicit-shape spec with constant bounds, ensure
2819 that the effective upper bound is not lower than the
2820 respective lower bound minus one. Otherwise adjust it so
2821 that the extent is trivially derived to be zero. */
2822 if (as
->lower
[i
]->expr_type
== EXPR_CONSTANT
2823 && as
->upper
[i
]->expr_type
== EXPR_CONSTANT
2824 && as
->lower
[i
]->ts
.type
== BT_INTEGER
2825 && as
->upper
[i
]->ts
.type
== BT_INTEGER
2826 && mpz_cmp (as
->upper
[i
]->value
.integer
,
2827 as
->lower
[i
]->value
.integer
) < 0)
2828 mpz_sub_ui (as
->upper
[i
]->value
.integer
,
2829 as
->lower
[i
]->value
.integer
, 1);
2836 cl_deferred
= false;
2838 if (current_ts
.type
== BT_CHARACTER
)
2840 switch (match_char_length (&char_len
, &cl_deferred
, false))
2843 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2845 cl
->length
= char_len
;
2848 /* Non-constant lengths need to be copied after the first
2849 element. Also copy assumed lengths. */
2852 && (current_ts
.u
.cl
->length
== NULL
2853 || current_ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
2855 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2856 cl
->length
= gfc_copy_expr (current_ts
.u
.cl
->length
);
2859 cl
= current_ts
.u
.cl
;
2861 cl_deferred
= current_ts
.deferred
;
2870 /* The dummy arguments and result of the abbreviated form of MODULE
2871 PROCEDUREs, used in SUBMODULES should not be redefined. */
2872 if (gfc_current_ns
->proc_name
2873 && gfc_current_ns
->proc_name
->abr_modproc_decl
)
2875 gfc_find_symbol (name
, gfc_current_ns
, 1, &sym
);
2876 if (sym
!= NULL
&& (sym
->attr
.dummy
|| sym
->attr
.result
))
2879 gfc_error ("%qs at %C is a redefinition of the declaration "
2880 "in the corresponding interface for MODULE "
2881 "PROCEDURE %qs", sym
->name
,
2882 gfc_current_ns
->proc_name
->name
);
2887 /* %FILL components may not have initializers. */
2888 if (startswith (name
, "%FILL") && gfc_match_eos () != MATCH_YES
)
2890 gfc_error ("%qs entity cannot have an initializer at %C", "%FILL");
2895 /* If this symbol has already shown up in a Cray Pointer declaration,
2896 and this is not a component declaration,
2897 then we want to set the type & bail out. */
2898 if (flag_cray_pointer
&& !gfc_comp_struct (gfc_current_state ()))
2900 gfc_find_symbol (name
, gfc_current_ns
, 0, &sym
);
2901 if (sym
!= NULL
&& sym
->attr
.cray_pointee
)
2904 if (!gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
2910 /* Check to see if we have an array specification. */
2913 if (sym
->as
!= NULL
)
2915 gfc_error ("Duplicate array spec for Cray pointee at %C");
2916 gfc_free_array_spec (cp_as
);
2922 if (!gfc_set_array_spec (sym
, cp_as
, &var_locus
))
2923 gfc_internal_error ("Cannot set pointee array spec.");
2925 /* Fix the array spec. */
2926 m
= gfc_mod_pointee_as (sym
->as
);
2927 if (m
== MATCH_ERROR
)
2935 gfc_free_array_spec (cp_as
);
2939 /* Procedure pointer as function result. */
2940 if (gfc_current_state () == COMP_FUNCTION
2941 && strcmp ("ppr@", gfc_current_block ()->name
) == 0
2942 && strcmp (name
, gfc_current_block ()->ns
->proc_name
->name
) == 0)
2943 strcpy (name
, "ppr@");
2945 if (gfc_current_state () == COMP_FUNCTION
2946 && strcmp (name
, gfc_current_block ()->name
) == 0
2947 && gfc_current_block ()->result
2948 && strcmp ("ppr@", gfc_current_block ()->result
->name
) == 0)
2949 strcpy (name
, "ppr@");
2951 /* OK, we've successfully matched the declaration. Now put the
2952 symbol in the current namespace, because it might be used in the
2953 optional initialization expression for this symbol, e.g. this is
2956 integer, parameter :: i = huge(i)
2958 This is only true for parameters or variables of a basic type.
2959 For components of derived types, it is not true, so we don't
2960 create a symbol for those yet. If we fail to create the symbol,
2962 if (!gfc_comp_struct (gfc_current_state ())
2963 && !build_sym (name
, cl
, cl_deferred
, &as
, &var_locus
))
2969 if (!check_function_name (name
))
2975 /* We allow old-style initializations of the form
2976 integer i /2/, j(4) /3*3, 1/
2977 (if no colon has been seen). These are different from data
2978 statements in that initializers are only allowed to apply to the
2979 variable immediately preceding, i.e.
2981 is not allowed. Therefore we have to do some work manually, that
2982 could otherwise be left to the matchers for DATA statements. */
2984 if (!colon_seen
&& gfc_match (" /") == MATCH_YES
)
2986 if (!gfc_notify_std (GFC_STD_GNU
, "Old-style "
2987 "initialization at %C"))
2990 /* Allow old style initializations for components of STRUCTUREs and MAPs
2991 but not components of derived types. */
2992 else if (gfc_current_state () == COMP_DERIVED
)
2994 gfc_error ("Invalid old style initialization for derived type "
3000 /* For structure components, read the initializer as a special
3001 expression and let the rest of this function apply the initializer
3003 else if (gfc_comp_struct (gfc_current_state ()))
3005 m
= match_clist_expr (&initializer
, ¤t_ts
, as
);
3007 gfc_error ("Syntax error in old style initialization of %s at %C",
3013 /* Otherwise we treat the old style initialization just like a
3014 DATA declaration for the current variable. */
3016 return match_old_style_init (name
);
3019 /* The double colon must be present in order to have initializers.
3020 Otherwise the statement is ambiguous with an assignment statement. */
3023 if (gfc_match (" =>") == MATCH_YES
)
3025 if (!current_attr
.pointer
)
3027 gfc_error ("Initialization at %C isn't for a pointer variable");
3032 m
= match_pointer_init (&initializer
, 0);
3036 /* The target of a pointer initialization must have the SAVE
3037 attribute. A variable in PROGRAM, MODULE, or SUBMODULE scope
3038 is implicit SAVEd. Explicitly, set the SAVE_IMPLICIT value. */
3039 if (initializer
->expr_type
== EXPR_VARIABLE
3040 && initializer
->symtree
->n
.sym
->attr
.save
== SAVE_NONE
3041 && (gfc_current_state () == COMP_PROGRAM
3042 || gfc_current_state () == COMP_MODULE
3043 || gfc_current_state () == COMP_SUBMODULE
))
3044 initializer
->symtree
->n
.sym
->attr
.save
= SAVE_IMPLICIT
;
3046 else if (gfc_match_char ('=') == MATCH_YES
)
3048 if (current_attr
.pointer
)
3050 gfc_error ("Pointer initialization at %C requires %<=>%>, "
3056 m
= gfc_match_init_expr (&initializer
);
3059 gfc_error ("Expected an initialization expression at %C");
3063 if (current_attr
.flavor
!= FL_PARAMETER
&& gfc_pure (NULL
)
3064 && !gfc_comp_struct (gfc_state_stack
->state
))
3066 gfc_error ("Initialization of variable at %C is not allowed in "
3067 "a PURE procedure");
3071 if (current_attr
.flavor
!= FL_PARAMETER
3072 && !gfc_comp_struct (gfc_state_stack
->state
))
3073 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
3080 if (initializer
!= NULL
&& current_attr
.allocatable
3081 && gfc_comp_struct (gfc_current_state ()))
3083 gfc_error ("Initialization of allocatable component at %C is not "
3089 if (gfc_current_state () == COMP_DERIVED
3090 && initializer
&& initializer
->ts
.type
== BT_HOLLERITH
)
3092 gfc_error ("Initialization of structure component with a HOLLERITH "
3093 "constant at %L is not allowed", &initializer
->where
);
3098 if (gfc_current_state () == COMP_DERIVED
3099 && gfc_current_block ()->attr
.pdt_template
)
3102 gfc_find_symbol (name
, gfc_current_block ()->f2k_derived
,
3104 if (!param
&& (current_attr
.pdt_kind
|| current_attr
.pdt_len
))
3106 gfc_error ("The component with KIND or LEN attribute at %C does not "
3107 "not appear in the type parameter list at %L",
3108 &gfc_current_block ()->declared_at
);
3112 else if (param
&& !(current_attr
.pdt_kind
|| current_attr
.pdt_len
))
3114 gfc_error ("The component at %C that appears in the type parameter "
3115 "list at %L has neither the KIND nor LEN attribute",
3116 &gfc_current_block ()->declared_at
);
3120 else if (as
&& (current_attr
.pdt_kind
|| current_attr
.pdt_len
))
3122 gfc_error ("The component at %C which is a type parameter must be "
3127 else if (param
&& initializer
)
3129 if (initializer
->ts
.type
== BT_BOZ
)
3131 gfc_error ("BOZ literal constant at %L cannot appear as an "
3132 "initializer", &initializer
->where
);
3136 param
->value
= gfc_copy_expr (initializer
);
3140 /* Before adding a possible initializer, do a simple check for compatibility
3141 of lhs and rhs types. Assigning a REAL value to a derived type is not a
3143 if (current_ts
.type
== BT_DERIVED
&& initializer
3144 && (gfc_numeric_ts (&initializer
->ts
)
3145 || initializer
->ts
.type
== BT_LOGICAL
3146 || initializer
->ts
.type
== BT_CHARACTER
))
3148 gfc_error ("Incompatible initialization between a derived type "
3149 "entity and an entity with %qs type at %C",
3150 gfc_typename (initializer
));
3156 /* Add the initializer. Note that it is fine if initializer is
3157 NULL here, because we sometimes also need to check if a
3158 declaration *must* have an initialization expression. */
3159 if (!gfc_comp_struct (gfc_current_state ()))
3160 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
3163 if (current_ts
.type
== BT_DERIVED
3164 && !current_attr
.pointer
&& !initializer
)
3165 initializer
= gfc_default_initializer (¤t_ts
);
3166 t
= build_struct (name
, cl
, &initializer
, &as
);
3168 /* If we match a nested structure definition we expect to see the
3169 * body even if the variable declarations blow up, so we need to keep
3170 * the structure declaration around. */
3171 if (gfc_new_block
&& gfc_new_block
->attr
.flavor
== FL_STRUCT
)
3172 gfc_commit_symbol (gfc_new_block
);
3175 m
= (t
) ? MATCH_YES
: MATCH_ERROR
;
3178 /* Free stuff up and return. */
3179 gfc_seen_div0
= false;
3180 gfc_free_expr (initializer
);
3181 gfc_free_array_spec (as
);
3187 /* Match an extended-f77 "TYPESPEC*bytesize"-style kind specification.
3188 This assumes that the byte size is equal to the kind number for
3189 non-COMPLEX types, and equal to twice the kind number for COMPLEX. */
3192 gfc_match_old_kind_spec (gfc_typespec
*ts
)
3197 if (gfc_match_char ('*') != MATCH_YES
)
3200 m
= gfc_match_small_literal_int (&ts
->kind
, NULL
);
3204 original_kind
= ts
->kind
;
3206 /* Massage the kind numbers for complex types. */
3207 if (ts
->type
== BT_COMPLEX
)
3211 gfc_error ("Old-style type declaration %s*%d not supported at %C",
3212 gfc_basic_typename (ts
->type
), original_kind
);
3219 if (ts
->type
== BT_INTEGER
&& ts
->kind
== 4 && flag_integer4_kind
== 8)
3222 if (ts
->type
== BT_REAL
|| ts
->type
== BT_COMPLEX
)
3226 if (flag_real4_kind
== 8)
3228 if (flag_real4_kind
== 10)
3230 if (flag_real4_kind
== 16)
3233 else if (ts
->kind
== 8)
3235 if (flag_real8_kind
== 4)
3237 if (flag_real8_kind
== 10)
3239 if (flag_real8_kind
== 16)
3244 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
3246 gfc_error ("Old-style type declaration %s*%d not supported at %C",
3247 gfc_basic_typename (ts
->type
), original_kind
);
3251 if (!gfc_notify_std (GFC_STD_GNU
,
3252 "Nonstandard type declaration %s*%d at %C",
3253 gfc_basic_typename(ts
->type
), original_kind
))
3260 /* Match a kind specification. Since kinds are generally optional, we
3261 usually return MATCH_NO if something goes wrong. If a "kind="
3262 string is found, then we know we have an error. */
3265 gfc_match_kind_spec (gfc_typespec
*ts
, bool kind_expr_only
)
3275 saved_kind_expr
= NULL
;
3277 where
= loc
= gfc_current_locus
;
3282 if (gfc_match_char ('(') == MATCH_NO
)
3285 /* Also gobbles optional text. */
3286 if (gfc_match (" kind = ") == MATCH_YES
)
3289 loc
= gfc_current_locus
;
3293 n
= gfc_match_init_expr (&e
);
3295 if (gfc_derived_parameter_expr (e
))
3298 saved_kind_expr
= gfc_copy_expr (e
);
3299 goto close_brackets
;
3304 if (gfc_matching_function
)
3306 /* The function kind expression might include use associated or
3307 imported parameters and try again after the specification
3309 if (gfc_match_char (')') != MATCH_YES
)
3311 gfc_error ("Missing right parenthesis at %C");
3317 gfc_undo_symbols ();
3322 /* ....or else, the match is real. */
3324 gfc_error ("Expected initialization expression at %C");
3332 gfc_error ("Expected scalar initialization expression at %C");
3337 if (gfc_extract_int (e
, &ts
->kind
, 1))
3343 /* Before throwing away the expression, let's see if we had a
3344 C interoperable kind (and store the fact). */
3345 if (e
->ts
.is_c_interop
== 1)
3347 /* Mark this as C interoperable if being declared with one
3348 of the named constants from iso_c_binding. */
3349 ts
->is_c_interop
= e
->ts
.is_iso_c
;
3350 ts
->f90_type
= e
->ts
.f90_type
;
3352 ts
->interop_kind
= e
->symtree
->n
.sym
;
3358 /* Ignore errors to this point, if we've gotten here. This means
3359 we ignore the m=MATCH_ERROR from above. */
3360 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
3362 gfc_error ("Kind %d not supported for type %s at %C", ts
->kind
,
3363 gfc_basic_typename (ts
->type
));
3364 gfc_current_locus
= where
;
3368 /* Warn if, e.g., c_int is used for a REAL variable, but not
3369 if, e.g., c_double is used for COMPLEX as the standard
3370 explicitly says that the kind type parameter for complex and real
3371 variable is the same, i.e. c_float == c_float_complex. */
3372 if (ts
->f90_type
!= BT_UNKNOWN
&& ts
->f90_type
!= ts
->type
3373 && !((ts
->f90_type
== BT_REAL
&& ts
->type
== BT_COMPLEX
)
3374 || (ts
->f90_type
== BT_COMPLEX
&& ts
->type
== BT_REAL
)))
3375 gfc_warning_now (0, "C kind type parameter is for type %s but type at %L "
3376 "is %s", gfc_basic_typename (ts
->f90_type
), &where
,
3377 gfc_basic_typename (ts
->type
));
3381 gfc_gobble_whitespace ();
3382 if ((c
= gfc_next_ascii_char ()) != ')'
3383 && (ts
->type
!= BT_CHARACTER
|| c
!= ','))
3385 if (ts
->type
== BT_CHARACTER
)
3386 gfc_error ("Missing right parenthesis or comma at %C");
3388 gfc_error ("Missing right parenthesis at %C");
3393 /* All tests passed. */
3396 if(m
== MATCH_ERROR
)
3397 gfc_current_locus
= where
;
3399 if (ts
->type
== BT_INTEGER
&& ts
->kind
== 4 && flag_integer4_kind
== 8)
3402 if (ts
->type
== BT_REAL
|| ts
->type
== BT_COMPLEX
)
3406 if (flag_real4_kind
== 8)
3408 if (flag_real4_kind
== 10)
3410 if (flag_real4_kind
== 16)
3413 else if (ts
->kind
== 8)
3415 if (flag_real8_kind
== 4)
3417 if (flag_real8_kind
== 10)
3419 if (flag_real8_kind
== 16)
3424 /* Return what we know from the test(s). */
3429 gfc_current_locus
= where
;
3435 match_char_kind (int * kind
, int * is_iso_c
)
3444 where
= gfc_current_locus
;
3446 n
= gfc_match_init_expr (&e
);
3448 if (n
!= MATCH_YES
&& gfc_matching_function
)
3450 /* The expression might include use-associated or imported
3451 parameters and try again after the specification
3454 gfc_undo_symbols ();
3459 gfc_error ("Expected initialization expression at %C");
3465 gfc_error ("Expected scalar initialization expression at %C");
3470 if (gfc_derived_parameter_expr (e
))
3472 saved_kind_expr
= e
;
3477 fail
= gfc_extract_int (e
, kind
, 1);
3478 *is_iso_c
= e
->ts
.is_iso_c
;
3487 /* Ignore errors to this point, if we've gotten here. This means
3488 we ignore the m=MATCH_ERROR from above. */
3489 if (gfc_validate_kind (BT_CHARACTER
, *kind
, true) < 0)
3491 gfc_error ("Kind %d is not supported for CHARACTER at %C", *kind
);
3495 /* All tests passed. */
3498 if (m
== MATCH_ERROR
)
3499 gfc_current_locus
= where
;
3501 /* Return what we know from the test(s). */
3506 gfc_current_locus
= where
;
3511 /* Match the various kind/length specifications in a CHARACTER
3512 declaration. We don't return MATCH_NO. */
3515 gfc_match_char_spec (gfc_typespec
*ts
)
3517 int kind
, seen_length
, is_iso_c
;
3529 /* Try the old-style specification first. */
3530 old_char_selector
= 0;
3532 m
= match_char_length (&len
, &deferred
, true);
3536 old_char_selector
= 1;
3541 m
= gfc_match_char ('(');
3544 m
= MATCH_YES
; /* Character without length is a single char. */
3548 /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ). */
3549 if (gfc_match (" kind =") == MATCH_YES
)
3551 m
= match_char_kind (&kind
, &is_iso_c
);
3553 if (m
== MATCH_ERROR
)
3558 if (gfc_match (" , len =") == MATCH_NO
)
3561 m
= char_len_param_value (&len
, &deferred
);
3564 if (m
== MATCH_ERROR
)
3571 /* Try to match "LEN = <len-param>" or "LEN = <len-param>, KIND = <int>". */
3572 if (gfc_match (" len =") == MATCH_YES
)
3574 m
= char_len_param_value (&len
, &deferred
);
3577 if (m
== MATCH_ERROR
)
3581 if (gfc_match_char (')') == MATCH_YES
)
3584 if (gfc_match (" , kind =") != MATCH_YES
)
3587 if (match_char_kind (&kind
, &is_iso_c
) == MATCH_ERROR
)
3593 /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ). */
3594 m
= char_len_param_value (&len
, &deferred
);
3597 if (m
== MATCH_ERROR
)
3601 m
= gfc_match_char (')');
3605 if (gfc_match_char (',') != MATCH_YES
)
3608 gfc_match (" kind ="); /* Gobble optional text. */
3610 m
= match_char_kind (&kind
, &is_iso_c
);
3611 if (m
== MATCH_ERROR
)
3617 /* Require a right-paren at this point. */
3618 m
= gfc_match_char (')');
3623 gfc_error ("Syntax error in CHARACTER declaration at %C");
3625 gfc_free_expr (len
);
3629 /* Deal with character functions after USE and IMPORT statements. */
3630 if (gfc_matching_function
)
3632 gfc_free_expr (len
);
3633 gfc_undo_symbols ();
3639 gfc_free_expr (len
);
3643 /* Do some final massaging of the length values. */
3644 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
3646 if (seen_length
== 0)
3647 cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
, 1);
3650 /* If gfortran ends up here, then len may be reducible to a constant.
3651 Try to do that here. If it does not reduce, simply assign len to
3652 charlen. A complication occurs with user-defined generic functions,
3653 which are not resolved. Use a private namespace to deal with
3654 generic functions. */
3656 if (len
&& len
->expr_type
!= EXPR_CONSTANT
)
3658 gfc_namespace
*old_ns
;
3661 old_ns
= gfc_current_ns
;
3662 gfc_current_ns
= gfc_get_namespace (NULL
, 0);
3664 e
= gfc_copy_expr (len
);
3665 gfc_push_suppress_errors ();
3666 gfc_reduce_init_expr (e
);
3667 gfc_pop_suppress_errors ();
3668 if (e
->expr_type
== EXPR_CONSTANT
)
3670 gfc_replace_expr (len
, e
);
3671 if (mpz_cmp_si (len
->value
.integer
, 0) < 0)
3672 mpz_set_ui (len
->value
.integer
, 0);
3677 gfc_free_namespace (gfc_current_ns
);
3678 gfc_current_ns
= old_ns
;
3685 ts
->kind
= kind
== 0 ? gfc_default_character_kind
: kind
;
3686 ts
->deferred
= deferred
;
3688 /* We have to know if it was a C interoperable kind so we can
3689 do accurate type checking of bind(c) procs, etc. */
3691 /* Mark this as C interoperable if being declared with one
3692 of the named constants from iso_c_binding. */
3693 ts
->is_c_interop
= is_iso_c
;
3694 else if (len
!= NULL
)
3695 /* Here, we might have parsed something such as: character(c_char)
3696 In this case, the parsing code above grabs the c_char when
3697 looking for the length (line 1690, roughly). it's the last
3698 testcase for parsing the kind params of a character variable.
3699 However, it's not actually the length. this seems like it
3701 To see if the user used a C interop kind, test the expr
3702 of the so called length, and see if it's C interoperable. */
3703 ts
->is_c_interop
= len
->ts
.is_iso_c
;
3709 /* Matches a RECORD declaration. */
3712 match_record_decl (char *name
)
3715 old_loc
= gfc_current_locus
;
3718 m
= gfc_match (" record /");
3721 if (!flag_dec_structure
)
3723 gfc_current_locus
= old_loc
;
3724 gfc_error ("RECORD at %C is an extension, enable it with "
3725 "%<-fdec-structure%>");
3728 m
= gfc_match (" %n/", name
);
3733 gfc_current_locus
= old_loc
;
3734 if (flag_dec_structure
3735 && (gfc_match (" record% ") == MATCH_YES
3736 || gfc_match (" record%t") == MATCH_YES
))
3737 gfc_error ("Structure name expected after RECORD at %C");
3745 /* This function uses the gfc_actual_arglist 'type_param_spec_list' as a source
3746 of expressions to substitute into the possibly parameterized expression
3747 'e'. Using a list is inefficient but should not be too bad since the
3748 number of type parameters is not likely to be large. */
3750 insert_parameter_exprs (gfc_expr
* e
, gfc_symbol
* sym ATTRIBUTE_UNUSED
,
3753 gfc_actual_arglist
*param
;
3756 if (e
->expr_type
!= EXPR_VARIABLE
)
3759 gcc_assert (e
->symtree
);
3760 if (e
->symtree
->n
.sym
->attr
.pdt_kind
3761 || (*f
!= 0 && e
->symtree
->n
.sym
->attr
.pdt_len
))
3763 for (param
= type_param_spec_list
; param
; param
= param
->next
)
3764 if (strcmp (e
->symtree
->n
.sym
->name
, param
->name
) == 0)
3769 copy
= gfc_copy_expr (param
->expr
);
3780 gfc_insert_kind_parameter_exprs (gfc_expr
*e
)
3782 return gfc_traverse_expr (e
, NULL
, &insert_parameter_exprs
, 0);
3787 gfc_insert_parameter_exprs (gfc_expr
*e
, gfc_actual_arglist
*param_list
)
3789 gfc_actual_arglist
*old_param_spec_list
= type_param_spec_list
;
3790 type_param_spec_list
= param_list
;
3791 bool res
= gfc_traverse_expr (e
, NULL
, &insert_parameter_exprs
, 1);
3792 type_param_spec_list
= old_param_spec_list
;
3796 /* Determines the instance of a parameterized derived type to be used by
3797 matching determining the values of the kind parameters and using them
3798 in the name of the instance. If the instance exists, it is used, otherwise
3799 a new derived type is created. */
3801 gfc_get_pdt_instance (gfc_actual_arglist
*param_list
, gfc_symbol
**sym
,
3802 gfc_actual_arglist
**ext_param_list
)
3804 /* The PDT template symbol. */
3805 gfc_symbol
*pdt
= *sym
;
3806 /* The symbol for the parameter in the template f2k_namespace. */
3808 /* The hoped for instance of the PDT. */
3809 gfc_symbol
*instance
;
3810 /* The list of parameters appearing in the PDT declaration. */
3811 gfc_formal_arglist
*type_param_name_list
;
3812 /* Used to store the parameter specification list during recursive calls. */
3813 gfc_actual_arglist
*old_param_spec_list
;
3814 /* Pointers to the parameter specification being used. */
3815 gfc_actual_arglist
*actual_param
;
3816 gfc_actual_arglist
*tail
= NULL
;
3817 /* Used to build up the name of the PDT instance. The prefix uses 4
3818 characters and each KIND parameter 2 more. Allow 8 of the latter. */
3819 char name
[GFC_MAX_SYMBOL_LEN
+ 21];
3821 bool name_seen
= (param_list
== NULL
);
3822 bool assumed_seen
= false;
3823 bool deferred_seen
= false;
3824 bool spec_error
= false;
3826 gfc_expr
*kind_expr
;
3827 gfc_component
*c1
, *c2
;
3830 type_param_spec_list
= NULL
;
3832 type_param_name_list
= pdt
->formal
;
3833 actual_param
= param_list
;
3834 sprintf (name
, "Pdt%s", pdt
->name
);
3836 /* Run through the parameter name list and pick up the actual
3837 parameter values or use the default values in the PDT declaration. */
3838 for (; type_param_name_list
;
3839 type_param_name_list
= type_param_name_list
->next
)
3841 if (actual_param
&& actual_param
->spec_type
!= SPEC_EXPLICIT
)
3843 if (actual_param
->spec_type
== SPEC_ASSUMED
)
3844 spec_error
= deferred_seen
;
3846 spec_error
= assumed_seen
;
3850 gfc_error ("The type parameter spec list at %C cannot contain "
3851 "both ASSUMED and DEFERRED parameters");
3856 if (actual_param
&& actual_param
->name
)
3858 param
= type_param_name_list
->sym
;
3860 if (!param
|| !param
->name
)
3863 c1
= gfc_find_component (pdt
, param
->name
, false, true, NULL
);
3864 /* An error should already have been thrown in resolve.cc
3865 (resolve_fl_derived0). */
3866 if (!pdt
->attr
.use_assoc
&& !c1
)
3872 if (!actual_param
&& !(c1
&& c1
->initializer
))
3874 gfc_error ("The type parameter spec list at %C does not contain "
3875 "enough parameter expressions");
3878 else if (!actual_param
&& c1
&& c1
->initializer
)
3879 kind_expr
= gfc_copy_expr (c1
->initializer
);
3880 else if (actual_param
&& actual_param
->spec_type
== SPEC_EXPLICIT
)
3881 kind_expr
= gfc_copy_expr (actual_param
->expr
);
3885 actual_param
= param_list
;
3886 for (;actual_param
; actual_param
= actual_param
->next
)
3887 if (actual_param
->name
3888 && strcmp (actual_param
->name
, param
->name
) == 0)
3890 if (actual_param
&& actual_param
->spec_type
== SPEC_EXPLICIT
)
3891 kind_expr
= gfc_copy_expr (actual_param
->expr
);
3894 if (c1
->initializer
)
3895 kind_expr
= gfc_copy_expr (c1
->initializer
);
3896 else if (!(actual_param
&& param
->attr
.pdt_len
))
3898 gfc_error ("The derived parameter %qs at %C does not "
3899 "have a default value", param
->name
);
3905 /* Store the current parameter expressions in a temporary actual
3906 arglist 'list' so that they can be substituted in the corresponding
3907 expressions in the PDT instance. */
3908 if (type_param_spec_list
== NULL
)
3910 type_param_spec_list
= gfc_get_actual_arglist ();
3911 tail
= type_param_spec_list
;
3915 tail
->next
= gfc_get_actual_arglist ();
3918 tail
->name
= param
->name
;
3922 /* Try simplification even for LEN expressions. */
3924 gfc_resolve_expr (kind_expr
);
3925 ok
= gfc_simplify_expr (kind_expr
, 1);
3926 /* Variable expressions seem to default to BT_PROCEDURE.
3927 TODO find out why this is and fix it. */
3928 if (kind_expr
->ts
.type
!= BT_INTEGER
3929 && kind_expr
->ts
.type
!= BT_PROCEDURE
)
3931 gfc_error ("The parameter expression at %C must be of "
3932 "INTEGER type and not %s type",
3933 gfc_basic_typename (kind_expr
->ts
.type
));
3936 if (kind_expr
->ts
.type
== BT_INTEGER
&& !ok
)
3938 gfc_error ("The parameter expression at %C does not "
3939 "simplify to an INTEGER constant");
3943 tail
->expr
= gfc_copy_expr (kind_expr
);
3947 tail
->spec_type
= actual_param
->spec_type
;
3949 if (!param
->attr
.pdt_kind
)
3951 if (!name_seen
&& actual_param
)
3952 actual_param
= actual_param
->next
;
3955 gfc_free_expr (kind_expr
);
3962 && (actual_param
->spec_type
== SPEC_ASSUMED
3963 || actual_param
->spec_type
== SPEC_DEFERRED
))
3965 gfc_error ("The KIND parameter %qs at %C cannot either be "
3966 "ASSUMED or DEFERRED", param
->name
);
3970 if (!kind_expr
|| !gfc_is_constant_expr (kind_expr
))
3972 gfc_error ("The value for the KIND parameter %qs at %C does not "
3973 "reduce to a constant expression", param
->name
);
3977 gfc_extract_int (kind_expr
, &kind_value
);
3978 sprintf (name
+ strlen (name
), "_%d", kind_value
);
3980 if (!name_seen
&& actual_param
)
3981 actual_param
= actual_param
->next
;
3982 gfc_free_expr (kind_expr
);
3985 if (!name_seen
&& actual_param
)
3987 gfc_error ("The type parameter spec list at %C contains too many "
3988 "parameter expressions");
3992 /* Now we search for the PDT instance 'name'. If it doesn't exist, we
3993 build it, using 'pdt' as a template. */
3994 if (gfc_get_symbol (name
, pdt
->ns
, &instance
))
3996 gfc_error ("Parameterized derived type at %C is ambiguous");
4002 if (instance
->attr
.flavor
== FL_DERIVED
4003 && instance
->attr
.pdt_type
)
4007 *ext_param_list
= type_param_spec_list
;
4009 gfc_commit_symbols ();
4013 /* Start building the new instance of the parameterized type. */
4014 gfc_copy_attr (&instance
->attr
, &pdt
->attr
, &pdt
->declared_at
);
4015 instance
->attr
.pdt_template
= 0;
4016 instance
->attr
.pdt_type
= 1;
4017 instance
->declared_at
= gfc_current_locus
;
4019 /* Add the components, replacing the parameters in all expressions
4020 with the expressions for their values in 'type_param_spec_list'. */
4021 c1
= pdt
->components
;
4022 tail
= type_param_spec_list
;
4023 for (; c1
; c1
= c1
->next
)
4025 gfc_add_component (instance
, c1
->name
, &c2
);
4028 c2
->attr
= c1
->attr
;
4030 /* The order of declaration of the type_specs might not be the
4031 same as that of the components. */
4032 if (c1
->attr
.pdt_kind
|| c1
->attr
.pdt_len
)
4034 for (tail
= type_param_spec_list
; tail
; tail
= tail
->next
)
4035 if (strcmp (c1
->name
, tail
->name
) == 0)
4039 /* Deal with type extension by recursively calling this function
4040 to obtain the instance of the extended type. */
4041 if (gfc_current_state () != COMP_DERIVED
4042 && c1
== pdt
->components
4043 && (c1
->ts
.type
== BT_DERIVED
|| c1
->ts
.type
== BT_CLASS
)
4044 && c1
->ts
.u
.derived
&& c1
->ts
.u
.derived
->attr
.pdt_template
4045 && gfc_get_derived_super_type (*sym
) == c2
->ts
.u
.derived
)
4047 gfc_formal_arglist
*f
;
4049 old_param_spec_list
= type_param_spec_list
;
4051 /* Obtain a spec list appropriate to the extended type..*/
4052 actual_param
= gfc_copy_actual_arglist (type_param_spec_list
);
4053 type_param_spec_list
= actual_param
;
4054 for (f
= c1
->ts
.u
.derived
->formal
; f
&& f
->next
; f
= f
->next
)
4055 actual_param
= actual_param
->next
;
4058 gfc_free_actual_arglist (actual_param
->next
);
4059 actual_param
->next
= NULL
;
4062 /* Now obtain the PDT instance for the extended type. */
4063 c2
->param_list
= type_param_spec_list
;
4064 m
= gfc_get_pdt_instance (type_param_spec_list
, &c2
->ts
.u
.derived
,
4066 type_param_spec_list
= old_param_spec_list
;
4068 c2
->ts
.u
.derived
->refs
++;
4069 gfc_set_sym_referenced (c2
->ts
.u
.derived
);
4071 /* Set extension level. */
4072 if (c2
->ts
.u
.derived
->attr
.extension
== 255)
4074 /* Since the extension field is 8 bit wide, we can only have
4075 up to 255 extension levels. */
4076 gfc_error ("Maximum extension level reached with type %qs at %L",
4077 c2
->ts
.u
.derived
->name
,
4078 &c2
->ts
.u
.derived
->declared_at
);
4081 instance
->attr
.extension
= c2
->ts
.u
.derived
->attr
.extension
+ 1;
4086 /* Set the component kind using the parameterized expression. */
4087 if ((c1
->ts
.kind
== 0 || c1
->ts
.type
== BT_CHARACTER
)
4088 && c1
->kind_expr
!= NULL
)
4090 gfc_expr
*e
= gfc_copy_expr (c1
->kind_expr
);
4091 gfc_insert_kind_parameter_exprs (e
);
4092 gfc_simplify_expr (e
, 1);
4093 gfc_extract_int (e
, &c2
->ts
.kind
);
4095 if (gfc_validate_kind (c2
->ts
.type
, c2
->ts
.kind
, true) < 0)
4097 gfc_error ("Kind %d not supported for type %s at %C",
4098 c2
->ts
.kind
, gfc_basic_typename (c2
->ts
.type
));
4103 /* Similarly, set the string length if parameterized. */
4104 if (c1
->ts
.type
== BT_CHARACTER
4105 && c1
->ts
.u
.cl
->length
4106 && gfc_derived_parameter_expr (c1
->ts
.u
.cl
->length
))
4109 e
= gfc_copy_expr (c1
->ts
.u
.cl
->length
);
4110 gfc_insert_kind_parameter_exprs (e
);
4111 gfc_simplify_expr (e
, 1);
4112 c2
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4113 c2
->ts
.u
.cl
->length
= e
;
4114 c2
->attr
.pdt_string
= 1;
4117 /* Set up either the KIND/LEN initializer, if constant,
4118 or the parameterized expression. Use the template
4119 initializer if one is not already set in this instance. */
4120 if (c2
->attr
.pdt_kind
|| c2
->attr
.pdt_len
)
4122 if (tail
&& tail
->expr
&& gfc_is_constant_expr (tail
->expr
))
4123 c2
->initializer
= gfc_copy_expr (tail
->expr
);
4124 else if (tail
&& tail
->expr
)
4126 c2
->param_list
= gfc_get_actual_arglist ();
4127 c2
->param_list
->name
= tail
->name
;
4128 c2
->param_list
->expr
= gfc_copy_expr (tail
->expr
);
4129 c2
->param_list
->next
= NULL
;
4132 if (!c2
->initializer
&& c1
->initializer
)
4133 c2
->initializer
= gfc_copy_expr (c1
->initializer
);
4136 /* Copy the array spec. */
4137 c2
->as
= gfc_copy_array_spec (c1
->as
);
4138 if (c1
->ts
.type
== BT_CLASS
)
4139 CLASS_DATA (c2
)->as
= gfc_copy_array_spec (CLASS_DATA (c1
)->as
);
4141 /* Determine if an array spec is parameterized. If so, substitute
4142 in the parameter expressions for the bounds and set the pdt_array
4143 attribute. Notice that this attribute must be unconditionally set
4144 if this is an array of parameterized character length. */
4145 if (c1
->as
&& c1
->as
->type
== AS_EXPLICIT
)
4147 bool pdt_array
= false;
4149 /* Are the bounds of the array parameterized? */
4150 for (i
= 0; i
< c1
->as
->rank
; i
++)
4152 if (gfc_derived_parameter_expr (c1
->as
->lower
[i
]))
4154 if (gfc_derived_parameter_expr (c1
->as
->upper
[i
]))
4158 /* If they are, free the expressions for the bounds and
4159 replace them with the template expressions with substitute
4161 for (i
= 0; pdt_array
&& i
< c1
->as
->rank
; i
++)
4164 e
= gfc_copy_expr (c1
->as
->lower
[i
]);
4165 gfc_insert_kind_parameter_exprs (e
);
4166 gfc_simplify_expr (e
, 1);
4167 gfc_free_expr (c2
->as
->lower
[i
]);
4168 c2
->as
->lower
[i
] = e
;
4169 e
= gfc_copy_expr (c1
->as
->upper
[i
]);
4170 gfc_insert_kind_parameter_exprs (e
);
4171 gfc_simplify_expr (e
, 1);
4172 gfc_free_expr (c2
->as
->upper
[i
]);
4173 c2
->as
->upper
[i
] = e
;
4175 c2
->attr
.pdt_array
= pdt_array
? 1 : c2
->attr
.pdt_string
;
4176 if (c1
->initializer
)
4178 c2
->initializer
= gfc_copy_expr (c1
->initializer
);
4179 gfc_insert_kind_parameter_exprs (c2
->initializer
);
4180 gfc_simplify_expr (c2
->initializer
, 1);
4184 /* Recurse into this function for PDT components. */
4185 if ((c1
->ts
.type
== BT_DERIVED
|| c1
->ts
.type
== BT_CLASS
)
4186 && c1
->ts
.u
.derived
&& c1
->ts
.u
.derived
->attr
.pdt_template
)
4188 gfc_actual_arglist
*params
;
4189 /* The component in the template has a list of specification
4190 expressions derived from its declaration. */
4191 params
= gfc_copy_actual_arglist (c1
->param_list
);
4192 actual_param
= params
;
4193 /* Substitute the template parameters with the expressions
4194 from the specification list. */
4195 for (;actual_param
; actual_param
= actual_param
->next
)
4196 gfc_insert_parameter_exprs (actual_param
->expr
,
4197 type_param_spec_list
);
4199 /* Now obtain the PDT instance for the component. */
4200 old_param_spec_list
= type_param_spec_list
;
4201 m
= gfc_get_pdt_instance (params
, &c2
->ts
.u
.derived
, NULL
);
4202 type_param_spec_list
= old_param_spec_list
;
4204 c2
->param_list
= params
;
4205 if (!(c2
->attr
.pointer
|| c2
->attr
.allocatable
))
4206 c2
->initializer
= gfc_default_initializer (&c2
->ts
);
4208 if (c2
->attr
.allocatable
)
4209 instance
->attr
.alloc_comp
= 1;
4213 gfc_commit_symbol (instance
);
4215 *ext_param_list
= type_param_spec_list
;
4220 gfc_free_actual_arglist (type_param_spec_list
);
4225 /* Match a legacy nonstandard BYTE type-spec. */
4228 match_byte_typespec (gfc_typespec
*ts
)
4230 if (gfc_match (" byte") == MATCH_YES
)
4232 if (!gfc_notify_std (GFC_STD_GNU
, "BYTE type at %C"))
4235 if (gfc_current_form
== FORM_FREE
)
4237 char c
= gfc_peek_ascii_char ();
4238 if (!gfc_is_whitespace (c
) && c
!= ',')
4242 if (gfc_validate_kind (BT_INTEGER
, 1, true) < 0)
4244 gfc_error ("BYTE type used at %C "
4245 "is not available on the target machine");
4249 ts
->type
= BT_INTEGER
;
4257 /* Matches a declaration-type-spec (F03:R502). If successful, sets the ts
4258 structure to the matched specification. This is necessary for FUNCTION and
4259 IMPLICIT statements.
4261 If implicit_flag is nonzero, then we don't check for the optional
4262 kind specification. Not doing so is needed for matching an IMPLICIT
4263 statement correctly. */
4266 gfc_match_decl_type_spec (gfc_typespec
*ts
, int implicit_flag
)
4268 /* Provide sufficient space to hold "pdtsymbol". */
4269 char *name
= XALLOCAVEC (char, GFC_MAX_SYMBOL_LEN
+ 1);
4270 gfc_symbol
*sym
, *dt_sym
;
4273 bool seen_deferred_kind
, matched_type
;
4274 const char *dt_name
;
4276 decl_type_param_list
= NULL
;
4278 /* A belt and braces check that the typespec is correctly being treated
4279 as a deferred characteristic association. */
4280 seen_deferred_kind
= (gfc_current_state () == COMP_FUNCTION
)
4281 && (gfc_current_block ()->result
->ts
.kind
== -1)
4282 && (ts
->kind
== -1);
4284 if (seen_deferred_kind
)
4287 /* Clear the current binding label, in case one is given. */
4288 curr_binding_label
= NULL
;
4290 /* Match BYTE type-spec. */
4291 m
= match_byte_typespec (ts
);
4295 m
= gfc_match (" type (");
4296 matched_type
= (m
== MATCH_YES
);
4299 gfc_gobble_whitespace ();
4300 if (gfc_peek_ascii_char () == '*')
4302 if ((m
= gfc_match ("* ) ")) != MATCH_YES
)
4304 if (gfc_comp_struct (gfc_current_state ()))
4306 gfc_error ("Assumed type at %C is not allowed for components");
4309 if (!gfc_notify_std (GFC_STD_F2018
, "Assumed type at %C"))
4311 ts
->type
= BT_ASSUMED
;
4315 m
= gfc_match ("%n", name
);
4316 matched_type
= (m
== MATCH_YES
);
4319 if ((matched_type
&& strcmp ("integer", name
) == 0)
4320 || (!matched_type
&& gfc_match (" integer") == MATCH_YES
))
4322 ts
->type
= BT_INTEGER
;
4323 ts
->kind
= gfc_default_integer_kind
;
4327 if ((matched_type
&& strcmp ("character", name
) == 0)
4328 || (!matched_type
&& gfc_match (" character") == MATCH_YES
))
4331 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
4332 "intrinsic-type-spec at %C"))
4335 ts
->type
= BT_CHARACTER
;
4336 if (implicit_flag
== 0)
4337 m
= gfc_match_char_spec (ts
);
4341 if (matched_type
&& m
== MATCH_YES
&& gfc_match_char (')') != MATCH_YES
)
4343 gfc_error ("Malformed type-spec at %C");
4350 if ((matched_type
&& strcmp ("real", name
) == 0)
4351 || (!matched_type
&& gfc_match (" real") == MATCH_YES
))
4354 ts
->kind
= gfc_default_real_kind
;
4359 && (strcmp ("doubleprecision", name
) == 0
4360 || (strcmp ("double", name
) == 0
4361 && gfc_match (" precision") == MATCH_YES
)))
4362 || (!matched_type
&& gfc_match (" double precision") == MATCH_YES
))
4365 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
4366 "intrinsic-type-spec at %C"))
4369 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
4371 gfc_error ("Malformed type-spec at %C");
4376 ts
->kind
= gfc_default_double_kind
;
4380 if ((matched_type
&& strcmp ("complex", name
) == 0)
4381 || (!matched_type
&& gfc_match (" complex") == MATCH_YES
))
4383 ts
->type
= BT_COMPLEX
;
4384 ts
->kind
= gfc_default_complex_kind
;
4389 && (strcmp ("doublecomplex", name
) == 0
4390 || (strcmp ("double", name
) == 0
4391 && gfc_match (" complex") == MATCH_YES
)))
4392 || (!matched_type
&& gfc_match (" double complex") == MATCH_YES
))
4394 if (!gfc_notify_std (GFC_STD_GNU
, "DOUBLE COMPLEX at %C"))
4398 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
4399 "intrinsic-type-spec at %C"))
4402 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
4404 gfc_error ("Malformed type-spec at %C");
4408 ts
->type
= BT_COMPLEX
;
4409 ts
->kind
= gfc_default_double_kind
;
4413 if ((matched_type
&& strcmp ("logical", name
) == 0)
4414 || (!matched_type
&& gfc_match (" logical") == MATCH_YES
))
4416 ts
->type
= BT_LOGICAL
;
4417 ts
->kind
= gfc_default_logical_kind
;
4423 m
= gfc_match_actual_arglist (1, &decl_type_param_list
, true);
4424 if (m
== MATCH_ERROR
)
4427 gfc_gobble_whitespace ();
4428 if (gfc_peek_ascii_char () != ')')
4430 gfc_error ("Malformed type-spec at %C");
4433 m
= gfc_match_char (')'); /* Burn closing ')'. */
4437 m
= match_record_decl (name
);
4439 if (matched_type
|| m
== MATCH_YES
)
4441 ts
->type
= BT_DERIVED
;
4442 /* We accept record/s/ or type(s) where s is a structure, but we
4443 * don't need all the extra derived-type stuff for structures. */
4444 if (gfc_find_symbol (gfc_dt_upper_string (name
), NULL
, 1, &sym
))
4446 gfc_error ("Type name %qs at %C is ambiguous", name
);
4450 if (sym
&& sym
->attr
.flavor
== FL_DERIVED
4451 && sym
->attr
.pdt_template
4452 && gfc_current_state () != COMP_DERIVED
)
4454 m
= gfc_get_pdt_instance (decl_type_param_list
, &sym
, NULL
);
4457 gcc_assert (!sym
->attr
.pdt_template
&& sym
->attr
.pdt_type
);
4458 ts
->u
.derived
= sym
;
4459 const char* lower
= gfc_dt_lower_string (sym
->name
);
4460 size_t len
= strlen (lower
);
4461 /* Reallocate with sufficient size. */
4462 if (len
> GFC_MAX_SYMBOL_LEN
)
4463 name
= XALLOCAVEC (char, len
+ 1);
4464 memcpy (name
, lower
, len
);
4468 if (sym
&& sym
->attr
.flavor
== FL_STRUCT
)
4470 ts
->u
.derived
= sym
;
4473 /* Actually a derived type. */
4478 /* Match nested STRUCTURE declarations; only valid within another
4479 structure declaration. */
4480 if (flag_dec_structure
4481 && (gfc_current_state () == COMP_STRUCTURE
4482 || gfc_current_state () == COMP_MAP
))
4484 m
= gfc_match (" structure");
4487 m
= gfc_match_structure_decl ();
4490 /* gfc_new_block is updated by match_structure_decl. */
4491 ts
->type
= BT_DERIVED
;
4492 ts
->u
.derived
= gfc_new_block
;
4496 if (m
== MATCH_ERROR
)
4500 /* Match CLASS declarations. */
4501 m
= gfc_match (" class ( * )");
4502 if (m
== MATCH_ERROR
)
4504 else if (m
== MATCH_YES
)
4508 ts
->type
= BT_CLASS
;
4509 gfc_find_symbol ("STAR", gfc_current_ns
, 1, &upe
);
4512 upe
= gfc_new_symbol ("STAR", gfc_current_ns
);
4513 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "STAR");
4515 gfc_set_sym_referenced (upe
);
4517 upe
->ts
.type
= BT_VOID
;
4518 upe
->attr
.unlimited_polymorphic
= 1;
4519 /* This is essential to force the construction of
4520 unlimited polymorphic component class containers. */
4521 upe
->attr
.zero_comp
= 1;
4522 if (!gfc_add_flavor (&upe
->attr
, FL_DERIVED
, NULL
,
4523 &gfc_current_locus
))
4528 st
= gfc_get_tbp_symtree (&gfc_current_ns
->sym_root
, "STAR");
4532 ts
->u
.derived
= upe
;
4536 m
= gfc_match (" class (");
4539 m
= gfc_match ("%n", name
);
4545 ts
->type
= BT_CLASS
;
4547 if (!gfc_notify_std (GFC_STD_F2003
, "CLASS statement at %C"))
4550 m
= gfc_match_actual_arglist (1, &decl_type_param_list
, true);
4551 if (m
== MATCH_ERROR
)
4554 m
= gfc_match_char (')');
4559 /* Defer association of the derived type until the end of the
4560 specification block. However, if the derived type can be
4561 found, add it to the typespec. */
4562 if (gfc_matching_function
)
4564 ts
->u
.derived
= NULL
;
4565 if (gfc_current_state () != COMP_INTERFACE
4566 && !gfc_find_symbol (name
, NULL
, 1, &sym
) && sym
)
4568 sym
= gfc_find_dt_in_generic (sym
);
4569 ts
->u
.derived
= sym
;
4574 /* Search for the name but allow the components to be defined later. If
4575 type = -1, this typespec has been seen in a function declaration but
4576 the type could not be accessed at that point. The actual derived type is
4577 stored in a symtree with the first letter of the name capitalized; the
4578 symtree with the all lower-case name contains the associated
4579 generic function. */
4580 dt_name
= gfc_dt_upper_string (name
);
4585 gfc_get_ha_symbol (name
, &sym
);
4586 if (sym
->generic
&& gfc_find_symbol (dt_name
, NULL
, 0, &dt_sym
))
4588 gfc_error ("Type name %qs at %C is ambiguous", name
);
4591 if (sym
->generic
&& !dt_sym
)
4592 dt_sym
= gfc_find_dt_in_generic (sym
);
4594 /* Host associated PDTs can get confused with their constructors
4595 because they ar instantiated in the template's namespace. */
4598 if (gfc_find_symbol (dt_name
, NULL
, 1, &dt_sym
))
4600 gfc_error ("Type name %qs at %C is ambiguous", name
);
4603 if (dt_sym
&& !dt_sym
->attr
.pdt_type
)
4607 else if (ts
->kind
== -1)
4609 int iface
= gfc_state_stack
->previous
->state
!= COMP_INTERFACE
4610 || gfc_current_ns
->has_import_set
;
4611 gfc_find_symbol (name
, NULL
, iface
, &sym
);
4612 if (sym
&& sym
->generic
&& gfc_find_symbol (dt_name
, NULL
, 1, &dt_sym
))
4614 gfc_error ("Type name %qs at %C is ambiguous", name
);
4617 if (sym
&& sym
->generic
&& !dt_sym
)
4618 dt_sym
= gfc_find_dt_in_generic (sym
);
4625 if ((sym
->attr
.flavor
!= FL_UNKNOWN
&& sym
->attr
.flavor
!= FL_STRUCT
4626 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.generic
))
4627 || sym
->attr
.subroutine
)
4629 gfc_error ("Type name %qs at %C conflicts with previously declared "
4630 "entity at %L, which has the same name", name
,
4635 if (sym
&& sym
->attr
.flavor
== FL_DERIVED
4636 && sym
->attr
.pdt_template
4637 && gfc_current_state () != COMP_DERIVED
)
4639 m
= gfc_get_pdt_instance (decl_type_param_list
, &sym
, NULL
);
4642 gcc_assert (!sym
->attr
.pdt_template
&& sym
->attr
.pdt_type
);
4643 ts
->u
.derived
= sym
;
4644 strcpy (name
, gfc_dt_lower_string (sym
->name
));
4647 gfc_save_symbol_data (sym
);
4648 gfc_set_sym_referenced (sym
);
4649 if (!sym
->attr
.generic
4650 && !gfc_add_generic (&sym
->attr
, sym
->name
, NULL
))
4653 if (!sym
->attr
.function
4654 && !gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
4657 if (dt_sym
&& dt_sym
->attr
.flavor
== FL_DERIVED
4658 && dt_sym
->attr
.pdt_template
4659 && gfc_current_state () != COMP_DERIVED
)
4661 m
= gfc_get_pdt_instance (decl_type_param_list
, &dt_sym
, NULL
);
4664 gcc_assert (!dt_sym
->attr
.pdt_template
&& dt_sym
->attr
.pdt_type
);
4669 gfc_interface
*intr
, *head
;
4671 /* Use upper case to save the actual derived-type symbol. */
4672 gfc_get_symbol (dt_name
, NULL
, &dt_sym
);
4673 dt_sym
->name
= gfc_get_string ("%s", sym
->name
);
4674 head
= sym
->generic
;
4675 intr
= gfc_get_interface ();
4677 intr
->where
= gfc_current_locus
;
4679 sym
->generic
= intr
;
4680 sym
->attr
.if_source
= IFSRC_DECL
;
4683 gfc_save_symbol_data (dt_sym
);
4685 gfc_set_sym_referenced (dt_sym
);
4687 if (dt_sym
->attr
.flavor
!= FL_DERIVED
&& dt_sym
->attr
.flavor
!= FL_STRUCT
4688 && !gfc_add_flavor (&dt_sym
->attr
, FL_DERIVED
, sym
->name
, NULL
))
4691 ts
->u
.derived
= dt_sym
;
4697 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
4698 "intrinsic-type-spec at %C"))
4701 /* For all types except double, derived and character, look for an
4702 optional kind specifier. MATCH_NO is actually OK at this point. */
4703 if (implicit_flag
== 1)
4705 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
4711 if (gfc_current_form
== FORM_FREE
)
4713 c
= gfc_peek_ascii_char ();
4714 if (!gfc_is_whitespace (c
) && c
!= '*' && c
!= '('
4715 && c
!= ':' && c
!= ',')
4717 if (matched_type
&& c
== ')')
4719 gfc_next_ascii_char ();
4722 gfc_error ("Malformed type-spec at %C");
4727 m
= gfc_match_kind_spec (ts
, false);
4728 if (m
== MATCH_ERROR
)
4731 if (m
== MATCH_NO
&& ts
->type
!= BT_CHARACTER
)
4733 m
= gfc_match_old_kind_spec (ts
);
4734 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) == -1)
4738 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
4740 gfc_error ("Malformed type-spec at %C");
4744 /* Defer association of the KIND expression of function results
4745 until after USE and IMPORT statements. */
4746 if ((gfc_current_state () == COMP_NONE
&& gfc_error_flag_test ())
4747 || gfc_matching_function
)
4751 m
= MATCH_YES
; /* No kind specifier found. */
4757 /* Match an IMPLICIT NONE statement. Actually, this statement is
4758 already matched in parse.cc, or we would not end up here in the
4759 first place. So the only thing we need to check, is if there is
4760 trailing garbage. If not, the match is successful. */
4763 gfc_match_implicit_none (void)
4767 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4769 bool external
= false;
4770 locus cur_loc
= gfc_current_locus
;
4772 if (gfc_current_ns
->seen_implicit_none
4773 || gfc_current_ns
->has_implicit_none_export
)
4775 gfc_error ("Duplicate IMPLICIT NONE statement at %C");
4779 gfc_gobble_whitespace ();
4780 c
= gfc_peek_ascii_char ();
4783 (void) gfc_next_ascii_char ();
4784 if (!gfc_notify_std (GFC_STD_F2018
, "IMPLICIT NONE with spec list at %C"))
4787 gfc_gobble_whitespace ();
4788 if (gfc_peek_ascii_char () == ')')
4790 (void) gfc_next_ascii_char ();
4796 m
= gfc_match (" %n", name
);
4800 if (strcmp (name
, "type") == 0)
4802 else if (strcmp (name
, "external") == 0)
4807 gfc_gobble_whitespace ();
4808 c
= gfc_next_ascii_char ();
4819 if (gfc_match_eos () != MATCH_YES
)
4822 gfc_set_implicit_none (type
, external
, &cur_loc
);
4828 /* Match the letter range(s) of an IMPLICIT statement. */
4831 match_implicit_range (void)
4837 cur_loc
= gfc_current_locus
;
4839 gfc_gobble_whitespace ();
4840 c
= gfc_next_ascii_char ();
4843 gfc_error ("Missing character range in IMPLICIT at %C");
4850 gfc_gobble_whitespace ();
4851 c1
= gfc_next_ascii_char ();
4855 gfc_gobble_whitespace ();
4856 c
= gfc_next_ascii_char ();
4861 inner
= 0; /* Fall through. */
4868 gfc_gobble_whitespace ();
4869 c2
= gfc_next_ascii_char ();
4873 gfc_gobble_whitespace ();
4874 c
= gfc_next_ascii_char ();
4876 if ((c
!= ',') && (c
!= ')'))
4889 gfc_error ("Letters must be in alphabetic order in "
4890 "IMPLICIT statement at %C");
4894 /* See if we can add the newly matched range to the pending
4895 implicits from this IMPLICIT statement. We do not check for
4896 conflicts with whatever earlier IMPLICIT statements may have
4897 set. This is done when we've successfully finished matching
4899 if (!gfc_add_new_implicit_range (c1
, c2
))
4906 gfc_syntax_error (ST_IMPLICIT
);
4908 gfc_current_locus
= cur_loc
;
4913 /* Match an IMPLICIT statement, storing the types for
4914 gfc_set_implicit() if the statement is accepted by the parser.
4915 There is a strange looking, but legal syntactic construction
4916 possible. It looks like:
4918 IMPLICIT INTEGER (a-b) (c-d)
4920 This is legal if "a-b" is a constant expression that happens to
4921 equal one of the legal kinds for integers. The real problem
4922 happens with an implicit specification that looks like:
4924 IMPLICIT INTEGER (a-b)
4926 In this case, a typespec matcher that is "greedy" (as most of the
4927 matchers are) gobbles the character range as a kindspec, leaving
4928 nothing left. We therefore have to go a bit more slowly in the
4929 matching process by inhibiting the kindspec checking during
4930 typespec matching and checking for a kind later. */
4933 gfc_match_implicit (void)
4940 if (gfc_current_ns
->seen_implicit_none
)
4942 gfc_error ("IMPLICIT statement at %C following an IMPLICIT NONE (type) "
4949 /* We don't allow empty implicit statements. */
4950 if (gfc_match_eos () == MATCH_YES
)
4952 gfc_error ("Empty IMPLICIT statement at %C");
4958 /* First cleanup. */
4959 gfc_clear_new_implicit ();
4961 /* A basic type is mandatory here. */
4962 m
= gfc_match_decl_type_spec (&ts
, 1);
4963 if (m
== MATCH_ERROR
)
4968 cur_loc
= gfc_current_locus
;
4969 m
= match_implicit_range ();
4973 /* We may have <TYPE> (<RANGE>). */
4974 gfc_gobble_whitespace ();
4975 c
= gfc_peek_ascii_char ();
4976 if (c
== ',' || c
== '\n' || c
== ';' || c
== '!')
4978 /* Check for CHARACTER with no length parameter. */
4979 if (ts
.type
== BT_CHARACTER
&& !ts
.u
.cl
)
4981 ts
.kind
= gfc_default_character_kind
;
4982 ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4983 ts
.u
.cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
,
4987 /* Record the Successful match. */
4988 if (!gfc_merge_new_implicit (&ts
))
4991 c
= gfc_next_ascii_char ();
4992 else if (gfc_match_eos () == MATCH_ERROR
)
4997 gfc_current_locus
= cur_loc
;
5000 /* Discard the (incorrectly) matched range. */
5001 gfc_clear_new_implicit ();
5003 /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
5004 if (ts
.type
== BT_CHARACTER
)
5005 m
= gfc_match_char_spec (&ts
);
5006 else if (gfc_numeric_ts(&ts
) || ts
.type
== BT_LOGICAL
)
5008 m
= gfc_match_kind_spec (&ts
, false);
5011 m
= gfc_match_old_kind_spec (&ts
);
5012 if (m
== MATCH_ERROR
)
5018 if (m
== MATCH_ERROR
)
5021 m
= match_implicit_range ();
5022 if (m
== MATCH_ERROR
)
5027 gfc_gobble_whitespace ();
5028 c
= gfc_next_ascii_char ();
5029 if (c
!= ',' && gfc_match_eos () != MATCH_YES
)
5032 if (!gfc_merge_new_implicit (&ts
))
5040 gfc_syntax_error (ST_IMPLICIT
);
5048 gfc_match_import (void)
5050 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5055 if (gfc_current_ns
->proc_name
== NULL
5056 || gfc_current_ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
5058 gfc_error ("IMPORT statement at %C only permitted in "
5059 "an INTERFACE body");
5063 if (gfc_current_ns
->proc_name
->attr
.module_procedure
)
5065 gfc_error ("F2008: C1210 IMPORT statement at %C is not permitted "
5066 "in a module procedure interface body");
5070 if (!gfc_notify_std (GFC_STD_F2003
, "IMPORT statement at %C"))
5073 if (gfc_match_eos () == MATCH_YES
)
5075 /* All host variables should be imported. */
5076 gfc_current_ns
->has_import_set
= 1;
5080 if (gfc_match (" ::") == MATCH_YES
)
5082 if (gfc_match_eos () == MATCH_YES
)
5084 gfc_error ("Expecting list of named entities at %C");
5092 m
= gfc_match (" %n", name
);
5096 if (gfc_current_ns
->parent
!= NULL
5097 && gfc_find_symbol (name
, gfc_current_ns
->parent
, 1, &sym
))
5099 gfc_error ("Type name %qs at %C is ambiguous", name
);
5102 else if (!sym
&& gfc_current_ns
->proc_name
->ns
->parent
!= NULL
5103 && gfc_find_symbol (name
,
5104 gfc_current_ns
->proc_name
->ns
->parent
,
5107 gfc_error ("Type name %qs at %C is ambiguous", name
);
5113 gfc_error ("Cannot IMPORT %qs from host scoping unit "
5114 "at %C - does not exist.", name
);
5118 if (gfc_find_symtree (gfc_current_ns
->sym_root
, name
))
5120 gfc_warning (0, "%qs is already IMPORTed from host scoping unit "
5125 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, name
);
5128 sym
->attr
.imported
= 1;
5130 if (sym
->attr
.generic
&& (sym
= gfc_find_dt_in_generic (sym
)))
5132 /* The actual derived type is stored in a symtree with the first
5133 letter of the name capitalized; the symtree with the all
5134 lower-case name contains the associated generic function. */
5135 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
,
5136 gfc_dt_upper_string (name
));
5139 sym
->attr
.imported
= 1;
5152 if (gfc_match_eos () == MATCH_YES
)
5154 if (gfc_match_char (',') != MATCH_YES
)
5161 gfc_error ("Syntax error in IMPORT statement at %C");
5166 /* A minimal implementation of gfc_match without whitespace, escape
5167 characters or variable arguments. Returns true if the next
5168 characters match the TARGET template exactly. */
5171 match_string_p (const char *target
)
5175 for (p
= target
; *p
; p
++)
5176 if ((char) gfc_next_ascii_char () != *p
)
5181 /* Matches an attribute specification including array specs. If
5182 successful, leaves the variables current_attr and current_as
5183 holding the specification. Also sets the colon_seen variable for
5184 later use by matchers associated with initializations.
5186 This subroutine is a little tricky in the sense that we don't know
5187 if we really have an attr-spec until we hit the double colon.
5188 Until that time, we can only return MATCH_NO. This forces us to
5189 check for duplicate specification at this level. */
5192 match_attr_spec (void)
5194 /* Modifiers that can exist in a type statement. */
5196 { GFC_DECL_BEGIN
= 0, DECL_ALLOCATABLE
= GFC_DECL_BEGIN
,
5197 DECL_IN
= INTENT_IN
, DECL_OUT
= INTENT_OUT
, DECL_INOUT
= INTENT_INOUT
,
5198 DECL_DIMENSION
, DECL_EXTERNAL
,
5199 DECL_INTRINSIC
, DECL_OPTIONAL
,
5200 DECL_PARAMETER
, DECL_POINTER
, DECL_PROTECTED
, DECL_PRIVATE
,
5201 DECL_STATIC
, DECL_AUTOMATIC
,
5202 DECL_PUBLIC
, DECL_SAVE
, DECL_TARGET
, DECL_VALUE
, DECL_VOLATILE
,
5203 DECL_IS_BIND_C
, DECL_CODIMENSION
, DECL_ASYNCHRONOUS
, DECL_CONTIGUOUS
,
5204 DECL_LEN
, DECL_KIND
, DECL_NONE
, GFC_DECL_END
/* Sentinel */
5207 /* GFC_DECL_END is the sentinel, index starts at 0. */
5208 #define NUM_DECL GFC_DECL_END
5210 /* Make sure that values from sym_intent are safe to be used here. */
5211 gcc_assert (INTENT_IN
> 0);
5213 locus start
, seen_at
[NUM_DECL
];
5220 gfc_clear_attr (¤t_attr
);
5221 start
= gfc_current_locus
;
5227 /* See if we get all of the keywords up to the final double colon. */
5228 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
5236 gfc_gobble_whitespace ();
5238 ch
= gfc_next_ascii_char ();
5241 /* This is the successful exit condition for the loop. */
5242 if (gfc_next_ascii_char () == ':')
5247 gfc_gobble_whitespace ();
5248 switch (gfc_peek_ascii_char ())
5251 gfc_next_ascii_char ();
5252 switch (gfc_next_ascii_char ())
5255 if (match_string_p ("locatable"))
5257 /* Matched "allocatable". */
5258 d
= DECL_ALLOCATABLE
;
5263 if (match_string_p ("ynchronous"))
5265 /* Matched "asynchronous". */
5266 d
= DECL_ASYNCHRONOUS
;
5271 if (match_string_p ("tomatic"))
5273 /* Matched "automatic". */
5281 /* Try and match the bind(c). */
5282 m
= gfc_match_bind_c (NULL
, true);
5285 else if (m
== MATCH_ERROR
)
5290 gfc_next_ascii_char ();
5291 if ('o' != gfc_next_ascii_char ())
5293 switch (gfc_next_ascii_char ())
5296 if (match_string_p ("imension"))
5298 d
= DECL_CODIMENSION
;
5303 if (match_string_p ("tiguous"))
5305 d
= DECL_CONTIGUOUS
;
5312 if (match_string_p ("dimension"))
5317 if (match_string_p ("external"))
5322 if (match_string_p ("int"))
5324 ch
= gfc_next_ascii_char ();
5327 if (match_string_p ("nt"))
5329 /* Matched "intent". */
5330 d
= match_intent_spec ();
5331 if (d
== INTENT_UNKNOWN
)
5340 if (match_string_p ("insic"))
5342 /* Matched "intrinsic". */
5350 if (match_string_p ("kind"))
5355 if (match_string_p ("len"))
5360 if (match_string_p ("optional"))
5365 gfc_next_ascii_char ();
5366 switch (gfc_next_ascii_char ())
5369 if (match_string_p ("rameter"))
5371 /* Matched "parameter". */
5377 if (match_string_p ("inter"))
5379 /* Matched "pointer". */
5385 ch
= gfc_next_ascii_char ();
5388 if (match_string_p ("vate"))
5390 /* Matched "private". */
5396 if (match_string_p ("tected"))
5398 /* Matched "protected". */
5405 if (match_string_p ("blic"))
5407 /* Matched "public". */
5415 gfc_next_ascii_char ();
5416 switch (gfc_next_ascii_char ())
5419 if (match_string_p ("ve"))
5421 /* Matched "save". */
5427 if (match_string_p ("atic"))
5429 /* Matched "static". */
5437 if (match_string_p ("target"))
5442 gfc_next_ascii_char ();
5443 ch
= gfc_next_ascii_char ();
5446 if (match_string_p ("lue"))
5448 /* Matched "value". */
5454 if (match_string_p ("latile"))
5456 /* Matched "volatile". */
5464 /* No double colon and no recognizable decl_type, so assume that
5465 we've been looking at something else the whole time. */
5472 /* Check to make sure any parens are paired up correctly. */
5473 if (gfc_match_parens () == MATCH_ERROR
)
5480 seen_at
[d
] = gfc_current_locus
;
5482 if (d
== DECL_DIMENSION
|| d
== DECL_CODIMENSION
)
5484 gfc_array_spec
*as
= NULL
;
5486 m
= gfc_match_array_spec (&as
, d
== DECL_DIMENSION
,
5487 d
== DECL_CODIMENSION
);
5489 if (current_as
== NULL
)
5491 else if (m
== MATCH_YES
)
5493 if (!merge_array_spec (as
, current_as
, false))
5500 if (d
== DECL_CODIMENSION
)
5501 gfc_error ("Missing codimension specification at %C");
5503 gfc_error ("Missing dimension specification at %C");
5507 if (m
== MATCH_ERROR
)
5512 /* Since we've seen a double colon, we have to be looking at an
5513 attr-spec. This means that we can now issue errors. */
5514 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
5519 case DECL_ALLOCATABLE
:
5520 attr
= "ALLOCATABLE";
5522 case DECL_ASYNCHRONOUS
:
5523 attr
= "ASYNCHRONOUS";
5525 case DECL_CODIMENSION
:
5526 attr
= "CODIMENSION";
5528 case DECL_CONTIGUOUS
:
5529 attr
= "CONTIGUOUS";
5531 case DECL_DIMENSION
:
5538 attr
= "INTENT (IN)";
5541 attr
= "INTENT (OUT)";
5544 attr
= "INTENT (IN OUT)";
5546 case DECL_INTRINSIC
:
5558 case DECL_PARAMETER
:
5564 case DECL_PROTECTED
:
5579 case DECL_AUTOMATIC
:
5585 case DECL_IS_BIND_C
:
5595 attr
= NULL
; /* This shouldn't happen. */
5598 gfc_error ("Duplicate %s attribute at %L", attr
, &seen_at
[d
]);
5603 /* Now that we've dealt with duplicate attributes, add the attributes
5604 to the current attribute. */
5605 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
5612 if ((d
== DECL_STATIC
|| d
== DECL_AUTOMATIC
)
5613 && !flag_dec_static
)
5615 gfc_error ("%s at %L is a DEC extension, enable with "
5617 d
== DECL_STATIC
? "STATIC" : "AUTOMATIC", &seen_at
[d
]);
5621 /* Allow SAVE with STATIC, but don't complain. */
5622 if (d
== DECL_STATIC
&& seen
[DECL_SAVE
])
5625 if (gfc_comp_struct (gfc_current_state ())
5626 && d
!= DECL_DIMENSION
&& d
!= DECL_CODIMENSION
5627 && d
!= DECL_POINTER
&& d
!= DECL_PRIVATE
5628 && d
!= DECL_PUBLIC
&& d
!= DECL_CONTIGUOUS
&& d
!= DECL_NONE
)
5630 bool is_derived
= gfc_current_state () == COMP_DERIVED
;
5631 if (d
== DECL_ALLOCATABLE
)
5633 if (!gfc_notify_std (GFC_STD_F2003
, is_derived
5634 ? G_("ALLOCATABLE attribute at %C in a "
5636 : G_("ALLOCATABLE attribute at %C in a "
5637 "STRUCTURE definition")))
5643 else if (d
== DECL_KIND
)
5645 if (!gfc_notify_std (GFC_STD_F2003
, is_derived
5646 ? G_("KIND attribute at %C in a "
5648 : G_("KIND attribute at %C in a "
5649 "STRUCTURE definition")))
5654 if (current_ts
.type
!= BT_INTEGER
)
5656 gfc_error ("Component with KIND attribute at %C must be "
5662 else if (d
== DECL_LEN
)
5664 if (!gfc_notify_std (GFC_STD_F2003
, is_derived
5665 ? G_("LEN attribute at %C in a "
5667 : G_("LEN attribute at %C in a "
5668 "STRUCTURE definition")))
5673 if (current_ts
.type
!= BT_INTEGER
)
5675 gfc_error ("Component with LEN attribute at %C must be "
5683 gfc_error (is_derived
? G_("Attribute at %L is not allowed in a "
5685 : G_("Attribute at %L is not allowed in a "
5686 "STRUCTURE definition"), &seen_at
[d
]);
5692 if ((d
== DECL_PRIVATE
|| d
== DECL_PUBLIC
)
5693 && gfc_current_state () != COMP_MODULE
)
5695 if (d
== DECL_PRIVATE
)
5699 if (gfc_current_state () == COMP_DERIVED
5700 && gfc_state_stack
->previous
5701 && gfc_state_stack
->previous
->state
== COMP_MODULE
)
5703 if (!gfc_notify_std (GFC_STD_F2003
, "Attribute %s "
5704 "at %L in a TYPE definition", attr
,
5713 gfc_error ("%s attribute at %L is not allowed outside of the "
5714 "specification part of a module", attr
, &seen_at
[d
]);
5720 if (gfc_current_state () != COMP_DERIVED
5721 && (d
== DECL_KIND
|| d
== DECL_LEN
))
5723 gfc_error ("Attribute at %L is not allowed outside a TYPE "
5724 "definition", &seen_at
[d
]);
5731 case DECL_ALLOCATABLE
:
5732 t
= gfc_add_allocatable (¤t_attr
, &seen_at
[d
]);
5735 case DECL_ASYNCHRONOUS
:
5736 if (!gfc_notify_std (GFC_STD_F2003
, "ASYNCHRONOUS attribute at %C"))
5739 t
= gfc_add_asynchronous (¤t_attr
, NULL
, &seen_at
[d
]);
5742 case DECL_CODIMENSION
:
5743 t
= gfc_add_codimension (¤t_attr
, NULL
, &seen_at
[d
]);
5746 case DECL_CONTIGUOUS
:
5747 if (!gfc_notify_std (GFC_STD_F2008
, "CONTIGUOUS attribute at %C"))
5750 t
= gfc_add_contiguous (¤t_attr
, NULL
, &seen_at
[d
]);
5753 case DECL_DIMENSION
:
5754 t
= gfc_add_dimension (¤t_attr
, NULL
, &seen_at
[d
]);
5758 t
= gfc_add_external (¤t_attr
, &seen_at
[d
]);
5762 t
= gfc_add_intent (¤t_attr
, INTENT_IN
, &seen_at
[d
]);
5766 t
= gfc_add_intent (¤t_attr
, INTENT_OUT
, &seen_at
[d
]);
5770 t
= gfc_add_intent (¤t_attr
, INTENT_INOUT
, &seen_at
[d
]);
5773 case DECL_INTRINSIC
:
5774 t
= gfc_add_intrinsic (¤t_attr
, &seen_at
[d
]);
5778 t
= gfc_add_optional (¤t_attr
, &seen_at
[d
]);
5782 t
= gfc_add_kind (¤t_attr
, &seen_at
[d
]);
5786 t
= gfc_add_len (¤t_attr
, &seen_at
[d
]);
5789 case DECL_PARAMETER
:
5790 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, &seen_at
[d
]);
5794 t
= gfc_add_pointer (¤t_attr
, &seen_at
[d
]);
5797 case DECL_PROTECTED
:
5798 if (gfc_current_state () != COMP_MODULE
5799 || (gfc_current_ns
->proc_name
5800 && gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
))
5802 gfc_error ("PROTECTED at %C only allowed in specification "
5803 "part of a module");
5808 if (!gfc_notify_std (GFC_STD_F2003
, "PROTECTED attribute at %C"))
5811 t
= gfc_add_protected (¤t_attr
, NULL
, &seen_at
[d
]);
5815 t
= gfc_add_access (¤t_attr
, ACCESS_PRIVATE
, NULL
,
5820 t
= gfc_add_access (¤t_attr
, ACCESS_PUBLIC
, NULL
,
5826 t
= gfc_add_save (¤t_attr
, SAVE_EXPLICIT
, NULL
, &seen_at
[d
]);
5829 case DECL_AUTOMATIC
:
5830 t
= gfc_add_automatic (¤t_attr
, NULL
, &seen_at
[d
]);
5834 t
= gfc_add_target (¤t_attr
, &seen_at
[d
]);
5837 case DECL_IS_BIND_C
:
5838 t
= gfc_add_is_bind_c(¤t_attr
, NULL
, &seen_at
[d
], 0);
5842 if (!gfc_notify_std (GFC_STD_F2003
, "VALUE attribute at %C"))
5845 t
= gfc_add_value (¤t_attr
, NULL
, &seen_at
[d
]);
5849 if (!gfc_notify_std (GFC_STD_F2003
, "VOLATILE attribute at %C"))
5852 t
= gfc_add_volatile (¤t_attr
, NULL
, &seen_at
[d
]);
5856 gfc_internal_error ("match_attr_spec(): Bad attribute");
5866 /* Since Fortran 2008 module variables implicitly have the SAVE attribute. */
5867 if ((gfc_current_state () == COMP_MODULE
5868 || gfc_current_state () == COMP_SUBMODULE
)
5869 && !current_attr
.save
5870 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
5871 current_attr
.save
= SAVE_IMPLICIT
;
5877 gfc_current_locus
= start
;
5878 gfc_free_array_spec (current_as
);
5885 /* Set the binding label, dest_label, either with the binding label
5886 stored in the given gfc_typespec, ts, or if none was provided, it
5887 will be the symbol name in all lower case, as required by the draft
5888 (J3/04-007, section 15.4.1). If a binding label was given and
5889 there is more than one argument (num_idents), it is an error. */
5892 set_binding_label (const char **dest_label
, const char *sym_name
,
5895 if (num_idents
> 1 && has_name_equals
)
5897 gfc_error ("Multiple identifiers provided with "
5898 "single NAME= specifier at %C");
5902 if (curr_binding_label
)
5903 /* Binding label given; store in temp holder till have sym. */
5904 *dest_label
= curr_binding_label
;
5907 /* No binding label given, and the NAME= specifier did not exist,
5908 which means there was no NAME="". */
5909 if (sym_name
!= NULL
&& has_name_equals
== 0)
5910 *dest_label
= IDENTIFIER_POINTER (get_identifier (sym_name
));
5917 /* Set the status of the given common block as being BIND(C) or not,
5918 depending on the given parameter, is_bind_c. */
5921 set_com_block_bind_c (gfc_common_head
*com_block
, int is_bind_c
)
5923 com_block
->is_bind_c
= is_bind_c
;
5928 /* Verify that the given gfc_typespec is for a C interoperable type. */
5931 gfc_verify_c_interop (gfc_typespec
*ts
)
5933 if (ts
->type
== BT_DERIVED
&& ts
->u
.derived
!= NULL
)
5934 return (ts
->u
.derived
->ts
.is_c_interop
|| ts
->u
.derived
->attr
.is_bind_c
)
5936 else if (ts
->type
== BT_CLASS
)
5938 else if (ts
->is_c_interop
!= 1 && ts
->type
!= BT_ASSUMED
)
5945 /* Verify that the variables of a given common block, which has been
5946 defined with the attribute specifier bind(c), to be of a C
5947 interoperable type. Errors will be reported here, if
5951 verify_com_block_vars_c_interop (gfc_common_head
*com_block
)
5953 gfc_symbol
*curr_sym
= NULL
;
5956 curr_sym
= com_block
->head
;
5958 /* Make sure we have at least one symbol. */
5959 if (curr_sym
== NULL
)
5962 /* Here we know we have a symbol, so we'll execute this loop
5966 /* The second to last param, 1, says this is in a common block. */
5967 retval
= verify_bind_c_sym (curr_sym
, &(curr_sym
->ts
), 1, com_block
);
5968 curr_sym
= curr_sym
->common_next
;
5969 } while (curr_sym
!= NULL
);
5975 /* Verify that a given BIND(C) symbol is C interoperable. If it is not,
5976 an appropriate error message is reported. */
5979 verify_bind_c_sym (gfc_symbol
*tmp_sym
, gfc_typespec
*ts
,
5980 int is_in_common
, gfc_common_head
*com_block
)
5982 bool bind_c_function
= false;
5985 if (tmp_sym
->attr
.function
&& tmp_sym
->attr
.is_bind_c
)
5986 bind_c_function
= true;
5988 if (tmp_sym
->attr
.function
&& tmp_sym
->result
!= NULL
)
5990 tmp_sym
= tmp_sym
->result
;
5991 /* Make sure it wasn't an implicitly typed result. */
5992 if (tmp_sym
->attr
.implicit_type
&& warn_c_binding_type
)
5994 gfc_warning (OPT_Wc_binding_type
,
5995 "Implicitly declared BIND(C) function %qs at "
5996 "%L may not be C interoperable", tmp_sym
->name
,
5997 &tmp_sym
->declared_at
);
5998 tmp_sym
->ts
.f90_type
= tmp_sym
->ts
.type
;
5999 /* Mark it as C interoperable to prevent duplicate warnings. */
6000 tmp_sym
->ts
.is_c_interop
= 1;
6001 tmp_sym
->attr
.is_c_interop
= 1;
6005 /* Here, we know we have the bind(c) attribute, so if we have
6006 enough type info, then verify that it's a C interop kind.
6007 The info could be in the symbol already, or possibly still in
6008 the given ts (current_ts), so look in both. */
6009 if (tmp_sym
->ts
.type
!= BT_UNKNOWN
|| ts
->type
!= BT_UNKNOWN
)
6011 if (!gfc_verify_c_interop (&(tmp_sym
->ts
)))
6013 /* See if we're dealing with a sym in a common block or not. */
6014 if (is_in_common
== 1 && warn_c_binding_type
)
6016 gfc_warning (OPT_Wc_binding_type
,
6017 "Variable %qs in common block %qs at %L "
6018 "may not be a C interoperable "
6019 "kind though common block %qs is BIND(C)",
6020 tmp_sym
->name
, com_block
->name
,
6021 &(tmp_sym
->declared_at
), com_block
->name
);
6025 if (tmp_sym
->ts
.type
== BT_DERIVED
|| ts
->type
== BT_DERIVED
6026 || tmp_sym
->ts
.type
== BT_CLASS
|| ts
->type
== BT_CLASS
)
6028 gfc_error ("Type declaration %qs at %L is not C "
6029 "interoperable but it is BIND(C)",
6030 tmp_sym
->name
, &(tmp_sym
->declared_at
));
6033 else if (warn_c_binding_type
)
6034 gfc_warning (OPT_Wc_binding_type
, "Variable %qs at %L "
6035 "may not be a C interoperable "
6036 "kind but it is BIND(C)",
6037 tmp_sym
->name
, &(tmp_sym
->declared_at
));
6041 /* Variables declared w/in a common block can't be bind(c)
6042 since there's no way for C to see these variables, so there's
6043 semantically no reason for the attribute. */
6044 if (is_in_common
== 1 && tmp_sym
->attr
.is_bind_c
== 1)
6046 gfc_error ("Variable %qs in common block %qs at "
6047 "%L cannot be declared with BIND(C) "
6048 "since it is not a global",
6049 tmp_sym
->name
, com_block
->name
,
6050 &(tmp_sym
->declared_at
));
6054 /* Scalar variables that are bind(c) cannot have the pointer
6055 or allocatable attributes. */
6056 if (tmp_sym
->attr
.is_bind_c
== 1)
6058 if (tmp_sym
->attr
.pointer
== 1)
6060 gfc_error ("Variable %qs at %L cannot have both the "
6061 "POINTER and BIND(C) attributes",
6062 tmp_sym
->name
, &(tmp_sym
->declared_at
));
6066 if (tmp_sym
->attr
.allocatable
== 1)
6068 gfc_error ("Variable %qs at %L cannot have both the "
6069 "ALLOCATABLE and BIND(C) attributes",
6070 tmp_sym
->name
, &(tmp_sym
->declared_at
));
6076 /* If it is a BIND(C) function, make sure the return value is a
6077 scalar value. The previous tests in this function made sure
6078 the type is interoperable. */
6079 if (bind_c_function
&& tmp_sym
->as
!= NULL
)
6080 gfc_error ("Return type of BIND(C) function %qs at %L cannot "
6081 "be an array", tmp_sym
->name
, &(tmp_sym
->declared_at
));
6083 /* BIND(C) functions cannot return a character string. */
6084 if (bind_c_function
&& tmp_sym
->ts
.type
== BT_CHARACTER
)
6085 if (!gfc_length_one_character_type_p (&tmp_sym
->ts
))
6086 gfc_error ("Return type of BIND(C) function %qs of character "
6087 "type at %L must have length 1", tmp_sym
->name
,
6088 &(tmp_sym
->declared_at
));
6091 /* See if the symbol has been marked as private. If it has, make sure
6092 there is no binding label and warn the user if there is one. */
6093 if (tmp_sym
->attr
.access
== ACCESS_PRIVATE
6094 && tmp_sym
->binding_label
)
6095 /* Use gfc_warning_now because we won't say that the symbol fails
6096 just because of this. */
6097 gfc_warning_now (0, "Symbol %qs at %L is marked PRIVATE but has been "
6098 "given the binding label %qs", tmp_sym
->name
,
6099 &(tmp_sym
->declared_at
), tmp_sym
->binding_label
);
6105 /* Set the appropriate fields for a symbol that's been declared as
6106 BIND(C) (the is_bind_c flag and the binding label), and verify that
6107 the type is C interoperable. Errors are reported by the functions
6108 used to set/test these fields. */
6111 set_verify_bind_c_sym (gfc_symbol
*tmp_sym
, int num_idents
)
6115 /* TODO: Do we need to make sure the vars aren't marked private? */
6117 /* Set the is_bind_c bit in symbol_attribute. */
6118 gfc_add_is_bind_c (&(tmp_sym
->attr
), tmp_sym
->name
, &gfc_current_locus
, 0);
6120 if (!set_binding_label (&tmp_sym
->binding_label
, tmp_sym
->name
, num_idents
))
6127 /* Set the fields marking the given common block as BIND(C), including
6128 a binding label, and report any errors encountered. */
6131 set_verify_bind_c_com_block (gfc_common_head
*com_block
, int num_idents
)
6135 /* destLabel, common name, typespec (which may have binding label). */
6136 if (!set_binding_label (&com_block
->binding_label
, com_block
->name
,
6140 /* Set the given common block (com_block) to being bind(c) (1). */
6141 set_com_block_bind_c (com_block
, 1);
6147 /* Retrieve the list of one or more identifiers that the given bind(c)
6148 attribute applies to. */
6151 get_bind_c_idents (void)
6153 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6155 gfc_symbol
*tmp_sym
= NULL
;
6157 gfc_common_head
*com_block
= NULL
;
6159 if (gfc_match_name (name
) == MATCH_YES
)
6161 found_id
= MATCH_YES
;
6162 gfc_get_ha_symbol (name
, &tmp_sym
);
6164 else if (gfc_match_common_name (name
) == MATCH_YES
)
6166 found_id
= MATCH_YES
;
6167 com_block
= gfc_get_common (name
, 0);
6171 gfc_error ("Need either entity or common block name for "
6172 "attribute specification statement at %C");
6176 /* Save the current identifier and look for more. */
6179 /* Increment the number of identifiers found for this spec stmt. */
6182 /* Make sure we have a sym or com block, and verify that it can
6183 be bind(c). Set the appropriate field(s) and look for more
6185 if (tmp_sym
!= NULL
|| com_block
!= NULL
)
6187 if (tmp_sym
!= NULL
)
6189 if (!set_verify_bind_c_sym (tmp_sym
, num_idents
))
6194 if (!set_verify_bind_c_com_block (com_block
, num_idents
))
6198 /* Look to see if we have another identifier. */
6200 if (gfc_match_eos () == MATCH_YES
)
6201 found_id
= MATCH_NO
;
6202 else if (gfc_match_char (',') != MATCH_YES
)
6203 found_id
= MATCH_NO
;
6204 else if (gfc_match_name (name
) == MATCH_YES
)
6206 found_id
= MATCH_YES
;
6207 gfc_get_ha_symbol (name
, &tmp_sym
);
6209 else if (gfc_match_common_name (name
) == MATCH_YES
)
6211 found_id
= MATCH_YES
;
6212 com_block
= gfc_get_common (name
, 0);
6216 gfc_error ("Missing entity or common block name for "
6217 "attribute specification statement at %C");
6223 gfc_internal_error ("Missing symbol");
6225 } while (found_id
== MATCH_YES
);
6227 /* if we get here we were successful */
6232 /* Try and match a BIND(C) attribute specification statement. */
6235 gfc_match_bind_c_stmt (void)
6237 match found_match
= MATCH_NO
;
6242 /* This may not be necessary. */
6244 /* Clear the temporary binding label holder. */
6245 curr_binding_label
= NULL
;
6247 /* Look for the bind(c). */
6248 found_match
= gfc_match_bind_c (NULL
, true);
6250 if (found_match
== MATCH_YES
)
6252 if (!gfc_notify_std (GFC_STD_F2003
, "BIND(C) statement at %C"))
6255 /* Look for the :: now, but it is not required. */
6258 /* Get the identifier(s) that needs to be updated. This may need to
6259 change to hand the flag(s) for the attr specified so all identifiers
6260 found can have all appropriate parts updated (assuming that the same
6261 spec stmt can have multiple attrs, such as both bind(c) and
6263 if (!get_bind_c_idents ())
6264 /* Error message should have printed already. */
6272 /* Match a data declaration statement. */
6275 gfc_match_data_decl (void)
6281 type_param_spec_list
= NULL
;
6282 decl_type_param_list
= NULL
;
6284 num_idents_on_line
= 0;
6286 m
= gfc_match_decl_type_spec (¤t_ts
, 0);
6290 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
6291 && !gfc_comp_struct (gfc_current_state ()))
6293 sym
= gfc_use_derived (current_ts
.u
.derived
);
6301 current_ts
.u
.derived
= sym
;
6304 m
= match_attr_spec ();
6305 if (m
== MATCH_ERROR
)
6312 if (current_ts
.type
== BT_CLASS
&& current_attr
.flavor
== FL_PARAMETER
)
6314 gfc_error ("CLASS entity at %C cannot have the PARAMETER attribute");
6319 if (current_ts
.type
== BT_CLASS
6320 && current_ts
.u
.derived
->attr
.unlimited_polymorphic
)
6323 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
6324 && current_ts
.u
.derived
->components
== NULL
6325 && !current_ts
.u
.derived
->attr
.zero_comp
)
6328 if (current_attr
.pointer
&& gfc_comp_struct (gfc_current_state ()))
6331 if (current_attr
.allocatable
&& gfc_current_state () == COMP_DERIVED
)
6334 gfc_find_symbol (current_ts
.u
.derived
->name
,
6335 current_ts
.u
.derived
->ns
, 1, &sym
);
6337 /* Any symbol that we find had better be a type definition
6338 which has its components defined, or be a structure definition
6339 actively being parsed. */
6340 if (sym
!= NULL
&& gfc_fl_struct (sym
->attr
.flavor
)
6341 && (current_ts
.u
.derived
->components
!= NULL
6342 || current_ts
.u
.derived
->attr
.zero_comp
6343 || current_ts
.u
.derived
== gfc_new_block
))
6346 gfc_error ("Derived type at %C has not been previously defined "
6347 "and so cannot appear in a derived type definition");
6353 /* If we have an old-style character declaration, and no new-style
6354 attribute specifications, then there a comma is optional between
6355 the type specification and the variable list. */
6356 if (m
== MATCH_NO
&& current_ts
.type
== BT_CHARACTER
&& old_char_selector
)
6357 gfc_match_char (',');
6359 /* Give the types/attributes to symbols that follow. Give the element
6360 a number so that repeat character length expressions can be copied. */
6364 num_idents_on_line
++;
6365 m
= variable_decl (elem
++);
6366 if (m
== MATCH_ERROR
)
6371 if (gfc_match_eos () == MATCH_YES
)
6373 if (gfc_match_char (',') != MATCH_YES
)
6377 if (!gfc_error_flag_test ())
6379 /* An anonymous structure declaration is unambiguous; if we matched one
6380 according to gfc_match_structure_decl, we need to return MATCH_YES
6381 here to avoid confusing the remaining matchers, even if there was an
6382 error during variable_decl. We must flush any such errors. Note this
6383 causes the parser to gracefully continue parsing the remaining input
6384 as a structure body, which likely follows. */
6385 if (current_ts
.type
== BT_DERIVED
&& current_ts
.u
.derived
6386 && gfc_fl_struct (current_ts
.u
.derived
->attr
.flavor
))
6388 gfc_error_now ("Syntax error in anonymous structure declaration"
6390 /* Skip the bad variable_decl and line up for the start of the
6392 gfc_error_recovery ();
6397 gfc_error ("Syntax error in data declaration at %C");
6402 gfc_free_data_all (gfc_current_ns
);
6405 if (saved_kind_expr
)
6406 gfc_free_expr (saved_kind_expr
);
6407 if (type_param_spec_list
)
6408 gfc_free_actual_arglist (type_param_spec_list
);
6409 if (decl_type_param_list
)
6410 gfc_free_actual_arglist (decl_type_param_list
);
6411 saved_kind_expr
= NULL
;
6412 gfc_free_array_spec (current_as
);
6418 in_module_or_interface(void)
6420 if (gfc_current_state () == COMP_MODULE
6421 || gfc_current_state () == COMP_SUBMODULE
6422 || gfc_current_state () == COMP_INTERFACE
)
6425 if (gfc_state_stack
->state
== COMP_CONTAINS
6426 || gfc_state_stack
->state
== COMP_FUNCTION
6427 || gfc_state_stack
->state
== COMP_SUBROUTINE
)
6430 for (p
= gfc_state_stack
->previous
; p
; p
= p
->previous
)
6432 if (p
->state
== COMP_MODULE
|| p
->state
== COMP_SUBMODULE
6433 || p
->state
== COMP_INTERFACE
)
6440 /* Match a prefix associated with a function or subroutine
6441 declaration. If the typespec pointer is nonnull, then a typespec
6442 can be matched. Note that if nothing matches, MATCH_YES is
6443 returned (the null string was matched). */
6446 gfc_match_prefix (gfc_typespec
*ts
)
6452 gfc_clear_attr (¤t_attr
);
6454 seen_impure
= false;
6456 gcc_assert (!gfc_matching_prefix
);
6457 gfc_matching_prefix
= true;
6461 found_prefix
= false;
6463 /* MODULE is a prefix like PURE, ELEMENTAL, etc., having a
6464 corresponding attribute seems natural and distinguishes these
6465 procedures from procedure types of PROC_MODULE, which these are
6467 if (gfc_match ("module% ") == MATCH_YES
)
6469 if (!gfc_notify_std (GFC_STD_F2008
, "MODULE prefix at %C"))
6472 if (!in_module_or_interface ())
6474 gfc_error ("MODULE prefix at %C found outside of a module, "
6475 "submodule, or interface");
6479 current_attr
.module_procedure
= 1;
6480 found_prefix
= true;
6483 if (!seen_type
&& ts
!= NULL
)
6486 m
= gfc_match_decl_type_spec (ts
, 0);
6487 if (m
== MATCH_ERROR
)
6489 if (m
== MATCH_YES
&& gfc_match_space () == MATCH_YES
)
6492 found_prefix
= true;
6496 if (gfc_match ("elemental% ") == MATCH_YES
)
6498 if (!gfc_add_elemental (¤t_attr
, NULL
))
6501 found_prefix
= true;
6504 if (gfc_match ("pure% ") == MATCH_YES
)
6506 if (!gfc_add_pure (¤t_attr
, NULL
))
6509 found_prefix
= true;
6512 if (gfc_match ("recursive% ") == MATCH_YES
)
6514 if (!gfc_add_recursive (¤t_attr
, NULL
))
6517 found_prefix
= true;
6520 /* IMPURE is a somewhat special case, as it needs not set an actual
6521 attribute but rather only prevents ELEMENTAL routines from being
6522 automatically PURE. */
6523 if (gfc_match ("impure% ") == MATCH_YES
)
6525 if (!gfc_notify_std (GFC_STD_F2008
, "IMPURE procedure at %C"))
6529 found_prefix
= true;
6532 while (found_prefix
);
6534 /* IMPURE and PURE must not both appear, of course. */
6535 if (seen_impure
&& current_attr
.pure
)
6537 gfc_error ("PURE and IMPURE must not appear both at %C");
6541 /* If IMPURE it not seen but the procedure is ELEMENTAL, mark it as PURE. */
6542 if (!seen_impure
&& current_attr
.elemental
&& !current_attr
.pure
)
6544 if (!gfc_add_pure (¤t_attr
, NULL
))
6548 /* At this point, the next item is not a prefix. */
6549 gcc_assert (gfc_matching_prefix
);
6551 gfc_matching_prefix
= false;
6555 gcc_assert (gfc_matching_prefix
);
6556 gfc_matching_prefix
= false;
6561 /* Copy attributes matched by gfc_match_prefix() to attributes on a symbol. */
6564 copy_prefix (symbol_attribute
*dest
, locus
*where
)
6566 if (dest
->module_procedure
)
6568 if (current_attr
.elemental
)
6569 dest
->elemental
= 1;
6571 if (current_attr
.pure
)
6574 if (current_attr
.recursive
)
6575 dest
->recursive
= 1;
6577 /* Module procedures are unusual in that the 'dest' is copied from
6578 the interface declaration. However, this is an oportunity to
6579 check that the submodule declaration is compliant with the
6581 if (dest
->elemental
&& !current_attr
.elemental
)
6583 gfc_error ("ELEMENTAL prefix in MODULE PROCEDURE interface is "
6584 "missing at %L", where
);
6588 if (dest
->pure
&& !current_attr
.pure
)
6590 gfc_error ("PURE prefix in MODULE PROCEDURE interface is "
6591 "missing at %L", where
);
6595 if (dest
->recursive
&& !current_attr
.recursive
)
6597 gfc_error ("RECURSIVE prefix in MODULE PROCEDURE interface is "
6598 "missing at %L", where
);
6605 if (current_attr
.elemental
&& !gfc_add_elemental (dest
, where
))
6608 if (current_attr
.pure
&& !gfc_add_pure (dest
, where
))
6611 if (current_attr
.recursive
&& !gfc_add_recursive (dest
, where
))
6618 /* Match a formal argument list or, if typeparam is true, a
6619 type_param_name_list. */
6622 gfc_match_formal_arglist (gfc_symbol
*progname
, int st_flag
,
6623 int null_flag
, bool typeparam
)
6625 gfc_formal_arglist
*head
, *tail
, *p
, *q
;
6626 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6629 gfc_formal_arglist
*formal
= NULL
;
6633 /* Keep the interface formal argument list and null it so that the
6634 matching for the new declaration can be done. The numbers and
6635 names of the arguments are checked here. The interface formal
6636 arguments are retained in formal_arglist and the characteristics
6637 are compared in resolve.cc(resolve_fl_procedure). See the remark
6638 in get_proc_name about the eventual need to copy the formal_arglist
6639 and populate the formal namespace of the interface symbol. */
6640 if (progname
->attr
.module_procedure
6641 && progname
->attr
.host_assoc
)
6643 formal
= progname
->formal
;
6644 progname
->formal
= NULL
;
6647 if (gfc_match_char ('(') != MATCH_YES
)
6654 if (gfc_match_char (')') == MATCH_YES
)
6658 gfc_error_now ("A type parameter list is required at %C");
6668 if (gfc_match_char ('*') == MATCH_YES
)
6671 if (!typeparam
&& !gfc_notify_std (GFC_STD_F95_OBS
,
6672 "Alternate-return argument at %C"))
6678 gfc_error_now ("A parameter name is required at %C");
6682 m
= gfc_match_name (name
);
6686 gfc_error_now ("A parameter name is required at %C");
6690 if (!typeparam
&& gfc_get_symbol (name
, NULL
, &sym
))
6693 && gfc_get_symbol (name
, progname
->f2k_derived
, &sym
))
6697 p
= gfc_get_formal_arglist ();
6709 /* We don't add the VARIABLE flavor because the name could be a
6710 dummy procedure. We don't apply these attributes to formal
6711 arguments of statement functions. */
6712 if (sym
!= NULL
&& !st_flag
6713 && (!gfc_add_dummy(&sym
->attr
, sym
->name
, NULL
)
6714 || !gfc_missing_attr (&sym
->attr
, NULL
)))
6720 /* The name of a program unit can be in a different namespace,
6721 so check for it explicitly. After the statement is accepted,
6722 the name is checked for especially in gfc_get_symbol(). */
6723 if (gfc_new_block
!= NULL
&& sym
!= NULL
&& !typeparam
6724 && strcmp (sym
->name
, gfc_new_block
->name
) == 0)
6726 gfc_error ("Name %qs at %C is the name of the procedure",
6732 if (gfc_match_char (')') == MATCH_YES
)
6735 m
= gfc_match_char (',');
6739 gfc_error_now ("Expected parameter list in type declaration "
6742 gfc_error ("Unexpected junk in formal argument list at %C");
6748 /* Check for duplicate symbols in the formal argument list. */
6751 for (p
= head
; p
->next
; p
= p
->next
)
6756 for (q
= p
->next
; q
; q
= q
->next
)
6757 if (p
->sym
== q
->sym
)
6760 gfc_error_now ("Duplicate name %qs in parameter "
6761 "list at %C", p
->sym
->name
);
6763 gfc_error ("Duplicate symbol %qs in formal argument "
6764 "list at %C", p
->sym
->name
);
6772 if (!gfc_add_explicit_interface (progname
, IFSRC_DECL
, head
, NULL
))
6778 /* gfc_error_now used in following and return with MATCH_YES because
6779 doing otherwise results in a cascade of extraneous errors and in
6780 some cases an ICE in symbol.cc(gfc_release_symbol). */
6781 if (progname
->attr
.module_procedure
&& progname
->attr
.host_assoc
)
6783 bool arg_count_mismatch
= false;
6785 if (!formal
&& head
)
6786 arg_count_mismatch
= true;
6788 /* Abbreviated module procedure declaration is not meant to have any
6789 formal arguments! */
6790 if (!progname
->abr_modproc_decl
&& formal
&& !head
)
6791 arg_count_mismatch
= true;
6793 for (p
= formal
, q
= head
; p
&& q
; p
= p
->next
, q
= q
->next
)
6795 if ((p
->next
!= NULL
&& q
->next
== NULL
)
6796 || (p
->next
== NULL
&& q
->next
!= NULL
))
6797 arg_count_mismatch
= true;
6798 else if ((p
->sym
== NULL
&& q
->sym
== NULL
)
6799 || (p
->sym
&& q
->sym
6800 && strcmp (p
->sym
->name
, q
->sym
->name
) == 0))
6805 gfc_error_now ("MODULE PROCEDURE formal argument %qs "
6806 "conflicts with alternate return at %C",
6808 else if (p
->sym
== NULL
)
6809 gfc_error_now ("MODULE PROCEDURE formal argument is "
6810 "alternate return and conflicts with "
6811 "%qs in the separate declaration at %C",
6814 gfc_error_now ("Mismatch in MODULE PROCEDURE formal "
6815 "argument names (%s/%s) at %C",
6816 p
->sym
->name
, q
->sym
->name
);
6820 if (arg_count_mismatch
)
6821 gfc_error_now ("Mismatch in number of MODULE PROCEDURE "
6822 "formal arguments at %C");
6828 gfc_free_formal_arglist (head
);
6833 /* Match a RESULT specification following a function declaration or
6834 ENTRY statement. Also matches the end-of-statement. */
6837 match_result (gfc_symbol
*function
, gfc_symbol
**result
)
6839 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6843 if (gfc_match (" result (") != MATCH_YES
)
6846 m
= gfc_match_name (name
);
6850 /* Get the right paren, and that's it because there could be the
6851 bind(c) attribute after the result clause. */
6852 if (gfc_match_char (')') != MATCH_YES
)
6854 /* TODO: should report the missing right paren here. */
6858 if (strcmp (function
->name
, name
) == 0)
6860 gfc_error ("RESULT variable at %C must be different than function name");
6864 if (gfc_get_symbol (name
, NULL
, &r
))
6867 if (!gfc_add_result (&r
->attr
, r
->name
, NULL
))
6876 /* Match a function suffix, which could be a combination of a result
6877 clause and BIND(C), either one, or neither. The draft does not
6878 require them to come in a specific order. */
6881 gfc_match_suffix (gfc_symbol
*sym
, gfc_symbol
**result
)
6883 match is_bind_c
; /* Found bind(c). */
6884 match is_result
; /* Found result clause. */
6885 match found_match
; /* Status of whether we've found a good match. */
6886 char peek_char
; /* Character we're going to peek at. */
6887 bool allow_binding_name
;
6889 /* Initialize to having found nothing. */
6890 found_match
= MATCH_NO
;
6891 is_bind_c
= MATCH_NO
;
6892 is_result
= MATCH_NO
;
6894 /* Get the next char to narrow between result and bind(c). */
6895 gfc_gobble_whitespace ();
6896 peek_char
= gfc_peek_ascii_char ();
6898 /* C binding names are not allowed for internal procedures. */
6899 if (gfc_current_state () == COMP_CONTAINS
6900 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
6901 allow_binding_name
= false;
6903 allow_binding_name
= true;
6908 /* Look for result clause. */
6909 is_result
= match_result (sym
, result
);
6910 if (is_result
== MATCH_YES
)
6912 /* Now see if there is a bind(c) after it. */
6913 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
6914 /* We've found the result clause and possibly bind(c). */
6915 found_match
= MATCH_YES
;
6918 /* This should only be MATCH_ERROR. */
6919 found_match
= is_result
;
6922 /* Look for bind(c) first. */
6923 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
6924 if (is_bind_c
== MATCH_YES
)
6926 /* Now see if a result clause followed it. */
6927 is_result
= match_result (sym
, result
);
6928 found_match
= MATCH_YES
;
6932 /* Should only be a MATCH_ERROR if we get here after seeing 'b'. */
6933 found_match
= MATCH_ERROR
;
6937 gfc_error ("Unexpected junk after function declaration at %C");
6938 found_match
= MATCH_ERROR
;
6942 if (is_bind_c
== MATCH_YES
)
6944 /* Fortran 2008 draft allows BIND(C) for internal procedures. */
6945 if (gfc_current_state () == COMP_CONTAINS
6946 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
6947 && !gfc_notify_std (GFC_STD_F2008
, "BIND(C) attribute "
6948 "at %L may not be specified for an internal "
6949 "procedure", &gfc_current_locus
))
6952 if (!gfc_add_is_bind_c (&(sym
->attr
), sym
->name
, &gfc_current_locus
, 1))
6960 /* Procedure pointer return value without RESULT statement:
6961 Add "hidden" result variable named "ppr@". */
6964 add_hidden_procptr_result (gfc_symbol
*sym
)
6968 if (gfc_notification_std (GFC_STD_F2003
) == ERROR
)
6971 /* First usage case: PROCEDURE and EXTERNAL statements. */
6972 case1
= gfc_current_state () == COMP_FUNCTION
&& gfc_current_block ()
6973 && strcmp (gfc_current_block ()->name
, sym
->name
) == 0
6974 && sym
->attr
.external
;
6975 /* Second usage case: INTERFACE statements. */
6976 case2
= gfc_current_state () == COMP_INTERFACE
&& gfc_state_stack
->previous
6977 && gfc_state_stack
->previous
->state
== COMP_FUNCTION
6978 && strcmp (gfc_state_stack
->previous
->sym
->name
, sym
->name
) == 0;
6984 gfc_get_sym_tree ("ppr@", gfc_current_ns
, &stree
, false);
6988 gfc_get_sym_tree ("ppr@", gfc_current_ns
->parent
, &stree
, false);
6989 st2
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "ppr@");
6990 st2
->n
.sym
= stree
->n
.sym
;
6991 stree
->n
.sym
->refs
++;
6993 sym
->result
= stree
->n
.sym
;
6995 sym
->result
->attr
.proc_pointer
= sym
->attr
.proc_pointer
;
6996 sym
->result
->attr
.pointer
= sym
->attr
.pointer
;
6997 sym
->result
->attr
.external
= sym
->attr
.external
;
6998 sym
->result
->attr
.referenced
= sym
->attr
.referenced
;
6999 sym
->result
->ts
= sym
->ts
;
7000 sym
->attr
.proc_pointer
= 0;
7001 sym
->attr
.pointer
= 0;
7002 sym
->attr
.external
= 0;
7003 if (sym
->result
->attr
.external
&& sym
->result
->attr
.pointer
)
7005 sym
->result
->attr
.pointer
= 0;
7006 sym
->result
->attr
.proc_pointer
= 1;
7009 return gfc_add_result (&sym
->result
->attr
, sym
->result
->name
, NULL
);
7011 /* POINTER after PROCEDURE/EXTERNAL/INTERFACE statement. */
7012 else if (sym
->attr
.function
&& !sym
->attr
.external
&& sym
->attr
.pointer
7013 && sym
->result
&& sym
->result
!= sym
&& sym
->result
->attr
.external
7014 && sym
== gfc_current_ns
->proc_name
7015 && sym
== sym
->result
->ns
->proc_name
7016 && strcmp ("ppr@", sym
->result
->name
) == 0)
7018 sym
->result
->attr
.proc_pointer
= 1;
7019 sym
->attr
.pointer
= 0;
7027 /* Match the interface for a PROCEDURE declaration,
7028 including brackets (R1212). */
7031 match_procedure_interface (gfc_symbol
**proc_if
)
7035 locus old_loc
, entry_loc
;
7036 gfc_namespace
*old_ns
= gfc_current_ns
;
7037 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7039 old_loc
= entry_loc
= gfc_current_locus
;
7040 gfc_clear_ts (¤t_ts
);
7042 if (gfc_match (" (") != MATCH_YES
)
7044 gfc_current_locus
= entry_loc
;
7048 /* Get the type spec. for the procedure interface. */
7049 old_loc
= gfc_current_locus
;
7050 m
= gfc_match_decl_type_spec (¤t_ts
, 0);
7051 gfc_gobble_whitespace ();
7052 if (m
== MATCH_YES
|| (m
== MATCH_NO
&& gfc_peek_ascii_char () == ')'))
7055 if (m
== MATCH_ERROR
)
7058 /* Procedure interface is itself a procedure. */
7059 gfc_current_locus
= old_loc
;
7060 m
= gfc_match_name (name
);
7062 /* First look to see if it is already accessible in the current
7063 namespace because it is use associated or contained. */
7065 if (gfc_find_sym_tree (name
, NULL
, 0, &st
))
7068 /* If it is still not found, then try the parent namespace, if it
7069 exists and create the symbol there if it is still not found. */
7070 if (gfc_current_ns
->parent
)
7071 gfc_current_ns
= gfc_current_ns
->parent
;
7072 if (st
== NULL
&& gfc_get_ha_sym_tree (name
, &st
))
7075 gfc_current_ns
= old_ns
;
7076 *proc_if
= st
->n
.sym
;
7081 /* Resolve interface if possible. That way, attr.procedure is only set
7082 if it is declared by a later procedure-declaration-stmt, which is
7083 invalid per F08:C1216 (cf. resolve_procedure_interface). */
7084 while ((*proc_if
)->ts
.interface
7085 && *proc_if
!= (*proc_if
)->ts
.interface
)
7086 *proc_if
= (*proc_if
)->ts
.interface
;
7088 if ((*proc_if
)->attr
.flavor
== FL_UNKNOWN
7089 && (*proc_if
)->ts
.type
== BT_UNKNOWN
7090 && !gfc_add_flavor (&(*proc_if
)->attr
, FL_PROCEDURE
,
7091 (*proc_if
)->name
, NULL
))
7096 if (gfc_match (" )") != MATCH_YES
)
7098 gfc_current_locus
= entry_loc
;
7106 /* Match a PROCEDURE declaration (R1211). */
7109 match_procedure_decl (void)
7112 gfc_symbol
*sym
, *proc_if
= NULL
;
7114 gfc_expr
*initializer
= NULL
;
7116 /* Parse interface (with brackets). */
7117 m
= match_procedure_interface (&proc_if
);
7121 /* Parse attributes (with colons). */
7122 m
= match_attr_spec();
7123 if (m
== MATCH_ERROR
)
7126 if (proc_if
&& proc_if
->attr
.is_bind_c
&& !current_attr
.is_bind_c
)
7128 current_attr
.is_bind_c
= 1;
7129 has_name_equals
= 0;
7130 curr_binding_label
= NULL
;
7133 /* Get procedure symbols. */
7136 m
= gfc_match_symbol (&sym
, 0);
7139 else if (m
== MATCH_ERROR
)
7142 /* Add current_attr to the symbol attributes. */
7143 if (!gfc_copy_attr (&sym
->attr
, ¤t_attr
, NULL
))
7146 if (sym
->attr
.is_bind_c
)
7148 /* Check for C1218. */
7149 if (!proc_if
|| !proc_if
->attr
.is_bind_c
)
7151 gfc_error ("BIND(C) attribute at %C requires "
7152 "an interface with BIND(C)");
7155 /* Check for C1217. */
7156 if (has_name_equals
&& sym
->attr
.pointer
)
7158 gfc_error ("BIND(C) procedure with NAME may not have "
7159 "POINTER attribute at %C");
7162 if (has_name_equals
&& sym
->attr
.dummy
)
7164 gfc_error ("Dummy procedure at %C may not have "
7165 "BIND(C) attribute with NAME");
7168 /* Set binding label for BIND(C). */
7169 if (!set_binding_label (&sym
->binding_label
, sym
->name
, num
))
7173 if (!gfc_add_external (&sym
->attr
, NULL
))
7176 if (add_hidden_procptr_result (sym
))
7179 if (!gfc_add_proc (&sym
->attr
, sym
->name
, NULL
))
7182 /* Set interface. */
7183 if (proc_if
!= NULL
)
7185 if (sym
->ts
.type
!= BT_UNKNOWN
)
7187 gfc_error ("Procedure %qs at %L already has basic type of %s",
7188 sym
->name
, &gfc_current_locus
,
7189 gfc_basic_typename (sym
->ts
.type
));
7192 sym
->ts
.interface
= proc_if
;
7193 sym
->attr
.untyped
= 1;
7194 sym
->attr
.if_source
= IFSRC_IFBODY
;
7196 else if (current_ts
.type
!= BT_UNKNOWN
)
7198 if (!gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
7200 sym
->ts
.interface
= gfc_new_symbol ("", gfc_current_ns
);
7201 sym
->ts
.interface
->ts
= current_ts
;
7202 sym
->ts
.interface
->attr
.flavor
= FL_PROCEDURE
;
7203 sym
->ts
.interface
->attr
.function
= 1;
7204 sym
->attr
.function
= 1;
7205 sym
->attr
.if_source
= IFSRC_UNKNOWN
;
7208 if (gfc_match (" =>") == MATCH_YES
)
7210 if (!current_attr
.pointer
)
7212 gfc_error ("Initialization at %C isn't for a pointer variable");
7217 m
= match_pointer_init (&initializer
, 1);
7221 if (!add_init_expr_to_sym (sym
->name
, &initializer
, &gfc_current_locus
))
7226 if (gfc_match_eos () == MATCH_YES
)
7228 if (gfc_match_char (',') != MATCH_YES
)
7233 gfc_error ("Syntax error in PROCEDURE statement at %C");
7237 /* Free stuff up and return. */
7238 gfc_free_expr (initializer
);
7244 match_binding_attributes (gfc_typebound_proc
* ba
, bool generic
, bool ppc
);
7247 /* Match a procedure pointer component declaration (R445). */
7250 match_ppc_decl (void)
7253 gfc_symbol
*proc_if
= NULL
;
7257 gfc_expr
*initializer
= NULL
;
7258 gfc_typebound_proc
* tb
;
7259 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7261 /* Parse interface (with brackets). */
7262 m
= match_procedure_interface (&proc_if
);
7266 /* Parse attributes. */
7267 tb
= XCNEW (gfc_typebound_proc
);
7268 tb
->where
= gfc_current_locus
;
7269 m
= match_binding_attributes (tb
, false, true);
7270 if (m
== MATCH_ERROR
)
7273 gfc_clear_attr (¤t_attr
);
7274 current_attr
.procedure
= 1;
7275 current_attr
.proc_pointer
= 1;
7276 current_attr
.access
= tb
->access
;
7277 current_attr
.flavor
= FL_PROCEDURE
;
7279 /* Match the colons (required). */
7280 if (gfc_match (" ::") != MATCH_YES
)
7282 gfc_error ("Expected %<::%> after binding-attributes at %C");
7286 /* Check for C450. */
7287 if (!tb
->nopass
&& proc_if
== NULL
)
7289 gfc_error("NOPASS or explicit interface required at %C");
7293 if (!gfc_notify_std (GFC_STD_F2003
, "Procedure pointer component at %C"))
7296 /* Match PPC names. */
7300 m
= gfc_match_name (name
);
7303 else if (m
== MATCH_ERROR
)
7306 if (!gfc_add_component (gfc_current_block(), name
, &c
))
7309 /* Add current_attr to the symbol attributes. */
7310 if (!gfc_copy_attr (&c
->attr
, ¤t_attr
, NULL
))
7313 if (!gfc_add_external (&c
->attr
, NULL
))
7316 if (!gfc_add_proc (&c
->attr
, name
, NULL
))
7323 c
->tb
= XCNEW (gfc_typebound_proc
);
7324 c
->tb
->where
= gfc_current_locus
;
7328 /* Set interface. */
7329 if (proc_if
!= NULL
)
7331 c
->ts
.interface
= proc_if
;
7332 c
->attr
.untyped
= 1;
7333 c
->attr
.if_source
= IFSRC_IFBODY
;
7335 else if (ts
.type
!= BT_UNKNOWN
)
7338 c
->ts
.interface
= gfc_new_symbol ("", gfc_current_ns
);
7339 c
->ts
.interface
->result
= c
->ts
.interface
;
7340 c
->ts
.interface
->ts
= ts
;
7341 c
->ts
.interface
->attr
.flavor
= FL_PROCEDURE
;
7342 c
->ts
.interface
->attr
.function
= 1;
7343 c
->attr
.function
= 1;
7344 c
->attr
.if_source
= IFSRC_UNKNOWN
;
7347 if (gfc_match (" =>") == MATCH_YES
)
7349 m
= match_pointer_init (&initializer
, 1);
7352 gfc_free_expr (initializer
);
7355 c
->initializer
= initializer
;
7358 if (gfc_match_eos () == MATCH_YES
)
7360 if (gfc_match_char (',') != MATCH_YES
)
7365 gfc_error ("Syntax error in procedure pointer component at %C");
7370 /* Match a PROCEDURE declaration inside an interface (R1206). */
7373 match_procedure_in_interface (void)
7377 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7380 if (current_interface
.type
== INTERFACE_NAMELESS
7381 || current_interface
.type
== INTERFACE_ABSTRACT
)
7383 gfc_error ("PROCEDURE at %C must be in a generic interface");
7387 /* Check if the F2008 optional double colon appears. */
7388 gfc_gobble_whitespace ();
7389 old_locus
= gfc_current_locus
;
7390 if (gfc_match ("::") == MATCH_YES
)
7392 if (!gfc_notify_std (GFC_STD_F2008
, "double colon in "
7393 "MODULE PROCEDURE statement at %L", &old_locus
))
7397 gfc_current_locus
= old_locus
;
7401 m
= gfc_match_name (name
);
7404 else if (m
== MATCH_ERROR
)
7406 if (gfc_get_symbol (name
, gfc_current_ns
->parent
, &sym
))
7409 if (!gfc_add_interface (sym
))
7412 if (gfc_match_eos () == MATCH_YES
)
7414 if (gfc_match_char (',') != MATCH_YES
)
7421 gfc_error ("Syntax error in PROCEDURE statement at %C");
7426 /* General matcher for PROCEDURE declarations. */
7428 static match
match_procedure_in_type (void);
7431 gfc_match_procedure (void)
7435 switch (gfc_current_state ())
7440 case COMP_SUBMODULE
:
7441 case COMP_SUBROUTINE
:
7444 m
= match_procedure_decl ();
7446 case COMP_INTERFACE
:
7447 m
= match_procedure_in_interface ();
7450 m
= match_ppc_decl ();
7452 case COMP_DERIVED_CONTAINS
:
7453 m
= match_procedure_in_type ();
7462 if (!gfc_notify_std (GFC_STD_F2003
, "PROCEDURE statement at %C"))
7469 /* Warn if a matched procedure has the same name as an intrinsic; this is
7470 simply a wrapper around gfc_warn_intrinsic_shadow that interprets the current
7471 parser-state-stack to find out whether we're in a module. */
7474 do_warn_intrinsic_shadow (const gfc_symbol
* sym
, bool func
)
7478 in_module
= (gfc_state_stack
->previous
7479 && (gfc_state_stack
->previous
->state
== COMP_MODULE
7480 || gfc_state_stack
->previous
->state
== COMP_SUBMODULE
));
7482 gfc_warn_intrinsic_shadow (sym
, in_module
, func
);
7486 /* Match a function declaration. */
7489 gfc_match_function_decl (void)
7491 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7492 gfc_symbol
*sym
, *result
;
7496 match found_match
; /* Status returned by match func. */
7498 if (gfc_current_state () != COMP_NONE
7499 && gfc_current_state () != COMP_INTERFACE
7500 && gfc_current_state () != COMP_CONTAINS
)
7503 gfc_clear_ts (¤t_ts
);
7505 old_loc
= gfc_current_locus
;
7507 m
= gfc_match_prefix (¤t_ts
);
7510 gfc_current_locus
= old_loc
;
7514 if (gfc_match ("function% %n", name
) != MATCH_YES
)
7516 gfc_current_locus
= old_loc
;
7520 if (get_proc_name (name
, &sym
, false))
7523 if (add_hidden_procptr_result (sym
))
7526 if (current_attr
.module_procedure
)
7527 sym
->attr
.module_procedure
= 1;
7529 gfc_new_block
= sym
;
7531 m
= gfc_match_formal_arglist (sym
, 0, 0);
7534 gfc_error ("Expected formal argument list in function "
7535 "definition at %C");
7539 else if (m
== MATCH_ERROR
)
7544 /* According to the draft, the bind(c) and result clause can
7545 come in either order after the formal_arg_list (i.e., either
7546 can be first, both can exist together or by themselves or neither
7547 one). Therefore, the match_result can't match the end of the
7548 string, and check for the bind(c) or result clause in either order. */
7549 found_match
= gfc_match_eos ();
7551 /* Make sure that it isn't already declared as BIND(C). If it is, it
7552 must have been marked BIND(C) with a BIND(C) attribute and that is
7553 not allowed for procedures. */
7554 if (sym
->attr
.is_bind_c
== 1)
7556 sym
->attr
.is_bind_c
= 0;
7558 if (gfc_state_stack
->previous
7559 && gfc_state_stack
->previous
->state
!= COMP_SUBMODULE
)
7562 loc
= sym
->old_symbol
!= NULL
7563 ? sym
->old_symbol
->declared_at
: gfc_current_locus
;
7564 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7565 "variables or common blocks", &loc
);
7569 if (found_match
!= MATCH_YES
)
7571 /* If we haven't found the end-of-statement, look for a suffix. */
7572 suffix_match
= gfc_match_suffix (sym
, &result
);
7573 if (suffix_match
== MATCH_YES
)
7574 /* Need to get the eos now. */
7575 found_match
= gfc_match_eos ();
7577 found_match
= suffix_match
;
7580 /* F2018 C1550 (R1526) If MODULE appears in the prefix of a module
7581 subprogram and a binding label is specified, it shall be the
7582 same as the binding label specified in the corresponding module
7583 procedure interface body. */
7584 if (sym
->attr
.is_bind_c
&& sym
->attr
.module_procedure
&& sym
->old_symbol
7585 && strcmp (sym
->name
, sym
->old_symbol
->name
) == 0
7586 && sym
->binding_label
&& sym
->old_symbol
->binding_label
7587 && strcmp (sym
->binding_label
, sym
->old_symbol
->binding_label
) != 0)
7589 const char *null
= "NULL", *s1
, *s2
;
7590 s1
= sym
->binding_label
;
7592 s2
= sym
->old_symbol
->binding_label
;
7594 gfc_error ("Mismatch in BIND(C) names (%qs/%qs) at %C", s1
, s2
);
7595 sym
->refs
++; /* Needed to avoid an ICE in gfc_release_symbol */
7599 if(found_match
!= MATCH_YES
)
7603 /* Make changes to the symbol. */
7606 if (!gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
7609 if (!gfc_missing_attr (&sym
->attr
, NULL
))
7612 if (!copy_prefix (&sym
->attr
, &sym
->declared_at
))
7614 if(!sym
->attr
.module_procedure
)
7620 /* Delay matching the function characteristics until after the
7621 specification block by signalling kind=-1. */
7622 sym
->declared_at
= old_loc
;
7623 if (current_ts
.type
!= BT_UNKNOWN
)
7624 current_ts
.kind
= -1;
7626 current_ts
.kind
= 0;
7630 if (current_ts
.type
!= BT_UNKNOWN
7631 && !gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
7637 if (current_ts
.type
!= BT_UNKNOWN
7638 && !gfc_add_type (result
, ¤t_ts
, &gfc_current_locus
))
7640 sym
->result
= result
;
7643 /* Warn if this procedure has the same name as an intrinsic. */
7644 do_warn_intrinsic_shadow (sym
, true);
7650 gfc_current_locus
= old_loc
;
7655 /* This is mostly a copy of parse.cc(add_global_procedure) but modified to
7656 pass the name of the entry, rather than the gfc_current_block name, and
7657 to return false upon finding an existing global entry. */
7660 add_global_entry (const char *name
, const char *binding_label
, bool sub
,
7664 enum gfc_symbol_type type
;
7666 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
7668 /* Only in Fortran 2003: For procedures with a binding label also the Fortran
7669 name is a global identifier. */
7670 if (!binding_label
|| gfc_notification_std (GFC_STD_F2008
))
7672 s
= gfc_get_gsymbol (name
, false);
7674 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= type
))
7676 gfc_global_used (s
, where
);
7685 s
->ns
= gfc_current_ns
;
7689 /* Don't add the symbol multiple times. */
7691 && (!gfc_notification_std (GFC_STD_F2008
)
7692 || strcmp (name
, binding_label
) != 0))
7694 s
= gfc_get_gsymbol (binding_label
, true);
7696 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= type
))
7698 gfc_global_used (s
, where
);
7705 s
->binding_label
= binding_label
;
7708 s
->ns
= gfc_current_ns
;
7716 /* Match an ENTRY statement. */
7719 gfc_match_entry (void)
7724 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7725 gfc_compile_state state
;
7729 bool module_procedure
;
7733 m
= gfc_match_name (name
);
7737 if (!gfc_notify_std (GFC_STD_F2008_OBS
, "ENTRY statement at %C"))
7740 state
= gfc_current_state ();
7741 if (state
!= COMP_SUBROUTINE
&& state
!= COMP_FUNCTION
)
7746 gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
7749 gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
7751 case COMP_SUBMODULE
:
7752 gfc_error ("ENTRY statement at %C cannot appear within a SUBMODULE");
7754 case COMP_BLOCK_DATA
:
7755 gfc_error ("ENTRY statement at %C cannot appear within "
7758 case COMP_INTERFACE
:
7759 gfc_error ("ENTRY statement at %C cannot appear within "
7762 case COMP_STRUCTURE
:
7763 gfc_error ("ENTRY statement at %C cannot appear within "
7764 "a STRUCTURE block");
7767 gfc_error ("ENTRY statement at %C cannot appear within "
7768 "a DERIVED TYPE block");
7771 gfc_error ("ENTRY statement at %C cannot appear within "
7772 "an IF-THEN block");
7775 case COMP_DO_CONCURRENT
:
7776 gfc_error ("ENTRY statement at %C cannot appear within "
7780 gfc_error ("ENTRY statement at %C cannot appear within "
7784 gfc_error ("ENTRY statement at %C cannot appear within "
7788 gfc_error ("ENTRY statement at %C cannot appear within "
7792 gfc_error ("ENTRY statement at %C cannot appear within "
7793 "a contained subprogram");
7796 gfc_error ("Unexpected ENTRY statement at %C");
7801 if ((state
== COMP_SUBROUTINE
|| state
== COMP_FUNCTION
)
7802 && gfc_state_stack
->previous
->state
== COMP_INTERFACE
)
7804 gfc_error ("ENTRY statement at %C cannot appear within an INTERFACE");
7808 module_procedure
= gfc_current_ns
->parent
!= NULL
7809 && gfc_current_ns
->parent
->proc_name
7810 && gfc_current_ns
->parent
->proc_name
->attr
.flavor
7813 if (gfc_current_ns
->parent
!= NULL
7814 && gfc_current_ns
->parent
->proc_name
7815 && !module_procedure
)
7817 gfc_error("ENTRY statement at %C cannot appear in a "
7818 "contained procedure");
7822 /* Module function entries need special care in get_proc_name
7823 because previous references within the function will have
7824 created symbols attached to the current namespace. */
7825 if (get_proc_name (name
, &entry
,
7826 gfc_current_ns
->parent
!= NULL
7827 && module_procedure
))
7830 proc
= gfc_current_block ();
7832 /* Make sure that it isn't already declared as BIND(C). If it is, it
7833 must have been marked BIND(C) with a BIND(C) attribute and that is
7834 not allowed for procedures. */
7835 if (entry
->attr
.is_bind_c
== 1)
7839 entry
->attr
.is_bind_c
= 0;
7841 loc
= entry
->old_symbol
!= NULL
7842 ? entry
->old_symbol
->declared_at
: gfc_current_locus
;
7843 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7844 "variables or common blocks", &loc
);
7847 /* Check what next non-whitespace character is so we can tell if there
7848 is the required parens if we have a BIND(C). */
7849 old_loc
= gfc_current_locus
;
7850 gfc_gobble_whitespace ();
7851 peek_char
= gfc_peek_ascii_char ();
7853 if (state
== COMP_SUBROUTINE
)
7855 m
= gfc_match_formal_arglist (entry
, 0, 1);
7859 /* Call gfc_match_bind_c with allow_binding_name = true as ENTRY can
7860 never be an internal procedure. */
7861 is_bind_c
= gfc_match_bind_c (entry
, true);
7862 if (is_bind_c
== MATCH_ERROR
)
7864 if (is_bind_c
== MATCH_YES
)
7866 if (peek_char
!= '(')
7868 gfc_error ("Missing required parentheses before BIND(C) at %C");
7872 if (!gfc_add_is_bind_c (&(entry
->attr
), entry
->name
,
7873 &(entry
->declared_at
), 1))
7878 if (!gfc_current_ns
->parent
7879 && !add_global_entry (name
, entry
->binding_label
, true,
7883 /* An entry in a subroutine. */
7884 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
7885 || !gfc_add_subroutine (&entry
->attr
, entry
->name
, NULL
))
7890 /* An entry in a function.
7891 We need to take special care because writing
7896 ENTRY f() RESULT (r)
7898 ENTRY f RESULT (r). */
7899 if (gfc_match_eos () == MATCH_YES
)
7901 gfc_current_locus
= old_loc
;
7902 /* Match the empty argument list, and add the interface to
7904 m
= gfc_match_formal_arglist (entry
, 0, 1);
7907 m
= gfc_match_formal_arglist (entry
, 0, 0);
7914 if (gfc_match_eos () == MATCH_YES
)
7916 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
7917 || !gfc_add_function (&entry
->attr
, entry
->name
, NULL
))
7920 entry
->result
= entry
;
7924 m
= gfc_match_suffix (entry
, &result
);
7926 gfc_syntax_error (ST_ENTRY
);
7932 if (!gfc_add_result (&result
->attr
, result
->name
, NULL
)
7933 || !gfc_add_entry (&entry
->attr
, result
->name
, NULL
)
7934 || !gfc_add_function (&entry
->attr
, result
->name
, NULL
))
7936 entry
->result
= result
;
7940 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
7941 || !gfc_add_function (&entry
->attr
, entry
->name
, NULL
))
7943 entry
->result
= entry
;
7947 if (!gfc_current_ns
->parent
7948 && !add_global_entry (name
, entry
->binding_label
, false,
7953 if (gfc_match_eos () != MATCH_YES
)
7955 gfc_syntax_error (ST_ENTRY
);
7959 /* F2018:C1546 An elemental procedure shall not have the BIND attribute. */
7960 if (proc
->attr
.elemental
&& entry
->attr
.is_bind_c
)
7962 gfc_error ("ENTRY statement at %L with BIND(C) prohibited in an "
7963 "elemental procedure", &entry
->declared_at
);
7967 entry
->attr
.recursive
= proc
->attr
.recursive
;
7968 entry
->attr
.elemental
= proc
->attr
.elemental
;
7969 entry
->attr
.pure
= proc
->attr
.pure
;
7971 el
= gfc_get_entry_list ();
7973 el
->next
= gfc_current_ns
->entries
;
7974 gfc_current_ns
->entries
= el
;
7976 el
->id
= el
->next
->id
+ 1;
7980 new_st
.op
= EXEC_ENTRY
;
7981 new_st
.ext
.entry
= el
;
7987 /* Match a subroutine statement, including optional prefixes. */
7990 gfc_match_subroutine (void)
7992 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7997 bool allow_binding_name
;
8000 if (gfc_current_state () != COMP_NONE
8001 && gfc_current_state () != COMP_INTERFACE
8002 && gfc_current_state () != COMP_CONTAINS
)
8005 m
= gfc_match_prefix (NULL
);
8009 m
= gfc_match ("subroutine% %n", name
);
8013 if (get_proc_name (name
, &sym
, false))
8016 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
8017 the symbol existed before. */
8018 sym
->declared_at
= gfc_current_locus
;
8020 if (current_attr
.module_procedure
)
8021 sym
->attr
.module_procedure
= 1;
8023 if (add_hidden_procptr_result (sym
))
8026 gfc_new_block
= sym
;
8028 /* Check what next non-whitespace character is so we can tell if there
8029 is the required parens if we have a BIND(C). */
8030 gfc_gobble_whitespace ();
8031 peek_char
= gfc_peek_ascii_char ();
8033 if (!gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
))
8036 if (gfc_match_formal_arglist (sym
, 0, 1) != MATCH_YES
)
8039 /* Make sure that it isn't already declared as BIND(C). If it is, it
8040 must have been marked BIND(C) with a BIND(C) attribute and that is
8041 not allowed for procedures. */
8042 if (sym
->attr
.is_bind_c
== 1)
8044 sym
->attr
.is_bind_c
= 0;
8046 if (gfc_state_stack
->previous
8047 && gfc_state_stack
->previous
->state
!= COMP_SUBMODULE
)
8050 loc
= sym
->old_symbol
!= NULL
8051 ? sym
->old_symbol
->declared_at
: gfc_current_locus
;
8052 gfc_error_now ("BIND(C) attribute at %L can only be used for "
8053 "variables or common blocks", &loc
);
8057 /* C binding names are not allowed for internal procedures. */
8058 if (gfc_current_state () == COMP_CONTAINS
8059 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
8060 allow_binding_name
= false;
8062 allow_binding_name
= true;
8064 /* Here, we are just checking if it has the bind(c) attribute, and if
8065 so, then we need to make sure it's all correct. If it doesn't,
8066 we still need to continue matching the rest of the subroutine line. */
8067 gfc_gobble_whitespace ();
8068 loc
= gfc_current_locus
;
8069 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
8070 if (is_bind_c
== MATCH_ERROR
)
8072 /* There was an attempt at the bind(c), but it was wrong. An
8073 error message should have been printed w/in the gfc_match_bind_c
8074 so here we'll just return the MATCH_ERROR. */
8078 if (is_bind_c
== MATCH_YES
)
8080 gfc_formal_arglist
*arg
;
8082 /* The following is allowed in the Fortran 2008 draft. */
8083 if (gfc_current_state () == COMP_CONTAINS
8084 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
8085 && !gfc_notify_std (GFC_STD_F2008
, "BIND(C) attribute "
8086 "at %L may not be specified for an internal "
8087 "procedure", &gfc_current_locus
))
8090 if (peek_char
!= '(')
8092 gfc_error ("Missing required parentheses before BIND(C) at %C");
8096 /* F2018 C1550 (R1526) If MODULE appears in the prefix of a module
8097 subprogram and a binding label is specified, it shall be the
8098 same as the binding label specified in the corresponding module
8099 procedure interface body. */
8100 if (sym
->attr
.module_procedure
&& sym
->old_symbol
8101 && strcmp (sym
->name
, sym
->old_symbol
->name
) == 0
8102 && sym
->binding_label
&& sym
->old_symbol
->binding_label
8103 && strcmp (sym
->binding_label
, sym
->old_symbol
->binding_label
) != 0)
8105 const char *null
= "NULL", *s1
, *s2
;
8106 s1
= sym
->binding_label
;
8108 s2
= sym
->old_symbol
->binding_label
;
8110 gfc_error ("Mismatch in BIND(C) names (%qs/%qs) at %C", s1
, s2
);
8111 sym
->refs
++; /* Needed to avoid an ICE in gfc_release_symbol */
8115 /* Scan the dummy arguments for an alternate return. */
8116 for (arg
= sym
->formal
; arg
; arg
= arg
->next
)
8119 gfc_error ("Alternate return dummy argument cannot appear in a "
8120 "SUBROUTINE with the BIND(C) attribute at %L", &loc
);
8124 if (!gfc_add_is_bind_c (&(sym
->attr
), sym
->name
, &(sym
->declared_at
), 1))
8128 if (gfc_match_eos () != MATCH_YES
)
8130 gfc_syntax_error (ST_SUBROUTINE
);
8134 if (!copy_prefix (&sym
->attr
, &sym
->declared_at
))
8136 if(!sym
->attr
.module_procedure
)
8142 /* Warn if it has the same name as an intrinsic. */
8143 do_warn_intrinsic_shadow (sym
, false);
8149 /* Check that the NAME identifier in a BIND attribute or statement
8150 is conform to C identifier rules. */
8153 check_bind_name_identifier (char **name
)
8155 char *n
= *name
, *p
;
8157 /* Remove leading spaces. */
8161 /* On an empty string, free memory and set name to NULL. */
8169 /* Remove trailing spaces. */
8170 p
= n
+ strlen(n
) - 1;
8174 /* Insert the identifier into the symbol table. */
8179 /* Now check that identifier is valid under C rules. */
8182 gfc_error ("Invalid C identifier in NAME= specifier at %C");
8187 if (!(ISALNUM (*p
) || *p
== '_' || *p
== '$'))
8189 gfc_error ("Invalid C identifier in NAME= specifier at %C");
8197 /* Match a BIND(C) specifier, with the optional 'name=' specifier if
8198 given, and set the binding label in either the given symbol (if not
8199 NULL), or in the current_ts. The symbol may be NULL because we may
8200 encounter the BIND(C) before the declaration itself. Return
8201 MATCH_NO if what we're looking at isn't a BIND(C) specifier,
8202 MATCH_ERROR if it is a BIND(C) clause but an error was encountered,
8203 or MATCH_YES if the specifier was correct and the binding label and
8204 bind(c) fields were set correctly for the given symbol or the
8205 current_ts. If allow_binding_name is false, no binding name may be
8209 gfc_match_bind_c (gfc_symbol
*sym
, bool allow_binding_name
)
8211 char *binding_label
= NULL
;
8214 /* Initialize the flag that specifies whether we encountered a NAME=
8215 specifier or not. */
8216 has_name_equals
= 0;
8218 /* This much we have to be able to match, in this order, if
8219 there is a bind(c) label. */
8220 if (gfc_match (" bind ( c ") != MATCH_YES
)
8223 /* Now see if there is a binding label, or if we've reached the
8224 end of the bind(c) attribute without one. */
8225 if (gfc_match_char (',') == MATCH_YES
)
8227 if (gfc_match (" name = ") != MATCH_YES
)
8229 gfc_error ("Syntax error in NAME= specifier for binding label "
8231 /* should give an error message here */
8235 has_name_equals
= 1;
8237 if (gfc_match_init_expr (&e
) != MATCH_YES
)
8243 if (!gfc_simplify_expr(e
, 0))
8245 gfc_error ("NAME= specifier at %C should be a constant expression");
8250 if (e
->expr_type
!= EXPR_CONSTANT
|| e
->ts
.type
!= BT_CHARACTER
8251 || e
->ts
.kind
!= gfc_default_character_kind
|| e
->rank
!= 0)
8253 gfc_error ("NAME= specifier at %C should be a scalar of "
8254 "default character kind");
8259 // Get a C string from the Fortran string constant
8260 binding_label
= gfc_widechar_to_char (e
->value
.character
.string
,
8261 e
->value
.character
.length
);
8264 // Check that it is valid (old gfc_match_name_C)
8265 if (check_bind_name_identifier (&binding_label
) != MATCH_YES
)
8269 /* Get the required right paren. */
8270 if (gfc_match_char (')') != MATCH_YES
)
8272 gfc_error ("Missing closing paren for binding label at %C");
8276 if (has_name_equals
&& !allow_binding_name
)
8278 gfc_error ("No binding name is allowed in BIND(C) at %C");
8282 if (has_name_equals
&& sym
!= NULL
&& sym
->attr
.dummy
)
8284 gfc_error ("For dummy procedure %s, no binding name is "
8285 "allowed in BIND(C) at %C", sym
->name
);
8290 /* Save the binding label to the symbol. If sym is null, we're
8291 probably matching the typespec attributes of a declaration and
8292 haven't gotten the name yet, and therefore, no symbol yet. */
8296 sym
->binding_label
= binding_label
;
8298 curr_binding_label
= binding_label
;
8300 else if (allow_binding_name
)
8302 /* No binding label, but if symbol isn't null, we
8303 can set the label for it here.
8304 If name="" or allow_binding_name is false, no C binding name is
8306 if (sym
!= NULL
&& sym
->name
!= NULL
&& has_name_equals
== 0)
8307 sym
->binding_label
= IDENTIFIER_POINTER (get_identifier (sym
->name
));
8310 if (has_name_equals
&& gfc_current_state () == COMP_INTERFACE
8311 && current_interface
.type
== INTERFACE_ABSTRACT
)
8313 gfc_error ("NAME not allowed on BIND(C) for ABSTRACT INTERFACE at %C");
8321 /* Return nonzero if we're currently compiling a contained procedure. */
8324 contained_procedure (void)
8326 gfc_state_data
*s
= gfc_state_stack
;
8328 if ((s
->state
== COMP_SUBROUTINE
|| s
->state
== COMP_FUNCTION
)
8329 && s
->previous
!= NULL
&& s
->previous
->state
== COMP_CONTAINS
)
8335 /* Set the kind of each enumerator. The kind is selected such that it is
8336 interoperable with the corresponding C enumeration type, making
8337 sure that -fshort-enums is honored. */
8342 enumerator_history
*current_history
= NULL
;
8346 if (max_enum
== NULL
|| enum_history
== NULL
)
8349 if (!flag_short_enums
)
8355 kind
= gfc_integer_kinds
[i
++].kind
;
8357 while (kind
< gfc_c_int_kind
8358 && gfc_check_integer_range (max_enum
->initializer
->value
.integer
,
8361 current_history
= enum_history
;
8362 while (current_history
!= NULL
)
8364 current_history
->sym
->ts
.kind
= kind
;
8365 current_history
= current_history
->next
;
8370 /* Match any of the various end-block statements. Returns the type of
8371 END to the caller. The END INTERFACE, END IF, END DO, END SELECT
8372 and END BLOCK statements cannot be replaced by a single END statement. */
8375 gfc_match_end (gfc_statement
*st
)
8377 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8378 gfc_compile_state state
;
8380 const char *block_name
;
8384 gfc_namespace
*parent_ns
, *ns
, *prev_ns
;
8385 gfc_namespace
**nsp
;
8386 bool abbreviated_modproc_decl
= false;
8387 bool got_matching_end
= false;
8389 old_loc
= gfc_current_locus
;
8390 if (gfc_match ("end") != MATCH_YES
)
8393 state
= gfc_current_state ();
8394 block_name
= gfc_current_block () == NULL
8395 ? NULL
: gfc_current_block ()->name
;
8399 case COMP_ASSOCIATE
:
8401 if (startswith (block_name
, "block@"))
8406 case COMP_DERIVED_CONTAINS
:
8407 state
= gfc_state_stack
->previous
->state
;
8408 block_name
= gfc_state_stack
->previous
->sym
== NULL
8409 ? NULL
: gfc_state_stack
->previous
->sym
->name
;
8410 abbreviated_modproc_decl
= gfc_state_stack
->previous
->sym
8411 && gfc_state_stack
->previous
->sym
->abr_modproc_decl
;
8418 if (!abbreviated_modproc_decl
)
8419 abbreviated_modproc_decl
= gfc_current_block ()
8420 && gfc_current_block ()->abr_modproc_decl
;
8426 *st
= ST_END_PROGRAM
;
8427 target
= " program";
8431 case COMP_SUBROUTINE
:
8432 *st
= ST_END_SUBROUTINE
;
8433 if (!abbreviated_modproc_decl
)
8434 target
= " subroutine";
8436 target
= " procedure";
8437 eos_ok
= !contained_procedure ();
8441 *st
= ST_END_FUNCTION
;
8442 if (!abbreviated_modproc_decl
)
8443 target
= " function";
8445 target
= " procedure";
8446 eos_ok
= !contained_procedure ();
8449 case COMP_BLOCK_DATA
:
8450 *st
= ST_END_BLOCK_DATA
;
8451 target
= " block data";
8456 *st
= ST_END_MODULE
;
8461 case COMP_SUBMODULE
:
8462 *st
= ST_END_SUBMODULE
;
8463 target
= " submodule";
8467 case COMP_INTERFACE
:
8468 *st
= ST_END_INTERFACE
;
8469 target
= " interface";
8485 case COMP_STRUCTURE
:
8486 *st
= ST_END_STRUCTURE
;
8487 target
= " structure";
8492 case COMP_DERIVED_CONTAINS
:
8498 case COMP_ASSOCIATE
:
8499 *st
= ST_END_ASSOCIATE
;
8500 target
= " associate";
8505 case COMP_OMP_STRICTLY_STRUCTURED_BLOCK
:
8518 case COMP_DO_CONCURRENT
:
8525 *st
= ST_END_CRITICAL
;
8526 target
= " critical";
8531 case COMP_SELECT_TYPE
:
8532 case COMP_SELECT_RANK
:
8533 *st
= ST_END_SELECT
;
8539 *st
= ST_END_FORALL
;
8554 last_initializer
= NULL
;
8556 gfc_free_enum_history ();
8560 gfc_error ("Unexpected END statement at %C");
8564 old_loc
= gfc_current_locus
;
8565 if (gfc_match_eos () == MATCH_YES
)
8567 if (!eos_ok
&& (*st
== ST_END_SUBROUTINE
|| *st
== ST_END_FUNCTION
))
8569 if (!gfc_notify_std (GFC_STD_F2008
, "END statement "
8570 "instead of %s statement at %L",
8571 abbreviated_modproc_decl
? "END PROCEDURE"
8572 : gfc_ascii_statement(*st
), &old_loc
))
8577 /* We would have required END [something]. */
8578 gfc_error ("%s statement expected at %L",
8579 gfc_ascii_statement (*st
), &old_loc
);
8586 /* Verify that we've got the sort of end-block that we're expecting. */
8587 if (gfc_match (target
) != MATCH_YES
)
8589 gfc_error ("Expecting %s statement at %L", abbreviated_modproc_decl
8590 ? "END PROCEDURE" : gfc_ascii_statement(*st
), &old_loc
);
8594 got_matching_end
= true;
8596 old_loc
= gfc_current_locus
;
8597 /* If we're at the end, make sure a block name wasn't required. */
8598 if (gfc_match_eos () == MATCH_YES
)
8601 if (*st
!= ST_ENDDO
&& *st
!= ST_ENDIF
&& *st
!= ST_END_SELECT
8602 && *st
!= ST_END_FORALL
&& *st
!= ST_END_WHERE
&& *st
!= ST_END_BLOCK
8603 && *st
!= ST_END_ASSOCIATE
&& *st
!= ST_END_CRITICAL
)
8609 gfc_error ("Expected block name of %qs in %s statement at %L",
8610 block_name
, gfc_ascii_statement (*st
), &old_loc
);
8615 /* END INTERFACE has a special handler for its several possible endings. */
8616 if (*st
== ST_END_INTERFACE
)
8617 return gfc_match_end_interface ();
8619 /* We haven't hit the end of statement, so what is left must be an
8621 m
= gfc_match_space ();
8623 m
= gfc_match_name (name
);
8626 gfc_error ("Expected terminating name at %C");
8630 if (block_name
== NULL
)
8633 /* We have to pick out the declared submodule name from the composite
8634 required by F2008:11.2.3 para 2, which ends in the declared name. */
8635 if (state
== COMP_SUBMODULE
)
8636 block_name
= strchr (block_name
, '.') + 1;
8638 if (strcmp (name
, block_name
) != 0 && strcmp (block_name
, "ppr@") != 0)
8640 gfc_error ("Expected label %qs for %s statement at %C", block_name
,
8641 gfc_ascii_statement (*st
));
8644 /* Procedure pointer as function result. */
8645 else if (strcmp (block_name
, "ppr@") == 0
8646 && strcmp (name
, gfc_current_block ()->ns
->proc_name
->name
) != 0)
8648 gfc_error ("Expected label %qs for %s statement at %C",
8649 gfc_current_block ()->ns
->proc_name
->name
,
8650 gfc_ascii_statement (*st
));
8654 if (gfc_match_eos () == MATCH_YES
)
8658 gfc_syntax_error (*st
);
8661 gfc_current_locus
= old_loc
;
8663 /* If we are missing an END BLOCK, we created a half-ready namespace.
8664 Remove it from the parent namespace's sibling list. */
8666 while (state
== COMP_BLOCK
&& !got_matching_end
)
8668 parent_ns
= gfc_current_ns
->parent
;
8670 nsp
= &(gfc_state_stack
->previous
->tail
->ext
.block
.ns
);
8676 if (ns
== gfc_current_ns
)
8678 if (prev_ns
== NULL
)
8681 prev_ns
->sibling
= ns
->sibling
;
8687 gfc_free_namespace (gfc_current_ns
);
8688 gfc_current_ns
= parent_ns
;
8689 gfc_state_stack
= gfc_state_stack
->previous
;
8690 state
= gfc_current_state ();
8698 /***************** Attribute declaration statements ****************/
8700 /* Set the attribute of a single variable. */
8705 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8708 /* Workaround -Wmaybe-uninitialized false positive during
8709 profiledbootstrap by initializing them. */
8710 gfc_symbol
*sym
= NULL
;
8716 m
= gfc_match_name (name
);
8720 if (find_special (name
, &sym
, false))
8723 if (!check_function_name (name
))
8729 var_locus
= gfc_current_locus
;
8731 /* Deal with possible array specification for certain attributes. */
8732 if (current_attr
.dimension
8733 || current_attr
.codimension
8734 || current_attr
.allocatable
8735 || current_attr
.pointer
8736 || current_attr
.target
)
8738 m
= gfc_match_array_spec (&as
, !current_attr
.codimension
,
8739 !current_attr
.dimension
8740 && !current_attr
.pointer
8741 && !current_attr
.target
);
8742 if (m
== MATCH_ERROR
)
8745 if (current_attr
.dimension
&& m
== MATCH_NO
)
8747 gfc_error ("Missing array specification at %L in DIMENSION "
8748 "statement", &var_locus
);
8753 if (current_attr
.dimension
&& sym
->value
)
8755 gfc_error ("Dimensions specified for %s at %L after its "
8756 "initialization", sym
->name
, &var_locus
);
8761 if (current_attr
.codimension
&& m
== MATCH_NO
)
8763 gfc_error ("Missing array specification at %L in CODIMENSION "
8764 "statement", &var_locus
);
8769 if ((current_attr
.allocatable
|| current_attr
.pointer
)
8770 && (m
== MATCH_YES
) && (as
->type
!= AS_DEFERRED
))
8772 gfc_error ("Array specification must be deferred at %L", &var_locus
);
8778 if (sym
->ts
.type
== BT_CLASS
8779 && sym
->ts
.u
.derived
8780 && sym
->ts
.u
.derived
->attr
.is_class
)
8782 sym
->attr
.pointer
= CLASS_DATA(sym
)->attr
.class_pointer
;
8783 sym
->attr
.allocatable
= CLASS_DATA(sym
)->attr
.allocatable
;
8784 sym
->attr
.dimension
= CLASS_DATA(sym
)->attr
.dimension
;
8785 sym
->attr
.codimension
= CLASS_DATA(sym
)->attr
.codimension
;
8786 if (CLASS_DATA (sym
)->as
)
8787 sym
->as
= gfc_copy_array_spec (CLASS_DATA (sym
)->as
);
8789 if (current_attr
.dimension
== 0 && current_attr
.codimension
== 0
8790 && !gfc_copy_attr (&sym
->attr
, ¤t_attr
, &var_locus
))
8795 if (!gfc_set_array_spec (sym
, as
, &var_locus
))
8801 if (sym
->attr
.cray_pointee
&& sym
->as
!= NULL
)
8803 /* Fix the array spec. */
8804 m
= gfc_mod_pointee_as (sym
->as
);
8805 if (m
== MATCH_ERROR
)
8809 if (!gfc_add_attribute (&sym
->attr
, &var_locus
))
8815 if ((current_attr
.external
|| current_attr
.intrinsic
)
8816 && sym
->attr
.flavor
!= FL_PROCEDURE
8817 && !gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, NULL
))
8823 if (sym
->ts
.type
== BT_CLASS
&& sym
->ts
.u
.derived
->attr
.is_class
8824 && !as
&& !current_attr
.pointer
&& !current_attr
.allocatable
8825 && !current_attr
.external
)
8827 sym
->attr
.pointer
= 0;
8828 sym
->attr
.allocatable
= 0;
8829 sym
->attr
.dimension
= 0;
8830 sym
->attr
.codimension
= 0;
8831 gfc_free_array_spec (sym
->as
);
8834 else if (sym
->ts
.type
== BT_CLASS
8835 && !gfc_build_class_symbol (&sym
->ts
, &sym
->attr
, &sym
->as
))
8841 add_hidden_procptr_result (sym
);
8846 gfc_free_array_spec (as
);
8851 /* Generic attribute declaration subroutine. Used for attributes that
8852 just have a list of names. */
8859 /* Gobble the optional double colon, by simply ignoring the result
8869 if (gfc_match_eos () == MATCH_YES
)
8875 if (gfc_match_char (',') != MATCH_YES
)
8877 gfc_error ("Unexpected character in variable list at %C");
8887 /* This routine matches Cray Pointer declarations of the form:
8888 pointer ( <pointer>, <pointee> )
8890 pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...
8891 The pointer, if already declared, should be an integer. Otherwise, we
8892 set it as BT_INTEGER with kind gfc_index_integer_kind. The pointee may
8893 be either a scalar, or an array declaration. No space is allocated for
8894 the pointee. For the statement
8895 pointer (ipt, ar(10))
8896 any subsequent uses of ar will be translated (in C-notation) as
8897 ar(i) => ((<type> *) ipt)(i)
8898 After gimplification, pointee variable will disappear in the code. */
8901 cray_pointer_decl (void)
8904 gfc_array_spec
*as
= NULL
;
8905 gfc_symbol
*cptr
; /* Pointer symbol. */
8906 gfc_symbol
*cpte
; /* Pointee symbol. */
8912 if (gfc_match_char ('(') != MATCH_YES
)
8914 gfc_error ("Expected %<(%> at %C");
8918 /* Match pointer. */
8919 var_locus
= gfc_current_locus
;
8920 gfc_clear_attr (¤t_attr
);
8921 gfc_add_cray_pointer (¤t_attr
, &var_locus
);
8922 current_ts
.type
= BT_INTEGER
;
8923 current_ts
.kind
= gfc_index_integer_kind
;
8925 m
= gfc_match_symbol (&cptr
, 0);
8928 gfc_error ("Expected variable name at %C");
8932 if (!gfc_add_cray_pointer (&cptr
->attr
, &var_locus
))
8935 gfc_set_sym_referenced (cptr
);
8937 if (cptr
->ts
.type
== BT_UNKNOWN
) /* Override the type, if necessary. */
8939 cptr
->ts
.type
= BT_INTEGER
;
8940 cptr
->ts
.kind
= gfc_index_integer_kind
;
8942 else if (cptr
->ts
.type
!= BT_INTEGER
)
8944 gfc_error ("Cray pointer at %C must be an integer");
8947 else if (cptr
->ts
.kind
< gfc_index_integer_kind
)
8948 gfc_warning (0, "Cray pointer at %C has %d bytes of precision;"
8949 " memory addresses require %d bytes",
8950 cptr
->ts
.kind
, gfc_index_integer_kind
);
8952 if (gfc_match_char (',') != MATCH_YES
)
8954 gfc_error ("Expected \",\" at %C");
8958 /* Match Pointee. */
8959 var_locus
= gfc_current_locus
;
8960 gfc_clear_attr (¤t_attr
);
8961 gfc_add_cray_pointee (¤t_attr
, &var_locus
);
8962 current_ts
.type
= BT_UNKNOWN
;
8963 current_ts
.kind
= 0;
8965 m
= gfc_match_symbol (&cpte
, 0);
8968 gfc_error ("Expected variable name at %C");
8972 /* Check for an optional array spec. */
8973 m
= gfc_match_array_spec (&as
, true, false);
8974 if (m
== MATCH_ERROR
)
8976 gfc_free_array_spec (as
);
8979 else if (m
== MATCH_NO
)
8981 gfc_free_array_spec (as
);
8985 if (!gfc_add_cray_pointee (&cpte
->attr
, &var_locus
))
8988 gfc_set_sym_referenced (cpte
);
8990 if (cpte
->as
== NULL
)
8992 if (!gfc_set_array_spec (cpte
, as
, &var_locus
))
8993 gfc_internal_error ("Cannot set Cray pointee array spec.");
8995 else if (as
!= NULL
)
8997 gfc_error ("Duplicate array spec for Cray pointee at %C");
8998 gfc_free_array_spec (as
);
9004 if (cpte
->as
!= NULL
)
9006 /* Fix array spec. */
9007 m
= gfc_mod_pointee_as (cpte
->as
);
9008 if (m
== MATCH_ERROR
)
9012 /* Point the Pointee at the Pointer. */
9013 cpte
->cp_pointer
= cptr
;
9015 if (gfc_match_char (')') != MATCH_YES
)
9017 gfc_error ("Expected \")\" at %C");
9020 m
= gfc_match_char (',');
9022 done
= true; /* Stop searching for more declarations. */
9026 if (m
== MATCH_ERROR
/* Failed when trying to find ',' above. */
9027 || gfc_match_eos () != MATCH_YES
)
9029 gfc_error ("Expected %<,%> or end of statement at %C");
9037 gfc_match_external (void)
9040 gfc_clear_attr (¤t_attr
);
9041 current_attr
.external
= 1;
9043 return attr_decl ();
9048 gfc_match_intent (void)
9052 /* This is not allowed within a BLOCK construct! */
9053 if (gfc_current_state () == COMP_BLOCK
)
9055 gfc_error ("INTENT is not allowed inside of BLOCK at %C");
9059 intent
= match_intent_spec ();
9060 if (intent
== INTENT_UNKNOWN
)
9063 gfc_clear_attr (¤t_attr
);
9064 current_attr
.intent
= intent
;
9066 return attr_decl ();
9071 gfc_match_intrinsic (void)
9074 gfc_clear_attr (¤t_attr
);
9075 current_attr
.intrinsic
= 1;
9077 return attr_decl ();
9082 gfc_match_optional (void)
9084 /* This is not allowed within a BLOCK construct! */
9085 if (gfc_current_state () == COMP_BLOCK
)
9087 gfc_error ("OPTIONAL is not allowed inside of BLOCK at %C");
9091 gfc_clear_attr (¤t_attr
);
9092 current_attr
.optional
= 1;
9094 return attr_decl ();
9099 gfc_match_pointer (void)
9101 gfc_gobble_whitespace ();
9102 if (gfc_peek_ascii_char () == '(')
9104 if (!flag_cray_pointer
)
9106 gfc_error ("Cray pointer declaration at %C requires "
9107 "%<-fcray-pointer%> flag");
9110 return cray_pointer_decl ();
9114 gfc_clear_attr (¤t_attr
);
9115 current_attr
.pointer
= 1;
9117 return attr_decl ();
9123 gfc_match_allocatable (void)
9125 gfc_clear_attr (¤t_attr
);
9126 current_attr
.allocatable
= 1;
9128 return attr_decl ();
9133 gfc_match_codimension (void)
9135 gfc_clear_attr (¤t_attr
);
9136 current_attr
.codimension
= 1;
9138 return attr_decl ();
9143 gfc_match_contiguous (void)
9145 if (!gfc_notify_std (GFC_STD_F2008
, "CONTIGUOUS statement at %C"))
9148 gfc_clear_attr (¤t_attr
);
9149 current_attr
.contiguous
= 1;
9151 return attr_decl ();
9156 gfc_match_dimension (void)
9158 gfc_clear_attr (¤t_attr
);
9159 current_attr
.dimension
= 1;
9161 return attr_decl ();
9166 gfc_match_target (void)
9168 gfc_clear_attr (¤t_attr
);
9169 current_attr
.target
= 1;
9171 return attr_decl ();
9175 /* Match the list of entities being specified in a PUBLIC or PRIVATE
9179 access_attr_decl (gfc_statement st
)
9181 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9182 interface_type type
;
9184 gfc_symbol
*sym
, *dt_sym
;
9185 gfc_intrinsic_op op
;
9187 gfc_access access
= (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
9189 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
9194 m
= gfc_match_generic_spec (&type
, name
, &op
);
9197 if (m
== MATCH_ERROR
)
9202 case INTERFACE_NAMELESS
:
9203 case INTERFACE_ABSTRACT
:
9206 case INTERFACE_GENERIC
:
9207 case INTERFACE_DTIO
:
9209 if (gfc_get_symbol (name
, NULL
, &sym
))
9212 if (type
== INTERFACE_DTIO
9213 && gfc_current_ns
->proc_name
9214 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
9215 && sym
->attr
.flavor
== FL_UNKNOWN
)
9216 sym
->attr
.flavor
= FL_PROCEDURE
;
9218 if (!gfc_add_access (&sym
->attr
, access
, sym
->name
, NULL
))
9221 if (sym
->attr
.generic
&& (dt_sym
= gfc_find_dt_in_generic (sym
))
9222 && !gfc_add_access (&dt_sym
->attr
, access
, sym
->name
, NULL
))
9227 case INTERFACE_INTRINSIC_OP
:
9228 if (gfc_current_ns
->operator_access
[op
] == ACCESS_UNKNOWN
)
9230 gfc_intrinsic_op other_op
;
9232 gfc_current_ns
->operator_access
[op
] = access
;
9234 /* Handle the case if there is another op with the same
9235 function, for INTRINSIC_EQ vs. INTRINSIC_EQ_OS and so on. */
9236 other_op
= gfc_equivalent_op (op
);
9238 if (other_op
!= INTRINSIC_NONE
)
9239 gfc_current_ns
->operator_access
[other_op
] = access
;
9243 gfc_error ("Access specification of the %s operator at %C has "
9244 "already been specified", gfc_op2string (op
));
9250 case INTERFACE_USER_OP
:
9251 uop
= gfc_get_uop (name
);
9253 if (uop
->access
== ACCESS_UNKNOWN
)
9255 uop
->access
= access
;
9259 gfc_error ("Access specification of the .%s. operator at %C "
9260 "has already been specified", uop
->name
);
9267 if (gfc_match_char (',') == MATCH_NO
)
9271 if (gfc_match_eos () != MATCH_YES
)
9276 gfc_syntax_error (st
);
9284 gfc_match_protected (void)
9290 /* PROTECTED has already been seen, but must be followed by whitespace
9292 c
= gfc_peek_ascii_char ();
9293 if (!gfc_is_whitespace (c
) && c
!= ':')
9296 if (!gfc_current_ns
->proc_name
9297 || gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
9299 gfc_error ("PROTECTED at %C only allowed in specification "
9300 "part of a module");
9307 if (!gfc_notify_std (GFC_STD_F2003
, "PROTECTED statement at %C"))
9310 /* PROTECTED has an entity-list. */
9311 if (gfc_match_eos () == MATCH_YES
)
9316 m
= gfc_match_symbol (&sym
, 0);
9320 if (!gfc_add_protected (&sym
->attr
, sym
->name
, &gfc_current_locus
))
9332 if (gfc_match_eos () == MATCH_YES
)
9334 if (gfc_match_char (',') != MATCH_YES
)
9341 gfc_error ("Syntax error in PROTECTED statement at %C");
9346 /* The PRIVATE statement is a bit weird in that it can be an attribute
9347 declaration, but also works as a standalone statement inside of a
9348 type declaration or a module. */
9351 gfc_match_private (gfc_statement
*st
)
9353 gfc_state_data
*prev
;
9355 if (gfc_match ("private") != MATCH_YES
)
9358 /* Try matching PRIVATE without an access-list. */
9359 if (gfc_match_eos () == MATCH_YES
)
9361 prev
= gfc_state_stack
->previous
;
9362 if (gfc_current_state () != COMP_MODULE
9363 && !(gfc_current_state () == COMP_DERIVED
9364 && prev
&& prev
->state
== COMP_MODULE
)
9365 && !(gfc_current_state () == COMP_DERIVED_CONTAINS
9366 && prev
->previous
&& prev
->previous
->state
== COMP_MODULE
))
9368 gfc_error ("PRIVATE statement at %C is only allowed in the "
9369 "specification part of a module");
9377 /* At this point in free-form source code, PRIVATE must be followed
9378 by whitespace or ::. */
9379 if (gfc_current_form
== FORM_FREE
)
9381 char c
= gfc_peek_ascii_char ();
9382 if (!gfc_is_whitespace (c
) && c
!= ':')
9386 prev
= gfc_state_stack
->previous
;
9387 if (gfc_current_state () != COMP_MODULE
9388 && !(gfc_current_state () == COMP_DERIVED
9389 && prev
&& prev
->state
== COMP_MODULE
)
9390 && !(gfc_current_state () == COMP_DERIVED_CONTAINS
9391 && prev
->previous
&& prev
->previous
->state
== COMP_MODULE
))
9393 gfc_error ("PRIVATE statement at %C is only allowed in the "
9394 "specification part of a module");
9399 return access_attr_decl (ST_PRIVATE
);
9404 gfc_match_public (gfc_statement
*st
)
9406 if (gfc_match ("public") != MATCH_YES
)
9409 /* Try matching PUBLIC without an access-list. */
9410 if (gfc_match_eos () == MATCH_YES
)
9412 if (gfc_current_state () != COMP_MODULE
)
9414 gfc_error ("PUBLIC statement at %C is only allowed in the "
9415 "specification part of a module");
9423 /* At this point in free-form source code, PUBLIC must be followed
9424 by whitespace or ::. */
9425 if (gfc_current_form
== FORM_FREE
)
9427 char c
= gfc_peek_ascii_char ();
9428 if (!gfc_is_whitespace (c
) && c
!= ':')
9432 if (gfc_current_state () != COMP_MODULE
)
9434 gfc_error ("PUBLIC statement at %C is only allowed in the "
9435 "specification part of a module");
9440 return access_attr_decl (ST_PUBLIC
);
9444 /* Workhorse for gfc_match_parameter. */
9454 m
= gfc_match_symbol (&sym
, 0);
9456 gfc_error ("Expected variable name at %C in PARAMETER statement");
9461 if (gfc_match_char ('=') == MATCH_NO
)
9463 gfc_error ("Expected = sign in PARAMETER statement at %C");
9467 m
= gfc_match_init_expr (&init
);
9469 gfc_error ("Expected expression at %C in PARAMETER statement");
9473 if (sym
->ts
.type
== BT_UNKNOWN
9474 && !gfc_set_default_type (sym
, 1, NULL
))
9480 if (!gfc_check_assign_symbol (sym
, NULL
, init
)
9481 || !gfc_add_flavor (&sym
->attr
, FL_PARAMETER
, sym
->name
, NULL
))
9489 gfc_error ("Initializing already initialized variable at %C");
9494 t
= add_init_expr_to_sym (sym
->name
, &init
, &gfc_current_locus
);
9495 return (t
) ? MATCH_YES
: MATCH_ERROR
;
9498 gfc_free_expr (init
);
9503 /* Match a parameter statement, with the weird syntax that these have. */
9506 gfc_match_parameter (void)
9508 const char *term
= " )%t";
9511 if (gfc_match_char ('(') == MATCH_NO
)
9513 /* With legacy PARAMETER statements, don't expect a terminating ')'. */
9514 if (!gfc_notify_std (GFC_STD_LEGACY
, "PARAMETER without '()' at %C"))
9525 if (gfc_match (term
) == MATCH_YES
)
9528 if (gfc_match_char (',') != MATCH_YES
)
9530 gfc_error ("Unexpected characters in PARAMETER statement at %C");
9541 gfc_match_automatic (void)
9545 bool seen_symbol
= false;
9547 if (!flag_dec_static
)
9549 gfc_error ("%s at %C is a DEC extension, enable with "
9560 m
= gfc_match_symbol (&sym
, 0);
9570 if (!gfc_add_automatic (&sym
->attr
, sym
->name
, &gfc_current_locus
))
9576 if (gfc_match_eos () == MATCH_YES
)
9578 if (gfc_match_char (',') != MATCH_YES
)
9584 gfc_error ("Expected entity-list in AUTOMATIC statement at %C");
9591 gfc_error ("Syntax error in AUTOMATIC statement at %C");
9597 gfc_match_static (void)
9601 bool seen_symbol
= false;
9603 if (!flag_dec_static
)
9605 gfc_error ("%s at %C is a DEC extension, enable with "
9615 m
= gfc_match_symbol (&sym
, 0);
9625 if (!gfc_add_save (&sym
->attr
, SAVE_EXPLICIT
, sym
->name
,
9626 &gfc_current_locus
))
9632 if (gfc_match_eos () == MATCH_YES
)
9634 if (gfc_match_char (',') != MATCH_YES
)
9640 gfc_error ("Expected entity-list in STATIC statement at %C");
9647 gfc_error ("Syntax error in STATIC statement at %C");
9652 /* Save statements have a special syntax. */
9655 gfc_match_save (void)
9657 char n
[GFC_MAX_SYMBOL_LEN
+1];
9662 if (gfc_match_eos () == MATCH_YES
)
9664 if (gfc_current_ns
->seen_save
)
9666 if (!gfc_notify_std (GFC_STD_LEGACY
, "Blanket SAVE statement at %C "
9667 "follows previous SAVE statement"))
9671 gfc_current_ns
->save_all
= gfc_current_ns
->seen_save
= 1;
9675 if (gfc_current_ns
->save_all
)
9677 if (!gfc_notify_std (GFC_STD_LEGACY
, "SAVE statement at %C follows "
9678 "blanket SAVE statement"))
9686 m
= gfc_match_symbol (&sym
, 0);
9690 if (!gfc_add_save (&sym
->attr
, SAVE_EXPLICIT
, sym
->name
,
9691 &gfc_current_locus
))
9702 m
= gfc_match (" / %n /", &n
);
9703 if (m
== MATCH_ERROR
)
9708 c
= gfc_get_common (n
, 0);
9711 gfc_current_ns
->seen_save
= 1;
9714 if (gfc_match_eos () == MATCH_YES
)
9716 if (gfc_match_char (',') != MATCH_YES
)
9723 if (gfc_current_ns
->seen_save
)
9725 gfc_error ("Syntax error in SAVE statement at %C");
9734 gfc_match_value (void)
9739 /* This is not allowed within a BLOCK construct! */
9740 if (gfc_current_state () == COMP_BLOCK
)
9742 gfc_error ("VALUE is not allowed inside of BLOCK at %C");
9746 if (!gfc_notify_std (GFC_STD_F2003
, "VALUE statement at %C"))
9749 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
9754 if (gfc_match_eos () == MATCH_YES
)
9759 m
= gfc_match_symbol (&sym
, 0);
9763 if (!gfc_add_value (&sym
->attr
, sym
->name
, &gfc_current_locus
))
9775 if (gfc_match_eos () == MATCH_YES
)
9777 if (gfc_match_char (',') != MATCH_YES
)
9784 gfc_error ("Syntax error in VALUE statement at %C");
9790 gfc_match_volatile (void)
9796 if (!gfc_notify_std (GFC_STD_F2003
, "VOLATILE statement at %C"))
9799 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
9804 if (gfc_match_eos () == MATCH_YES
)
9809 /* VOLATILE is special because it can be added to host-associated
9810 symbols locally. Except for coarrays. */
9811 m
= gfc_match_symbol (&sym
, 1);
9815 name
= XCNEWVAR (char, strlen (sym
->name
) + 1);
9816 strcpy (name
, sym
->name
);
9817 if (!check_function_name (name
))
9819 /* F2008, C560+C561. VOLATILE for host-/use-associated variable or
9820 for variable in a BLOCK which is defined outside of the BLOCK. */
9821 if (sym
->ns
!= gfc_current_ns
&& sym
->attr
.codimension
)
9823 gfc_error ("Specifying VOLATILE for coarray variable %qs at "
9824 "%C, which is use-/host-associated", sym
->name
);
9827 if (!gfc_add_volatile (&sym
->attr
, sym
->name
, &gfc_current_locus
))
9839 if (gfc_match_eos () == MATCH_YES
)
9841 if (gfc_match_char (',') != MATCH_YES
)
9848 gfc_error ("Syntax error in VOLATILE statement at %C");
9854 gfc_match_asynchronous (void)
9860 if (!gfc_notify_std (GFC_STD_F2003
, "ASYNCHRONOUS statement at %C"))
9863 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
9868 if (gfc_match_eos () == MATCH_YES
)
9873 /* ASYNCHRONOUS is special because it can be added to host-associated
9875 m
= gfc_match_symbol (&sym
, 1);
9879 name
= XCNEWVAR (char, strlen (sym
->name
) + 1);
9880 strcpy (name
, sym
->name
);
9881 if (!check_function_name (name
))
9883 if (!gfc_add_asynchronous (&sym
->attr
, sym
->name
, &gfc_current_locus
))
9895 if (gfc_match_eos () == MATCH_YES
)
9897 if (gfc_match_char (',') != MATCH_YES
)
9904 gfc_error ("Syntax error in ASYNCHRONOUS statement at %C");
9909 /* Match a module procedure statement in a submodule. */
9912 gfc_match_submod_proc (void)
9914 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9915 gfc_symbol
*sym
, *fsym
;
9917 gfc_formal_arglist
*formal
, *head
, *tail
;
9919 if (gfc_current_state () != COMP_CONTAINS
9920 || !(gfc_state_stack
->previous
9921 && (gfc_state_stack
->previous
->state
== COMP_SUBMODULE
9922 || gfc_state_stack
->previous
->state
== COMP_MODULE
)))
9925 m
= gfc_match (" module% procedure% %n", name
);
9929 if (!gfc_notify_std (GFC_STD_F2008
, "MODULE PROCEDURE declaration "
9933 if (get_proc_name (name
, &sym
, false))
9936 /* Make sure that the result field is appropriately filled. */
9937 if (sym
->tlink
&& sym
->tlink
->attr
.function
)
9939 if (sym
->tlink
->result
&& sym
->tlink
->result
!= sym
->tlink
)
9941 sym
->result
= sym
->tlink
->result
;
9942 if (!sym
->result
->attr
.use_assoc
)
9944 gfc_symtree
*st
= gfc_new_symtree (&gfc_current_ns
->sym_root
,
9946 st
->n
.sym
= sym
->result
;
9947 sym
->result
->refs
++;
9954 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
9955 the symbol existed before. */
9956 sym
->declared_at
= gfc_current_locus
;
9958 if (!sym
->attr
.module_procedure
)
9961 /* Signal match_end to expect "end procedure". */
9962 sym
->abr_modproc_decl
= 1;
9964 /* Change from IFSRC_IFBODY coming from the interface declaration. */
9965 sym
->attr
.if_source
= IFSRC_DECL
;
9967 gfc_new_block
= sym
;
9969 /* Make a new formal arglist with the symbols in the procedure
9972 for (formal
= sym
->formal
; formal
&& formal
->sym
; formal
= formal
->next
)
9974 if (formal
== sym
->formal
)
9975 head
= tail
= gfc_get_formal_arglist ();
9978 tail
->next
= gfc_get_formal_arglist ();
9982 if (gfc_copy_dummy_sym (&fsym
, formal
->sym
, 0))
9986 gfc_set_sym_referenced (fsym
);
9989 /* The dummy symbols get cleaned up, when the formal_namespace of the
9990 interface declaration is cleared. This allows us to add the
9991 explicit interface as is done for other type of procedure. */
9992 if (!gfc_add_explicit_interface (sym
, IFSRC_DECL
, head
,
9993 &gfc_current_locus
))
9996 if (gfc_match_eos () != MATCH_YES
)
9998 /* Unset st->n.sym. Note: in reject_statement (), the symbol changes are
9999 undone, such that the st->n.sym->formal points to the original symbol;
10000 if now this namespace is finalized, the formal namespace is freed,
10001 but it might be still needed in the parent namespace. */
10002 gfc_symtree
*st
= gfc_find_symtree (gfc_current_ns
->sym_root
, sym
->name
);
10004 gfc_free_symbol (sym
->tlink
);
10007 gfc_syntax_error (ST_MODULE_PROC
);
10008 return MATCH_ERROR
;
10014 gfc_free_formal_arglist (head
);
10015 return MATCH_ERROR
;
10019 /* Match a module procedure statement. Note that we have to modify
10020 symbols in the parent's namespace because the current one was there
10021 to receive symbols that are in an interface's formal argument list. */
10024 gfc_match_modproc (void)
10026 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10030 gfc_namespace
*module_ns
;
10031 gfc_interface
*old_interface_head
, *interface
;
10033 if (gfc_state_stack
->previous
== NULL
10034 || (gfc_state_stack
->state
!= COMP_INTERFACE
10035 && (gfc_state_stack
->state
!= COMP_CONTAINS
10036 || gfc_state_stack
->previous
->state
!= COMP_INTERFACE
))
10037 || current_interface
.type
== INTERFACE_NAMELESS
10038 || current_interface
.type
== INTERFACE_ABSTRACT
)
10040 gfc_error ("MODULE PROCEDURE at %C must be in a generic module "
10042 return MATCH_ERROR
;
10045 module_ns
= gfc_current_ns
->parent
;
10046 for (; module_ns
; module_ns
= module_ns
->parent
)
10047 if (module_ns
->proc_name
->attr
.flavor
== FL_MODULE
10048 || module_ns
->proc_name
->attr
.flavor
== FL_PROGRAM
10049 || (module_ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
10050 && !module_ns
->proc_name
->attr
.contained
))
10053 if (module_ns
== NULL
)
10054 return MATCH_ERROR
;
10056 /* Store the current state of the interface. We will need it if we
10057 end up with a syntax error and need to recover. */
10058 old_interface_head
= gfc_current_interface_head ();
10060 /* Check if the F2008 optional double colon appears. */
10061 gfc_gobble_whitespace ();
10062 old_locus
= gfc_current_locus
;
10063 if (gfc_match ("::") == MATCH_YES
)
10065 if (!gfc_notify_std (GFC_STD_F2008
, "double colon in "
10066 "MODULE PROCEDURE statement at %L", &old_locus
))
10067 return MATCH_ERROR
;
10070 gfc_current_locus
= old_locus
;
10075 old_locus
= gfc_current_locus
;
10077 m
= gfc_match_name (name
);
10080 if (m
!= MATCH_YES
)
10081 return MATCH_ERROR
;
10083 /* Check for syntax error before starting to add symbols to the
10084 current namespace. */
10085 if (gfc_match_eos () == MATCH_YES
)
10088 if (!last
&& gfc_match_char (',') != MATCH_YES
)
10091 /* Now we're sure the syntax is valid, we process this item
10093 if (gfc_get_symbol (name
, module_ns
, &sym
))
10094 return MATCH_ERROR
;
10096 if (sym
->attr
.intrinsic
)
10098 gfc_error ("Intrinsic procedure at %L cannot be a MODULE "
10099 "PROCEDURE", &old_locus
);
10100 return MATCH_ERROR
;
10103 if (sym
->attr
.proc
!= PROC_MODULE
10104 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
10105 return MATCH_ERROR
;
10107 if (!gfc_add_interface (sym
))
10108 return MATCH_ERROR
;
10110 sym
->attr
.mod_proc
= 1;
10111 sym
->declared_at
= old_locus
;
10120 /* Restore the previous state of the interface. */
10121 interface
= gfc_current_interface_head ();
10122 gfc_set_current_interface_head (old_interface_head
);
10124 /* Free the new interfaces. */
10125 while (interface
!= old_interface_head
)
10127 gfc_interface
*i
= interface
->next
;
10132 /* And issue a syntax error. */
10133 gfc_syntax_error (ST_MODULE_PROC
);
10134 return MATCH_ERROR
;
10138 /* Check a derived type that is being extended. */
10141 check_extended_derived_type (char *name
)
10143 gfc_symbol
*extended
;
10145 if (gfc_find_symbol (name
, gfc_current_ns
, 1, &extended
))
10147 gfc_error ("Ambiguous symbol in TYPE definition at %C");
10151 extended
= gfc_find_dt_in_generic (extended
);
10156 gfc_error ("Symbol %qs at %C has not been previously defined", name
);
10160 if (extended
->attr
.flavor
!= FL_DERIVED
)
10162 gfc_error ("%qs in EXTENDS expression at %C is not a "
10163 "derived type", name
);
10167 if (extended
->attr
.is_bind_c
)
10169 gfc_error ("%qs cannot be extended at %C because it "
10170 "is BIND(C)", extended
->name
);
10174 if (extended
->attr
.sequence
)
10176 gfc_error ("%qs cannot be extended at %C because it "
10177 "is a SEQUENCE type", extended
->name
);
10185 /* Match the optional attribute specifiers for a type declaration.
10186 Return MATCH_ERROR if an error is encountered in one of the handled
10187 attributes (public, private, bind(c)), MATCH_NO if what's found is
10188 not a handled attribute, and MATCH_YES otherwise. TODO: More error
10189 checking on attribute conflicts needs to be done. */
10192 gfc_get_type_attr_spec (symbol_attribute
*attr
, char *name
)
10194 /* See if the derived type is marked as private. */
10195 if (gfc_match (" , private") == MATCH_YES
)
10197 if (gfc_current_state () != COMP_MODULE
)
10199 gfc_error ("Derived type at %C can only be PRIVATE in the "
10200 "specification part of a module");
10201 return MATCH_ERROR
;
10204 if (!gfc_add_access (attr
, ACCESS_PRIVATE
, NULL
, NULL
))
10205 return MATCH_ERROR
;
10207 else if (gfc_match (" , public") == MATCH_YES
)
10209 if (gfc_current_state () != COMP_MODULE
)
10211 gfc_error ("Derived type at %C can only be PUBLIC in the "
10212 "specification part of a module");
10213 return MATCH_ERROR
;
10216 if (!gfc_add_access (attr
, ACCESS_PUBLIC
, NULL
, NULL
))
10217 return MATCH_ERROR
;
10219 else if (gfc_match (" , bind ( c )") == MATCH_YES
)
10221 /* If the type is defined to be bind(c) it then needs to make
10222 sure that all fields are interoperable. This will
10223 need to be a semantic check on the finished derived type.
10224 See 15.2.3 (lines 9-12) of F2003 draft. */
10225 if (!gfc_add_is_bind_c (attr
, NULL
, &gfc_current_locus
, 0))
10226 return MATCH_ERROR
;
10228 /* TODO: attr conflicts need to be checked, probably in symbol.cc. */
10230 else if (gfc_match (" , abstract") == MATCH_YES
)
10232 if (!gfc_notify_std (GFC_STD_F2003
, "ABSTRACT type at %C"))
10233 return MATCH_ERROR
;
10235 if (!gfc_add_abstract (attr
, &gfc_current_locus
))
10236 return MATCH_ERROR
;
10238 else if (name
&& gfc_match (" , extends ( %n )", name
) == MATCH_YES
)
10240 if (!gfc_add_extension (attr
, &gfc_current_locus
))
10241 return MATCH_ERROR
;
10246 /* If we get here, something matched. */
10251 /* Common function for type declaration blocks similar to derived types, such
10252 as STRUCTURES and MAPs. Unlike derived types, a structure type
10253 does NOT have a generic symbol matching the name given by the user.
10254 STRUCTUREs can share names with variables and PARAMETERs so we must allow
10255 for the creation of an independent symbol.
10256 Other parameters are a message to prefix errors with, the name of the new
10257 type to be created, and the flavor to add to the resulting symbol. */
10260 get_struct_decl (const char *name
, sym_flavor fl
, locus
*decl
,
10261 gfc_symbol
**result
)
10266 gcc_assert (name
[0] == (char) TOUPPER (name
[0]));
10271 where
= gfc_current_locus
;
10273 if (gfc_get_symbol (name
, NULL
, &sym
))
10278 gfc_internal_error ("Failed to create structure type '%s' at %C", name
);
10282 if (sym
->components
!= NULL
|| sym
->attr
.zero_comp
)
10284 gfc_error ("Type definition of %qs at %C was already defined at %L",
10285 sym
->name
, &sym
->declared_at
);
10289 sym
->declared_at
= where
;
10291 if (sym
->attr
.flavor
!= fl
10292 && !gfc_add_flavor (&sym
->attr
, fl
, sym
->name
, NULL
))
10295 if (!sym
->hash_value
)
10296 /* Set the hash for the compound name for this type. */
10297 sym
->hash_value
= gfc_hash_value (sym
);
10299 /* Normally the type is expected to have been completely parsed by the time
10300 a field declaration with this type is seen. For unions, maps, and nested
10301 structure declarations, we need to indicate that it is okay that we
10302 haven't seen any components yet. This will be updated after the structure
10303 is fully parsed. */
10304 sym
->attr
.zero_comp
= 0;
10306 /* Structures always act like derived-types with the SEQUENCE attribute */
10307 gfc_add_sequence (&sym
->attr
, sym
->name
, NULL
);
10309 if (result
) *result
= sym
;
10315 /* Match the opening of a MAP block. Like a struct within a union in C;
10316 behaves identical to STRUCTURE blocks. */
10319 gfc_match_map (void)
10321 /* Counter used to give unique internal names to map structures. */
10322 static unsigned int gfc_map_id
= 0;
10323 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10327 old_loc
= gfc_current_locus
;
10329 if (gfc_match_eos () != MATCH_YES
)
10331 gfc_error ("Junk after MAP statement at %C");
10332 gfc_current_locus
= old_loc
;
10333 return MATCH_ERROR
;
10336 /* Map blocks are anonymous so we make up unique names for the symbol table
10337 which are invalid Fortran identifiers. */
10338 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "MM$%u", gfc_map_id
++);
10340 if (!get_struct_decl (name
, FL_STRUCT
, &old_loc
, &sym
))
10341 return MATCH_ERROR
;
10343 gfc_new_block
= sym
;
10349 /* Match the opening of a UNION block. */
10352 gfc_match_union (void)
10354 /* Counter used to give unique internal names to union types. */
10355 static unsigned int gfc_union_id
= 0;
10356 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10360 old_loc
= gfc_current_locus
;
10362 if (gfc_match_eos () != MATCH_YES
)
10364 gfc_error ("Junk after UNION statement at %C");
10365 gfc_current_locus
= old_loc
;
10366 return MATCH_ERROR
;
10369 /* Unions are anonymous so we make up unique names for the symbol table
10370 which are invalid Fortran identifiers. */
10371 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "UU$%u", gfc_union_id
++);
10373 if (!get_struct_decl (name
, FL_UNION
, &old_loc
, &sym
))
10374 return MATCH_ERROR
;
10376 gfc_new_block
= sym
;
10382 /* Match the beginning of a STRUCTURE declaration. This is similar to
10383 matching the beginning of a derived type declaration with a few
10384 twists. The resulting type symbol has no access control or other
10385 interesting attributes. */
10388 gfc_match_structure_decl (void)
10390 /* Counter used to give unique internal names to anonymous structures. */
10391 static unsigned int gfc_structure_id
= 0;
10392 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10397 if (!flag_dec_structure
)
10399 gfc_error ("%s at %C is a DEC extension, enable with "
10400 "%<-fdec-structure%>",
10402 return MATCH_ERROR
;
10407 m
= gfc_match (" /%n/", name
);
10408 if (m
!= MATCH_YES
)
10410 /* Non-nested structure declarations require a structure name. */
10411 if (!gfc_comp_struct (gfc_current_state ()))
10413 gfc_error ("Structure name expected in non-nested structure "
10414 "declaration at %C");
10415 return MATCH_ERROR
;
10417 /* This is an anonymous structure; make up a unique name for it
10418 (upper-case letters never make it to symbol names from the source).
10419 The important thing is initializing the type variable
10420 and setting gfc_new_symbol, which is immediately used by
10421 parse_structure () and variable_decl () to add components of
10423 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "SS$%u", gfc_structure_id
++);
10426 where
= gfc_current_locus
;
10427 /* No field list allowed after non-nested structure declaration. */
10428 if (!gfc_comp_struct (gfc_current_state ())
10429 && gfc_match_eos () != MATCH_YES
)
10431 gfc_error ("Junk after non-nested STRUCTURE statement at %C");
10432 return MATCH_ERROR
;
10435 /* Make sure the name is not the name of an intrinsic type. */
10436 if (gfc_is_intrinsic_typename (name
))
10438 gfc_error ("Structure name %qs at %C cannot be the same as an"
10439 " intrinsic type", name
);
10440 return MATCH_ERROR
;
10443 /* Store the actual type symbol for the structure with an upper-case first
10444 letter (an invalid Fortran identifier). */
10446 if (!get_struct_decl (gfc_dt_upper_string (name
), FL_STRUCT
, &where
, &sym
))
10447 return MATCH_ERROR
;
10449 gfc_new_block
= sym
;
10454 /* This function does some work to determine which matcher should be used to
10455 * match a statement beginning with "TYPE". This is used to disambiguate TYPE
10456 * as an alias for PRINT from derived type declarations, TYPE IS statements,
10457 * and [parameterized] derived type declarations. */
10460 gfc_match_type (gfc_statement
*st
)
10462 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10466 /* Requires -fdec. */
10470 m
= gfc_match ("type");
10471 if (m
!= MATCH_YES
)
10473 /* If we already have an error in the buffer, it is probably from failing to
10474 * match a derived type data declaration. Let it happen. */
10475 else if (gfc_error_flag_test ())
10478 old_loc
= gfc_current_locus
;
10481 /* If we see an attribute list before anything else it's definitely a derived
10482 * type declaration. */
10483 if (gfc_match (" ,") == MATCH_YES
|| gfc_match (" ::") == MATCH_YES
)
10486 /* By now "TYPE" has already been matched. If we do not see a name, this may
10487 * be something like "TYPE *" or "TYPE <fmt>". */
10488 m
= gfc_match_name (name
);
10489 if (m
!= MATCH_YES
)
10491 /* Let print match if it can, otherwise throw an error from
10492 * gfc_match_derived_decl. */
10493 gfc_current_locus
= old_loc
;
10494 if (gfc_match_print () == MATCH_YES
)
10502 /* Check for EOS. */
10503 if (gfc_match_eos () == MATCH_YES
)
10505 /* By now we have "TYPE <name> <EOS>". Check first if the name is an
10506 * intrinsic typename - if so let gfc_match_derived_decl dump an error.
10507 * Otherwise if gfc_match_derived_decl fails it's probably an existing
10508 * symbol which can be printed. */
10509 gfc_current_locus
= old_loc
;
10510 m
= gfc_match_derived_decl ();
10511 if (gfc_is_intrinsic_typename (name
) || m
== MATCH_YES
)
10513 *st
= ST_DERIVED_DECL
;
10519 /* Here we have "TYPE <name>". Check for <TYPE IS (> or a PDT declaration
10520 like <type name(parameter)>. */
10521 gfc_gobble_whitespace ();
10522 bool paren
= gfc_peek_ascii_char () == '(';
10525 if (strcmp ("is", name
) == 0)
10532 /* Treat TYPE... like PRINT... */
10533 gfc_current_locus
= old_loc
;
10535 return gfc_match_print ();
10538 gfc_current_locus
= old_loc
;
10539 *st
= ST_DERIVED_DECL
;
10540 return gfc_match_derived_decl ();
10543 gfc_current_locus
= old_loc
;
10545 return gfc_match_type_is ();
10549 /* Match the beginning of a derived type declaration. If a type name
10550 was the result of a function, then it is possible to have a symbol
10551 already to be known as a derived type yet have no components. */
10554 gfc_match_derived_decl (void)
10556 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10557 char parent
[GFC_MAX_SYMBOL_LEN
+ 1];
10558 symbol_attribute attr
;
10559 gfc_symbol
*sym
, *gensym
;
10560 gfc_symbol
*extended
;
10562 match is_type_attr_spec
= MATCH_NO
;
10563 bool seen_attr
= false;
10564 gfc_interface
*intr
= NULL
, *head
;
10565 bool parameterized_type
= false;
10566 bool seen_colons
= false;
10568 if (gfc_comp_struct (gfc_current_state ()))
10573 gfc_clear_attr (&attr
);
10578 is_type_attr_spec
= gfc_get_type_attr_spec (&attr
, parent
);
10579 if (is_type_attr_spec
== MATCH_ERROR
)
10580 return MATCH_ERROR
;
10581 if (is_type_attr_spec
== MATCH_YES
)
10583 } while (is_type_attr_spec
== MATCH_YES
);
10585 /* Deal with derived type extensions. The extension attribute has
10586 been added to 'attr' but now the parent type must be found and
10589 extended
= check_extended_derived_type (parent
);
10591 if (parent
[0] && !extended
)
10592 return MATCH_ERROR
;
10594 m
= gfc_match (" ::");
10595 if (m
== MATCH_YES
)
10597 seen_colons
= true;
10599 else if (seen_attr
)
10601 gfc_error ("Expected :: in TYPE definition at %C");
10602 return MATCH_ERROR
;
10605 /* In free source form, need to check for TYPE XXX as oppose to TYPEXXX.
10606 But, we need to simply return for TYPE(. */
10607 if (m
== MATCH_NO
&& gfc_current_form
== FORM_FREE
)
10609 char c
= gfc_peek_ascii_char ();
10612 if (!gfc_is_whitespace (c
))
10614 gfc_error ("Mangled derived type definition at %C");
10619 m
= gfc_match (" %n ", name
);
10620 if (m
!= MATCH_YES
)
10623 /* Make sure that we don't identify TYPE IS (...) as a parameterized
10624 derived type named 'is'.
10625 TODO Expand the check, when 'name' = "is" by matching " (tname) "
10626 and checking if this is a(n intrinsic) typename. This picks up
10627 misplaced TYPE IS statements such as in select_type_1.f03. */
10628 if (gfc_peek_ascii_char () == '(')
10630 if (gfc_current_state () == COMP_SELECT_TYPE
10631 || (!seen_colons
&& !strcmp (name
, "is")))
10633 parameterized_type
= true;
10636 m
= gfc_match_eos ();
10637 if (m
!= MATCH_YES
&& !parameterized_type
)
10640 /* Make sure the name is not the name of an intrinsic type. */
10641 if (gfc_is_intrinsic_typename (name
))
10643 gfc_error ("Type name %qs at %C cannot be the same as an intrinsic "
10645 return MATCH_ERROR
;
10648 if (gfc_get_symbol (name
, NULL
, &gensym
))
10649 return MATCH_ERROR
;
10651 if (!gensym
->attr
.generic
&& gensym
->ts
.type
!= BT_UNKNOWN
)
10653 if (gensym
->ts
.u
.derived
)
10654 gfc_error ("Derived type name %qs at %C already has a basic type "
10655 "of %s", gensym
->name
, gfc_typename (&gensym
->ts
));
10657 gfc_error ("Derived type name %qs at %C already has a basic type",
10659 return MATCH_ERROR
;
10662 if (!gensym
->attr
.generic
10663 && !gfc_add_generic (&gensym
->attr
, gensym
->name
, NULL
))
10664 return MATCH_ERROR
;
10666 if (!gensym
->attr
.function
10667 && !gfc_add_function (&gensym
->attr
, gensym
->name
, NULL
))
10668 return MATCH_ERROR
;
10670 if (gensym
->attr
.dummy
)
10672 gfc_error ("Dummy argument %qs at %L cannot be a derived type at %C",
10673 name
, &gensym
->declared_at
);
10674 return MATCH_ERROR
;
10677 sym
= gfc_find_dt_in_generic (gensym
);
10679 if (sym
&& (sym
->components
!= NULL
|| sym
->attr
.zero_comp
))
10681 gfc_error ("Derived type definition of %qs at %C has already been "
10682 "defined", sym
->name
);
10683 return MATCH_ERROR
;
10688 /* Use upper case to save the actual derived-type symbol. */
10689 gfc_get_symbol (gfc_dt_upper_string (gensym
->name
), NULL
, &sym
);
10690 sym
->name
= gfc_get_string ("%s", gensym
->name
);
10691 head
= gensym
->generic
;
10692 intr
= gfc_get_interface ();
10694 intr
->where
= gfc_current_locus
;
10695 intr
->sym
->declared_at
= gfc_current_locus
;
10697 gensym
->generic
= intr
;
10698 gensym
->attr
.if_source
= IFSRC_DECL
;
10701 /* The symbol may already have the derived attribute without the
10702 components. The ways this can happen is via a function
10703 definition, an INTRINSIC statement or a subtype in another
10704 derived type that is a pointer. The first part of the AND clause
10705 is true if the symbol is not the return value of a function. */
10706 if (sym
->attr
.flavor
!= FL_DERIVED
10707 && !gfc_add_flavor (&sym
->attr
, FL_DERIVED
, sym
->name
, NULL
))
10708 return MATCH_ERROR
;
10710 if (attr
.access
!= ACCESS_UNKNOWN
10711 && !gfc_add_access (&sym
->attr
, attr
.access
, sym
->name
, NULL
))
10712 return MATCH_ERROR
;
10713 else if (sym
->attr
.access
== ACCESS_UNKNOWN
10714 && gensym
->attr
.access
!= ACCESS_UNKNOWN
10715 && !gfc_add_access (&sym
->attr
, gensym
->attr
.access
,
10717 return MATCH_ERROR
;
10719 if (sym
->attr
.access
!= ACCESS_UNKNOWN
10720 && gensym
->attr
.access
== ACCESS_UNKNOWN
)
10721 gensym
->attr
.access
= sym
->attr
.access
;
10723 /* See if the derived type was labeled as bind(c). */
10724 if (attr
.is_bind_c
!= 0)
10725 sym
->attr
.is_bind_c
= attr
.is_bind_c
;
10727 /* Construct the f2k_derived namespace if it is not yet there. */
10728 if (!sym
->f2k_derived
)
10729 sym
->f2k_derived
= gfc_get_namespace (NULL
, 0);
10731 if (parameterized_type
)
10733 /* Ignore error or mismatches by going to the end of the statement
10734 in order to avoid the component declarations causing problems. */
10735 m
= gfc_match_formal_arglist (sym
, 0, 0, true);
10736 if (m
!= MATCH_YES
)
10737 gfc_error_recovery ();
10739 sym
->attr
.pdt_template
= 1;
10740 m
= gfc_match_eos ();
10741 if (m
!= MATCH_YES
)
10743 gfc_error_recovery ();
10744 gfc_error_now ("Garbage after PARAMETERIZED TYPE declaration at %C");
10748 if (extended
&& !sym
->components
)
10751 gfc_formal_arglist
*f
, *g
, *h
;
10753 /* Add the extended derived type as the first component. */
10754 gfc_add_component (sym
, parent
, &p
);
10756 gfc_set_sym_referenced (extended
);
10758 p
->ts
.type
= BT_DERIVED
;
10759 p
->ts
.u
.derived
= extended
;
10760 p
->initializer
= gfc_default_initializer (&p
->ts
);
10762 /* Set extension level. */
10763 if (extended
->attr
.extension
== 255)
10765 /* Since the extension field is 8 bit wide, we can only have
10766 up to 255 extension levels. */
10767 gfc_error ("Maximum extension level reached with type %qs at %L",
10768 extended
->name
, &extended
->declared_at
);
10769 return MATCH_ERROR
;
10771 sym
->attr
.extension
= extended
->attr
.extension
+ 1;
10773 /* Provide the links between the extended type and its extension. */
10774 if (!extended
->f2k_derived
)
10775 extended
->f2k_derived
= gfc_get_namespace (NULL
, 0);
10777 /* Copy the extended type-param-name-list from the extended type,
10778 append those of the extension and add the whole lot to the
10780 if (extended
->attr
.pdt_template
)
10783 sym
->attr
.pdt_template
= 1;
10784 for (f
= extended
->formal
; f
; f
= f
->next
)
10786 if (f
== extended
->formal
)
10788 g
= gfc_get_formal_arglist ();
10793 g
->next
= gfc_get_formal_arglist ();
10798 g
->next
= sym
->formal
;
10803 if (!sym
->hash_value
)
10804 /* Set the hash for the compound name for this type. */
10805 sym
->hash_value
= gfc_hash_value (sym
);
10807 /* Take over the ABSTRACT attribute. */
10808 sym
->attr
.abstract
= attr
.abstract
;
10810 gfc_new_block
= sym
;
10816 /* Cray Pointees can be declared as:
10817 pointer (ipt, a (n,m,...,*)) */
10820 gfc_mod_pointee_as (gfc_array_spec
*as
)
10822 as
->cray_pointee
= true; /* This will be useful to know later. */
10823 if (as
->type
== AS_ASSUMED_SIZE
)
10824 as
->cp_was_assumed
= true;
10825 else if (as
->type
== AS_ASSUMED_SHAPE
)
10827 gfc_error ("Cray Pointee at %C cannot be assumed shape array");
10828 return MATCH_ERROR
;
10834 /* Match the enum definition statement, here we are trying to match
10835 the first line of enum definition statement.
10836 Returns MATCH_YES if match is found. */
10839 gfc_match_enum (void)
10843 m
= gfc_match_eos ();
10844 if (m
!= MATCH_YES
)
10847 if (!gfc_notify_std (GFC_STD_F2003
, "ENUM and ENUMERATOR at %C"))
10848 return MATCH_ERROR
;
10854 /* Returns an initializer whose value is one higher than the value of the
10855 LAST_INITIALIZER argument. If the argument is NULL, the
10856 initializers value will be set to zero. The initializer's kind
10857 will be set to gfc_c_int_kind.
10859 If -fshort-enums is given, the appropriate kind will be selected
10860 later after all enumerators have been parsed. A warning is issued
10861 here if an initializer exceeds gfc_c_int_kind. */
10864 enum_initializer (gfc_expr
*last_initializer
, locus where
)
10867 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_c_int_kind
, &where
);
10869 mpz_init (result
->value
.integer
);
10871 if (last_initializer
!= NULL
)
10873 mpz_add_ui (result
->value
.integer
, last_initializer
->value
.integer
, 1);
10874 result
->where
= last_initializer
->where
;
10876 if (gfc_check_integer_range (result
->value
.integer
,
10877 gfc_c_int_kind
) != ARITH_OK
)
10879 gfc_error ("Enumerator exceeds the C integer type at %C");
10885 /* Control comes here, if it's the very first enumerator and no
10886 initializer has been given. It will be initialized to zero. */
10887 mpz_set_si (result
->value
.integer
, 0);
10894 /* Match a variable name with an optional initializer. When this
10895 subroutine is called, a variable is expected to be parsed next.
10896 Depending on what is happening at the moment, updates either the
10897 symbol table or the current interface. */
10900 enumerator_decl (void)
10902 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10903 gfc_expr
*initializer
;
10904 gfc_array_spec
*as
= NULL
;
10911 initializer
= NULL
;
10912 old_locus
= gfc_current_locus
;
10914 /* When we get here, we've just matched a list of attributes and
10915 maybe a type and a double colon. The next thing we expect to see
10916 is the name of the symbol. */
10917 m
= gfc_match_name (name
);
10918 if (m
!= MATCH_YES
)
10921 var_locus
= gfc_current_locus
;
10923 /* OK, we've successfully matched the declaration. Now put the
10924 symbol in the current namespace. If we fail to create the symbol,
10926 if (!build_sym (name
, NULL
, false, &as
, &var_locus
))
10932 /* The double colon must be present in order to have initializers.
10933 Otherwise the statement is ambiguous with an assignment statement. */
10936 if (gfc_match_char ('=') == MATCH_YES
)
10938 m
= gfc_match_init_expr (&initializer
);
10941 gfc_error ("Expected an initialization expression at %C");
10945 if (m
!= MATCH_YES
)
10950 /* If we do not have an initializer, the initialization value of the
10951 previous enumerator (stored in last_initializer) is incremented
10952 by 1 and is used to initialize the current enumerator. */
10953 if (initializer
== NULL
)
10954 initializer
= enum_initializer (last_initializer
, old_locus
);
10956 if (initializer
== NULL
|| initializer
->ts
.type
!= BT_INTEGER
)
10958 gfc_error ("ENUMERATOR %L not initialized with integer expression",
10964 /* Store this current initializer, for the next enumerator variable
10965 to be parsed. add_init_expr_to_sym() zeros initializer, so we
10966 use last_initializer below. */
10967 last_initializer
= initializer
;
10968 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
10970 /* Maintain enumerator history. */
10971 gfc_find_symbol (name
, NULL
, 0, &sym
);
10972 create_enum_history (sym
, last_initializer
);
10974 return (t
) ? MATCH_YES
: MATCH_ERROR
;
10977 /* Free stuff up and return. */
10978 gfc_free_expr (initializer
);
10984 /* Match the enumerator definition statement. */
10987 gfc_match_enumerator_def (void)
10992 gfc_clear_ts (¤t_ts
);
10994 m
= gfc_match (" enumerator");
10995 if (m
!= MATCH_YES
)
10998 m
= gfc_match (" :: ");
10999 if (m
== MATCH_ERROR
)
11002 colon_seen
= (m
== MATCH_YES
);
11004 if (gfc_current_state () != COMP_ENUM
)
11006 gfc_error ("ENUM definition statement expected before %C");
11007 gfc_free_enum_history ();
11008 return MATCH_ERROR
;
11011 (¤t_ts
)->type
= BT_INTEGER
;
11012 (¤t_ts
)->kind
= gfc_c_int_kind
;
11014 gfc_clear_attr (¤t_attr
);
11015 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, NULL
);
11024 m
= enumerator_decl ();
11025 if (m
== MATCH_ERROR
)
11027 gfc_free_enum_history ();
11033 if (gfc_match_eos () == MATCH_YES
)
11035 if (gfc_match_char (',') != MATCH_YES
)
11039 if (gfc_current_state () == COMP_ENUM
)
11041 gfc_free_enum_history ();
11042 gfc_error ("Syntax error in ENUMERATOR definition at %C");
11047 gfc_free_array_spec (current_as
);
11054 /* Match binding attributes. */
11057 match_binding_attributes (gfc_typebound_proc
* ba
, bool generic
, bool ppc
)
11059 bool found_passing
= false;
11060 bool seen_ptr
= false;
11061 match m
= MATCH_YES
;
11063 /* Initialize to defaults. Do so even before the MATCH_NO check so that in
11064 this case the defaults are in there. */
11065 ba
->access
= ACCESS_UNKNOWN
;
11066 ba
->pass_arg
= NULL
;
11067 ba
->pass_arg_num
= 0;
11069 ba
->non_overridable
= 0;
11073 /* If we find a comma, we believe there are binding attributes. */
11074 m
= gfc_match_char (',');
11080 /* Access specifier. */
11082 m
= gfc_match (" public");
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_PUBLIC
;
11097 m
= gfc_match (" private");
11098 if (m
== MATCH_ERROR
)
11100 if (m
== MATCH_YES
)
11102 if (ba
->access
!= ACCESS_UNKNOWN
)
11104 gfc_error ("Duplicate access-specifier at %C");
11108 ba
->access
= ACCESS_PRIVATE
;
11112 /* If inside GENERIC, the following is not allowed. */
11117 m
= gfc_match (" nopass");
11118 if (m
== MATCH_ERROR
)
11120 if (m
== MATCH_YES
)
11124 gfc_error ("Binding attributes already specify passing,"
11125 " illegal NOPASS at %C");
11129 found_passing
= true;
11134 /* PASS possibly including argument. */
11135 m
= gfc_match (" pass");
11136 if (m
== MATCH_ERROR
)
11138 if (m
== MATCH_YES
)
11140 char arg
[GFC_MAX_SYMBOL_LEN
+ 1];
11144 gfc_error ("Binding attributes already specify passing,"
11145 " illegal PASS at %C");
11149 m
= gfc_match (" ( %n )", arg
);
11150 if (m
== MATCH_ERROR
)
11152 if (m
== MATCH_YES
)
11153 ba
->pass_arg
= gfc_get_string ("%s", arg
);
11154 gcc_assert ((m
== MATCH_YES
) == (ba
->pass_arg
!= NULL
));
11156 found_passing
= true;
11163 /* POINTER flag. */
11164 m
= gfc_match (" pointer");
11165 if (m
== MATCH_ERROR
)
11167 if (m
== MATCH_YES
)
11171 gfc_error ("Duplicate POINTER attribute at %C");
11181 /* NON_OVERRIDABLE flag. */
11182 m
= gfc_match (" non_overridable");
11183 if (m
== MATCH_ERROR
)
11185 if (m
== MATCH_YES
)
11187 if (ba
->non_overridable
)
11189 gfc_error ("Duplicate NON_OVERRIDABLE at %C");
11193 ba
->non_overridable
= 1;
11197 /* DEFERRED flag. */
11198 m
= gfc_match (" deferred");
11199 if (m
== MATCH_ERROR
)
11201 if (m
== MATCH_YES
)
11205 gfc_error ("Duplicate DEFERRED at %C");
11216 /* Nothing matching found. */
11218 gfc_error ("Expected access-specifier at %C");
11220 gfc_error ("Expected binding attribute at %C");
11223 while (gfc_match_char (',') == MATCH_YES
);
11225 /* NON_OVERRIDABLE and DEFERRED exclude themselves. */
11226 if (ba
->non_overridable
&& ba
->deferred
)
11228 gfc_error ("NON_OVERRIDABLE and DEFERRED cannot both appear at %C");
11235 if (ba
->access
== ACCESS_UNKNOWN
)
11236 ba
->access
= ppc
? gfc_current_block()->component_access
11237 : gfc_typebound_default_access
;
11239 if (ppc
&& !seen_ptr
)
11241 gfc_error ("POINTER attribute is required for procedure pointer component"
11249 return MATCH_ERROR
;
11253 /* Match a PROCEDURE specific binding inside a derived type. */
11256 match_procedure_in_type (void)
11258 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
11259 char target_buf
[GFC_MAX_SYMBOL_LEN
+ 1];
11260 char* target
= NULL
, *ifc
= NULL
;
11261 gfc_typebound_proc tb
;
11265 gfc_symtree
* stree
;
11270 /* Check current state. */
11271 gcc_assert (gfc_state_stack
->state
== COMP_DERIVED_CONTAINS
);
11272 block
= gfc_state_stack
->previous
->sym
;
11273 gcc_assert (block
);
11275 /* Try to match PROCEDURE(interface). */
11276 if (gfc_match (" (") == MATCH_YES
)
11278 m
= gfc_match_name (target_buf
);
11279 if (m
== MATCH_ERROR
)
11281 if (m
!= MATCH_YES
)
11283 gfc_error ("Interface-name expected after %<(%> at %C");
11284 return MATCH_ERROR
;
11287 if (gfc_match (" )") != MATCH_YES
)
11289 gfc_error ("%<)%> expected at %C");
11290 return MATCH_ERROR
;
11296 /* Construct the data structure. */
11297 memset (&tb
, 0, sizeof (tb
));
11298 tb
.where
= gfc_current_locus
;
11300 /* Match binding attributes. */
11301 m
= match_binding_attributes (&tb
, false, false);
11302 if (m
== MATCH_ERROR
)
11304 seen_attrs
= (m
== MATCH_YES
);
11306 /* Check that attribute DEFERRED is given if an interface is specified. */
11307 if (tb
.deferred
&& !ifc
)
11309 gfc_error ("Interface must be specified for DEFERRED binding at %C");
11310 return MATCH_ERROR
;
11312 if (ifc
&& !tb
.deferred
)
11314 gfc_error ("PROCEDURE(interface) at %C should be declared DEFERRED");
11315 return MATCH_ERROR
;
11318 /* Match the colons. */
11319 m
= gfc_match (" ::");
11320 if (m
== MATCH_ERROR
)
11322 seen_colons
= (m
== MATCH_YES
);
11323 if (seen_attrs
&& !seen_colons
)
11325 gfc_error ("Expected %<::%> after binding-attributes at %C");
11326 return MATCH_ERROR
;
11329 /* Match the binding names. */
11332 m
= gfc_match_name (name
);
11333 if (m
== MATCH_ERROR
)
11337 gfc_error ("Expected binding name at %C");
11338 return MATCH_ERROR
;
11341 if (num
>1 && !gfc_notify_std (GFC_STD_F2008
, "PROCEDURE list at %C"))
11342 return MATCH_ERROR
;
11344 /* Try to match the '=> target', if it's there. */
11346 m
= gfc_match (" =>");
11347 if (m
== MATCH_ERROR
)
11349 if (m
== MATCH_YES
)
11353 gfc_error ("%<=> target%> is invalid for DEFERRED binding at %C");
11354 return MATCH_ERROR
;
11359 gfc_error ("%<::%> needed in PROCEDURE binding with explicit target"
11361 return MATCH_ERROR
;
11364 m
= gfc_match_name (target_buf
);
11365 if (m
== MATCH_ERROR
)
11369 gfc_error ("Expected binding target after %<=>%> at %C");
11370 return MATCH_ERROR
;
11372 target
= target_buf
;
11375 /* If no target was found, it has the same name as the binding. */
11379 /* Get the namespace to insert the symbols into. */
11380 ns
= block
->f2k_derived
;
11383 /* If the binding is DEFERRED, check that the containing type is ABSTRACT. */
11384 if (tb
.deferred
&& !block
->attr
.abstract
)
11386 gfc_error ("Type %qs containing DEFERRED binding at %C "
11387 "is not ABSTRACT", block
->name
);
11388 return MATCH_ERROR
;
11391 /* See if we already have a binding with this name in the symtree which
11392 would be an error. If a GENERIC already targeted this binding, it may
11393 be already there but then typebound is still NULL. */
11394 stree
= gfc_find_symtree (ns
->tb_sym_root
, name
);
11395 if (stree
&& stree
->n
.tb
)
11397 gfc_error ("There is already a procedure with binding name %qs for "
11398 "the derived type %qs at %C", name
, block
->name
);
11399 return MATCH_ERROR
;
11402 /* Insert it and set attributes. */
11406 stree
= gfc_new_symtree (&ns
->tb_sym_root
, name
);
11407 gcc_assert (stree
);
11409 stree
->n
.tb
= gfc_get_typebound_proc (&tb
);
11411 if (gfc_get_sym_tree (target
, gfc_current_ns
, &stree
->n
.tb
->u
.specific
,
11413 return MATCH_ERROR
;
11414 gfc_set_sym_referenced (stree
->n
.tb
->u
.specific
->n
.sym
);
11415 gfc_add_flavor(&stree
->n
.tb
->u
.specific
->n
.sym
->attr
, FL_PROCEDURE
,
11416 target
, &stree
->n
.tb
->u
.specific
->n
.sym
->declared_at
);
11418 if (gfc_match_eos () == MATCH_YES
)
11420 if (gfc_match_char (',') != MATCH_YES
)
11425 gfc_error ("Syntax error in PROCEDURE statement at %C");
11426 return MATCH_ERROR
;
11430 /* Match a GENERIC procedure binding inside a derived type. */
11433 gfc_match_generic (void)
11435 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
11436 char bind_name
[GFC_MAX_SYMBOL_LEN
+ 16]; /* Allow space for OPERATOR(...). */
11438 gfc_typebound_proc tbattr
; /* Used for match_binding_attributes. */
11439 gfc_typebound_proc
* tb
;
11441 interface_type op_type
;
11442 gfc_intrinsic_op op
;
11445 /* Check current state. */
11446 if (gfc_current_state () == COMP_DERIVED
)
11448 gfc_error ("GENERIC at %C must be inside a derived-type CONTAINS");
11449 return MATCH_ERROR
;
11451 if (gfc_current_state () != COMP_DERIVED_CONTAINS
)
11453 block
= gfc_state_stack
->previous
->sym
;
11454 ns
= block
->f2k_derived
;
11455 gcc_assert (block
&& ns
);
11457 memset (&tbattr
, 0, sizeof (tbattr
));
11458 tbattr
.where
= gfc_current_locus
;
11460 /* See if we get an access-specifier. */
11461 m
= match_binding_attributes (&tbattr
, true, false);
11462 if (m
== MATCH_ERROR
)
11465 /* Now the colons, those are required. */
11466 if (gfc_match (" ::") != MATCH_YES
)
11468 gfc_error ("Expected %<::%> at %C");
11472 /* Match the binding name; depending on type (operator / generic) format
11473 it for future error messages into bind_name. */
11475 m
= gfc_match_generic_spec (&op_type
, name
, &op
);
11476 if (m
== MATCH_ERROR
)
11477 return MATCH_ERROR
;
11480 gfc_error ("Expected generic name or operator descriptor at %C");
11486 case INTERFACE_GENERIC
:
11487 case INTERFACE_DTIO
:
11488 snprintf (bind_name
, sizeof (bind_name
), "%s", name
);
11491 case INTERFACE_USER_OP
:
11492 snprintf (bind_name
, sizeof (bind_name
), "OPERATOR(.%s.)", name
);
11495 case INTERFACE_INTRINSIC_OP
:
11496 snprintf (bind_name
, sizeof (bind_name
), "OPERATOR(%s)",
11497 gfc_op2string (op
));
11500 case INTERFACE_NAMELESS
:
11501 gfc_error ("Malformed GENERIC statement at %C");
11506 gcc_unreachable ();
11509 /* Match the required =>. */
11510 if (gfc_match (" =>") != MATCH_YES
)
11512 gfc_error ("Expected %<=>%> at %C");
11516 /* Try to find existing GENERIC binding with this name / for this operator;
11517 if there is something, check that it is another GENERIC and then extend
11518 it rather than building a new node. Otherwise, create it and put it
11519 at the right position. */
11523 case INTERFACE_DTIO
:
11524 case INTERFACE_USER_OP
:
11525 case INTERFACE_GENERIC
:
11527 const bool is_op
= (op_type
== INTERFACE_USER_OP
);
11530 st
= gfc_find_symtree (is_op
? ns
->tb_uop_root
: ns
->tb_sym_root
, name
);
11531 tb
= st
? st
->n
.tb
: NULL
;
11535 case INTERFACE_INTRINSIC_OP
:
11536 tb
= ns
->tb_op
[op
];
11540 gcc_unreachable ();
11545 if (!tb
->is_generic
)
11547 gcc_assert (op_type
== INTERFACE_GENERIC
);
11548 gfc_error ("There's already a non-generic procedure with binding name"
11549 " %qs for the derived type %qs at %C",
11550 bind_name
, block
->name
);
11554 if (tb
->access
!= tbattr
.access
)
11556 gfc_error ("Binding at %C must have the same access as already"
11557 " defined binding %qs", bind_name
);
11563 tb
= gfc_get_typebound_proc (NULL
);
11564 tb
->where
= gfc_current_locus
;
11565 tb
->access
= tbattr
.access
;
11566 tb
->is_generic
= 1;
11567 tb
->u
.generic
= NULL
;
11571 case INTERFACE_DTIO
:
11572 case INTERFACE_GENERIC
:
11573 case INTERFACE_USER_OP
:
11575 const bool is_op
= (op_type
== INTERFACE_USER_OP
);
11576 gfc_symtree
* st
= gfc_get_tbp_symtree (is_op
? &ns
->tb_uop_root
:
11577 &ns
->tb_sym_root
, name
);
11584 case INTERFACE_INTRINSIC_OP
:
11585 ns
->tb_op
[op
] = tb
;
11589 gcc_unreachable ();
11593 /* Now, match all following names as specific targets. */
11596 gfc_symtree
* target_st
;
11597 gfc_tbp_generic
* target
;
11599 m
= gfc_match_name (name
);
11600 if (m
== MATCH_ERROR
)
11604 gfc_error ("Expected specific binding name at %C");
11608 target_st
= gfc_get_tbp_symtree (&ns
->tb_sym_root
, name
);
11610 /* See if this is a duplicate specification. */
11611 for (target
= tb
->u
.generic
; target
; target
= target
->next
)
11612 if (target_st
== target
->specific_st
)
11614 gfc_error ("%qs already defined as specific binding for the"
11615 " generic %qs at %C", name
, bind_name
);
11619 target
= gfc_get_tbp_generic ();
11620 target
->specific_st
= target_st
;
11621 target
->specific
= NULL
;
11622 target
->next
= tb
->u
.generic
;
11623 target
->is_operator
= ((op_type
== INTERFACE_USER_OP
)
11624 || (op_type
== INTERFACE_INTRINSIC_OP
));
11625 tb
->u
.generic
= target
;
11627 while (gfc_match (" ,") == MATCH_YES
);
11629 /* Here should be the end. */
11630 if (gfc_match_eos () != MATCH_YES
)
11632 gfc_error ("Junk after GENERIC binding at %C");
11639 return MATCH_ERROR
;
11643 /* Match a FINAL declaration inside a derived type. */
11646 gfc_match_final_decl (void)
11648 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
11651 gfc_namespace
* module_ns
;
11655 if (gfc_current_form
== FORM_FREE
)
11657 char c
= gfc_peek_ascii_char ();
11658 if (!gfc_is_whitespace (c
) && c
!= ':')
11662 if (gfc_state_stack
->state
!= COMP_DERIVED_CONTAINS
)
11664 if (gfc_current_form
== FORM_FIXED
)
11667 gfc_error ("FINAL declaration at %C must be inside a derived type "
11668 "CONTAINS section");
11669 return MATCH_ERROR
;
11672 block
= gfc_state_stack
->previous
->sym
;
11673 gcc_assert (block
);
11675 if (gfc_state_stack
->previous
->previous
11676 && gfc_state_stack
->previous
->previous
->state
!= COMP_MODULE
11677 && gfc_state_stack
->previous
->previous
->state
!= COMP_SUBMODULE
)
11679 gfc_error ("Derived type declaration with FINAL at %C must be in the"
11680 " specification part of a MODULE");
11681 return MATCH_ERROR
;
11684 module_ns
= gfc_current_ns
;
11685 gcc_assert (module_ns
);
11686 gcc_assert (module_ns
->proc_name
->attr
.flavor
== FL_MODULE
);
11688 /* Match optional ::, don't care about MATCH_YES or MATCH_NO. */
11689 if (gfc_match (" ::") == MATCH_ERROR
)
11690 return MATCH_ERROR
;
11692 /* Match the sequence of procedure names. */
11699 if (first
&& gfc_match_eos () == MATCH_YES
)
11701 gfc_error ("Empty FINAL at %C");
11702 return MATCH_ERROR
;
11705 m
= gfc_match_name (name
);
11708 gfc_error ("Expected module procedure name at %C");
11709 return MATCH_ERROR
;
11711 else if (m
!= MATCH_YES
)
11712 return MATCH_ERROR
;
11714 if (gfc_match_eos () == MATCH_YES
)
11716 if (!last
&& gfc_match_char (',') != MATCH_YES
)
11718 gfc_error ("Expected %<,%> at %C");
11719 return MATCH_ERROR
;
11722 if (gfc_get_symbol (name
, module_ns
, &sym
))
11724 gfc_error ("Unknown procedure name %qs at %C", name
);
11725 return MATCH_ERROR
;
11728 /* Mark the symbol as module procedure. */
11729 if (sym
->attr
.proc
!= PROC_MODULE
11730 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
11731 return MATCH_ERROR
;
11733 /* Check if we already have this symbol in the list, this is an error. */
11734 for (f
= block
->f2k_derived
->finalizers
; f
; f
= f
->next
)
11735 if (f
->proc_sym
== sym
)
11737 gfc_error ("%qs at %C is already defined as FINAL procedure",
11739 return MATCH_ERROR
;
11742 /* Add this symbol to the list of finalizers. */
11743 gcc_assert (block
->f2k_derived
);
11745 f
= XCNEW (gfc_finalizer
);
11747 f
->proc_tree
= NULL
;
11748 f
->where
= gfc_current_locus
;
11749 f
->next
= block
->f2k_derived
->finalizers
;
11750 block
->f2k_derived
->finalizers
= f
;
11760 const ext_attr_t ext_attr_list
[] = {
11761 { "dllimport", EXT_ATTR_DLLIMPORT
, "dllimport" },
11762 { "dllexport", EXT_ATTR_DLLEXPORT
, "dllexport" },
11763 { "cdecl", EXT_ATTR_CDECL
, "cdecl" },
11764 { "stdcall", EXT_ATTR_STDCALL
, "stdcall" },
11765 { "fastcall", EXT_ATTR_FASTCALL
, "fastcall" },
11766 { "no_arg_check", EXT_ATTR_NO_ARG_CHECK
, NULL
},
11767 { "deprecated", EXT_ATTR_DEPRECATED
, NULL
},
11768 { "noinline", EXT_ATTR_NOINLINE
, NULL
},
11769 { "noreturn", EXT_ATTR_NORETURN
, NULL
},
11770 { "weak", EXT_ATTR_WEAK
, NULL
},
11771 { NULL
, EXT_ATTR_LAST
, NULL
}
11774 /* Match a !GCC$ ATTRIBUTES statement of the form:
11775 !GCC$ ATTRIBUTES attribute-list :: var-name [, var-name] ...
11776 When we come here, we have already matched the !GCC$ ATTRIBUTES string.
11778 TODO: We should support all GCC attributes using the same syntax for
11779 the attribute list, i.e. the list in C
11780 __attributes(( attribute-list ))
11782 !GCC$ ATTRIBUTES attribute-list ::
11783 Cf. c-parser.cc's c_parser_attributes; the data can then directly be
11786 As there is absolutely no risk of confusion, we should never return
11789 gfc_match_gcc_attributes (void)
11791 symbol_attribute attr
;
11792 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
11797 gfc_clear_attr (&attr
);
11802 if (gfc_match_name (name
) != MATCH_YES
)
11803 return MATCH_ERROR
;
11805 for (id
= 0; id
< EXT_ATTR_LAST
; id
++)
11806 if (strcmp (name
, ext_attr_list
[id
].name
) == 0)
11809 if (id
== EXT_ATTR_LAST
)
11811 gfc_error ("Unknown attribute in !GCC$ ATTRIBUTES statement at %C");
11812 return MATCH_ERROR
;
11815 if (!gfc_add_ext_attribute (&attr
, (ext_attr_id_t
)id
, &gfc_current_locus
))
11816 return MATCH_ERROR
;
11818 gfc_gobble_whitespace ();
11819 ch
= gfc_next_ascii_char ();
11822 /* This is the successful exit condition for the loop. */
11823 if (gfc_next_ascii_char () == ':')
11833 if (gfc_match_eos () == MATCH_YES
)
11838 m
= gfc_match_name (name
);
11839 if (m
!= MATCH_YES
)
11842 if (find_special (name
, &sym
, true))
11843 return MATCH_ERROR
;
11845 sym
->attr
.ext_attr
|= attr
.ext_attr
;
11847 if (gfc_match_eos () == MATCH_YES
)
11850 if (gfc_match_char (',') != MATCH_YES
)
11857 gfc_error ("Syntax error in !GCC$ ATTRIBUTES statement at %C");
11858 return MATCH_ERROR
;
11862 /* Match a !GCC$ UNROLL statement of the form:
11865 The parameter n is the number of times we are supposed to unroll.
11867 When we come here, we have already matched the !GCC$ UNROLL string. */
11869 gfc_match_gcc_unroll (void)
11873 /* FIXME: use gfc_match_small_literal_int instead, delete small_int */
11874 if (gfc_match_small_int (&value
) == MATCH_YES
)
11876 if (value
< 0 || value
> USHRT_MAX
)
11878 gfc_error ("%<GCC unroll%> directive requires a"
11879 " non-negative integral constant"
11880 " less than or equal to %u at %C",
11883 return MATCH_ERROR
;
11885 if (gfc_match_eos () == MATCH_YES
)
11887 directive_unroll
= value
== 0 ? 1 : value
;
11892 gfc_error ("Syntax error in !GCC$ UNROLL directive at %C");
11893 return MATCH_ERROR
;
11896 /* Match a !GCC$ builtin (b) attributes simd flags if('target') form:
11898 The parameter b is name of a middle-end built-in.
11899 FLAGS is optional and must be one of:
11903 IF('target') is optional and TARGET is a name of a multilib ABI.
11905 When we come here, we have already matched the !GCC$ builtin string. */
11908 gfc_match_gcc_builtin (void)
11910 char builtin
[GFC_MAX_SYMBOL_LEN
+ 1];
11911 char target
[GFC_MAX_SYMBOL_LEN
+ 1];
11913 if (gfc_match (" ( %n ) attributes simd", builtin
) != MATCH_YES
)
11914 return MATCH_ERROR
;
11916 gfc_simd_clause clause
= SIMD_NONE
;
11917 if (gfc_match (" ( notinbranch ) ") == MATCH_YES
)
11918 clause
= SIMD_NOTINBRANCH
;
11919 else if (gfc_match (" ( inbranch ) ") == MATCH_YES
)
11920 clause
= SIMD_INBRANCH
;
11922 if (gfc_match (" if ( '%n' ) ", target
) == MATCH_YES
)
11924 const char *abi
= targetm
.get_multilib_abi_name ();
11925 if (abi
== NULL
|| strcmp (abi
, target
) != 0)
11929 if (gfc_vectorized_builtins
== NULL
)
11930 gfc_vectorized_builtins
= new hash_map
<nofree_string_hash
, int> ();
11932 char *r
= XNEWVEC (char, strlen (builtin
) + 32);
11933 sprintf (r
, "__builtin_%s", builtin
);
11936 int &value
= gfc_vectorized_builtins
->get_or_insert (r
, &existed
);
11944 /* Match an !GCC$ IVDEP statement.
11945 When we come here, we have already matched the !GCC$ IVDEP string. */
11948 gfc_match_gcc_ivdep (void)
11950 if (gfc_match_eos () == MATCH_YES
)
11952 directive_ivdep
= true;
11956 gfc_error ("Syntax error in !GCC$ IVDEP directive at %C");
11957 return MATCH_ERROR
;
11960 /* Match an !GCC$ VECTOR statement.
11961 When we come here, we have already matched the !GCC$ VECTOR string. */
11964 gfc_match_gcc_vector (void)
11966 if (gfc_match_eos () == MATCH_YES
)
11968 directive_vector
= true;
11969 directive_novector
= false;
11973 gfc_error ("Syntax error in !GCC$ VECTOR directive at %C");
11974 return MATCH_ERROR
;
11977 /* Match an !GCC$ NOVECTOR statement.
11978 When we come here, we have already matched the !GCC$ NOVECTOR string. */
11981 gfc_match_gcc_novector (void)
11983 if (gfc_match_eos () == MATCH_YES
)
11985 directive_novector
= true;
11986 directive_vector
= false;
11990 gfc_error ("Syntax error in !GCC$ NOVECTOR directive at %C");
11991 return MATCH_ERROR
;