1 /* Declaration statement matcher
2 Copyright (C) 2002-2020 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
->n
.sym
->attr
.save
427 && (*result
)->symtree
->n
.sym
->attr
.target
)
429 gfc_free_expr (*result
);
432 gfc_current_locus
= old_loc
;
434 m
= gfc_match_name (name
);
438 if (gfc_find_symbol (name
, NULL
, 1, &sym
))
441 if (sym
&& sym
->attr
.generic
)
442 dt_sym
= gfc_find_dt_in_generic (sym
);
445 || (sym
->attr
.flavor
!= FL_PARAMETER
446 && (!dt_sym
|| !gfc_fl_struct (dt_sym
->attr
.flavor
))))
448 gfc_error ("Symbol %qs must be a PARAMETER in DATA statement at %C",
453 else if (dt_sym
&& gfc_fl_struct (dt_sym
->attr
.flavor
))
454 return gfc_match_structure_constructor (dt_sym
, result
);
456 /* Check to see if the value is an initialization array expression. */
457 if (sym
->value
->expr_type
== EXPR_ARRAY
)
459 gfc_current_locus
= old_loc
;
461 m
= gfc_match_init_expr (result
);
462 if (m
== MATCH_ERROR
)
467 if (!gfc_simplify_expr (*result
, 0))
470 if ((*result
)->expr_type
== EXPR_CONSTANT
)
474 gfc_error ("Invalid initializer %s in Data statement at %C", name
);
480 *result
= gfc_copy_expr (sym
->value
);
485 /* Match a list of values in a DATA statement. The leading '/' has
486 already been seen at this point. */
489 top_val_list (gfc_data
*data
)
491 gfc_data_value
*new_val
, *tail
;
499 m
= match_data_constant (&expr
);
502 if (m
== MATCH_ERROR
)
505 new_val
= gfc_get_data_value ();
506 mpz_init (new_val
->repeat
);
509 data
->value
= new_val
;
511 tail
->next
= new_val
;
515 if (expr
->ts
.type
!= BT_INTEGER
|| gfc_match_char ('*') != MATCH_YES
)
518 mpz_set_ui (tail
->repeat
, 1);
522 mpz_set (tail
->repeat
, expr
->value
.integer
);
523 gfc_free_expr (expr
);
525 m
= match_data_constant (&tail
->expr
);
528 if (m
== MATCH_ERROR
)
532 if (gfc_match_char ('/') == MATCH_YES
)
534 if (gfc_match_char (',') == MATCH_NO
)
541 gfc_syntax_error (ST_DATA
);
542 gfc_free_data_all (gfc_current_ns
);
547 /* Matches an old style initialization. */
550 match_old_style_init (const char *name
)
555 gfc_data
*newdata
, *nd
;
557 /* Set up data structure to hold initializers. */
558 gfc_find_sym_tree (name
, NULL
, 0, &st
);
561 newdata
= gfc_get_data ();
562 newdata
->var
= gfc_get_data_variable ();
563 newdata
->var
->expr
= gfc_get_variable_expr (st
);
564 newdata
->var
->expr
->where
= sym
->declared_at
;
565 newdata
->where
= gfc_current_locus
;
567 /* Match initial value list. This also eats the terminal '/'. */
568 m
= top_val_list (newdata
);
575 /* Check that a BOZ did not creep into an old-style initialization. */
576 for (nd
= newdata
; nd
; nd
= nd
->next
)
578 if (nd
->value
->expr
->ts
.type
== BT_BOZ
579 && gfc_invalid_boz ("BOZ at %L cannot appear in an old-style "
580 "initialization", &nd
->value
->expr
->where
))
583 if (nd
->var
->expr
->ts
.type
!= BT_INTEGER
584 && nd
->var
->expr
->ts
.type
!= BT_REAL
585 && nd
->value
->expr
->ts
.type
== BT_BOZ
)
587 gfc_error ("BOZ literal constant near %L cannot be assigned to "
588 "a %qs variable in an old-style initialization",
589 &nd
->value
->expr
->where
,
590 gfc_typename (&nd
->value
->expr
->ts
));
597 gfc_error ("Initialization at %C is not allowed in a PURE procedure");
601 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
603 /* Mark the variable as having appeared in a data statement. */
604 if (!gfc_add_data (&sym
->attr
, sym
->name
, &sym
->declared_at
))
610 /* Chain in namespace list of DATA initializers. */
611 newdata
->next
= gfc_current_ns
->data
;
612 gfc_current_ns
->data
= newdata
;
618 /* Match the stuff following a DATA statement. If ERROR_FLAG is set,
619 we are matching a DATA statement and are therefore issuing an error
620 if we encounter something unexpected, if not, we're trying to match
621 an old-style initialization expression of the form INTEGER I /2/. */
624 gfc_match_data (void)
632 /* DATA has been matched. In free form source code, the next character
633 needs to be whitespace or '(' from an implied do-loop. Check that
635 c
= gfc_peek_ascii_char ();
636 if (gfc_current_form
== FORM_FREE
&& !gfc_is_whitespace (c
) && c
!= '(')
639 /* Before parsing the rest of a DATA statement, check F2008:c1206. */
640 if ((gfc_current_state () == COMP_FUNCTION
641 || gfc_current_state () == COMP_SUBROUTINE
)
642 && gfc_state_stack
->previous
->state
== COMP_INTERFACE
)
644 gfc_error ("DATA statement at %C cannot appear within an INTERFACE");
648 set_in_match_data (true);
652 new_data
= gfc_get_data ();
653 new_data
->where
= gfc_current_locus
;
655 m
= top_var_list (new_data
);
659 if (new_data
->var
->iter
.var
660 && new_data
->var
->iter
.var
->ts
.type
== BT_INTEGER
661 && new_data
->var
->iter
.var
->symtree
->n
.sym
->attr
.implied_index
== 1
662 && new_data
->var
->list
663 && new_data
->var
->list
->expr
664 && new_data
->var
->list
->expr
->ts
.type
== BT_CHARACTER
665 && new_data
->var
->list
->expr
->ref
666 && new_data
->var
->list
->expr
->ref
->type
== REF_SUBSTRING
)
668 gfc_error ("Invalid substring in data-implied-do at %L in DATA "
669 "statement", &new_data
->var
->list
->expr
->where
);
673 /* Check for an entity with an allocatable component, which is not
675 e
= new_data
->var
->expr
;
681 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
682 if ((ref
->type
== REF_COMPONENT
683 && ref
->u
.c
.component
->attr
.allocatable
)
684 || (ref
->type
== REF_ARRAY
685 && e
->symtree
->n
.sym
->attr
.pointer
!= 1
686 && ref
->u
.ar
.as
&& ref
->u
.ar
.as
->type
== AS_DEFERRED
))
691 gfc_error ("Allocatable component or deferred-shaped array "
692 "near %C in DATA statement");
696 /* F2008:C567 (R536) A data-i-do-object or a variable that appears
697 as a data-stmt-object shall not be an object designator in which
698 a pointer appears other than as the entire rightmost part-ref. */
700 if (e
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
701 && e
->symtree
->n
.sym
->attr
.pointer
702 && ref
->type
== REF_COMPONENT
)
705 for (; ref
; ref
= ref
->next
)
706 if (ref
->type
== REF_COMPONENT
707 && ref
->u
.c
.component
->attr
.pointer
712 m
= top_val_list (new_data
);
716 new_data
->next
= gfc_current_ns
->data
;
717 gfc_current_ns
->data
= new_data
;
719 if (gfc_match_eos () == MATCH_YES
)
722 gfc_match_char (','); /* Optional comma */
725 set_in_match_data (false);
729 gfc_error ("DATA statement at %C is not allowed in a PURE procedure");
732 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
738 gfc_error ("part-ref with pointer attribute near %L is not "
739 "rightmost part-ref of data-stmt-object",
743 set_in_match_data (false);
744 gfc_free_data (new_data
);
749 /************************ Declaration statements *********************/
752 /* Like gfc_match_init_expr, but matches a 'clist' (old-style initialization
753 list). The difference here is the expression is a list of constants
754 and is surrounded by '/'.
755 The typespec ts must match the typespec of the variable which the
756 clist is initializing.
757 The arrayspec tells whether this should match a list of constants
758 corresponding to array elements or a scalar (as == NULL). */
761 match_clist_expr (gfc_expr
**result
, gfc_typespec
*ts
, gfc_array_spec
*as
)
763 gfc_constructor_base array_head
= NULL
;
764 gfc_expr
*expr
= NULL
;
765 match m
= MATCH_ERROR
;
767 mpz_t repeat
, cons_size
, as_size
;
773 /* We have already matched '/' - now look for a constant list, as with
774 top_val_list from decl.c, but append the result to an array. */
775 if (gfc_match ("/") == MATCH_YES
)
777 gfc_error ("Empty old style initializer list at %C");
781 where
= gfc_current_locus
;
782 scalar
= !as
|| !as
->rank
;
784 if (!scalar
&& !spec_size (as
, &as_size
))
786 gfc_error ("Array in initializer list at %L must have an explicit shape",
787 as
->type
== AS_EXPLICIT
? &as
->upper
[0]->where
: &where
);
788 /* Nothing to cleanup yet. */
792 mpz_init_set_ui (repeat
, 0);
796 m
= match_data_constant (&expr
);
798 expr
= NULL
; /* match_data_constant may set expr to garbage */
801 if (m
== MATCH_ERROR
)
804 /* Found r in repeat spec r*c; look for the constant to repeat. */
805 if ( gfc_match_char ('*') == MATCH_YES
)
809 gfc_error ("Repeat spec invalid in scalar initializer at %C");
812 if (expr
->ts
.type
!= BT_INTEGER
)
814 gfc_error ("Repeat spec must be an integer at %C");
817 mpz_set (repeat
, expr
->value
.integer
);
818 gfc_free_expr (expr
);
821 m
= match_data_constant (&expr
);
825 gfc_error ("Expected data constant after repeat spec at %C");
830 /* No repeat spec, we matched the data constant itself. */
832 mpz_set_ui (repeat
, 1);
836 /* Add the constant initializer as many times as repeated. */
837 for (; mpz_cmp_ui (repeat
, 0) > 0; mpz_sub_ui (repeat
, repeat
, 1))
839 /* Make sure types of elements match */
840 if(ts
&& !gfc_compare_types (&expr
->ts
, ts
)
841 && !gfc_convert_type (expr
, ts
, 1))
844 gfc_constructor_append_expr (&array_head
,
845 gfc_copy_expr (expr
), &gfc_current_locus
);
848 gfc_free_expr (expr
);
852 /* For scalar initializers quit after one element. */
855 if(gfc_match_char ('/') != MATCH_YES
)
857 gfc_error ("End of scalar initializer expected at %C");
863 if (gfc_match_char ('/') == MATCH_YES
)
865 if (gfc_match_char (',') == MATCH_NO
)
869 /* If we break early from here out, we encountered an error. */
872 /* Set up expr as an array constructor. */
875 expr
= gfc_get_array_expr (ts
->type
, ts
->kind
, &where
);
877 expr
->value
.constructor
= array_head
;
879 expr
->rank
= as
->rank
;
880 expr
->shape
= gfc_get_shape (expr
->rank
);
882 /* Validate sizes. We built expr ourselves, so cons_size will be
883 constant (we fail above for non-constant expressions).
884 We still need to verify that the sizes match. */
885 gcc_assert (gfc_array_size (expr
, &cons_size
));
886 cmp
= mpz_cmp (cons_size
, as_size
);
888 gfc_error ("Not enough elements in array initializer at %C");
890 gfc_error ("Too many elements in array initializer at %C");
891 mpz_clear (cons_size
);
896 /* Make sure scalar types match. */
897 else if (!gfc_compare_types (&expr
->ts
, ts
)
898 && !gfc_convert_type (expr
, ts
, 1))
902 expr
->ts
.u
.cl
->length_from_typespec
= 1;
910 gfc_error ("Syntax error in old style initializer list at %C");
914 expr
->value
.constructor
= NULL
;
915 gfc_free_expr (expr
);
916 gfc_constructor_free (array_head
);
926 /* Auxiliary function to merge DIMENSION and CODIMENSION array specs. */
929 merge_array_spec (gfc_array_spec
*from
, gfc_array_spec
*to
, bool copy
)
931 if ((from
->type
== AS_ASSUMED_RANK
&& to
->corank
)
932 || (to
->type
== AS_ASSUMED_RANK
&& from
->corank
))
934 gfc_error ("The assumed-rank array at %C shall not have a codimension");
938 if (to
->rank
== 0 && from
->rank
> 0)
940 to
->rank
= from
->rank
;
941 to
->type
= from
->type
;
942 to
->cray_pointee
= from
->cray_pointee
;
943 to
->cp_was_assumed
= from
->cp_was_assumed
;
945 for (int i
= to
->corank
- 1; i
>= 0; i
--)
947 /* Do not exceed the limits on lower[] and upper[]. gfortran
948 cleans up elsewhere. */
949 int j
= from
->rank
+ i
;
950 if (j
>= GFC_MAX_DIMENSIONS
)
953 to
->lower
[j
] = to
->lower
[i
];
954 to
->upper
[j
] = to
->upper
[i
];
956 for (int i
= 0; i
< from
->rank
; i
++)
960 to
->lower
[i
] = gfc_copy_expr (from
->lower
[i
]);
961 to
->upper
[i
] = gfc_copy_expr (from
->upper
[i
]);
965 to
->lower
[i
] = from
->lower
[i
];
966 to
->upper
[i
] = from
->upper
[i
];
970 else if (to
->corank
== 0 && from
->corank
> 0)
972 to
->corank
= from
->corank
;
973 to
->cotype
= from
->cotype
;
975 for (int i
= 0; i
< from
->corank
; i
++)
977 /* Do not exceed the limits on lower[] and upper[]. gfortran
978 cleans up elsewhere. */
979 int k
= from
->rank
+ i
;
980 int j
= to
->rank
+ i
;
981 if (j
>= GFC_MAX_DIMENSIONS
)
986 to
->lower
[j
] = gfc_copy_expr (from
->lower
[k
]);
987 to
->upper
[j
] = gfc_copy_expr (from
->upper
[k
]);
991 to
->lower
[j
] = from
->lower
[k
];
992 to
->upper
[j
] = from
->upper
[k
];
997 if (to
->rank
+ to
->corank
> GFC_MAX_DIMENSIONS
)
999 gfc_error ("Sum of array rank %d and corank %d at %C exceeds maximum "
1000 "allowed dimensions of %d",
1001 to
->rank
, to
->corank
, GFC_MAX_DIMENSIONS
);
1002 to
->corank
= GFC_MAX_DIMENSIONS
- to
->rank
;
1009 /* Match an intent specification. Since this can only happen after an
1010 INTENT word, a legal intent-spec must follow. */
1013 match_intent_spec (void)
1016 if (gfc_match (" ( in out )") == MATCH_YES
)
1017 return INTENT_INOUT
;
1018 if (gfc_match (" ( in )") == MATCH_YES
)
1020 if (gfc_match (" ( out )") == MATCH_YES
)
1023 gfc_error ("Bad INTENT specification at %C");
1024 return INTENT_UNKNOWN
;
1028 /* Matches a character length specification, which is either a
1029 specification expression, '*', or ':'. */
1032 char_len_param_value (gfc_expr
**expr
, bool *deferred
)
1039 if (gfc_match_char ('*') == MATCH_YES
)
1042 if (gfc_match_char (':') == MATCH_YES
)
1044 if (!gfc_notify_std (GFC_STD_F2003
, "deferred type parameter at %C"))
1052 m
= gfc_match_expr (expr
);
1054 if (m
== MATCH_NO
|| m
== MATCH_ERROR
)
1057 if (!gfc_expr_check_typed (*expr
, gfc_current_ns
, false))
1060 if ((*expr
)->expr_type
== EXPR_FUNCTION
)
1062 if ((*expr
)->ts
.type
== BT_INTEGER
1063 || ((*expr
)->ts
.type
== BT_UNKNOWN
1064 && strcmp((*expr
)->symtree
->name
, "null") != 0))
1069 else if ((*expr
)->expr_type
== EXPR_CONSTANT
)
1071 /* F2008, 4.4.3.1: The length is a type parameter; its kind is
1072 processor dependent and its value is greater than or equal to zero.
1073 F2008, 4.4.3.2: If the character length parameter value evaluates
1074 to a negative value, the length of character entities declared
1077 if ((*expr
)->ts
.type
== BT_INTEGER
)
1079 if (mpz_cmp_si ((*expr
)->value
.integer
, 0) < 0)
1080 mpz_set_si ((*expr
)->value
.integer
, 0);
1085 else if ((*expr
)->expr_type
== EXPR_ARRAY
)
1087 else if ((*expr
)->expr_type
== EXPR_VARIABLE
)
1092 e
= gfc_copy_expr (*expr
);
1094 /* This catches the invalid code "[character(m(2:3)) :: 'x', 'y']",
1095 which causes an ICE if gfc_reduce_init_expr() is called. */
1096 if (e
->ref
&& e
->ref
->type
== REF_ARRAY
1097 && e
->ref
->u
.ar
.type
== AR_UNKNOWN
1098 && e
->ref
->u
.ar
.dimen_type
[0] == DIMEN_RANGE
)
1101 t
= gfc_reduce_init_expr (e
);
1103 if (!t
&& e
->ts
.type
== BT_UNKNOWN
1104 && e
->symtree
->n
.sym
->attr
.untyped
== 1
1105 && (flag_implicit_none
1106 || e
->symtree
->n
.sym
->ns
->seen_implicit_none
== 1
1107 || e
->symtree
->n
.sym
->ns
->parent
->seen_implicit_none
== 1))
1113 if ((e
->ref
&& e
->ref
->type
== REF_ARRAY
1114 && e
->ref
->u
.ar
.type
!= AR_ELEMENT
)
1115 || (!e
->ref
&& e
->expr_type
== EXPR_ARRAY
))
1127 gfc_error ("Scalar INTEGER expression expected at %L", &(*expr
)->where
);
1132 /* A character length is a '*' followed by a literal integer or a
1133 char_len_param_value in parenthesis. */
1136 match_char_length (gfc_expr
**expr
, bool *deferred
, bool obsolescent_check
)
1142 m
= gfc_match_char ('*');
1146 m
= gfc_match_small_literal_int (&length
, NULL
);
1147 if (m
== MATCH_ERROR
)
1152 if (obsolescent_check
1153 && !gfc_notify_std (GFC_STD_F95_OBS
, "Old-style character length at %C"))
1155 *expr
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
, length
);
1159 if (gfc_match_char ('(') == MATCH_NO
)
1162 m
= char_len_param_value (expr
, deferred
);
1163 if (m
!= MATCH_YES
&& gfc_matching_function
)
1165 gfc_undo_symbols ();
1169 if (m
== MATCH_ERROR
)
1174 if (gfc_match_char (')') == MATCH_NO
)
1176 gfc_free_expr (*expr
);
1184 gfc_error ("Syntax error in character length specification at %C");
1189 /* Special subroutine for finding a symbol. Check if the name is found
1190 in the current name space. If not, and we're compiling a function or
1191 subroutine and the parent compilation unit is an interface, then check
1192 to see if the name we've been given is the name of the interface
1193 (located in another namespace). */
1196 find_special (const char *name
, gfc_symbol
**result
, bool allow_subroutine
)
1202 i
= gfc_get_sym_tree (name
, NULL
, &st
, allow_subroutine
);
1205 *result
= st
? st
->n
.sym
: NULL
;
1209 if (gfc_current_state () != COMP_SUBROUTINE
1210 && gfc_current_state () != COMP_FUNCTION
)
1213 s
= gfc_state_stack
->previous
;
1217 if (s
->state
!= COMP_INTERFACE
)
1220 goto end
; /* Nameless interface. */
1222 if (strcmp (name
, s
->sym
->name
) == 0)
1233 /* Special subroutine for getting a symbol node associated with a
1234 procedure name, used in SUBROUTINE and FUNCTION statements. The
1235 symbol is created in the parent using with symtree node in the
1236 child unit pointing to the symbol. If the current namespace has no
1237 parent, then the symbol is just created in the current unit. */
1240 get_proc_name (const char *name
, gfc_symbol
**result
, bool module_fcn_entry
)
1246 /* Module functions have to be left in their own namespace because
1247 they have potentially (almost certainly!) already been referenced.
1248 In this sense, they are rather like external functions. This is
1249 fixed up in resolve.c(resolve_entries), where the symbol name-
1250 space is set to point to the master function, so that the fake
1251 result mechanism can work. */
1252 if (module_fcn_entry
)
1254 /* Present if entry is declared to be a module procedure. */
1255 rc
= gfc_find_symbol (name
, gfc_current_ns
->parent
, 0, result
);
1257 if (*result
== NULL
)
1258 rc
= gfc_get_symbol (name
, NULL
, result
);
1259 else if (!gfc_get_symbol (name
, NULL
, &sym
) && sym
1260 && (*result
)->ts
.type
== BT_UNKNOWN
1261 && sym
->attr
.flavor
== FL_UNKNOWN
)
1262 /* Pick up the typespec for the entry, if declared in the function
1263 body. Note that this symbol is FL_UNKNOWN because it will
1264 only have appeared in a type declaration. The local symtree
1265 is set to point to the module symbol and a unique symtree
1266 to the local version. This latter ensures a correct clearing
1269 /* If the ENTRY proceeds its specification, we need to ensure
1270 that this does not raise a "has no IMPLICIT type" error. */
1271 if (sym
->ts
.type
== BT_UNKNOWN
)
1272 sym
->attr
.untyped
= 1;
1274 (*result
)->ts
= sym
->ts
;
1276 /* Put the symbol in the procedure namespace so that, should
1277 the ENTRY precede its specification, the specification
1279 (*result
)->ns
= gfc_current_ns
;
1281 gfc_find_sym_tree (name
, gfc_current_ns
, 0, &st
);
1282 st
->n
.sym
= *result
;
1283 st
= gfc_get_unique_symtree (gfc_current_ns
);
1289 rc
= gfc_get_symbol (name
, gfc_current_ns
->parent
, result
);
1295 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
1298 if (sym
->attr
.module_procedure
&& sym
->attr
.if_source
== IFSRC_IFBODY
)
1300 /* Create a partially populated interface symbol to carry the
1301 characteristics of the procedure and the result. */
1302 sym
->tlink
= gfc_new_symbol (name
, sym
->ns
);
1303 gfc_add_type (sym
->tlink
, &(sym
->ts
), &gfc_current_locus
);
1304 gfc_copy_attr (&sym
->tlink
->attr
, &sym
->attr
, NULL
);
1305 if (sym
->attr
.dimension
)
1306 sym
->tlink
->as
= gfc_copy_array_spec (sym
->as
);
1308 /* Ideally, at this point, a copy would be made of the formal
1309 arguments and their namespace. However, this does not appear
1310 to be necessary, albeit at the expense of not being able to
1311 use gfc_compare_interfaces directly. */
1313 if (sym
->result
&& sym
->result
!= sym
)
1315 sym
->tlink
->result
= sym
->result
;
1318 else if (sym
->result
)
1320 sym
->tlink
->result
= sym
->tlink
;
1323 else if (sym
&& !sym
->gfc_new
1324 && gfc_current_state () != COMP_INTERFACE
)
1326 /* Trap another encompassed procedure with the same name. All
1327 these conditions are necessary to avoid picking up an entry
1328 whose name clashes with that of the encompassing procedure;
1329 this is handled using gsymbols to register unique, globally
1330 accessible names. */
1331 if (sym
->attr
.flavor
!= 0
1332 && sym
->attr
.proc
!= 0
1333 && (sym
->attr
.subroutine
|| sym
->attr
.function
|| sym
->attr
.entry
)
1334 && sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
1336 gfc_error_now ("Procedure %qs at %C is already defined at %L",
1337 name
, &sym
->declared_at
);
1340 if (sym
->attr
.flavor
!= 0
1341 && sym
->attr
.entry
&& sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
1343 gfc_error_now ("Procedure %qs at %C is already defined at %L",
1344 name
, &sym
->declared_at
);
1348 if (sym
->attr
.external
&& sym
->attr
.procedure
1349 && gfc_current_state () == COMP_CONTAINS
)
1351 gfc_error_now ("Contained procedure %qs at %C clashes with "
1352 "procedure defined at %L",
1353 name
, &sym
->declared_at
);
1357 /* Trap a procedure with a name the same as interface in the
1358 encompassing scope. */
1359 if (sym
->attr
.generic
!= 0
1360 && (sym
->attr
.subroutine
|| sym
->attr
.function
)
1361 && !sym
->attr
.mod_proc
)
1363 gfc_error_now ("Name %qs at %C is already defined"
1364 " as a generic interface at %L",
1365 name
, &sym
->declared_at
);
1369 /* Trap declarations of attributes in encompassing scope. The
1370 signature for this is that ts.kind is nonzero for no-CLASS
1371 entity. For a CLASS entity, ts.kind is zero. */
1372 if ((sym
->ts
.kind
!= 0 || sym
->ts
.type
== BT_CLASS
)
1373 && !sym
->attr
.implicit_type
1374 && sym
->attr
.proc
== 0
1375 && gfc_current_ns
->parent
!= NULL
1376 && sym
->attr
.access
== 0
1377 && !module_fcn_entry
)
1379 gfc_error_now ("Procedure %qs at %C has an explicit interface "
1380 "from a previous declaration", name
);
1385 /* C1246 (R1225) MODULE shall appear only in the function-stmt or
1386 subroutine-stmt of a module subprogram or of a nonabstract interface
1387 body that is declared in the scoping unit of a module or submodule. */
1388 if (sym
->attr
.external
1389 && (sym
->attr
.subroutine
|| sym
->attr
.function
)
1390 && sym
->attr
.if_source
== IFSRC_IFBODY
1391 && !current_attr
.module_procedure
1392 && sym
->attr
.proc
== PROC_MODULE
1393 && gfc_state_stack
->state
== COMP_CONTAINS
)
1395 gfc_error_now ("Procedure %qs defined in interface body at %L "
1396 "clashes with internal procedure defined at %C",
1397 name
, &sym
->declared_at
);
1401 if (sym
&& !sym
->gfc_new
1402 && sym
->attr
.flavor
!= FL_UNKNOWN
1403 && sym
->attr
.referenced
== 0 && sym
->attr
.subroutine
== 1
1404 && gfc_state_stack
->state
== COMP_CONTAINS
1405 && gfc_state_stack
->previous
->state
== COMP_SUBROUTINE
)
1407 gfc_error_now ("Procedure %qs at %C is already defined at %L",
1408 name
, &sym
->declared_at
);
1412 if (gfc_current_ns
->parent
== NULL
|| *result
== NULL
)
1415 /* Module function entries will already have a symtree in
1416 the current namespace but will need one at module level. */
1417 if (module_fcn_entry
)
1419 /* Present if entry is declared to be a module procedure. */
1420 rc
= gfc_find_sym_tree (name
, gfc_current_ns
->parent
, 0, &st
);
1422 st
= gfc_new_symtree (&gfc_current_ns
->parent
->sym_root
, name
);
1425 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, name
);
1430 /* See if the procedure should be a module procedure. */
1432 if (((sym
->ns
->proc_name
!= NULL
1433 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
1434 && sym
->attr
.proc
!= PROC_MODULE
)
1435 || (module_fcn_entry
&& sym
->attr
.proc
!= PROC_MODULE
))
1436 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
1443 /* Verify that the given symbol representing a parameter is C
1444 interoperable, by checking to see if it was marked as such after
1445 its declaration. If the given symbol is not interoperable, a
1446 warning is reported, thus removing the need to return the status to
1447 the calling function. The standard does not require the user use
1448 one of the iso_c_binding named constants to declare an
1449 interoperable parameter, but we can't be sure if the param is C
1450 interop or not if the user doesn't. For example, integer(4) may be
1451 legal Fortran, but doesn't have meaning in C. It may interop with
1452 a number of the C types, which causes a problem because the
1453 compiler can't know which one. This code is almost certainly not
1454 portable, and the user will get what they deserve if the C type
1455 across platforms isn't always interoperable with integer(4). If
1456 the user had used something like integer(c_int) or integer(c_long),
1457 the compiler could have automatically handled the varying sizes
1458 across platforms. */
1461 gfc_verify_c_interop_param (gfc_symbol
*sym
)
1463 int is_c_interop
= 0;
1466 /* We check implicitly typed variables in symbol.c:gfc_set_default_type().
1467 Don't repeat the checks here. */
1468 if (sym
->attr
.implicit_type
)
1471 /* For subroutines or functions that are passed to a BIND(C) procedure,
1472 they're interoperable if they're BIND(C) and their params are all
1474 if (sym
->attr
.flavor
== FL_PROCEDURE
)
1476 if (sym
->attr
.is_bind_c
== 0)
1478 gfc_error_now ("Procedure %qs at %L must have the BIND(C) "
1479 "attribute to be C interoperable", sym
->name
,
1480 &(sym
->declared_at
));
1485 if (sym
->attr
.is_c_interop
== 1)
1486 /* We've already checked this procedure; don't check it again. */
1489 return verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
1494 /* See if we've stored a reference to a procedure that owns sym. */
1495 if (sym
->ns
!= NULL
&& sym
->ns
->proc_name
!= NULL
)
1497 if (sym
->ns
->proc_name
->attr
.is_bind_c
== 1)
1499 is_c_interop
= (gfc_verify_c_interop(&(sym
->ts
)) ? 1 : 0);
1501 if (is_c_interop
!= 1)
1503 /* Make personalized messages to give better feedback. */
1504 if (sym
->ts
.type
== BT_DERIVED
)
1505 gfc_error ("Variable %qs at %L is a dummy argument to the "
1506 "BIND(C) procedure %qs but is not C interoperable "
1507 "because derived type %qs is not C interoperable",
1508 sym
->name
, &(sym
->declared_at
),
1509 sym
->ns
->proc_name
->name
,
1510 sym
->ts
.u
.derived
->name
);
1511 else if (sym
->ts
.type
== BT_CLASS
)
1512 gfc_error ("Variable %qs at %L is a dummy argument to the "
1513 "BIND(C) procedure %qs but is not C interoperable "
1514 "because it is polymorphic",
1515 sym
->name
, &(sym
->declared_at
),
1516 sym
->ns
->proc_name
->name
);
1517 else if (warn_c_binding_type
)
1518 gfc_warning (OPT_Wc_binding_type
,
1519 "Variable %qs at %L is a dummy argument of the "
1520 "BIND(C) procedure %qs but may not be C "
1522 sym
->name
, &(sym
->declared_at
),
1523 sym
->ns
->proc_name
->name
);
1526 /* Character strings are only C interoperable if they have a
1528 if (sym
->ts
.type
== BT_CHARACTER
&& !sym
->attr
.dimension
)
1530 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
1531 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
1532 || mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
1534 gfc_error ("Character argument %qs at %L "
1535 "must be length 1 because "
1536 "procedure %qs is BIND(C)",
1537 sym
->name
, &sym
->declared_at
,
1538 sym
->ns
->proc_name
->name
);
1543 /* We have to make sure that any param to a bind(c) routine does
1544 not have the allocatable, pointer, or optional attributes,
1545 according to J3/04-007, section 5.1. */
1546 if (sym
->attr
.allocatable
== 1
1547 && !gfc_notify_std (GFC_STD_F2018
, "Variable %qs at %L with "
1548 "ALLOCATABLE attribute in procedure %qs "
1549 "with BIND(C)", sym
->name
,
1550 &(sym
->declared_at
),
1551 sym
->ns
->proc_name
->name
))
1554 if (sym
->attr
.pointer
== 1
1555 && !gfc_notify_std (GFC_STD_F2018
, "Variable %qs at %L with "
1556 "POINTER attribute in procedure %qs "
1557 "with BIND(C)", sym
->name
,
1558 &(sym
->declared_at
),
1559 sym
->ns
->proc_name
->name
))
1562 if (sym
->attr
.optional
== 1 && sym
->attr
.value
)
1564 gfc_error ("Variable %qs at %L cannot have both the OPTIONAL "
1565 "and the VALUE attribute because procedure %qs "
1566 "is BIND(C)", sym
->name
, &(sym
->declared_at
),
1567 sym
->ns
->proc_name
->name
);
1570 else if (sym
->attr
.optional
== 1
1571 && !gfc_notify_std (GFC_STD_F2018
, "Variable %qs "
1572 "at %L with OPTIONAL attribute in "
1573 "procedure %qs which is BIND(C)",
1574 sym
->name
, &(sym
->declared_at
),
1575 sym
->ns
->proc_name
->name
))
1578 /* Make sure that if it has the dimension attribute, that it is
1579 either assumed size or explicit shape. Deferred shape is already
1580 covered by the pointer/allocatable attribute. */
1581 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SHAPE
1582 && !gfc_notify_std (GFC_STD_F2018
, "Assumed-shape array %qs "
1583 "at %L as dummy argument to the BIND(C) "
1584 "procedure %qs at %L", sym
->name
,
1585 &(sym
->declared_at
),
1586 sym
->ns
->proc_name
->name
,
1587 &(sym
->ns
->proc_name
->declared_at
)))
1597 /* Function called by variable_decl() that adds a name to the symbol table. */
1600 build_sym (const char *name
, gfc_charlen
*cl
, bool cl_deferred
,
1601 gfc_array_spec
**as
, locus
*var_locus
)
1603 symbol_attribute attr
;
1608 /* Symbols in a submodule are host associated from the parent module or
1609 submodules. Therefore, they can be overridden by declarations in the
1610 submodule scope. Deal with this by attaching the existing symbol to
1611 a new symtree and recycling the old symtree with a new symbol... */
1612 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
1613 if (st
!= NULL
&& gfc_state_stack
->state
== COMP_SUBMODULE
1614 && st
->n
.sym
!= NULL
1615 && st
->n
.sym
->attr
.host_assoc
&& st
->n
.sym
->attr
.used_in_submodule
)
1617 gfc_symtree
*s
= gfc_get_unique_symtree (gfc_current_ns
);
1618 s
->n
.sym
= st
->n
.sym
;
1619 sym
= gfc_new_symbol (name
, gfc_current_ns
);
1624 gfc_set_sym_referenced (sym
);
1626 /* ...Otherwise generate a new symtree and new symbol. */
1627 else if (gfc_get_symbol (name
, NULL
, &sym
))
1630 /* Check if the name has already been defined as a type. The
1631 first letter of the symtree will be in upper case then. Of
1632 course, this is only necessary if the upper case letter is
1633 actually different. */
1635 upper
= TOUPPER(name
[0]);
1636 if (upper
!= name
[0])
1638 char u_name
[GFC_MAX_SYMBOL_LEN
+ 1];
1641 gcc_assert (strlen(name
) <= GFC_MAX_SYMBOL_LEN
);
1642 strcpy (u_name
, name
);
1645 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, u_name
);
1647 /* STRUCTURE types can alias symbol names */
1648 if (st
!= 0 && st
->n
.sym
->attr
.flavor
!= FL_STRUCT
)
1650 gfc_error ("Symbol %qs at %C also declared as a type at %L", name
,
1651 &st
->n
.sym
->declared_at
);
1656 /* Start updating the symbol table. Add basic type attribute if present. */
1657 if (current_ts
.type
!= BT_UNKNOWN
1658 && (sym
->attr
.implicit_type
== 0
1659 || !gfc_compare_types (&sym
->ts
, ¤t_ts
))
1660 && !gfc_add_type (sym
, ¤t_ts
, var_locus
))
1663 if (sym
->ts
.type
== BT_CHARACTER
)
1666 sym
->ts
.deferred
= cl_deferred
;
1669 /* Add dimension attribute if present. */
1670 if (!gfc_set_array_spec (sym
, *as
, var_locus
))
1674 /* Add attribute to symbol. The copy is so that we can reset the
1675 dimension attribute. */
1676 attr
= current_attr
;
1678 attr
.codimension
= 0;
1680 if (!gfc_copy_attr (&sym
->attr
, &attr
, var_locus
))
1683 /* Finish any work that may need to be done for the binding label,
1684 if it's a bind(c). The bind(c) attr is found before the symbol
1685 is made, and before the symbol name (for data decls), so the
1686 current_ts is holding the binding label, or nothing if the
1687 name= attr wasn't given. Therefore, test here if we're dealing
1688 with a bind(c) and make sure the binding label is set correctly. */
1689 if (sym
->attr
.is_bind_c
== 1)
1691 if (!sym
->binding_label
)
1693 /* Set the binding label and verify that if a NAME= was specified
1694 then only one identifier was in the entity-decl-list. */
1695 if (!set_binding_label (&sym
->binding_label
, sym
->name
,
1696 num_idents_on_line
))
1701 /* See if we know we're in a common block, and if it's a bind(c)
1702 common then we need to make sure we're an interoperable type. */
1703 if (sym
->attr
.in_common
== 1)
1705 /* Test the common block object. */
1706 if (sym
->common_block
!= NULL
&& sym
->common_block
->is_bind_c
== 1
1707 && sym
->ts
.is_c_interop
!= 1)
1709 gfc_error_now ("Variable %qs in common block %qs at %C "
1710 "must be declared with a C interoperable "
1711 "kind since common block %qs is BIND(C)",
1712 sym
->name
, sym
->common_block
->name
,
1713 sym
->common_block
->name
);
1718 sym
->attr
.implied_index
= 0;
1720 /* Use the parameter expressions for a parameterized derived type. */
1721 if ((sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
1722 && sym
->ts
.u
.derived
->attr
.pdt_type
&& type_param_spec_list
)
1723 sym
->param_list
= gfc_copy_actual_arglist (type_param_spec_list
);
1725 if (sym
->ts
.type
== BT_CLASS
)
1726 return gfc_build_class_symbol (&sym
->ts
, &sym
->attr
, &sym
->as
);
1732 /* Set character constant to the given length. The constant will be padded or
1733 truncated. If we're inside an array constructor without a typespec, we
1734 additionally check that all elements have the same length; check_len -1
1735 means no checking. */
1738 gfc_set_constant_character_len (gfc_charlen_t len
, gfc_expr
*expr
,
1739 gfc_charlen_t check_len
)
1744 if (expr
->ts
.type
!= BT_CHARACTER
)
1747 if (expr
->expr_type
!= EXPR_CONSTANT
)
1749 gfc_error_now ("CHARACTER length must be a constant at %L", &expr
->where
);
1753 slen
= expr
->value
.character
.length
;
1756 s
= gfc_get_wide_string (len
+ 1);
1757 memcpy (s
, expr
->value
.character
.string
,
1758 MIN (len
, slen
) * sizeof (gfc_char_t
));
1760 gfc_wide_memset (&s
[slen
], ' ', len
- slen
);
1762 if (warn_character_truncation
&& slen
> len
)
1763 gfc_warning_now (OPT_Wcharacter_truncation
,
1764 "CHARACTER expression at %L is being truncated "
1765 "(%ld/%ld)", &expr
->where
,
1766 (long) slen
, (long) len
);
1768 /* Apply the standard by 'hand' otherwise it gets cleared for
1770 if (check_len
!= -1 && slen
!= check_len
1771 && !(gfc_option
.allow_std
& GFC_STD_GNU
))
1772 gfc_error_now ("The CHARACTER elements of the array constructor "
1773 "at %L must have the same length (%ld/%ld)",
1774 &expr
->where
, (long) slen
,
1778 free (expr
->value
.character
.string
);
1779 expr
->value
.character
.string
= s
;
1780 expr
->value
.character
.length
= len
;
1781 /* If explicit representation was given, clear it
1782 as it is no longer needed after padding. */
1783 if (expr
->representation
.length
)
1785 expr
->representation
.length
= 0;
1786 free (expr
->representation
.string
);
1787 expr
->representation
.string
= NULL
;
1793 /* Function to create and update the enumerator history
1794 using the information passed as arguments.
1795 Pointer "max_enum" is also updated, to point to
1796 enum history node containing largest initializer.
1798 SYM points to the symbol node of enumerator.
1799 INIT points to its enumerator value. */
1802 create_enum_history (gfc_symbol
*sym
, gfc_expr
*init
)
1804 enumerator_history
*new_enum_history
;
1805 gcc_assert (sym
!= NULL
&& init
!= NULL
);
1807 new_enum_history
= XCNEW (enumerator_history
);
1809 new_enum_history
->sym
= sym
;
1810 new_enum_history
->initializer
= init
;
1811 new_enum_history
->next
= NULL
;
1813 if (enum_history
== NULL
)
1815 enum_history
= new_enum_history
;
1816 max_enum
= enum_history
;
1820 new_enum_history
->next
= enum_history
;
1821 enum_history
= new_enum_history
;
1823 if (mpz_cmp (max_enum
->initializer
->value
.integer
,
1824 new_enum_history
->initializer
->value
.integer
) < 0)
1825 max_enum
= new_enum_history
;
1830 /* Function to free enum kind history. */
1833 gfc_free_enum_history (void)
1835 enumerator_history
*current
= enum_history
;
1836 enumerator_history
*next
;
1838 while (current
!= NULL
)
1840 next
= current
->next
;
1845 enum_history
= NULL
;
1849 /* Function called by variable_decl() that adds an initialization
1850 expression to a symbol. */
1853 add_init_expr_to_sym (const char *name
, gfc_expr
**initp
, locus
*var_locus
)
1855 symbol_attribute attr
;
1860 if (find_special (name
, &sym
, false))
1865 /* If this symbol is confirming an implicit parameter type,
1866 then an initialization expression is not allowed. */
1867 if (attr
.flavor
== FL_PARAMETER
1868 && sym
->value
!= NULL
1871 gfc_error ("Initializer not allowed for PARAMETER %qs at %C",
1878 /* An initializer is required for PARAMETER declarations. */
1879 if (attr
.flavor
== FL_PARAMETER
)
1881 gfc_error ("PARAMETER at %L is missing an initializer", var_locus
);
1887 /* If a variable appears in a DATA block, it cannot have an
1891 gfc_error ("Variable %qs at %C with an initializer already "
1892 "appears in a DATA statement", sym
->name
);
1896 /* Check if the assignment can happen. This has to be put off
1897 until later for derived type variables and procedure pointers. */
1898 if (!gfc_bt_struct (sym
->ts
.type
) && !gfc_bt_struct (init
->ts
.type
)
1899 && sym
->ts
.type
!= BT_CLASS
&& init
->ts
.type
!= BT_CLASS
1900 && !sym
->attr
.proc_pointer
1901 && !gfc_check_assign_symbol (sym
, NULL
, init
))
1904 if (sym
->ts
.type
== BT_CHARACTER
&& sym
->ts
.u
.cl
1905 && init
->ts
.type
== BT_CHARACTER
)
1907 /* Update symbol character length according initializer. */
1908 if (!gfc_check_assign_symbol (sym
, NULL
, init
))
1911 if (sym
->ts
.u
.cl
->length
== NULL
)
1914 /* If there are multiple CHARACTER variables declared on the
1915 same line, we don't want them to share the same length. */
1916 sym
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1918 if (sym
->attr
.flavor
== FL_PARAMETER
)
1920 if (init
->expr_type
== EXPR_CONSTANT
)
1922 clen
= init
->value
.character
.length
;
1923 sym
->ts
.u
.cl
->length
1924 = gfc_get_int_expr (gfc_charlen_int_kind
,
1927 else if (init
->expr_type
== EXPR_ARRAY
)
1929 if (init
->ts
.u
.cl
&& init
->ts
.u
.cl
->length
)
1931 const gfc_expr
*length
= init
->ts
.u
.cl
->length
;
1932 if (length
->expr_type
!= EXPR_CONSTANT
)
1934 gfc_error ("Cannot initialize parameter array "
1936 "with variable length elements",
1940 clen
= mpz_get_si (length
->value
.integer
);
1942 else if (init
->value
.constructor
)
1945 c
= gfc_constructor_first (init
->value
.constructor
);
1946 clen
= c
->expr
->value
.character
.length
;
1950 sym
->ts
.u
.cl
->length
1951 = gfc_get_int_expr (gfc_charlen_int_kind
,
1954 else if (init
->ts
.u
.cl
&& init
->ts
.u
.cl
->length
)
1955 sym
->ts
.u
.cl
->length
=
1956 gfc_copy_expr (init
->ts
.u
.cl
->length
);
1959 /* Update initializer character length according symbol. */
1960 else if (sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1962 if (!gfc_specification_expr (sym
->ts
.u
.cl
->length
))
1965 int k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
,
1967 /* resolve_charlen will complain later on if the length
1968 is too large. Just skeep the initialization in that case. */
1969 if (mpz_cmp (sym
->ts
.u
.cl
->length
->value
.integer
,
1970 gfc_integer_kinds
[k
].huge
) <= 0)
1973 = gfc_mpz_get_hwi (sym
->ts
.u
.cl
->length
->value
.integer
);
1975 if (init
->expr_type
== EXPR_CONSTANT
)
1976 gfc_set_constant_character_len (len
, init
, -1);
1977 else if (init
->expr_type
== EXPR_ARRAY
)
1981 /* Build a new charlen to prevent simplification from
1982 deleting the length before it is resolved. */
1983 init
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1984 init
->ts
.u
.cl
->length
1985 = gfc_copy_expr (sym
->ts
.u
.cl
->length
);
1987 for (c
= gfc_constructor_first (init
->value
.constructor
);
1988 c
; c
= gfc_constructor_next (c
))
1989 gfc_set_constant_character_len (len
, c
->expr
, -1);
1995 /* If sym is implied-shape, set its upper bounds from init. */
1996 if (sym
->attr
.flavor
== FL_PARAMETER
&& sym
->attr
.dimension
1997 && sym
->as
->type
== AS_IMPLIED_SHAPE
)
2001 if (init
->rank
== 0)
2003 gfc_error ("Cannot initialize implied-shape array at %L"
2004 " with scalar", &sym
->declared_at
);
2008 /* The shape may be NULL for EXPR_ARRAY, set it. */
2009 if (init
->shape
== NULL
)
2011 gcc_assert (init
->expr_type
== EXPR_ARRAY
);
2012 init
->shape
= gfc_get_shape (1);
2013 if (!gfc_array_size (init
, &init
->shape
[0]))
2014 gfc_internal_error ("gfc_array_size failed");
2017 for (dim
= 0; dim
< sym
->as
->rank
; ++dim
)
2020 gfc_expr
*e
, *lower
;
2022 lower
= sym
->as
->lower
[dim
];
2024 /* If the lower bound is an array element from another
2025 parameterized array, then it is marked with EXPR_VARIABLE and
2026 is an initialization expression. Try to reduce it. */
2027 if (lower
->expr_type
== EXPR_VARIABLE
)
2028 gfc_reduce_init_expr (lower
);
2030 if (lower
->expr_type
== EXPR_CONSTANT
)
2032 /* All dimensions must be without upper bound. */
2033 gcc_assert (!sym
->as
->upper
[dim
]);
2036 e
= gfc_get_constant_expr (BT_INTEGER
, k
, &sym
->declared_at
);
2037 mpz_add (e
->value
.integer
, lower
->value
.integer
,
2039 mpz_sub_ui (e
->value
.integer
, e
->value
.integer
, 1);
2040 sym
->as
->upper
[dim
] = e
;
2044 gfc_error ("Non-constant lower bound in implied-shape"
2045 " declaration at %L", &lower
->where
);
2050 sym
->as
->type
= AS_EXPLICIT
;
2053 /* Need to check if the expression we initialized this
2054 to was one of the iso_c_binding named constants. If so,
2055 and we're a parameter (constant), let it be iso_c.
2057 integer(c_int), parameter :: my_int = c_int
2058 integer(my_int) :: my_int_2
2059 If we mark my_int as iso_c (since we can see it's value
2060 is equal to one of the named constants), then my_int_2
2061 will be considered C interoperable. */
2062 if (sym
->ts
.type
!= BT_CHARACTER
&& !gfc_bt_struct (sym
->ts
.type
))
2064 sym
->ts
.is_iso_c
|= init
->ts
.is_iso_c
;
2065 sym
->ts
.is_c_interop
|= init
->ts
.is_c_interop
;
2066 /* attr bits needed for module files. */
2067 sym
->attr
.is_iso_c
|= init
->ts
.is_iso_c
;
2068 sym
->attr
.is_c_interop
|= init
->ts
.is_c_interop
;
2069 if (init
->ts
.is_iso_c
)
2070 sym
->ts
.f90_type
= init
->ts
.f90_type
;
2073 /* Add initializer. Make sure we keep the ranks sane. */
2074 if (sym
->attr
.dimension
&& init
->rank
== 0)
2079 if (sym
->attr
.flavor
== FL_PARAMETER
2080 && init
->expr_type
== EXPR_CONSTANT
2081 && spec_size (sym
->as
, &size
)
2082 && mpz_cmp_si (size
, 0) > 0)
2084 array
= gfc_get_array_expr (init
->ts
.type
, init
->ts
.kind
,
2086 for (n
= 0; n
< (int)mpz_get_si (size
); n
++)
2087 gfc_constructor_append_expr (&array
->value
.constructor
,
2090 : gfc_copy_expr (init
),
2093 array
->shape
= gfc_get_shape (sym
->as
->rank
);
2094 for (n
= 0; n
< sym
->as
->rank
; n
++)
2095 spec_dimen_size (sym
->as
, n
, &array
->shape
[n
]);
2100 init
->rank
= sym
->as
->rank
;
2104 if (sym
->attr
.save
== SAVE_NONE
)
2105 sym
->attr
.save
= SAVE_IMPLICIT
;
2113 /* Function called by variable_decl() that adds a name to a structure
2117 build_struct (const char *name
, gfc_charlen
*cl
, gfc_expr
**init
,
2118 gfc_array_spec
**as
)
2123 /* F03:C438/C439. If the current symbol is of the same derived type that we're
2124 constructing, it must have the pointer attribute. */
2125 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
2126 && current_ts
.u
.derived
== gfc_current_block ()
2127 && current_attr
.pointer
== 0)
2129 if (current_attr
.allocatable
2130 && !gfc_notify_std(GFC_STD_F2008
, "Component at %C "
2131 "must have the POINTER attribute"))
2135 else if (current_attr
.allocatable
== 0)
2137 gfc_error ("Component at %C must have the POINTER attribute");
2143 if (current_ts
.type
== BT_CLASS
2144 && !(current_attr
.pointer
|| current_attr
.allocatable
))
2146 gfc_error ("Component %qs with CLASS at %C must be allocatable "
2147 "or pointer", name
);
2151 if (gfc_current_block ()->attr
.pointer
&& (*as
)->rank
!= 0)
2153 if ((*as
)->type
!= AS_DEFERRED
&& (*as
)->type
!= AS_EXPLICIT
)
2155 gfc_error ("Array component of structure at %C must have explicit "
2156 "or deferred shape");
2161 /* If we are in a nested union/map definition, gfc_add_component will not
2162 properly find repeated components because:
2163 (i) gfc_add_component does a flat search, where components of unions
2164 and maps are implicity chained so nested components may conflict.
2165 (ii) Unions and maps are not linked as components of their parent
2166 structures until after they are parsed.
2167 For (i) we use gfc_find_component which searches recursively, and for (ii)
2168 we search each block directly from the parse stack until we find the top
2171 s
= gfc_state_stack
;
2172 if (s
->state
== COMP_UNION
|| s
->state
== COMP_MAP
)
2174 while (s
->state
== COMP_UNION
|| gfc_comp_struct (s
->state
))
2176 c
= gfc_find_component (s
->sym
, name
, true, true, NULL
);
2179 gfc_error_now ("Component %qs at %C already declared at %L",
2183 /* Break after we've searched the entire chain. */
2184 if (s
->state
== COMP_DERIVED
|| s
->state
== COMP_STRUCTURE
)
2190 if (!gfc_add_component (gfc_current_block(), name
, &c
))
2194 if (c
->ts
.type
== BT_CHARACTER
)
2197 if (c
->ts
.type
!= BT_CLASS
&& c
->ts
.type
!= BT_DERIVED
2198 && (c
->ts
.kind
== 0 || c
->ts
.type
== BT_CHARACTER
)
2199 && saved_kind_expr
!= NULL
)
2200 c
->kind_expr
= gfc_copy_expr (saved_kind_expr
);
2202 c
->attr
= current_attr
;
2204 c
->initializer
= *init
;
2211 c
->attr
.codimension
= 1;
2213 c
->attr
.dimension
= 1;
2217 gfc_apply_init (&c
->ts
, &c
->attr
, c
->initializer
);
2219 /* Check array components. */
2220 if (!c
->attr
.dimension
)
2223 if (c
->attr
.pointer
)
2225 if (c
->as
->type
!= AS_DEFERRED
)
2227 gfc_error ("Pointer array component of structure at %C must have a "
2232 else if (c
->attr
.allocatable
)
2234 if (c
->as
->type
!= AS_DEFERRED
)
2236 gfc_error ("Allocatable component of structure at %C must have a "
2243 if (c
->as
->type
!= AS_EXPLICIT
)
2245 gfc_error ("Array component of structure at %C must have an "
2252 if (c
->ts
.type
== BT_CLASS
)
2253 return gfc_build_class_symbol (&c
->ts
, &c
->attr
, &c
->as
);
2255 if (c
->attr
.pdt_kind
|| c
->attr
.pdt_len
)
2258 gfc_find_symbol (c
->name
, gfc_current_block ()->f2k_derived
,
2262 gfc_error ("Type parameter %qs at %C has no corresponding entry "
2263 "in the type parameter name list at %L",
2264 c
->name
, &gfc_current_block ()->declared_at
);
2268 sym
->attr
.pdt_kind
= c
->attr
.pdt_kind
;
2269 sym
->attr
.pdt_len
= c
->attr
.pdt_len
;
2271 sym
->value
= gfc_copy_expr (c
->initializer
);
2272 sym
->attr
.flavor
= FL_VARIABLE
;
2275 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
2276 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_template
2277 && decl_type_param_list
)
2278 c
->param_list
= gfc_copy_actual_arglist (decl_type_param_list
);
2284 /* Match a 'NULL()', and possibly take care of some side effects. */
2287 gfc_match_null (gfc_expr
**result
)
2290 match m
, m2
= MATCH_NO
;
2292 if ((m
= gfc_match (" null ( )")) == MATCH_ERROR
)
2298 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2300 if ((m2
= gfc_match (" null (")) != MATCH_YES
)
2303 old_loc
= gfc_current_locus
;
2304 if ((m2
= gfc_match (" %n ) ", name
)) == MATCH_ERROR
)
2307 && ((m2
= gfc_match (" mold = %n )", name
)) == MATCH_ERROR
))
2311 gfc_current_locus
= old_loc
;
2316 /* The NULL symbol now has to be/become an intrinsic function. */
2317 if (gfc_get_symbol ("null", NULL
, &sym
))
2319 gfc_error ("NULL() initialization at %C is ambiguous");
2323 gfc_intrinsic_symbol (sym
);
2325 if (sym
->attr
.proc
!= PROC_INTRINSIC
2326 && !(sym
->attr
.use_assoc
&& sym
->attr
.intrinsic
)
2327 && (!gfc_add_procedure(&sym
->attr
, PROC_INTRINSIC
, sym
->name
, NULL
)
2328 || !gfc_add_function (&sym
->attr
, sym
->name
, NULL
)))
2331 *result
= gfc_get_null_expr (&gfc_current_locus
);
2333 /* Invalid per F2008, C512. */
2334 if (m2
== MATCH_YES
)
2336 gfc_error ("NULL() initialization at %C may not have MOLD");
2344 /* Match the initialization expr for a data pointer or procedure pointer. */
2347 match_pointer_init (gfc_expr
**init
, int procptr
)
2351 if (gfc_pure (NULL
) && !gfc_comp_struct (gfc_state_stack
->state
))
2353 gfc_error ("Initialization of pointer at %C is not allowed in "
2354 "a PURE procedure");
2357 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
2359 /* Match NULL() initialization. */
2360 m
= gfc_match_null (init
);
2364 /* Match non-NULL initialization. */
2365 gfc_matching_ptr_assignment
= !procptr
;
2366 gfc_matching_procptr_assignment
= procptr
;
2367 m
= gfc_match_rvalue (init
);
2368 gfc_matching_ptr_assignment
= 0;
2369 gfc_matching_procptr_assignment
= 0;
2370 if (m
== MATCH_ERROR
)
2372 else if (m
== MATCH_NO
)
2374 gfc_error ("Error in pointer initialization at %C");
2378 if (!procptr
&& !gfc_resolve_expr (*init
))
2381 if (!gfc_notify_std (GFC_STD_F2008
, "non-NULL pointer "
2382 "initialization at %C"))
2390 check_function_name (char *name
)
2392 /* In functions that have a RESULT variable defined, the function name always
2393 refers to function calls. Therefore, the name is not allowed to appear in
2394 specification statements. When checking this, be careful about
2395 'hidden' procedure pointer results ('ppr@'). */
2397 if (gfc_current_state () == COMP_FUNCTION
)
2399 gfc_symbol
*block
= gfc_current_block ();
2400 if (block
&& block
->result
&& block
->result
!= block
2401 && strcmp (block
->result
->name
, "ppr@") != 0
2402 && strcmp (block
->name
, name
) == 0)
2404 gfc_error ("RESULT variable %qs at %L prohibits FUNCTION name %qs at %C "
2405 "from appearing in a specification statement",
2406 block
->result
->name
, &block
->result
->declared_at
, name
);
2415 /* Match a variable name with an optional initializer. When this
2416 subroutine is called, a variable is expected to be parsed next.
2417 Depending on what is happening at the moment, updates either the
2418 symbol table or the current interface. */
2421 variable_decl (int elem
)
2423 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2424 static unsigned int fill_id
= 0;
2425 gfc_expr
*initializer
, *char_len
;
2427 gfc_array_spec
*cp_as
; /* Extra copy for Cray Pointees. */
2440 /* When we get here, we've just matched a list of attributes and
2441 maybe a type and a double colon. The next thing we expect to see
2442 is the name of the symbol. */
2444 /* If we are parsing a structure with legacy support, we allow the symbol
2445 name to be '%FILL' which gives it an anonymous (inaccessible) name. */
2447 gfc_gobble_whitespace ();
2448 c
= gfc_peek_ascii_char ();
2451 gfc_next_ascii_char (); /* Burn % character. */
2452 m
= gfc_match ("fill");
2455 if (gfc_current_state () != COMP_STRUCTURE
)
2457 if (flag_dec_structure
)
2458 gfc_error ("%qs not allowed outside STRUCTURE at %C", "%FILL");
2460 gfc_error ("%qs at %C is a DEC extension, enable with "
2461 "%<-fdec-structure%>", "%FILL");
2468 gfc_error ("%qs entity cannot have attributes at %C", "%FILL");
2473 /* %FILL components are given invalid fortran names. */
2474 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "%%FILL%u", fill_id
++);
2478 gfc_error ("Invalid character %qc in variable name at %C", c
);
2484 m
= gfc_match_name (name
);
2489 var_locus
= gfc_current_locus
;
2491 /* Now we could see the optional array spec. or character length. */
2492 m
= gfc_match_array_spec (&as
, true, true);
2493 if (m
== MATCH_ERROR
)
2497 as
= gfc_copy_array_spec (current_as
);
2499 && !merge_array_spec (current_as
, as
, true))
2505 if (flag_cray_pointer
)
2506 cp_as
= gfc_copy_array_spec (as
);
2508 /* At this point, we know for sure if the symbol is PARAMETER and can thus
2509 determine (and check) whether it can be implied-shape. If it
2510 was parsed as assumed-size, change it because PARAMETERs cannot
2513 An explicit-shape-array cannot appear under several conditions.
2514 That check is done here as well. */
2517 if (as
->type
== AS_IMPLIED_SHAPE
&& current_attr
.flavor
!= FL_PARAMETER
)
2520 gfc_error ("Non-PARAMETER symbol %qs at %L cannot be implied-shape",
2525 if (as
->type
== AS_ASSUMED_SIZE
&& as
->rank
== 1
2526 && current_attr
.flavor
== FL_PARAMETER
)
2527 as
->type
= AS_IMPLIED_SHAPE
;
2529 if (as
->type
== AS_IMPLIED_SHAPE
2530 && !gfc_notify_std (GFC_STD_F2008
, "Implied-shape array at %L",
2537 gfc_seen_div0
= false;
2539 /* F2018:C830 (R816) An explicit-shape-spec whose bounds are not
2540 constant expressions shall appear only in a subprogram, derived
2541 type definition, BLOCK construct, or interface body. */
2542 if (as
->type
== AS_EXPLICIT
2543 && gfc_current_state () != COMP_BLOCK
2544 && gfc_current_state () != COMP_DERIVED
2545 && gfc_current_state () != COMP_FUNCTION
2546 && gfc_current_state () != COMP_INTERFACE
2547 && gfc_current_state () != COMP_SUBROUTINE
)
2550 bool not_constant
= false;
2552 for (int i
= 0; i
< as
->rank
; i
++)
2554 e
= gfc_copy_expr (as
->lower
[i
]);
2555 if (!gfc_resolve_expr (e
) && gfc_seen_div0
)
2561 gfc_simplify_expr (e
, 0);
2562 if (e
&& (e
->expr_type
!= EXPR_CONSTANT
))
2564 not_constant
= true;
2569 e
= gfc_copy_expr (as
->upper
[i
]);
2570 if (!gfc_resolve_expr (e
) && gfc_seen_div0
)
2576 gfc_simplify_expr (e
, 0);
2577 if (e
&& (e
->expr_type
!= EXPR_CONSTANT
))
2579 not_constant
= true;
2587 gfc_error ("Explicit shaped array with nonconstant bounds at %C");
2592 if (as
->type
== AS_EXPLICIT
)
2594 for (int i
= 0; i
< as
->rank
; i
++)
2598 if (e
->expr_type
!= EXPR_CONSTANT
)
2600 n
= gfc_copy_expr (e
);
2601 if (!gfc_simplify_expr (n
, 1) && gfc_seen_div0
)
2607 if (n
->expr_type
== EXPR_CONSTANT
)
2608 gfc_replace_expr (e
, n
);
2613 if (e
->expr_type
!= EXPR_CONSTANT
)
2615 n
= gfc_copy_expr (e
);
2616 if (!gfc_simplify_expr (n
, 1) && gfc_seen_div0
)
2622 if (n
->expr_type
== EXPR_CONSTANT
)
2623 gfc_replace_expr (e
, n
);
2633 cl_deferred
= false;
2635 if (current_ts
.type
== BT_CHARACTER
)
2637 switch (match_char_length (&char_len
, &cl_deferred
, false))
2640 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2642 cl
->length
= char_len
;
2645 /* Non-constant lengths need to be copied after the first
2646 element. Also copy assumed lengths. */
2649 && (current_ts
.u
.cl
->length
== NULL
2650 || current_ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
2652 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2653 cl
->length
= gfc_copy_expr (current_ts
.u
.cl
->length
);
2656 cl
= current_ts
.u
.cl
;
2658 cl_deferred
= current_ts
.deferred
;
2667 /* The dummy arguments and result of the abreviated form of MODULE
2668 PROCEDUREs, used in SUBMODULES should not be redefined. */
2669 if (gfc_current_ns
->proc_name
2670 && gfc_current_ns
->proc_name
->abr_modproc_decl
)
2672 gfc_find_symbol (name
, gfc_current_ns
, 1, &sym
);
2673 if (sym
!= NULL
&& (sym
->attr
.dummy
|| sym
->attr
.result
))
2676 gfc_error ("%qs at %C is a redefinition of the declaration "
2677 "in the corresponding interface for MODULE "
2678 "PROCEDURE %qs", sym
->name
,
2679 gfc_current_ns
->proc_name
->name
);
2684 /* %FILL components may not have initializers. */
2685 if (gfc_str_startswith (name
, "%FILL") && gfc_match_eos () != MATCH_YES
)
2687 gfc_error ("%qs entity cannot have an initializer at %C", "%FILL");
2692 /* If this symbol has already shown up in a Cray Pointer declaration,
2693 and this is not a component declaration,
2694 then we want to set the type & bail out. */
2695 if (flag_cray_pointer
&& !gfc_comp_struct (gfc_current_state ()))
2697 gfc_find_symbol (name
, gfc_current_ns
, 0, &sym
);
2698 if (sym
!= NULL
&& sym
->attr
.cray_pointee
)
2701 if (!gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
2707 /* Check to see if we have an array specification. */
2710 if (sym
->as
!= NULL
)
2712 gfc_error ("Duplicate array spec for Cray pointee at %C");
2713 gfc_free_array_spec (cp_as
);
2719 if (!gfc_set_array_spec (sym
, cp_as
, &var_locus
))
2720 gfc_internal_error ("Cannot set pointee array spec.");
2722 /* Fix the array spec. */
2723 m
= gfc_mod_pointee_as (sym
->as
);
2724 if (m
== MATCH_ERROR
)
2732 gfc_free_array_spec (cp_as
);
2736 /* Procedure pointer as function result. */
2737 if (gfc_current_state () == COMP_FUNCTION
2738 && strcmp ("ppr@", gfc_current_block ()->name
) == 0
2739 && strcmp (name
, gfc_current_block ()->ns
->proc_name
->name
) == 0)
2740 strcpy (name
, "ppr@");
2742 if (gfc_current_state () == COMP_FUNCTION
2743 && strcmp (name
, gfc_current_block ()->name
) == 0
2744 && gfc_current_block ()->result
2745 && strcmp ("ppr@", gfc_current_block ()->result
->name
) == 0)
2746 strcpy (name
, "ppr@");
2748 /* OK, we've successfully matched the declaration. Now put the
2749 symbol in the current namespace, because it might be used in the
2750 optional initialization expression for this symbol, e.g. this is
2753 integer, parameter :: i = huge(i)
2755 This is only true for parameters or variables of a basic type.
2756 For components of derived types, it is not true, so we don't
2757 create a symbol for those yet. If we fail to create the symbol,
2759 if (!gfc_comp_struct (gfc_current_state ())
2760 && !build_sym (name
, cl
, cl_deferred
, &as
, &var_locus
))
2766 if (!check_function_name (name
))
2772 /* We allow old-style initializations of the form
2773 integer i /2/, j(4) /3*3, 1/
2774 (if no colon has been seen). These are different from data
2775 statements in that initializers are only allowed to apply to the
2776 variable immediately preceding, i.e.
2778 is not allowed. Therefore we have to do some work manually, that
2779 could otherwise be left to the matchers for DATA statements. */
2781 if (!colon_seen
&& gfc_match (" /") == MATCH_YES
)
2783 if (!gfc_notify_std (GFC_STD_GNU
, "Old-style "
2784 "initialization at %C"))
2787 /* Allow old style initializations for components of STRUCTUREs and MAPs
2788 but not components of derived types. */
2789 else if (gfc_current_state () == COMP_DERIVED
)
2791 gfc_error ("Invalid old style initialization for derived type "
2797 /* For structure components, read the initializer as a special
2798 expression and let the rest of this function apply the initializer
2800 else if (gfc_comp_struct (gfc_current_state ()))
2802 m
= match_clist_expr (&initializer
, ¤t_ts
, as
);
2804 gfc_error ("Syntax error in old style initialization of %s at %C",
2810 /* Otherwise we treat the old style initialization just like a
2811 DATA declaration for the current variable. */
2813 return match_old_style_init (name
);
2816 /* The double colon must be present in order to have initializers.
2817 Otherwise the statement is ambiguous with an assignment statement. */
2820 if (gfc_match (" =>") == MATCH_YES
)
2822 if (!current_attr
.pointer
)
2824 gfc_error ("Initialization at %C isn't for a pointer variable");
2829 m
= match_pointer_init (&initializer
, 0);
2833 /* The target of a pointer initialization must have the SAVE
2834 attribute. A variable in PROGRAM, MODULE, or SUBMODULE scope
2835 is implicit SAVEd. Explicitly, set the SAVE_IMPLICIT value. */
2836 if (initializer
->expr_type
== EXPR_VARIABLE
2837 && initializer
->symtree
->n
.sym
->attr
.save
== SAVE_NONE
2838 && (gfc_current_state () == COMP_PROGRAM
2839 || gfc_current_state () == COMP_MODULE
2840 || gfc_current_state () == COMP_SUBMODULE
))
2841 initializer
->symtree
->n
.sym
->attr
.save
= SAVE_IMPLICIT
;
2843 else if (gfc_match_char ('=') == MATCH_YES
)
2845 if (current_attr
.pointer
)
2847 gfc_error ("Pointer initialization at %C requires %<=>%>, "
2853 m
= gfc_match_init_expr (&initializer
);
2856 gfc_error ("Expected an initialization expression at %C");
2860 if (current_attr
.flavor
!= FL_PARAMETER
&& gfc_pure (NULL
)
2861 && !gfc_comp_struct (gfc_state_stack
->state
))
2863 gfc_error ("Initialization of variable at %C is not allowed in "
2864 "a PURE procedure");
2868 if (current_attr
.flavor
!= FL_PARAMETER
2869 && !gfc_comp_struct (gfc_state_stack
->state
))
2870 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
2877 if (initializer
!= NULL
&& current_attr
.allocatable
2878 && gfc_comp_struct (gfc_current_state ()))
2880 gfc_error ("Initialization of allocatable component at %C is not "
2886 if (gfc_current_state () == COMP_DERIVED
2887 && gfc_current_block ()->attr
.pdt_template
)
2890 gfc_find_symbol (name
, gfc_current_block ()->f2k_derived
,
2892 if (!param
&& (current_attr
.pdt_kind
|| current_attr
.pdt_len
))
2894 gfc_error ("The component with KIND or LEN attribute at %C does not "
2895 "not appear in the type parameter list at %L",
2896 &gfc_current_block ()->declared_at
);
2900 else if (param
&& !(current_attr
.pdt_kind
|| current_attr
.pdt_len
))
2902 gfc_error ("The component at %C that appears in the type parameter "
2903 "list at %L has neither the KIND nor LEN attribute",
2904 &gfc_current_block ()->declared_at
);
2908 else if (as
&& (current_attr
.pdt_kind
|| current_attr
.pdt_len
))
2910 gfc_error ("The component at %C which is a type parameter must be "
2915 else if (param
&& initializer
)
2916 param
->value
= gfc_copy_expr (initializer
);
2919 /* Before adding a possible initilizer, do a simple check for compatibility
2920 of lhs and rhs types. Assigning a REAL value to a derived type is not a
2922 if (current_ts
.type
== BT_DERIVED
&& initializer
2923 && (gfc_numeric_ts (&initializer
->ts
)
2924 || initializer
->ts
.type
== BT_LOGICAL
2925 || initializer
->ts
.type
== BT_CHARACTER
))
2927 gfc_error ("Incompatible initialization between a derived type "
2928 "entity and an entity with %qs type at %C",
2929 gfc_typename (initializer
));
2935 /* Add the initializer. Note that it is fine if initializer is
2936 NULL here, because we sometimes also need to check if a
2937 declaration *must* have an initialization expression. */
2938 if (!gfc_comp_struct (gfc_current_state ()))
2939 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
2942 if (current_ts
.type
== BT_DERIVED
2943 && !current_attr
.pointer
&& !initializer
)
2944 initializer
= gfc_default_initializer (¤t_ts
);
2945 t
= build_struct (name
, cl
, &initializer
, &as
);
2947 /* If we match a nested structure definition we expect to see the
2948 * body even if the variable declarations blow up, so we need to keep
2949 * the structure declaration around. */
2950 if (gfc_new_block
&& gfc_new_block
->attr
.flavor
== FL_STRUCT
)
2951 gfc_commit_symbol (gfc_new_block
);
2954 m
= (t
) ? MATCH_YES
: MATCH_ERROR
;
2957 /* Free stuff up and return. */
2958 gfc_seen_div0
= false;
2959 gfc_free_expr (initializer
);
2960 gfc_free_array_spec (as
);
2966 /* Match an extended-f77 "TYPESPEC*bytesize"-style kind specification.
2967 This assumes that the byte size is equal to the kind number for
2968 non-COMPLEX types, and equal to twice the kind number for COMPLEX. */
2971 gfc_match_old_kind_spec (gfc_typespec
*ts
)
2976 if (gfc_match_char ('*') != MATCH_YES
)
2979 m
= gfc_match_small_literal_int (&ts
->kind
, NULL
);
2983 original_kind
= ts
->kind
;
2985 /* Massage the kind numbers for complex types. */
2986 if (ts
->type
== BT_COMPLEX
)
2990 gfc_error ("Old-style type declaration %s*%d not supported at %C",
2991 gfc_basic_typename (ts
->type
), original_kind
);
2998 if (ts
->type
== BT_INTEGER
&& ts
->kind
== 4 && flag_integer4_kind
== 8)
3001 if (ts
->type
== BT_REAL
|| ts
->type
== BT_COMPLEX
)
3005 if (flag_real4_kind
== 8)
3007 if (flag_real4_kind
== 10)
3009 if (flag_real4_kind
== 16)
3015 if (flag_real8_kind
== 4)
3017 if (flag_real8_kind
== 10)
3019 if (flag_real8_kind
== 16)
3024 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
3026 gfc_error ("Old-style type declaration %s*%d not supported at %C",
3027 gfc_basic_typename (ts
->type
), original_kind
);
3031 if (!gfc_notify_std (GFC_STD_GNU
,
3032 "Nonstandard type declaration %s*%d at %C",
3033 gfc_basic_typename(ts
->type
), original_kind
))
3040 /* Match a kind specification. Since kinds are generally optional, we
3041 usually return MATCH_NO if something goes wrong. If a "kind="
3042 string is found, then we know we have an error. */
3045 gfc_match_kind_spec (gfc_typespec
*ts
, bool kind_expr_only
)
3055 saved_kind_expr
= NULL
;
3057 where
= loc
= gfc_current_locus
;
3062 if (gfc_match_char ('(') == MATCH_NO
)
3065 /* Also gobbles optional text. */
3066 if (gfc_match (" kind = ") == MATCH_YES
)
3069 loc
= gfc_current_locus
;
3073 n
= gfc_match_init_expr (&e
);
3075 if (gfc_derived_parameter_expr (e
))
3078 saved_kind_expr
= gfc_copy_expr (e
);
3079 goto close_brackets
;
3084 if (gfc_matching_function
)
3086 /* The function kind expression might include use associated or
3087 imported parameters and try again after the specification
3089 if (gfc_match_char (')') != MATCH_YES
)
3091 gfc_error ("Missing right parenthesis at %C");
3097 gfc_undo_symbols ();
3102 /* ....or else, the match is real. */
3104 gfc_error ("Expected initialization expression at %C");
3112 gfc_error ("Expected scalar initialization expression at %C");
3117 if (gfc_extract_int (e
, &ts
->kind
, 1))
3123 /* Before throwing away the expression, let's see if we had a
3124 C interoperable kind (and store the fact). */
3125 if (e
->ts
.is_c_interop
== 1)
3127 /* Mark this as C interoperable if being declared with one
3128 of the named constants from iso_c_binding. */
3129 ts
->is_c_interop
= e
->ts
.is_iso_c
;
3130 ts
->f90_type
= e
->ts
.f90_type
;
3132 ts
->interop_kind
= e
->symtree
->n
.sym
;
3138 /* Ignore errors to this point, if we've gotten here. This means
3139 we ignore the m=MATCH_ERROR from above. */
3140 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
3142 gfc_error ("Kind %d not supported for type %s at %C", ts
->kind
,
3143 gfc_basic_typename (ts
->type
));
3144 gfc_current_locus
= where
;
3148 /* Warn if, e.g., c_int is used for a REAL variable, but not
3149 if, e.g., c_double is used for COMPLEX as the standard
3150 explicitly says that the kind type parameter for complex and real
3151 variable is the same, i.e. c_float == c_float_complex. */
3152 if (ts
->f90_type
!= BT_UNKNOWN
&& ts
->f90_type
!= ts
->type
3153 && !((ts
->f90_type
== BT_REAL
&& ts
->type
== BT_COMPLEX
)
3154 || (ts
->f90_type
== BT_COMPLEX
&& ts
->type
== BT_REAL
)))
3155 gfc_warning_now (0, "C kind type parameter is for type %s but type at %L "
3156 "is %s", gfc_basic_typename (ts
->f90_type
), &where
,
3157 gfc_basic_typename (ts
->type
));
3161 gfc_gobble_whitespace ();
3162 if ((c
= gfc_next_ascii_char ()) != ')'
3163 && (ts
->type
!= BT_CHARACTER
|| c
!= ','))
3165 if (ts
->type
== BT_CHARACTER
)
3166 gfc_error ("Missing right parenthesis or comma at %C");
3168 gfc_error ("Missing right parenthesis at %C");
3172 /* All tests passed. */
3175 if(m
== MATCH_ERROR
)
3176 gfc_current_locus
= where
;
3178 if (ts
->type
== BT_INTEGER
&& ts
->kind
== 4 && flag_integer4_kind
== 8)
3181 if (ts
->type
== BT_REAL
|| ts
->type
== BT_COMPLEX
)
3185 if (flag_real4_kind
== 8)
3187 if (flag_real4_kind
== 10)
3189 if (flag_real4_kind
== 16)
3195 if (flag_real8_kind
== 4)
3197 if (flag_real8_kind
== 10)
3199 if (flag_real8_kind
== 16)
3204 /* Return what we know from the test(s). */
3209 gfc_current_locus
= where
;
3215 match_char_kind (int * kind
, int * is_iso_c
)
3224 where
= gfc_current_locus
;
3226 n
= gfc_match_init_expr (&e
);
3228 if (n
!= MATCH_YES
&& gfc_matching_function
)
3230 /* The expression might include use-associated or imported
3231 parameters and try again after the specification
3234 gfc_undo_symbols ();
3239 gfc_error ("Expected initialization expression at %C");
3245 gfc_error ("Expected scalar initialization expression at %C");
3250 if (gfc_derived_parameter_expr (e
))
3252 saved_kind_expr
= e
;
3257 fail
= gfc_extract_int (e
, kind
, 1);
3258 *is_iso_c
= e
->ts
.is_iso_c
;
3267 /* Ignore errors to this point, if we've gotten here. This means
3268 we ignore the m=MATCH_ERROR from above. */
3269 if (gfc_validate_kind (BT_CHARACTER
, *kind
, true) < 0)
3271 gfc_error ("Kind %d is not supported for CHARACTER at %C", *kind
);
3275 /* All tests passed. */
3278 if (m
== MATCH_ERROR
)
3279 gfc_current_locus
= where
;
3281 /* Return what we know from the test(s). */
3286 gfc_current_locus
= where
;
3291 /* Match the various kind/length specifications in a CHARACTER
3292 declaration. We don't return MATCH_NO. */
3295 gfc_match_char_spec (gfc_typespec
*ts
)
3297 int kind
, seen_length
, is_iso_c
;
3309 /* Try the old-style specification first. */
3310 old_char_selector
= 0;
3312 m
= match_char_length (&len
, &deferred
, true);
3316 old_char_selector
= 1;
3321 m
= gfc_match_char ('(');
3324 m
= MATCH_YES
; /* Character without length is a single char. */
3328 /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ). */
3329 if (gfc_match (" kind =") == MATCH_YES
)
3331 m
= match_char_kind (&kind
, &is_iso_c
);
3333 if (m
== MATCH_ERROR
)
3338 if (gfc_match (" , len =") == MATCH_NO
)
3341 m
= char_len_param_value (&len
, &deferred
);
3344 if (m
== MATCH_ERROR
)
3351 /* Try to match "LEN = <len-param>" or "LEN = <len-param>, KIND = <int>". */
3352 if (gfc_match (" len =") == MATCH_YES
)
3354 m
= char_len_param_value (&len
, &deferred
);
3357 if (m
== MATCH_ERROR
)
3361 if (gfc_match_char (')') == MATCH_YES
)
3364 if (gfc_match (" , kind =") != MATCH_YES
)
3367 if (match_char_kind (&kind
, &is_iso_c
) == MATCH_ERROR
)
3373 /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ). */
3374 m
= char_len_param_value (&len
, &deferred
);
3377 if (m
== MATCH_ERROR
)
3381 m
= gfc_match_char (')');
3385 if (gfc_match_char (',') != MATCH_YES
)
3388 gfc_match (" kind ="); /* Gobble optional text. */
3390 m
= match_char_kind (&kind
, &is_iso_c
);
3391 if (m
== MATCH_ERROR
)
3397 /* Require a right-paren at this point. */
3398 m
= gfc_match_char (')');
3403 gfc_error ("Syntax error in CHARACTER declaration at %C");
3405 gfc_free_expr (len
);
3409 /* Deal with character functions after USE and IMPORT statements. */
3410 if (gfc_matching_function
)
3412 gfc_free_expr (len
);
3413 gfc_undo_symbols ();
3419 gfc_free_expr (len
);
3423 /* Do some final massaging of the length values. */
3424 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
3426 if (seen_length
== 0)
3427 cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
, 1);
3430 /* If gfortran ends up here, then len may be reducible to a constant.
3431 Try to do that here. If it does not reduce, simply assign len to
3432 charlen. A complication occurs with user-defined generic functions,
3433 which are not resolved. Use a private namespace to deal with
3434 generic functions. */
3436 if (len
&& len
->expr_type
!= EXPR_CONSTANT
)
3438 gfc_namespace
*old_ns
;
3441 old_ns
= gfc_current_ns
;
3442 gfc_current_ns
= gfc_get_namespace (NULL
, 0);
3444 e
= gfc_copy_expr (len
);
3445 gfc_reduce_init_expr (e
);
3446 if (e
->expr_type
== EXPR_CONSTANT
)
3448 gfc_replace_expr (len
, e
);
3449 if (mpz_cmp_si (len
->value
.integer
, 0) < 0)
3450 mpz_set_ui (len
->value
.integer
, 0);
3455 gfc_free_namespace (gfc_current_ns
);
3456 gfc_current_ns
= old_ns
;
3463 ts
->kind
= kind
== 0 ? gfc_default_character_kind
: kind
;
3464 ts
->deferred
= deferred
;
3466 /* We have to know if it was a C interoperable kind so we can
3467 do accurate type checking of bind(c) procs, etc. */
3469 /* Mark this as C interoperable if being declared with one
3470 of the named constants from iso_c_binding. */
3471 ts
->is_c_interop
= is_iso_c
;
3472 else if (len
!= NULL
)
3473 /* Here, we might have parsed something such as: character(c_char)
3474 In this case, the parsing code above grabs the c_char when
3475 looking for the length (line 1690, roughly). it's the last
3476 testcase for parsing the kind params of a character variable.
3477 However, it's not actually the length. this seems like it
3479 To see if the user used a C interop kind, test the expr
3480 of the so called length, and see if it's C interoperable. */
3481 ts
->is_c_interop
= len
->ts
.is_iso_c
;
3487 /* Matches a RECORD declaration. */
3490 match_record_decl (char *name
)
3493 old_loc
= gfc_current_locus
;
3496 m
= gfc_match (" record /");
3499 if (!flag_dec_structure
)
3501 gfc_current_locus
= old_loc
;
3502 gfc_error ("RECORD at %C is an extension, enable it with "
3503 "%<-fdec-structure%>");
3506 m
= gfc_match (" %n/", name
);
3511 gfc_current_locus
= old_loc
;
3512 if (flag_dec_structure
3513 && (gfc_match (" record% ") == MATCH_YES
3514 || gfc_match (" record%t") == MATCH_YES
))
3515 gfc_error ("Structure name expected after RECORD at %C");
3523 /* This function uses the gfc_actual_arglist 'type_param_spec_list' as a source
3524 of expressions to substitute into the possibly parameterized expression
3525 'e'. Using a list is inefficient but should not be too bad since the
3526 number of type parameters is not likely to be large. */
3528 insert_parameter_exprs (gfc_expr
* e
, gfc_symbol
* sym ATTRIBUTE_UNUSED
,
3531 gfc_actual_arglist
*param
;
3534 if (e
->expr_type
!= EXPR_VARIABLE
)
3537 gcc_assert (e
->symtree
);
3538 if (e
->symtree
->n
.sym
->attr
.pdt_kind
3539 || (*f
!= 0 && e
->symtree
->n
.sym
->attr
.pdt_len
))
3541 for (param
= type_param_spec_list
; param
; param
= param
->next
)
3542 if (strcmp (e
->symtree
->n
.sym
->name
, param
->name
) == 0)
3547 copy
= gfc_copy_expr (param
->expr
);
3558 gfc_insert_kind_parameter_exprs (gfc_expr
*e
)
3560 return gfc_traverse_expr (e
, NULL
, &insert_parameter_exprs
, 0);
3565 gfc_insert_parameter_exprs (gfc_expr
*e
, gfc_actual_arglist
*param_list
)
3567 gfc_actual_arglist
*old_param_spec_list
= type_param_spec_list
;
3568 type_param_spec_list
= param_list
;
3569 return gfc_traverse_expr (e
, NULL
, &insert_parameter_exprs
, 1);
3570 type_param_spec_list
= NULL
;
3571 type_param_spec_list
= old_param_spec_list
;
3574 /* Determines the instance of a parameterized derived type to be used by
3575 matching determining the values of the kind parameters and using them
3576 in the name of the instance. If the instance exists, it is used, otherwise
3577 a new derived type is created. */
3579 gfc_get_pdt_instance (gfc_actual_arglist
*param_list
, gfc_symbol
**sym
,
3580 gfc_actual_arglist
**ext_param_list
)
3582 /* The PDT template symbol. */
3583 gfc_symbol
*pdt
= *sym
;
3584 /* The symbol for the parameter in the template f2k_namespace. */
3586 /* The hoped for instance of the PDT. */
3587 gfc_symbol
*instance
;
3588 /* The list of parameters appearing in the PDT declaration. */
3589 gfc_formal_arglist
*type_param_name_list
;
3590 /* Used to store the parameter specification list during recursive calls. */
3591 gfc_actual_arglist
*old_param_spec_list
;
3592 /* Pointers to the parameter specification being used. */
3593 gfc_actual_arglist
*actual_param
;
3594 gfc_actual_arglist
*tail
= NULL
;
3595 /* Used to build up the name of the PDT instance. The prefix uses 4
3596 characters and each KIND parameter 2 more. Allow 8 of the latter. */
3597 char name
[GFC_MAX_SYMBOL_LEN
+ 21];
3599 bool name_seen
= (param_list
== NULL
);
3600 bool assumed_seen
= false;
3601 bool deferred_seen
= false;
3602 bool spec_error
= false;
3604 gfc_expr
*kind_expr
;
3605 gfc_component
*c1
, *c2
;
3608 type_param_spec_list
= NULL
;
3610 type_param_name_list
= pdt
->formal
;
3611 actual_param
= param_list
;
3612 sprintf (name
, "Pdt%s", pdt
->name
);
3614 /* Run through the parameter name list and pick up the actual
3615 parameter values or use the default values in the PDT declaration. */
3616 for (; type_param_name_list
;
3617 type_param_name_list
= type_param_name_list
->next
)
3619 if (actual_param
&& actual_param
->spec_type
!= SPEC_EXPLICIT
)
3621 if (actual_param
->spec_type
== SPEC_ASSUMED
)
3622 spec_error
= deferred_seen
;
3624 spec_error
= assumed_seen
;
3628 gfc_error ("The type parameter spec list at %C cannot contain "
3629 "both ASSUMED and DEFERRED parameters");
3634 if (actual_param
&& actual_param
->name
)
3636 param
= type_param_name_list
->sym
;
3638 if (!param
|| !param
->name
)
3641 c1
= gfc_find_component (pdt
, param
->name
, false, true, NULL
);
3642 /* An error should already have been thrown in resolve.c
3643 (resolve_fl_derived0). */
3644 if (!pdt
->attr
.use_assoc
&& !c1
)
3650 if (!actual_param
&& !(c1
&& c1
->initializer
))
3652 gfc_error ("The type parameter spec list at %C does not contain "
3653 "enough parameter expressions");
3656 else if (!actual_param
&& c1
&& c1
->initializer
)
3657 kind_expr
= gfc_copy_expr (c1
->initializer
);
3658 else if (actual_param
&& actual_param
->spec_type
== SPEC_EXPLICIT
)
3659 kind_expr
= gfc_copy_expr (actual_param
->expr
);
3663 actual_param
= param_list
;
3664 for (;actual_param
; actual_param
= actual_param
->next
)
3665 if (actual_param
->name
3666 && strcmp (actual_param
->name
, param
->name
) == 0)
3668 if (actual_param
&& actual_param
->spec_type
== SPEC_EXPLICIT
)
3669 kind_expr
= gfc_copy_expr (actual_param
->expr
);
3672 if (c1
->initializer
)
3673 kind_expr
= gfc_copy_expr (c1
->initializer
);
3674 else if (!(actual_param
&& param
->attr
.pdt_len
))
3676 gfc_error ("The derived parameter %qs at %C does not "
3677 "have a default value", param
->name
);
3683 /* Store the current parameter expressions in a temporary actual
3684 arglist 'list' so that they can be substituted in the corresponding
3685 expressions in the PDT instance. */
3686 if (type_param_spec_list
== NULL
)
3688 type_param_spec_list
= gfc_get_actual_arglist ();
3689 tail
= type_param_spec_list
;
3693 tail
->next
= gfc_get_actual_arglist ();
3696 tail
->name
= param
->name
;
3700 /* Try simplification even for LEN expressions. */
3701 gfc_resolve_expr (kind_expr
);
3702 gfc_simplify_expr (kind_expr
, 1);
3703 /* Variable expressions seem to default to BT_PROCEDURE.
3704 TODO find out why this is and fix it. */
3705 if (kind_expr
->ts
.type
!= BT_INTEGER
3706 && kind_expr
->ts
.type
!= BT_PROCEDURE
)
3708 gfc_error ("The parameter expression at %C must be of "
3709 "INTEGER type and not %s type",
3710 gfc_basic_typename (kind_expr
->ts
.type
));
3714 tail
->expr
= gfc_copy_expr (kind_expr
);
3718 tail
->spec_type
= actual_param
->spec_type
;
3720 if (!param
->attr
.pdt_kind
)
3722 if (!name_seen
&& actual_param
)
3723 actual_param
= actual_param
->next
;
3726 gfc_free_expr (kind_expr
);
3733 && (actual_param
->spec_type
== SPEC_ASSUMED
3734 || actual_param
->spec_type
== SPEC_DEFERRED
))
3736 gfc_error ("The KIND parameter %qs at %C cannot either be "
3737 "ASSUMED or DEFERRED", param
->name
);
3741 if (!kind_expr
|| !gfc_is_constant_expr (kind_expr
))
3743 gfc_error ("The value for the KIND parameter %qs at %C does not "
3744 "reduce to a constant expression", param
->name
);
3748 gfc_extract_int (kind_expr
, &kind_value
);
3749 sprintf (name
+ strlen (name
), "_%d", kind_value
);
3751 if (!name_seen
&& actual_param
)
3752 actual_param
= actual_param
->next
;
3753 gfc_free_expr (kind_expr
);
3756 if (!name_seen
&& actual_param
)
3758 gfc_error ("The type parameter spec list at %C contains too many "
3759 "parameter expressions");
3763 /* Now we search for the PDT instance 'name'. If it doesn't exist, we
3764 build it, using 'pdt' as a template. */
3765 if (gfc_get_symbol (name
, pdt
->ns
, &instance
))
3767 gfc_error ("Parameterized derived type at %C is ambiguous");
3773 if (instance
->attr
.flavor
== FL_DERIVED
3774 && instance
->attr
.pdt_type
)
3778 *ext_param_list
= type_param_spec_list
;
3780 gfc_commit_symbols ();
3784 /* Start building the new instance of the parameterized type. */
3785 gfc_copy_attr (&instance
->attr
, &pdt
->attr
, &pdt
->declared_at
);
3786 instance
->attr
.pdt_template
= 0;
3787 instance
->attr
.pdt_type
= 1;
3788 instance
->declared_at
= gfc_current_locus
;
3790 /* Add the components, replacing the parameters in all expressions
3791 with the expressions for their values in 'type_param_spec_list'. */
3792 c1
= pdt
->components
;
3793 tail
= type_param_spec_list
;
3794 for (; c1
; c1
= c1
->next
)
3796 gfc_add_component (instance
, c1
->name
, &c2
);
3799 c2
->attr
= c1
->attr
;
3801 /* The order of declaration of the type_specs might not be the
3802 same as that of the components. */
3803 if (c1
->attr
.pdt_kind
|| c1
->attr
.pdt_len
)
3805 for (tail
= type_param_spec_list
; tail
; tail
= tail
->next
)
3806 if (strcmp (c1
->name
, tail
->name
) == 0)
3810 /* Deal with type extension by recursively calling this function
3811 to obtain the instance of the extended type. */
3812 if (gfc_current_state () != COMP_DERIVED
3813 && c1
== pdt
->components
3814 && (c1
->ts
.type
== BT_DERIVED
|| c1
->ts
.type
== BT_CLASS
)
3815 && c1
->ts
.u
.derived
&& c1
->ts
.u
.derived
->attr
.pdt_template
3816 && gfc_get_derived_super_type (*sym
) == c2
->ts
.u
.derived
)
3818 gfc_formal_arglist
*f
;
3820 old_param_spec_list
= type_param_spec_list
;
3822 /* Obtain a spec list appropriate to the extended type..*/
3823 actual_param
= gfc_copy_actual_arglist (type_param_spec_list
);
3824 type_param_spec_list
= actual_param
;
3825 for (f
= c1
->ts
.u
.derived
->formal
; f
&& f
->next
; f
= f
->next
)
3826 actual_param
= actual_param
->next
;
3829 gfc_free_actual_arglist (actual_param
->next
);
3830 actual_param
->next
= NULL
;
3833 /* Now obtain the PDT instance for the extended type. */
3834 c2
->param_list
= type_param_spec_list
;
3835 m
= gfc_get_pdt_instance (type_param_spec_list
, &c2
->ts
.u
.derived
,
3837 type_param_spec_list
= old_param_spec_list
;
3839 c2
->ts
.u
.derived
->refs
++;
3840 gfc_set_sym_referenced (c2
->ts
.u
.derived
);
3842 /* Set extension level. */
3843 if (c2
->ts
.u
.derived
->attr
.extension
== 255)
3845 /* Since the extension field is 8 bit wide, we can only have
3846 up to 255 extension levels. */
3847 gfc_error ("Maximum extension level reached with type %qs at %L",
3848 c2
->ts
.u
.derived
->name
,
3849 &c2
->ts
.u
.derived
->declared_at
);
3852 instance
->attr
.extension
= c2
->ts
.u
.derived
->attr
.extension
+ 1;
3857 /* Set the component kind using the parameterized expression. */
3858 if ((c1
->ts
.kind
== 0 || c1
->ts
.type
== BT_CHARACTER
)
3859 && c1
->kind_expr
!= NULL
)
3861 gfc_expr
*e
= gfc_copy_expr (c1
->kind_expr
);
3862 gfc_insert_kind_parameter_exprs (e
);
3863 gfc_simplify_expr (e
, 1);
3864 gfc_extract_int (e
, &c2
->ts
.kind
);
3866 if (gfc_validate_kind (c2
->ts
.type
, c2
->ts
.kind
, true) < 0)
3868 gfc_error ("Kind %d not supported for type %s at %C",
3869 c2
->ts
.kind
, gfc_basic_typename (c2
->ts
.type
));
3874 /* Similarly, set the string length if parameterized. */
3875 if (c1
->ts
.type
== BT_CHARACTER
3876 && c1
->ts
.u
.cl
->length
3877 && gfc_derived_parameter_expr (c1
->ts
.u
.cl
->length
))
3880 e
= gfc_copy_expr (c1
->ts
.u
.cl
->length
);
3881 gfc_insert_kind_parameter_exprs (e
);
3882 gfc_simplify_expr (e
, 1);
3883 c2
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
3884 c2
->ts
.u
.cl
->length
= e
;
3885 c2
->attr
.pdt_string
= 1;
3888 /* Set up either the KIND/LEN initializer, if constant,
3889 or the parameterized expression. Use the template
3890 initializer if one is not already set in this instance. */
3891 if (c2
->attr
.pdt_kind
|| c2
->attr
.pdt_len
)
3893 if (tail
&& tail
->expr
&& gfc_is_constant_expr (tail
->expr
))
3894 c2
->initializer
= gfc_copy_expr (tail
->expr
);
3895 else if (tail
&& tail
->expr
)
3897 c2
->param_list
= gfc_get_actual_arglist ();
3898 c2
->param_list
->name
= tail
->name
;
3899 c2
->param_list
->expr
= gfc_copy_expr (tail
->expr
);
3900 c2
->param_list
->next
= NULL
;
3903 if (!c2
->initializer
&& c1
->initializer
)
3904 c2
->initializer
= gfc_copy_expr (c1
->initializer
);
3907 /* Copy the array spec. */
3908 c2
->as
= gfc_copy_array_spec (c1
->as
);
3909 if (c1
->ts
.type
== BT_CLASS
)
3910 CLASS_DATA (c2
)->as
= gfc_copy_array_spec (CLASS_DATA (c1
)->as
);
3912 /* Determine if an array spec is parameterized. If so, substitute
3913 in the parameter expressions for the bounds and set the pdt_array
3914 attribute. Notice that this attribute must be unconditionally set
3915 if this is an array of parameterized character length. */
3916 if (c1
->as
&& c1
->as
->type
== AS_EXPLICIT
)
3918 bool pdt_array
= false;
3920 /* Are the bounds of the array parameterized? */
3921 for (i
= 0; i
< c1
->as
->rank
; i
++)
3923 if (gfc_derived_parameter_expr (c1
->as
->lower
[i
]))
3925 if (gfc_derived_parameter_expr (c1
->as
->upper
[i
]))
3929 /* If they are, free the expressions for the bounds and
3930 replace them with the template expressions with substitute
3932 for (i
= 0; pdt_array
&& i
< c1
->as
->rank
; i
++)
3935 e
= gfc_copy_expr (c1
->as
->lower
[i
]);
3936 gfc_insert_kind_parameter_exprs (e
);
3937 gfc_simplify_expr (e
, 1);
3938 gfc_free_expr (c2
->as
->lower
[i
]);
3939 c2
->as
->lower
[i
] = e
;
3940 e
= gfc_copy_expr (c1
->as
->upper
[i
]);
3941 gfc_insert_kind_parameter_exprs (e
);
3942 gfc_simplify_expr (e
, 1);
3943 gfc_free_expr (c2
->as
->upper
[i
]);
3944 c2
->as
->upper
[i
] = e
;
3946 c2
->attr
.pdt_array
= pdt_array
? 1 : c2
->attr
.pdt_string
;
3947 if (c1
->initializer
)
3949 c2
->initializer
= gfc_copy_expr (c1
->initializer
);
3950 gfc_insert_kind_parameter_exprs (c2
->initializer
);
3951 gfc_simplify_expr (c2
->initializer
, 1);
3955 /* Recurse into this function for PDT components. */
3956 if ((c1
->ts
.type
== BT_DERIVED
|| c1
->ts
.type
== BT_CLASS
)
3957 && c1
->ts
.u
.derived
&& c1
->ts
.u
.derived
->attr
.pdt_template
)
3959 gfc_actual_arglist
*params
;
3960 /* The component in the template has a list of specification
3961 expressions derived from its declaration. */
3962 params
= gfc_copy_actual_arglist (c1
->param_list
);
3963 actual_param
= params
;
3964 /* Substitute the template parameters with the expressions
3965 from the specification list. */
3966 for (;actual_param
; actual_param
= actual_param
->next
)
3967 gfc_insert_parameter_exprs (actual_param
->expr
,
3968 type_param_spec_list
);
3970 /* Now obtain the PDT instance for the component. */
3971 old_param_spec_list
= type_param_spec_list
;
3972 m
= gfc_get_pdt_instance (params
, &c2
->ts
.u
.derived
, NULL
);
3973 type_param_spec_list
= old_param_spec_list
;
3975 c2
->param_list
= params
;
3976 if (!(c2
->attr
.pointer
|| c2
->attr
.allocatable
))
3977 c2
->initializer
= gfc_default_initializer (&c2
->ts
);
3979 if (c2
->attr
.allocatable
)
3980 instance
->attr
.alloc_comp
= 1;
3984 gfc_commit_symbol (instance
);
3986 *ext_param_list
= type_param_spec_list
;
3991 gfc_free_actual_arglist (type_param_spec_list
);
3996 /* Match a legacy nonstandard BYTE type-spec. */
3999 match_byte_typespec (gfc_typespec
*ts
)
4001 if (gfc_match (" byte") == MATCH_YES
)
4003 if (!gfc_notify_std (GFC_STD_GNU
, "BYTE type at %C"))
4006 if (gfc_current_form
== FORM_FREE
)
4008 char c
= gfc_peek_ascii_char ();
4009 if (!gfc_is_whitespace (c
) && c
!= ',')
4013 if (gfc_validate_kind (BT_INTEGER
, 1, true) < 0)
4015 gfc_error ("BYTE type used at %C "
4016 "is not available on the target machine");
4020 ts
->type
= BT_INTEGER
;
4028 /* Matches a declaration-type-spec (F03:R502). If successful, sets the ts
4029 structure to the matched specification. This is necessary for FUNCTION and
4030 IMPLICIT statements.
4032 If implicit_flag is nonzero, then we don't check for the optional
4033 kind specification. Not doing so is needed for matching an IMPLICIT
4034 statement correctly. */
4037 gfc_match_decl_type_spec (gfc_typespec
*ts
, int implicit_flag
)
4039 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4040 gfc_symbol
*sym
, *dt_sym
;
4043 bool seen_deferred_kind
, matched_type
;
4044 const char *dt_name
;
4046 decl_type_param_list
= NULL
;
4048 /* A belt and braces check that the typespec is correctly being treated
4049 as a deferred characteristic association. */
4050 seen_deferred_kind
= (gfc_current_state () == COMP_FUNCTION
)
4051 && (gfc_current_block ()->result
->ts
.kind
== -1)
4052 && (ts
->kind
== -1);
4054 if (seen_deferred_kind
)
4057 /* Clear the current binding label, in case one is given. */
4058 curr_binding_label
= NULL
;
4060 /* Match BYTE type-spec. */
4061 m
= match_byte_typespec (ts
);
4065 m
= gfc_match (" type (");
4066 matched_type
= (m
== MATCH_YES
);
4069 gfc_gobble_whitespace ();
4070 if (gfc_peek_ascii_char () == '*')
4072 if ((m
= gfc_match ("*)")) != MATCH_YES
)
4074 if (gfc_comp_struct (gfc_current_state ()))
4076 gfc_error ("Assumed type at %C is not allowed for components");
4079 if (!gfc_notify_std (GFC_STD_F2018
, "Assumed type at %C"))
4081 ts
->type
= BT_ASSUMED
;
4085 m
= gfc_match ("%n", name
);
4086 matched_type
= (m
== MATCH_YES
);
4089 if ((matched_type
&& strcmp ("integer", name
) == 0)
4090 || (!matched_type
&& gfc_match (" integer") == MATCH_YES
))
4092 ts
->type
= BT_INTEGER
;
4093 ts
->kind
= gfc_default_integer_kind
;
4097 if ((matched_type
&& strcmp ("character", name
) == 0)
4098 || (!matched_type
&& gfc_match (" character") == MATCH_YES
))
4101 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
4102 "intrinsic-type-spec at %C"))
4105 ts
->type
= BT_CHARACTER
;
4106 if (implicit_flag
== 0)
4107 m
= gfc_match_char_spec (ts
);
4111 if (matched_type
&& m
== MATCH_YES
&& gfc_match_char (')') != MATCH_YES
)
4113 gfc_error ("Malformed type-spec at %C");
4120 if ((matched_type
&& strcmp ("real", name
) == 0)
4121 || (!matched_type
&& gfc_match (" real") == MATCH_YES
))
4124 ts
->kind
= gfc_default_real_kind
;
4129 && (strcmp ("doubleprecision", name
) == 0
4130 || (strcmp ("double", name
) == 0
4131 && gfc_match (" precision") == MATCH_YES
)))
4132 || (!matched_type
&& gfc_match (" double precision") == MATCH_YES
))
4135 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
4136 "intrinsic-type-spec at %C"))
4139 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
4141 gfc_error ("Malformed type-spec at %C");
4146 ts
->kind
= gfc_default_double_kind
;
4150 if ((matched_type
&& strcmp ("complex", name
) == 0)
4151 || (!matched_type
&& gfc_match (" complex") == MATCH_YES
))
4153 ts
->type
= BT_COMPLEX
;
4154 ts
->kind
= gfc_default_complex_kind
;
4159 && (strcmp ("doublecomplex", name
) == 0
4160 || (strcmp ("double", name
) == 0
4161 && gfc_match (" complex") == MATCH_YES
)))
4162 || (!matched_type
&& gfc_match (" double complex") == MATCH_YES
))
4164 if (!gfc_notify_std (GFC_STD_GNU
, "DOUBLE COMPLEX at %C"))
4168 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
4169 "intrinsic-type-spec at %C"))
4172 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
4174 gfc_error ("Malformed type-spec at %C");
4178 ts
->type
= BT_COMPLEX
;
4179 ts
->kind
= gfc_default_double_kind
;
4183 if ((matched_type
&& strcmp ("logical", name
) == 0)
4184 || (!matched_type
&& gfc_match (" logical") == MATCH_YES
))
4186 ts
->type
= BT_LOGICAL
;
4187 ts
->kind
= gfc_default_logical_kind
;
4193 m
= gfc_match_actual_arglist (1, &decl_type_param_list
, true);
4194 if (m
== MATCH_ERROR
)
4197 gfc_gobble_whitespace ();
4198 if (gfc_peek_ascii_char () != ')')
4200 gfc_error ("Malformed type-spec at %C");
4203 m
= gfc_match_char (')'); /* Burn closing ')'. */
4207 m
= match_record_decl (name
);
4209 if (matched_type
|| m
== MATCH_YES
)
4211 ts
->type
= BT_DERIVED
;
4212 /* We accept record/s/ or type(s) where s is a structure, but we
4213 * don't need all the extra derived-type stuff for structures. */
4214 if (gfc_find_symbol (gfc_dt_upper_string (name
), NULL
, 1, &sym
))
4216 gfc_error ("Type name %qs at %C is ambiguous", name
);
4220 if (sym
&& sym
->attr
.flavor
== FL_DERIVED
4221 && sym
->attr
.pdt_template
4222 && gfc_current_state () != COMP_DERIVED
)
4224 m
= gfc_get_pdt_instance (decl_type_param_list
, &sym
, NULL
);
4227 gcc_assert (!sym
->attr
.pdt_template
&& sym
->attr
.pdt_type
);
4228 ts
->u
.derived
= sym
;
4229 strcpy (name
, gfc_dt_lower_string (sym
->name
));
4232 if (sym
&& sym
->attr
.flavor
== FL_STRUCT
)
4234 ts
->u
.derived
= sym
;
4237 /* Actually a derived type. */
4242 /* Match nested STRUCTURE declarations; only valid within another
4243 structure declaration. */
4244 if (flag_dec_structure
4245 && (gfc_current_state () == COMP_STRUCTURE
4246 || gfc_current_state () == COMP_MAP
))
4248 m
= gfc_match (" structure");
4251 m
= gfc_match_structure_decl ();
4254 /* gfc_new_block is updated by match_structure_decl. */
4255 ts
->type
= BT_DERIVED
;
4256 ts
->u
.derived
= gfc_new_block
;
4260 if (m
== MATCH_ERROR
)
4264 /* Match CLASS declarations. */
4265 m
= gfc_match (" class ( * )");
4266 if (m
== MATCH_ERROR
)
4268 else if (m
== MATCH_YES
)
4272 ts
->type
= BT_CLASS
;
4273 gfc_find_symbol ("STAR", gfc_current_ns
, 1, &upe
);
4276 upe
= gfc_new_symbol ("STAR", gfc_current_ns
);
4277 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "STAR");
4279 gfc_set_sym_referenced (upe
);
4281 upe
->ts
.type
= BT_VOID
;
4282 upe
->attr
.unlimited_polymorphic
= 1;
4283 /* This is essential to force the construction of
4284 unlimited polymorphic component class containers. */
4285 upe
->attr
.zero_comp
= 1;
4286 if (!gfc_add_flavor (&upe
->attr
, FL_DERIVED
, NULL
,
4287 &gfc_current_locus
))
4292 st
= gfc_get_tbp_symtree (&gfc_current_ns
->sym_root
, "STAR");
4296 ts
->u
.derived
= upe
;
4300 m
= gfc_match (" class (");
4303 m
= gfc_match ("%n", name
);
4309 ts
->type
= BT_CLASS
;
4311 if (!gfc_notify_std (GFC_STD_F2003
, "CLASS statement at %C"))
4314 m
= gfc_match_actual_arglist (1, &decl_type_param_list
, true);
4315 if (m
== MATCH_ERROR
)
4318 m
= gfc_match_char (')');
4323 /* Defer association of the derived type until the end of the
4324 specification block. However, if the derived type can be
4325 found, add it to the typespec. */
4326 if (gfc_matching_function
)
4328 ts
->u
.derived
= NULL
;
4329 if (gfc_current_state () != COMP_INTERFACE
4330 && !gfc_find_symbol (name
, NULL
, 1, &sym
) && sym
)
4332 sym
= gfc_find_dt_in_generic (sym
);
4333 ts
->u
.derived
= sym
;
4338 /* Search for the name but allow the components to be defined later. If
4339 type = -1, this typespec has been seen in a function declaration but
4340 the type could not be accessed at that point. The actual derived type is
4341 stored in a symtree with the first letter of the name capitalized; the
4342 symtree with the all lower-case name contains the associated
4343 generic function. */
4344 dt_name
= gfc_dt_upper_string (name
);
4349 gfc_get_ha_symbol (name
, &sym
);
4350 if (sym
->generic
&& gfc_find_symbol (dt_name
, NULL
, 0, &dt_sym
))
4352 gfc_error ("Type name %qs at %C is ambiguous", name
);
4355 if (sym
->generic
&& !dt_sym
)
4356 dt_sym
= gfc_find_dt_in_generic (sym
);
4358 /* Host associated PDTs can get confused with their constructors
4359 because they ar instantiated in the template's namespace. */
4362 if (gfc_find_symbol (dt_name
, NULL
, 1, &dt_sym
))
4364 gfc_error ("Type name %qs at %C is ambiguous", name
);
4367 if (dt_sym
&& !dt_sym
->attr
.pdt_type
)
4371 else if (ts
->kind
== -1)
4373 int iface
= gfc_state_stack
->previous
->state
!= COMP_INTERFACE
4374 || gfc_current_ns
->has_import_set
;
4375 gfc_find_symbol (name
, NULL
, iface
, &sym
);
4376 if (sym
&& sym
->generic
&& gfc_find_symbol (dt_name
, NULL
, 1, &dt_sym
))
4378 gfc_error ("Type name %qs at %C is ambiguous", name
);
4381 if (sym
&& sym
->generic
&& !dt_sym
)
4382 dt_sym
= gfc_find_dt_in_generic (sym
);
4389 if ((sym
->attr
.flavor
!= FL_UNKNOWN
&& sym
->attr
.flavor
!= FL_STRUCT
4390 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.generic
))
4391 || sym
->attr
.subroutine
)
4393 gfc_error ("Type name %qs at %C conflicts with previously declared "
4394 "entity at %L, which has the same name", name
,
4399 if (sym
&& sym
->attr
.flavor
== FL_DERIVED
4400 && sym
->attr
.pdt_template
4401 && gfc_current_state () != COMP_DERIVED
)
4403 m
= gfc_get_pdt_instance (decl_type_param_list
, &sym
, NULL
);
4406 gcc_assert (!sym
->attr
.pdt_template
&& sym
->attr
.pdt_type
);
4407 ts
->u
.derived
= sym
;
4408 strcpy (name
, gfc_dt_lower_string (sym
->name
));
4411 gfc_save_symbol_data (sym
);
4412 gfc_set_sym_referenced (sym
);
4413 if (!sym
->attr
.generic
4414 && !gfc_add_generic (&sym
->attr
, sym
->name
, NULL
))
4417 if (!sym
->attr
.function
4418 && !gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
4421 if (dt_sym
&& dt_sym
->attr
.flavor
== FL_DERIVED
4422 && dt_sym
->attr
.pdt_template
4423 && gfc_current_state () != COMP_DERIVED
)
4425 m
= gfc_get_pdt_instance (decl_type_param_list
, &dt_sym
, NULL
);
4428 gcc_assert (!dt_sym
->attr
.pdt_template
&& dt_sym
->attr
.pdt_type
);
4433 gfc_interface
*intr
, *head
;
4435 /* Use upper case to save the actual derived-type symbol. */
4436 gfc_get_symbol (dt_name
, NULL
, &dt_sym
);
4437 dt_sym
->name
= gfc_get_string ("%s", sym
->name
);
4438 head
= sym
->generic
;
4439 intr
= gfc_get_interface ();
4441 intr
->where
= gfc_current_locus
;
4443 sym
->generic
= intr
;
4444 sym
->attr
.if_source
= IFSRC_DECL
;
4447 gfc_save_symbol_data (dt_sym
);
4449 gfc_set_sym_referenced (dt_sym
);
4451 if (dt_sym
->attr
.flavor
!= FL_DERIVED
&& dt_sym
->attr
.flavor
!= FL_STRUCT
4452 && !gfc_add_flavor (&dt_sym
->attr
, FL_DERIVED
, sym
->name
, NULL
))
4455 ts
->u
.derived
= dt_sym
;
4461 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
4462 "intrinsic-type-spec at %C"))
4465 /* For all types except double, derived and character, look for an
4466 optional kind specifier. MATCH_NO is actually OK at this point. */
4467 if (implicit_flag
== 1)
4469 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
4475 if (gfc_current_form
== FORM_FREE
)
4477 c
= gfc_peek_ascii_char ();
4478 if (!gfc_is_whitespace (c
) && c
!= '*' && c
!= '('
4479 && c
!= ':' && c
!= ',')
4481 if (matched_type
&& c
== ')')
4483 gfc_next_ascii_char ();
4486 gfc_error ("Malformed type-spec at %C");
4491 m
= gfc_match_kind_spec (ts
, false);
4492 if (m
== MATCH_NO
&& ts
->type
!= BT_CHARACTER
)
4494 m
= gfc_match_old_kind_spec (ts
);
4495 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) == -1)
4499 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
4501 gfc_error ("Malformed type-spec at %C");
4505 /* Defer association of the KIND expression of function results
4506 until after USE and IMPORT statements. */
4507 if ((gfc_current_state () == COMP_NONE
&& gfc_error_flag_test ())
4508 || gfc_matching_function
)
4512 m
= MATCH_YES
; /* No kind specifier found. */
4518 /* Match an IMPLICIT NONE statement. Actually, this statement is
4519 already matched in parse.c, or we would not end up here in the
4520 first place. So the only thing we need to check, is if there is
4521 trailing garbage. If not, the match is successful. */
4524 gfc_match_implicit_none (void)
4528 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4530 bool external
= false;
4531 locus cur_loc
= gfc_current_locus
;
4533 if (gfc_current_ns
->seen_implicit_none
4534 || gfc_current_ns
->has_implicit_none_export
)
4536 gfc_error ("Duplicate IMPLICIT NONE statement at %C");
4540 gfc_gobble_whitespace ();
4541 c
= gfc_peek_ascii_char ();
4544 (void) gfc_next_ascii_char ();
4545 if (!gfc_notify_std (GFC_STD_F2018
, "IMPORT NONE with spec list at %C"))
4548 gfc_gobble_whitespace ();
4549 if (gfc_peek_ascii_char () == ')')
4551 (void) gfc_next_ascii_char ();
4557 m
= gfc_match (" %n", name
);
4561 if (strcmp (name
, "type") == 0)
4563 else if (strcmp (name
, "external") == 0)
4568 gfc_gobble_whitespace ();
4569 c
= gfc_next_ascii_char ();
4580 if (gfc_match_eos () != MATCH_YES
)
4583 gfc_set_implicit_none (type
, external
, &cur_loc
);
4589 /* Match the letter range(s) of an IMPLICIT statement. */
4592 match_implicit_range (void)
4598 cur_loc
= gfc_current_locus
;
4600 gfc_gobble_whitespace ();
4601 c
= gfc_next_ascii_char ();
4604 gfc_error ("Missing character range in IMPLICIT at %C");
4611 gfc_gobble_whitespace ();
4612 c1
= gfc_next_ascii_char ();
4616 gfc_gobble_whitespace ();
4617 c
= gfc_next_ascii_char ();
4622 inner
= 0; /* Fall through. */
4629 gfc_gobble_whitespace ();
4630 c2
= gfc_next_ascii_char ();
4634 gfc_gobble_whitespace ();
4635 c
= gfc_next_ascii_char ();
4637 if ((c
!= ',') && (c
!= ')'))
4650 gfc_error ("Letters must be in alphabetic order in "
4651 "IMPLICIT statement at %C");
4655 /* See if we can add the newly matched range to the pending
4656 implicits from this IMPLICIT statement. We do not check for
4657 conflicts with whatever earlier IMPLICIT statements may have
4658 set. This is done when we've successfully finished matching
4660 if (!gfc_add_new_implicit_range (c1
, c2
))
4667 gfc_syntax_error (ST_IMPLICIT
);
4669 gfc_current_locus
= cur_loc
;
4674 /* Match an IMPLICIT statement, storing the types for
4675 gfc_set_implicit() if the statement is accepted by the parser.
4676 There is a strange looking, but legal syntactic construction
4677 possible. It looks like:
4679 IMPLICIT INTEGER (a-b) (c-d)
4681 This is legal if "a-b" is a constant expression that happens to
4682 equal one of the legal kinds for integers. The real problem
4683 happens with an implicit specification that looks like:
4685 IMPLICIT INTEGER (a-b)
4687 In this case, a typespec matcher that is "greedy" (as most of the
4688 matchers are) gobbles the character range as a kindspec, leaving
4689 nothing left. We therefore have to go a bit more slowly in the
4690 matching process by inhibiting the kindspec checking during
4691 typespec matching and checking for a kind later. */
4694 gfc_match_implicit (void)
4701 if (gfc_current_ns
->seen_implicit_none
)
4703 gfc_error ("IMPLICIT statement at %C following an IMPLICIT NONE (type) "
4710 /* We don't allow empty implicit statements. */
4711 if (gfc_match_eos () == MATCH_YES
)
4713 gfc_error ("Empty IMPLICIT statement at %C");
4719 /* First cleanup. */
4720 gfc_clear_new_implicit ();
4722 /* A basic type is mandatory here. */
4723 m
= gfc_match_decl_type_spec (&ts
, 1);
4724 if (m
== MATCH_ERROR
)
4729 cur_loc
= gfc_current_locus
;
4730 m
= match_implicit_range ();
4734 /* We may have <TYPE> (<RANGE>). */
4735 gfc_gobble_whitespace ();
4736 c
= gfc_peek_ascii_char ();
4737 if (c
== ',' || c
== '\n' || c
== ';' || c
== '!')
4739 /* Check for CHARACTER with no length parameter. */
4740 if (ts
.type
== BT_CHARACTER
&& !ts
.u
.cl
)
4742 ts
.kind
= gfc_default_character_kind
;
4743 ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4744 ts
.u
.cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
,
4748 /* Record the Successful match. */
4749 if (!gfc_merge_new_implicit (&ts
))
4752 c
= gfc_next_ascii_char ();
4753 else if (gfc_match_eos () == MATCH_ERROR
)
4758 gfc_current_locus
= cur_loc
;
4761 /* Discard the (incorrectly) matched range. */
4762 gfc_clear_new_implicit ();
4764 /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
4765 if (ts
.type
== BT_CHARACTER
)
4766 m
= gfc_match_char_spec (&ts
);
4769 m
= gfc_match_kind_spec (&ts
, false);
4772 m
= gfc_match_old_kind_spec (&ts
);
4773 if (m
== MATCH_ERROR
)
4779 if (m
== MATCH_ERROR
)
4782 m
= match_implicit_range ();
4783 if (m
== MATCH_ERROR
)
4788 gfc_gobble_whitespace ();
4789 c
= gfc_next_ascii_char ();
4790 if (c
!= ',' && gfc_match_eos () != MATCH_YES
)
4793 if (!gfc_merge_new_implicit (&ts
))
4801 gfc_syntax_error (ST_IMPLICIT
);
4809 gfc_match_import (void)
4811 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4816 if (gfc_current_ns
->proc_name
== NULL
4817 || gfc_current_ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
4819 gfc_error ("IMPORT statement at %C only permitted in "
4820 "an INTERFACE body");
4824 if (gfc_current_ns
->proc_name
->attr
.module_procedure
)
4826 gfc_error ("F2008: C1210 IMPORT statement at %C is not permitted "
4827 "in a module procedure interface body");
4831 if (!gfc_notify_std (GFC_STD_F2003
, "IMPORT statement at %C"))
4834 if (gfc_match_eos () == MATCH_YES
)
4836 /* All host variables should be imported. */
4837 gfc_current_ns
->has_import_set
= 1;
4841 if (gfc_match (" ::") == MATCH_YES
)
4843 if (gfc_match_eos () == MATCH_YES
)
4845 gfc_error ("Expecting list of named entities at %C");
4853 m
= gfc_match (" %n", name
);
4857 if (gfc_current_ns
->parent
!= NULL
4858 && gfc_find_symbol (name
, gfc_current_ns
->parent
, 1, &sym
))
4860 gfc_error ("Type name %qs at %C is ambiguous", name
);
4863 else if (!sym
&& gfc_current_ns
->proc_name
->ns
->parent
!= NULL
4864 && gfc_find_symbol (name
,
4865 gfc_current_ns
->proc_name
->ns
->parent
,
4868 gfc_error ("Type name %qs at %C is ambiguous", name
);
4874 gfc_error ("Cannot IMPORT %qs from host scoping unit "
4875 "at %C - does not exist.", name
);
4879 if (gfc_find_symtree (gfc_current_ns
->sym_root
, name
))
4881 gfc_warning (0, "%qs is already IMPORTed from host scoping unit "
4886 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, name
);
4889 sym
->attr
.imported
= 1;
4891 if (sym
->attr
.generic
&& (sym
= gfc_find_dt_in_generic (sym
)))
4893 /* The actual derived type is stored in a symtree with the first
4894 letter of the name capitalized; the symtree with the all
4895 lower-case name contains the associated generic function. */
4896 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
,
4897 gfc_dt_upper_string (name
));
4900 sym
->attr
.imported
= 1;
4913 if (gfc_match_eos () == MATCH_YES
)
4915 if (gfc_match_char (',') != MATCH_YES
)
4922 gfc_error ("Syntax error in IMPORT statement at %C");
4927 /* A minimal implementation of gfc_match without whitespace, escape
4928 characters or variable arguments. Returns true if the next
4929 characters match the TARGET template exactly. */
4932 match_string_p (const char *target
)
4936 for (p
= target
; *p
; p
++)
4937 if ((char) gfc_next_ascii_char () != *p
)
4942 /* Matches an attribute specification including array specs. If
4943 successful, leaves the variables current_attr and current_as
4944 holding the specification. Also sets the colon_seen variable for
4945 later use by matchers associated with initializations.
4947 This subroutine is a little tricky in the sense that we don't know
4948 if we really have an attr-spec until we hit the double colon.
4949 Until that time, we can only return MATCH_NO. This forces us to
4950 check for duplicate specification at this level. */
4953 match_attr_spec (void)
4955 /* Modifiers that can exist in a type statement. */
4957 { GFC_DECL_BEGIN
= 0, DECL_ALLOCATABLE
= GFC_DECL_BEGIN
,
4958 DECL_IN
= INTENT_IN
, DECL_OUT
= INTENT_OUT
, DECL_INOUT
= INTENT_INOUT
,
4959 DECL_DIMENSION
, DECL_EXTERNAL
,
4960 DECL_INTRINSIC
, DECL_OPTIONAL
,
4961 DECL_PARAMETER
, DECL_POINTER
, DECL_PROTECTED
, DECL_PRIVATE
,
4962 DECL_STATIC
, DECL_AUTOMATIC
,
4963 DECL_PUBLIC
, DECL_SAVE
, DECL_TARGET
, DECL_VALUE
, DECL_VOLATILE
,
4964 DECL_IS_BIND_C
, DECL_CODIMENSION
, DECL_ASYNCHRONOUS
, DECL_CONTIGUOUS
,
4965 DECL_LEN
, DECL_KIND
, DECL_NONE
, GFC_DECL_END
/* Sentinel */
4968 /* GFC_DECL_END is the sentinel, index starts at 0. */
4969 #define NUM_DECL GFC_DECL_END
4971 /* Make sure that values from sym_intent are safe to be used here. */
4972 gcc_assert (INTENT_IN
> 0);
4974 locus start
, seen_at
[NUM_DECL
];
4981 gfc_clear_attr (¤t_attr
);
4982 start
= gfc_current_locus
;
4988 /* See if we get all of the keywords up to the final double colon. */
4989 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
4997 gfc_gobble_whitespace ();
4999 ch
= gfc_next_ascii_char ();
5002 /* This is the successful exit condition for the loop. */
5003 if (gfc_next_ascii_char () == ':')
5008 gfc_gobble_whitespace ();
5009 switch (gfc_peek_ascii_char ())
5012 gfc_next_ascii_char ();
5013 switch (gfc_next_ascii_char ())
5016 if (match_string_p ("locatable"))
5018 /* Matched "allocatable". */
5019 d
= DECL_ALLOCATABLE
;
5024 if (match_string_p ("ynchronous"))
5026 /* Matched "asynchronous". */
5027 d
= DECL_ASYNCHRONOUS
;
5032 if (match_string_p ("tomatic"))
5034 /* Matched "automatic". */
5042 /* Try and match the bind(c). */
5043 m
= gfc_match_bind_c (NULL
, true);
5046 else if (m
== MATCH_ERROR
)
5051 gfc_next_ascii_char ();
5052 if ('o' != gfc_next_ascii_char ())
5054 switch (gfc_next_ascii_char ())
5057 if (match_string_p ("imension"))
5059 d
= DECL_CODIMENSION
;
5064 if (match_string_p ("tiguous"))
5066 d
= DECL_CONTIGUOUS
;
5073 if (match_string_p ("dimension"))
5078 if (match_string_p ("external"))
5083 if (match_string_p ("int"))
5085 ch
= gfc_next_ascii_char ();
5088 if (match_string_p ("nt"))
5090 /* Matched "intent". */
5091 d
= match_intent_spec ();
5092 if (d
== INTENT_UNKNOWN
)
5101 if (match_string_p ("insic"))
5103 /* Matched "intrinsic". */
5111 if (match_string_p ("kind"))
5116 if (match_string_p ("len"))
5121 if (match_string_p ("optional"))
5126 gfc_next_ascii_char ();
5127 switch (gfc_next_ascii_char ())
5130 if (match_string_p ("rameter"))
5132 /* Matched "parameter". */
5138 if (match_string_p ("inter"))
5140 /* Matched "pointer". */
5146 ch
= gfc_next_ascii_char ();
5149 if (match_string_p ("vate"))
5151 /* Matched "private". */
5157 if (match_string_p ("tected"))
5159 /* Matched "protected". */
5166 if (match_string_p ("blic"))
5168 /* Matched "public". */
5176 gfc_next_ascii_char ();
5177 switch (gfc_next_ascii_char ())
5180 if (match_string_p ("ve"))
5182 /* Matched "save". */
5188 if (match_string_p ("atic"))
5190 /* Matched "static". */
5198 if (match_string_p ("target"))
5203 gfc_next_ascii_char ();
5204 ch
= gfc_next_ascii_char ();
5207 if (match_string_p ("lue"))
5209 /* Matched "value". */
5215 if (match_string_p ("latile"))
5217 /* Matched "volatile". */
5225 /* No double colon and no recognizable decl_type, so assume that
5226 we've been looking at something else the whole time. */
5233 /* Check to make sure any parens are paired up correctly. */
5234 if (gfc_match_parens () == MATCH_ERROR
)
5241 seen_at
[d
] = gfc_current_locus
;
5243 if (d
== DECL_DIMENSION
|| d
== DECL_CODIMENSION
)
5245 gfc_array_spec
*as
= NULL
;
5247 m
= gfc_match_array_spec (&as
, d
== DECL_DIMENSION
,
5248 d
== DECL_CODIMENSION
);
5250 if (current_as
== NULL
)
5252 else if (m
== MATCH_YES
)
5254 if (!merge_array_spec (as
, current_as
, false))
5261 if (d
== DECL_CODIMENSION
)
5262 gfc_error ("Missing codimension specification at %C");
5264 gfc_error ("Missing dimension specification at %C");
5268 if (m
== MATCH_ERROR
)
5273 /* Since we've seen a double colon, we have to be looking at an
5274 attr-spec. This means that we can now issue errors. */
5275 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
5280 case DECL_ALLOCATABLE
:
5281 attr
= "ALLOCATABLE";
5283 case DECL_ASYNCHRONOUS
:
5284 attr
= "ASYNCHRONOUS";
5286 case DECL_CODIMENSION
:
5287 attr
= "CODIMENSION";
5289 case DECL_CONTIGUOUS
:
5290 attr
= "CONTIGUOUS";
5292 case DECL_DIMENSION
:
5299 attr
= "INTENT (IN)";
5302 attr
= "INTENT (OUT)";
5305 attr
= "INTENT (IN OUT)";
5307 case DECL_INTRINSIC
:
5319 case DECL_PARAMETER
:
5325 case DECL_PROTECTED
:
5340 case DECL_AUTOMATIC
:
5346 case DECL_IS_BIND_C
:
5356 attr
= NULL
; /* This shouldn't happen. */
5359 gfc_error ("Duplicate %s attribute at %L", attr
, &seen_at
[d
]);
5364 /* Now that we've dealt with duplicate attributes, add the attributes
5365 to the current attribute. */
5366 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
5373 if ((d
== DECL_STATIC
|| d
== DECL_AUTOMATIC
)
5374 && !flag_dec_static
)
5376 gfc_error ("%s at %L is a DEC extension, enable with "
5378 d
== DECL_STATIC
? "STATIC" : "AUTOMATIC", &seen_at
[d
]);
5382 /* Allow SAVE with STATIC, but don't complain. */
5383 if (d
== DECL_STATIC
&& seen
[DECL_SAVE
])
5386 if (gfc_current_state () == COMP_DERIVED
5387 && d
!= DECL_DIMENSION
&& d
!= DECL_CODIMENSION
5388 && d
!= DECL_POINTER
&& d
!= DECL_PRIVATE
5389 && d
!= DECL_PUBLIC
&& d
!= DECL_CONTIGUOUS
&& d
!= DECL_NONE
)
5391 if (d
== DECL_ALLOCATABLE
)
5393 if (!gfc_notify_std (GFC_STD_F2003
, "ALLOCATABLE "
5394 "attribute at %C in a TYPE definition"))
5400 else if (d
== DECL_KIND
)
5402 if (!gfc_notify_std (GFC_STD_F2003
, "KIND "
5403 "attribute at %C in a TYPE definition"))
5408 if (current_ts
.type
!= BT_INTEGER
)
5410 gfc_error ("Component with KIND attribute at %C must be "
5415 if (current_ts
.kind
!= gfc_default_integer_kind
)
5417 gfc_error ("Component with KIND attribute at %C must be "
5418 "default integer kind (%d)",
5419 gfc_default_integer_kind
);
5424 else if (d
== DECL_LEN
)
5426 if (!gfc_notify_std (GFC_STD_F2003
, "LEN "
5427 "attribute at %C in a TYPE definition"))
5432 if (current_ts
.type
!= BT_INTEGER
)
5434 gfc_error ("Component with LEN attribute at %C must be "
5439 if (current_ts
.kind
!= gfc_default_integer_kind
)
5441 gfc_error ("Component with LEN attribute at %C must be "
5442 "default integer kind (%d)",
5443 gfc_default_integer_kind
);
5450 gfc_error ("Attribute at %L is not allowed in a TYPE definition",
5457 if ((d
== DECL_PRIVATE
|| d
== DECL_PUBLIC
)
5458 && gfc_current_state () != COMP_MODULE
)
5460 if (d
== DECL_PRIVATE
)
5464 if (gfc_current_state () == COMP_DERIVED
5465 && gfc_state_stack
->previous
5466 && gfc_state_stack
->previous
->state
== COMP_MODULE
)
5468 if (!gfc_notify_std (GFC_STD_F2003
, "Attribute %s "
5469 "at %L in a TYPE definition", attr
,
5478 gfc_error ("%s attribute at %L is not allowed outside of the "
5479 "specification part of a module", attr
, &seen_at
[d
]);
5485 if (gfc_current_state () != COMP_DERIVED
5486 && (d
== DECL_KIND
|| d
== DECL_LEN
))
5488 gfc_error ("Attribute at %L is not allowed outside a TYPE "
5489 "definition", &seen_at
[d
]);
5496 case DECL_ALLOCATABLE
:
5497 t
= gfc_add_allocatable (¤t_attr
, &seen_at
[d
]);
5500 case DECL_ASYNCHRONOUS
:
5501 if (!gfc_notify_std (GFC_STD_F2003
, "ASYNCHRONOUS attribute at %C"))
5504 t
= gfc_add_asynchronous (¤t_attr
, NULL
, &seen_at
[d
]);
5507 case DECL_CODIMENSION
:
5508 t
= gfc_add_codimension (¤t_attr
, NULL
, &seen_at
[d
]);
5511 case DECL_CONTIGUOUS
:
5512 if (!gfc_notify_std (GFC_STD_F2008
, "CONTIGUOUS attribute at %C"))
5515 t
= gfc_add_contiguous (¤t_attr
, NULL
, &seen_at
[d
]);
5518 case DECL_DIMENSION
:
5519 t
= gfc_add_dimension (¤t_attr
, NULL
, &seen_at
[d
]);
5523 t
= gfc_add_external (¤t_attr
, &seen_at
[d
]);
5527 t
= gfc_add_intent (¤t_attr
, INTENT_IN
, &seen_at
[d
]);
5531 t
= gfc_add_intent (¤t_attr
, INTENT_OUT
, &seen_at
[d
]);
5535 t
= gfc_add_intent (¤t_attr
, INTENT_INOUT
, &seen_at
[d
]);
5538 case DECL_INTRINSIC
:
5539 t
= gfc_add_intrinsic (¤t_attr
, &seen_at
[d
]);
5543 t
= gfc_add_optional (¤t_attr
, &seen_at
[d
]);
5547 t
= gfc_add_kind (¤t_attr
, &seen_at
[d
]);
5551 t
= gfc_add_len (¤t_attr
, &seen_at
[d
]);
5554 case DECL_PARAMETER
:
5555 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, &seen_at
[d
]);
5559 t
= gfc_add_pointer (¤t_attr
, &seen_at
[d
]);
5562 case DECL_PROTECTED
:
5563 if (gfc_current_state () != COMP_MODULE
5564 || (gfc_current_ns
->proc_name
5565 && gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
))
5567 gfc_error ("PROTECTED at %C only allowed in specification "
5568 "part of a module");
5573 if (!gfc_notify_std (GFC_STD_F2003
, "PROTECTED attribute at %C"))
5576 t
= gfc_add_protected (¤t_attr
, NULL
, &seen_at
[d
]);
5580 t
= gfc_add_access (¤t_attr
, ACCESS_PRIVATE
, NULL
,
5585 t
= gfc_add_access (¤t_attr
, ACCESS_PUBLIC
, NULL
,
5591 t
= gfc_add_save (¤t_attr
, SAVE_EXPLICIT
, NULL
, &seen_at
[d
]);
5594 case DECL_AUTOMATIC
:
5595 t
= gfc_add_automatic (¤t_attr
, NULL
, &seen_at
[d
]);
5599 t
= gfc_add_target (¤t_attr
, &seen_at
[d
]);
5602 case DECL_IS_BIND_C
:
5603 t
= gfc_add_is_bind_c(¤t_attr
, NULL
, &seen_at
[d
], 0);
5607 if (!gfc_notify_std (GFC_STD_F2003
, "VALUE attribute at %C"))
5610 t
= gfc_add_value (¤t_attr
, NULL
, &seen_at
[d
]);
5614 if (!gfc_notify_std (GFC_STD_F2003
, "VOLATILE attribute at %C"))
5617 t
= gfc_add_volatile (¤t_attr
, NULL
, &seen_at
[d
]);
5621 gfc_internal_error ("match_attr_spec(): Bad attribute");
5631 /* Since Fortran 2008 module variables implicitly have the SAVE attribute. */
5632 if ((gfc_current_state () == COMP_MODULE
5633 || gfc_current_state () == COMP_SUBMODULE
)
5634 && !current_attr
.save
5635 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
5636 current_attr
.save
= SAVE_IMPLICIT
;
5642 gfc_current_locus
= start
;
5643 gfc_free_array_spec (current_as
);
5650 /* Set the binding label, dest_label, either with the binding label
5651 stored in the given gfc_typespec, ts, or if none was provided, it
5652 will be the symbol name in all lower case, as required by the draft
5653 (J3/04-007, section 15.4.1). If a binding label was given and
5654 there is more than one argument (num_idents), it is an error. */
5657 set_binding_label (const char **dest_label
, const char *sym_name
,
5660 if (num_idents
> 1 && has_name_equals
)
5662 gfc_error ("Multiple identifiers provided with "
5663 "single NAME= specifier at %C");
5667 if (curr_binding_label
)
5668 /* Binding label given; store in temp holder till have sym. */
5669 *dest_label
= curr_binding_label
;
5672 /* No binding label given, and the NAME= specifier did not exist,
5673 which means there was no NAME="". */
5674 if (sym_name
!= NULL
&& has_name_equals
== 0)
5675 *dest_label
= IDENTIFIER_POINTER (get_identifier (sym_name
));
5682 /* Set the status of the given common block as being BIND(C) or not,
5683 depending on the given parameter, is_bind_c. */
5686 set_com_block_bind_c (gfc_common_head
*com_block
, int is_bind_c
)
5688 com_block
->is_bind_c
= is_bind_c
;
5693 /* Verify that the given gfc_typespec is for a C interoperable type. */
5696 gfc_verify_c_interop (gfc_typespec
*ts
)
5698 if (ts
->type
== BT_DERIVED
&& ts
->u
.derived
!= NULL
)
5699 return (ts
->u
.derived
->ts
.is_c_interop
|| ts
->u
.derived
->attr
.is_bind_c
)
5701 else if (ts
->type
== BT_CLASS
)
5703 else if (ts
->is_c_interop
!= 1 && ts
->type
!= BT_ASSUMED
)
5710 /* Verify that the variables of a given common block, which has been
5711 defined with the attribute specifier bind(c), to be of a C
5712 interoperable type. Errors will be reported here, if
5716 verify_com_block_vars_c_interop (gfc_common_head
*com_block
)
5718 gfc_symbol
*curr_sym
= NULL
;
5721 curr_sym
= com_block
->head
;
5723 /* Make sure we have at least one symbol. */
5724 if (curr_sym
== NULL
)
5727 /* Here we know we have a symbol, so we'll execute this loop
5731 /* The second to last param, 1, says this is in a common block. */
5732 retval
= verify_bind_c_sym (curr_sym
, &(curr_sym
->ts
), 1, com_block
);
5733 curr_sym
= curr_sym
->common_next
;
5734 } while (curr_sym
!= NULL
);
5740 /* Verify that a given BIND(C) symbol is C interoperable. If it is not,
5741 an appropriate error message is reported. */
5744 verify_bind_c_sym (gfc_symbol
*tmp_sym
, gfc_typespec
*ts
,
5745 int is_in_common
, gfc_common_head
*com_block
)
5747 bool bind_c_function
= false;
5750 if (tmp_sym
->attr
.function
&& tmp_sym
->attr
.is_bind_c
)
5751 bind_c_function
= true;
5753 if (tmp_sym
->attr
.function
&& tmp_sym
->result
!= NULL
)
5755 tmp_sym
= tmp_sym
->result
;
5756 /* Make sure it wasn't an implicitly typed result. */
5757 if (tmp_sym
->attr
.implicit_type
&& warn_c_binding_type
)
5759 gfc_warning (OPT_Wc_binding_type
,
5760 "Implicitly declared BIND(C) function %qs at "
5761 "%L may not be C interoperable", tmp_sym
->name
,
5762 &tmp_sym
->declared_at
);
5763 tmp_sym
->ts
.f90_type
= tmp_sym
->ts
.type
;
5764 /* Mark it as C interoperable to prevent duplicate warnings. */
5765 tmp_sym
->ts
.is_c_interop
= 1;
5766 tmp_sym
->attr
.is_c_interop
= 1;
5770 /* Here, we know we have the bind(c) attribute, so if we have
5771 enough type info, then verify that it's a C interop kind.
5772 The info could be in the symbol already, or possibly still in
5773 the given ts (current_ts), so look in both. */
5774 if (tmp_sym
->ts
.type
!= BT_UNKNOWN
|| ts
->type
!= BT_UNKNOWN
)
5776 if (!gfc_verify_c_interop (&(tmp_sym
->ts
)))
5778 /* See if we're dealing with a sym in a common block or not. */
5779 if (is_in_common
== 1 && warn_c_binding_type
)
5781 gfc_warning (OPT_Wc_binding_type
,
5782 "Variable %qs in common block %qs at %L "
5783 "may not be a C interoperable "
5784 "kind though common block %qs is BIND(C)",
5785 tmp_sym
->name
, com_block
->name
,
5786 &(tmp_sym
->declared_at
), com_block
->name
);
5790 if (tmp_sym
->ts
.type
== BT_DERIVED
|| ts
->type
== BT_DERIVED
)
5791 gfc_error ("Type declaration %qs at %L is not C "
5792 "interoperable but it is BIND(C)",
5793 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5794 else if (warn_c_binding_type
)
5795 gfc_warning (OPT_Wc_binding_type
, "Variable %qs at %L "
5796 "may not be a C interoperable "
5797 "kind but it is BIND(C)",
5798 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5802 /* Variables declared w/in a common block can't be bind(c)
5803 since there's no way for C to see these variables, so there's
5804 semantically no reason for the attribute. */
5805 if (is_in_common
== 1 && tmp_sym
->attr
.is_bind_c
== 1)
5807 gfc_error ("Variable %qs in common block %qs at "
5808 "%L cannot be declared with BIND(C) "
5809 "since it is not a global",
5810 tmp_sym
->name
, com_block
->name
,
5811 &(tmp_sym
->declared_at
));
5815 /* Scalar variables that are bind(c) cannot have the pointer
5816 or allocatable attributes. */
5817 if (tmp_sym
->attr
.is_bind_c
== 1)
5819 if (tmp_sym
->attr
.pointer
== 1)
5821 gfc_error ("Variable %qs at %L cannot have both the "
5822 "POINTER and BIND(C) attributes",
5823 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5827 if (tmp_sym
->attr
.allocatable
== 1)
5829 gfc_error ("Variable %qs at %L cannot have both the "
5830 "ALLOCATABLE and BIND(C) attributes",
5831 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5837 /* If it is a BIND(C) function, make sure the return value is a
5838 scalar value. The previous tests in this function made sure
5839 the type is interoperable. */
5840 if (bind_c_function
&& tmp_sym
->as
!= NULL
)
5841 gfc_error ("Return type of BIND(C) function %qs at %L cannot "
5842 "be an array", tmp_sym
->name
, &(tmp_sym
->declared_at
));
5844 /* BIND(C) functions cannot return a character string. */
5845 if (bind_c_function
&& tmp_sym
->ts
.type
== BT_CHARACTER
)
5846 if (tmp_sym
->ts
.u
.cl
== NULL
|| tmp_sym
->ts
.u
.cl
->length
== NULL
5847 || tmp_sym
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
5848 || mpz_cmp_si (tmp_sym
->ts
.u
.cl
->length
->value
.integer
, 1) != 0)
5849 gfc_error ("Return type of BIND(C) function %qs of character "
5850 "type at %L must have length 1", tmp_sym
->name
,
5851 &(tmp_sym
->declared_at
));
5854 /* See if the symbol has been marked as private. If it has, make sure
5855 there is no binding label and warn the user if there is one. */
5856 if (tmp_sym
->attr
.access
== ACCESS_PRIVATE
5857 && tmp_sym
->binding_label
)
5858 /* Use gfc_warning_now because we won't say that the symbol fails
5859 just because of this. */
5860 gfc_warning_now (0, "Symbol %qs at %L is marked PRIVATE but has been "
5861 "given the binding label %qs", tmp_sym
->name
,
5862 &(tmp_sym
->declared_at
), tmp_sym
->binding_label
);
5868 /* Set the appropriate fields for a symbol that's been declared as
5869 BIND(C) (the is_bind_c flag and the binding label), and verify that
5870 the type is C interoperable. Errors are reported by the functions
5871 used to set/test these fields. */
5874 set_verify_bind_c_sym (gfc_symbol
*tmp_sym
, int num_idents
)
5878 /* TODO: Do we need to make sure the vars aren't marked private? */
5880 /* Set the is_bind_c bit in symbol_attribute. */
5881 gfc_add_is_bind_c (&(tmp_sym
->attr
), tmp_sym
->name
, &gfc_current_locus
, 0);
5883 if (!set_binding_label (&tmp_sym
->binding_label
, tmp_sym
->name
, num_idents
))
5890 /* Set the fields marking the given common block as BIND(C), including
5891 a binding label, and report any errors encountered. */
5894 set_verify_bind_c_com_block (gfc_common_head
*com_block
, int num_idents
)
5898 /* destLabel, common name, typespec (which may have binding label). */
5899 if (!set_binding_label (&com_block
->binding_label
, com_block
->name
,
5903 /* Set the given common block (com_block) to being bind(c) (1). */
5904 set_com_block_bind_c (com_block
, 1);
5910 /* Retrieve the list of one or more identifiers that the given bind(c)
5911 attribute applies to. */
5914 get_bind_c_idents (void)
5916 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5918 gfc_symbol
*tmp_sym
= NULL
;
5920 gfc_common_head
*com_block
= NULL
;
5922 if (gfc_match_name (name
) == MATCH_YES
)
5924 found_id
= MATCH_YES
;
5925 gfc_get_ha_symbol (name
, &tmp_sym
);
5927 else if (match_common_name (name
) == MATCH_YES
)
5929 found_id
= MATCH_YES
;
5930 com_block
= gfc_get_common (name
, 0);
5934 gfc_error ("Need either entity or common block name for "
5935 "attribute specification statement at %C");
5939 /* Save the current identifier and look for more. */
5942 /* Increment the number of identifiers found for this spec stmt. */
5945 /* Make sure we have a sym or com block, and verify that it can
5946 be bind(c). Set the appropriate field(s) and look for more
5948 if (tmp_sym
!= NULL
|| com_block
!= NULL
)
5950 if (tmp_sym
!= NULL
)
5952 if (!set_verify_bind_c_sym (tmp_sym
, num_idents
))
5957 if (!set_verify_bind_c_com_block (com_block
, num_idents
))
5961 /* Look to see if we have another identifier. */
5963 if (gfc_match_eos () == MATCH_YES
)
5964 found_id
= MATCH_NO
;
5965 else if (gfc_match_char (',') != MATCH_YES
)
5966 found_id
= MATCH_NO
;
5967 else if (gfc_match_name (name
) == MATCH_YES
)
5969 found_id
= MATCH_YES
;
5970 gfc_get_ha_symbol (name
, &tmp_sym
);
5972 else if (match_common_name (name
) == MATCH_YES
)
5974 found_id
= MATCH_YES
;
5975 com_block
= gfc_get_common (name
, 0);
5979 gfc_error ("Missing entity or common block name for "
5980 "attribute specification statement at %C");
5986 gfc_internal_error ("Missing symbol");
5988 } while (found_id
== MATCH_YES
);
5990 /* if we get here we were successful */
5995 /* Try and match a BIND(C) attribute specification statement. */
5998 gfc_match_bind_c_stmt (void)
6000 match found_match
= MATCH_NO
;
6005 /* This may not be necessary. */
6007 /* Clear the temporary binding label holder. */
6008 curr_binding_label
= NULL
;
6010 /* Look for the bind(c). */
6011 found_match
= gfc_match_bind_c (NULL
, true);
6013 if (found_match
== MATCH_YES
)
6015 if (!gfc_notify_std (GFC_STD_F2003
, "BIND(C) statement at %C"))
6018 /* Look for the :: now, but it is not required. */
6021 /* Get the identifier(s) that needs to be updated. This may need to
6022 change to hand the flag(s) for the attr specified so all identifiers
6023 found can have all appropriate parts updated (assuming that the same
6024 spec stmt can have multiple attrs, such as both bind(c) and
6026 if (!get_bind_c_idents ())
6027 /* Error message should have printed already. */
6035 /* Match a data declaration statement. */
6038 gfc_match_data_decl (void)
6044 type_param_spec_list
= NULL
;
6045 decl_type_param_list
= NULL
;
6047 num_idents_on_line
= 0;
6049 m
= gfc_match_decl_type_spec (¤t_ts
, 0);
6053 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
6054 && !gfc_comp_struct (gfc_current_state ()))
6056 sym
= gfc_use_derived (current_ts
.u
.derived
);
6064 current_ts
.u
.derived
= sym
;
6067 m
= match_attr_spec ();
6068 if (m
== MATCH_ERROR
)
6074 if (current_ts
.type
== BT_CLASS
6075 && current_ts
.u
.derived
->attr
.unlimited_polymorphic
)
6078 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
6079 && current_ts
.u
.derived
->components
== NULL
6080 && !current_ts
.u
.derived
->attr
.zero_comp
)
6083 if (current_attr
.pointer
&& gfc_comp_struct (gfc_current_state ()))
6086 if (current_attr
.allocatable
&& gfc_current_state () == COMP_DERIVED
)
6089 gfc_find_symbol (current_ts
.u
.derived
->name
,
6090 current_ts
.u
.derived
->ns
, 1, &sym
);
6092 /* Any symbol that we find had better be a type definition
6093 which has its components defined, or be a structure definition
6094 actively being parsed. */
6095 if (sym
!= NULL
&& gfc_fl_struct (sym
->attr
.flavor
)
6096 && (current_ts
.u
.derived
->components
!= NULL
6097 || current_ts
.u
.derived
->attr
.zero_comp
6098 || current_ts
.u
.derived
== gfc_new_block
))
6101 gfc_error ("Derived type at %C has not been previously defined "
6102 "and so cannot appear in a derived type definition");
6108 /* If we have an old-style character declaration, and no new-style
6109 attribute specifications, then there a comma is optional between
6110 the type specification and the variable list. */
6111 if (m
== MATCH_NO
&& current_ts
.type
== BT_CHARACTER
&& old_char_selector
)
6112 gfc_match_char (',');
6114 /* Give the types/attributes to symbols that follow. Give the element
6115 a number so that repeat character length expressions can be copied. */
6119 num_idents_on_line
++;
6120 m
= variable_decl (elem
++);
6121 if (m
== MATCH_ERROR
)
6126 if (gfc_match_eos () == MATCH_YES
)
6128 if (gfc_match_char (',') != MATCH_YES
)
6132 if (!gfc_error_flag_test ())
6134 /* An anonymous structure declaration is unambiguous; if we matched one
6135 according to gfc_match_structure_decl, we need to return MATCH_YES
6136 here to avoid confusing the remaining matchers, even if there was an
6137 error during variable_decl. We must flush any such errors. Note this
6138 causes the parser to gracefully continue parsing the remaining input
6139 as a structure body, which likely follows. */
6140 if (current_ts
.type
== BT_DERIVED
&& current_ts
.u
.derived
6141 && gfc_fl_struct (current_ts
.u
.derived
->attr
.flavor
))
6143 gfc_error_now ("Syntax error in anonymous structure declaration"
6145 /* Skip the bad variable_decl and line up for the start of the
6147 gfc_error_recovery ();
6152 gfc_error ("Syntax error in data declaration at %C");
6157 gfc_free_data_all (gfc_current_ns
);
6160 if (saved_kind_expr
)
6161 gfc_free_expr (saved_kind_expr
);
6162 if (type_param_spec_list
)
6163 gfc_free_actual_arglist (type_param_spec_list
);
6164 if (decl_type_param_list
)
6165 gfc_free_actual_arglist (decl_type_param_list
);
6166 saved_kind_expr
= NULL
;
6167 gfc_free_array_spec (current_as
);
6173 in_module_or_interface(void)
6175 if (gfc_current_state () == COMP_MODULE
6176 || gfc_current_state () == COMP_SUBMODULE
6177 || gfc_current_state () == COMP_INTERFACE
)
6180 if (gfc_state_stack
->state
== COMP_CONTAINS
6181 || gfc_state_stack
->state
== COMP_FUNCTION
6182 || gfc_state_stack
->state
== COMP_SUBROUTINE
)
6185 for (p
= gfc_state_stack
->previous
; p
; p
= p
->previous
)
6187 if (p
->state
== COMP_MODULE
|| p
->state
== COMP_SUBMODULE
6188 || p
->state
== COMP_INTERFACE
)
6195 /* Match a prefix associated with a function or subroutine
6196 declaration. If the typespec pointer is nonnull, then a typespec
6197 can be matched. Note that if nothing matches, MATCH_YES is
6198 returned (the null string was matched). */
6201 gfc_match_prefix (gfc_typespec
*ts
)
6207 gfc_clear_attr (¤t_attr
);
6209 seen_impure
= false;
6211 gcc_assert (!gfc_matching_prefix
);
6212 gfc_matching_prefix
= true;
6216 found_prefix
= false;
6218 /* MODULE is a prefix like PURE, ELEMENTAL, etc., having a
6219 corresponding attribute seems natural and distinguishes these
6220 procedures from procedure types of PROC_MODULE, which these are
6222 if (gfc_match ("module% ") == MATCH_YES
)
6224 if (!gfc_notify_std (GFC_STD_F2008
, "MODULE prefix at %C"))
6227 if (!in_module_or_interface ())
6229 gfc_error ("MODULE prefix at %C found outside of a module, "
6230 "submodule, or interface");
6234 current_attr
.module_procedure
= 1;
6235 found_prefix
= true;
6238 if (!seen_type
&& ts
!= NULL
)
6241 m
= gfc_match_decl_type_spec (ts
, 0);
6242 if (m
== MATCH_ERROR
)
6244 if (m
== MATCH_YES
&& gfc_match_space () == MATCH_YES
)
6247 found_prefix
= true;
6251 if (gfc_match ("elemental% ") == MATCH_YES
)
6253 if (!gfc_add_elemental (¤t_attr
, NULL
))
6256 found_prefix
= true;
6259 if (gfc_match ("pure% ") == MATCH_YES
)
6261 if (!gfc_add_pure (¤t_attr
, NULL
))
6264 found_prefix
= true;
6267 if (gfc_match ("recursive% ") == MATCH_YES
)
6269 if (!gfc_add_recursive (¤t_attr
, NULL
))
6272 found_prefix
= true;
6275 /* IMPURE is a somewhat special case, as it needs not set an actual
6276 attribute but rather only prevents ELEMENTAL routines from being
6277 automatically PURE. */
6278 if (gfc_match ("impure% ") == MATCH_YES
)
6280 if (!gfc_notify_std (GFC_STD_F2008
, "IMPURE procedure at %C"))
6284 found_prefix
= true;
6287 while (found_prefix
);
6289 /* IMPURE and PURE must not both appear, of course. */
6290 if (seen_impure
&& current_attr
.pure
)
6292 gfc_error ("PURE and IMPURE must not appear both at %C");
6296 /* If IMPURE it not seen but the procedure is ELEMENTAL, mark it as PURE. */
6297 if (!seen_impure
&& current_attr
.elemental
&& !current_attr
.pure
)
6299 if (!gfc_add_pure (¤t_attr
, NULL
))
6303 /* At this point, the next item is not a prefix. */
6304 gcc_assert (gfc_matching_prefix
);
6306 gfc_matching_prefix
= false;
6310 gcc_assert (gfc_matching_prefix
);
6311 gfc_matching_prefix
= false;
6316 /* Copy attributes matched by gfc_match_prefix() to attributes on a symbol. */
6319 copy_prefix (symbol_attribute
*dest
, locus
*where
)
6321 if (dest
->module_procedure
)
6323 if (current_attr
.elemental
)
6324 dest
->elemental
= 1;
6326 if (current_attr
.pure
)
6329 if (current_attr
.recursive
)
6330 dest
->recursive
= 1;
6332 /* Module procedures are unusual in that the 'dest' is copied from
6333 the interface declaration. However, this is an oportunity to
6334 check that the submodule declaration is compliant with the
6336 if (dest
->elemental
&& !current_attr
.elemental
)
6338 gfc_error ("ELEMENTAL prefix in MODULE PROCEDURE interface is "
6339 "missing at %L", where
);
6343 if (dest
->pure
&& !current_attr
.pure
)
6345 gfc_error ("PURE prefix in MODULE PROCEDURE interface is "
6346 "missing at %L", where
);
6350 if (dest
->recursive
&& !current_attr
.recursive
)
6352 gfc_error ("RECURSIVE prefix in MODULE PROCEDURE interface is "
6353 "missing at %L", where
);
6360 if (current_attr
.elemental
&& !gfc_add_elemental (dest
, where
))
6363 if (current_attr
.pure
&& !gfc_add_pure (dest
, where
))
6366 if (current_attr
.recursive
&& !gfc_add_recursive (dest
, where
))
6373 /* Match a formal argument list or, if typeparam is true, a
6374 type_param_name_list. */
6377 gfc_match_formal_arglist (gfc_symbol
*progname
, int st_flag
,
6378 int null_flag
, bool typeparam
)
6380 gfc_formal_arglist
*head
, *tail
, *p
, *q
;
6381 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6384 gfc_formal_arglist
*formal
= NULL
;
6388 /* Keep the interface formal argument list and null it so that the
6389 matching for the new declaration can be done. The numbers and
6390 names of the arguments are checked here. The interface formal
6391 arguments are retained in formal_arglist and the characteristics
6392 are compared in resolve.c(resolve_fl_procedure). See the remark
6393 in get_proc_name about the eventual need to copy the formal_arglist
6394 and populate the formal namespace of the interface symbol. */
6395 if (progname
->attr
.module_procedure
6396 && progname
->attr
.host_assoc
)
6398 formal
= progname
->formal
;
6399 progname
->formal
= NULL
;
6402 if (gfc_match_char ('(') != MATCH_YES
)
6409 if (gfc_match_char (')') == MATCH_YES
)
6413 gfc_error_now ("A type parameter list is required at %C");
6423 if (gfc_match_char ('*') == MATCH_YES
)
6426 if (!typeparam
&& !gfc_notify_std (GFC_STD_F95_OBS
,
6427 "Alternate-return argument at %C"))
6433 gfc_error_now ("A parameter name is required at %C");
6437 m
= gfc_match_name (name
);
6441 gfc_error_now ("A parameter name is required at %C");
6445 if (!typeparam
&& gfc_get_symbol (name
, NULL
, &sym
))
6448 && gfc_get_symbol (name
, progname
->f2k_derived
, &sym
))
6452 p
= gfc_get_formal_arglist ();
6464 /* We don't add the VARIABLE flavor because the name could be a
6465 dummy procedure. We don't apply these attributes to formal
6466 arguments of statement functions. */
6467 if (sym
!= NULL
&& !st_flag
6468 && (!gfc_add_dummy(&sym
->attr
, sym
->name
, NULL
)
6469 || !gfc_missing_attr (&sym
->attr
, NULL
)))
6475 /* The name of a program unit can be in a different namespace,
6476 so check for it explicitly. After the statement is accepted,
6477 the name is checked for especially in gfc_get_symbol(). */
6478 if (gfc_new_block
!= NULL
&& sym
!= NULL
&& !typeparam
6479 && strcmp (sym
->name
, gfc_new_block
->name
) == 0)
6481 gfc_error ("Name %qs at %C is the name of the procedure",
6487 if (gfc_match_char (')') == MATCH_YES
)
6490 m
= gfc_match_char (',');
6494 gfc_error_now ("Expected parameter list in type declaration "
6497 gfc_error ("Unexpected junk in formal argument list at %C");
6503 /* Check for duplicate symbols in the formal argument list. */
6506 for (p
= head
; p
->next
; p
= p
->next
)
6511 for (q
= p
->next
; q
; q
= q
->next
)
6512 if (p
->sym
== q
->sym
)
6515 gfc_error_now ("Duplicate name %qs in parameter "
6516 "list at %C", p
->sym
->name
);
6518 gfc_error ("Duplicate symbol %qs in formal argument "
6519 "list at %C", p
->sym
->name
);
6527 if (!gfc_add_explicit_interface (progname
, IFSRC_DECL
, head
, NULL
))
6533 /* gfc_error_now used in following and return with MATCH_YES because
6534 doing otherwise results in a cascade of extraneous errors and in
6535 some cases an ICE in symbol.c(gfc_release_symbol). */
6536 if (progname
->attr
.module_procedure
&& progname
->attr
.host_assoc
)
6538 bool arg_count_mismatch
= false;
6540 if (!formal
&& head
)
6541 arg_count_mismatch
= true;
6543 /* Abbreviated module procedure declaration is not meant to have any
6544 formal arguments! */
6545 if (!progname
->abr_modproc_decl
&& formal
&& !head
)
6546 arg_count_mismatch
= true;
6548 for (p
= formal
, q
= head
; p
&& q
; p
= p
->next
, q
= q
->next
)
6550 if ((p
->next
!= NULL
&& q
->next
== NULL
)
6551 || (p
->next
== NULL
&& q
->next
!= NULL
))
6552 arg_count_mismatch
= true;
6553 else if ((p
->sym
== NULL
&& q
->sym
== NULL
)
6554 || strcmp (p
->sym
->name
, q
->sym
->name
) == 0)
6557 gfc_error_now ("Mismatch in MODULE PROCEDURE formal "
6558 "argument names (%s/%s) at %C",
6559 p
->sym
->name
, q
->sym
->name
);
6562 if (arg_count_mismatch
)
6563 gfc_error_now ("Mismatch in number of MODULE PROCEDURE "
6564 "formal arguments at %C");
6570 gfc_free_formal_arglist (head
);
6575 /* Match a RESULT specification following a function declaration or
6576 ENTRY statement. Also matches the end-of-statement. */
6579 match_result (gfc_symbol
*function
, gfc_symbol
**result
)
6581 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6585 if (gfc_match (" result (") != MATCH_YES
)
6588 m
= gfc_match_name (name
);
6592 /* Get the right paren, and that's it because there could be the
6593 bind(c) attribute after the result clause. */
6594 if (gfc_match_char (')') != MATCH_YES
)
6596 /* TODO: should report the missing right paren here. */
6600 if (strcmp (function
->name
, name
) == 0)
6602 gfc_error ("RESULT variable at %C must be different than function name");
6606 if (gfc_get_symbol (name
, NULL
, &r
))
6609 if (!gfc_add_result (&r
->attr
, r
->name
, NULL
))
6618 /* Match a function suffix, which could be a combination of a result
6619 clause and BIND(C), either one, or neither. The draft does not
6620 require them to come in a specific order. */
6623 gfc_match_suffix (gfc_symbol
*sym
, gfc_symbol
**result
)
6625 match is_bind_c
; /* Found bind(c). */
6626 match is_result
; /* Found result clause. */
6627 match found_match
; /* Status of whether we've found a good match. */
6628 char peek_char
; /* Character we're going to peek at. */
6629 bool allow_binding_name
;
6631 /* Initialize to having found nothing. */
6632 found_match
= MATCH_NO
;
6633 is_bind_c
= MATCH_NO
;
6634 is_result
= MATCH_NO
;
6636 /* Get the next char to narrow between result and bind(c). */
6637 gfc_gobble_whitespace ();
6638 peek_char
= gfc_peek_ascii_char ();
6640 /* C binding names are not allowed for internal procedures. */
6641 if (gfc_current_state () == COMP_CONTAINS
6642 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
6643 allow_binding_name
= false;
6645 allow_binding_name
= true;
6650 /* Look for result clause. */
6651 is_result
= match_result (sym
, result
);
6652 if (is_result
== MATCH_YES
)
6654 /* Now see if there is a bind(c) after it. */
6655 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
6656 /* We've found the result clause and possibly bind(c). */
6657 found_match
= MATCH_YES
;
6660 /* This should only be MATCH_ERROR. */
6661 found_match
= is_result
;
6664 /* Look for bind(c) first. */
6665 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
6666 if (is_bind_c
== MATCH_YES
)
6668 /* Now see if a result clause followed it. */
6669 is_result
= match_result (sym
, result
);
6670 found_match
= MATCH_YES
;
6674 /* Should only be a MATCH_ERROR if we get here after seeing 'b'. */
6675 found_match
= MATCH_ERROR
;
6679 gfc_error ("Unexpected junk after function declaration at %C");
6680 found_match
= MATCH_ERROR
;
6684 if (is_bind_c
== MATCH_YES
)
6686 /* Fortran 2008 draft allows BIND(C) for internal procedures. */
6687 if (gfc_current_state () == COMP_CONTAINS
6688 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
6689 && !gfc_notify_std (GFC_STD_F2008
, "BIND(C) attribute "
6690 "at %L may not be specified for an internal "
6691 "procedure", &gfc_current_locus
))
6694 if (!gfc_add_is_bind_c (&(sym
->attr
), sym
->name
, &gfc_current_locus
, 1))
6702 /* Procedure pointer return value without RESULT statement:
6703 Add "hidden" result variable named "ppr@". */
6706 add_hidden_procptr_result (gfc_symbol
*sym
)
6710 if (gfc_notification_std (GFC_STD_F2003
) == ERROR
)
6713 /* First usage case: PROCEDURE and EXTERNAL statements. */
6714 case1
= gfc_current_state () == COMP_FUNCTION
&& gfc_current_block ()
6715 && strcmp (gfc_current_block ()->name
, sym
->name
) == 0
6716 && sym
->attr
.external
;
6717 /* Second usage case: INTERFACE statements. */
6718 case2
= gfc_current_state () == COMP_INTERFACE
&& gfc_state_stack
->previous
6719 && gfc_state_stack
->previous
->state
== COMP_FUNCTION
6720 && strcmp (gfc_state_stack
->previous
->sym
->name
, sym
->name
) == 0;
6726 gfc_get_sym_tree ("ppr@", gfc_current_ns
, &stree
, false);
6730 gfc_get_sym_tree ("ppr@", gfc_current_ns
->parent
, &stree
, false);
6731 st2
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "ppr@");
6732 st2
->n
.sym
= stree
->n
.sym
;
6733 stree
->n
.sym
->refs
++;
6735 sym
->result
= stree
->n
.sym
;
6737 sym
->result
->attr
.proc_pointer
= sym
->attr
.proc_pointer
;
6738 sym
->result
->attr
.pointer
= sym
->attr
.pointer
;
6739 sym
->result
->attr
.external
= sym
->attr
.external
;
6740 sym
->result
->attr
.referenced
= sym
->attr
.referenced
;
6741 sym
->result
->ts
= sym
->ts
;
6742 sym
->attr
.proc_pointer
= 0;
6743 sym
->attr
.pointer
= 0;
6744 sym
->attr
.external
= 0;
6745 if (sym
->result
->attr
.external
&& sym
->result
->attr
.pointer
)
6747 sym
->result
->attr
.pointer
= 0;
6748 sym
->result
->attr
.proc_pointer
= 1;
6751 return gfc_add_result (&sym
->result
->attr
, sym
->result
->name
, NULL
);
6753 /* POINTER after PROCEDURE/EXTERNAL/INTERFACE statement. */
6754 else if (sym
->attr
.function
&& !sym
->attr
.external
&& sym
->attr
.pointer
6755 && sym
->result
&& sym
->result
!= sym
&& sym
->result
->attr
.external
6756 && sym
== gfc_current_ns
->proc_name
6757 && sym
== sym
->result
->ns
->proc_name
6758 && strcmp ("ppr@", sym
->result
->name
) == 0)
6760 sym
->result
->attr
.proc_pointer
= 1;
6761 sym
->attr
.pointer
= 0;
6769 /* Match the interface for a PROCEDURE declaration,
6770 including brackets (R1212). */
6773 match_procedure_interface (gfc_symbol
**proc_if
)
6777 locus old_loc
, entry_loc
;
6778 gfc_namespace
*old_ns
= gfc_current_ns
;
6779 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6781 old_loc
= entry_loc
= gfc_current_locus
;
6782 gfc_clear_ts (¤t_ts
);
6784 if (gfc_match (" (") != MATCH_YES
)
6786 gfc_current_locus
= entry_loc
;
6790 /* Get the type spec. for the procedure interface. */
6791 old_loc
= gfc_current_locus
;
6792 m
= gfc_match_decl_type_spec (¤t_ts
, 0);
6793 gfc_gobble_whitespace ();
6794 if (m
== MATCH_YES
|| (m
== MATCH_NO
&& gfc_peek_ascii_char () == ')'))
6797 if (m
== MATCH_ERROR
)
6800 /* Procedure interface is itself a procedure. */
6801 gfc_current_locus
= old_loc
;
6802 m
= gfc_match_name (name
);
6804 /* First look to see if it is already accessible in the current
6805 namespace because it is use associated or contained. */
6807 if (gfc_find_sym_tree (name
, NULL
, 0, &st
))
6810 /* If it is still not found, then try the parent namespace, if it
6811 exists and create the symbol there if it is still not found. */
6812 if (gfc_current_ns
->parent
)
6813 gfc_current_ns
= gfc_current_ns
->parent
;
6814 if (st
== NULL
&& gfc_get_ha_sym_tree (name
, &st
))
6817 gfc_current_ns
= old_ns
;
6818 *proc_if
= st
->n
.sym
;
6823 /* Resolve interface if possible. That way, attr.procedure is only set
6824 if it is declared by a later procedure-declaration-stmt, which is
6825 invalid per F08:C1216 (cf. resolve_procedure_interface). */
6826 while ((*proc_if
)->ts
.interface
6827 && *proc_if
!= (*proc_if
)->ts
.interface
)
6828 *proc_if
= (*proc_if
)->ts
.interface
;
6830 if ((*proc_if
)->attr
.flavor
== FL_UNKNOWN
6831 && (*proc_if
)->ts
.type
== BT_UNKNOWN
6832 && !gfc_add_flavor (&(*proc_if
)->attr
, FL_PROCEDURE
,
6833 (*proc_if
)->name
, NULL
))
6838 if (gfc_match (" )") != MATCH_YES
)
6840 gfc_current_locus
= entry_loc
;
6848 /* Match a PROCEDURE declaration (R1211). */
6851 match_procedure_decl (void)
6854 gfc_symbol
*sym
, *proc_if
= NULL
;
6856 gfc_expr
*initializer
= NULL
;
6858 /* Parse interface (with brackets). */
6859 m
= match_procedure_interface (&proc_if
);
6863 /* Parse attributes (with colons). */
6864 m
= match_attr_spec();
6865 if (m
== MATCH_ERROR
)
6868 if (proc_if
&& proc_if
->attr
.is_bind_c
&& !current_attr
.is_bind_c
)
6870 current_attr
.is_bind_c
= 1;
6871 has_name_equals
= 0;
6872 curr_binding_label
= NULL
;
6875 /* Get procedure symbols. */
6878 m
= gfc_match_symbol (&sym
, 0);
6881 else if (m
== MATCH_ERROR
)
6884 /* Add current_attr to the symbol attributes. */
6885 if (!gfc_copy_attr (&sym
->attr
, ¤t_attr
, NULL
))
6888 if (sym
->attr
.is_bind_c
)
6890 /* Check for C1218. */
6891 if (!proc_if
|| !proc_if
->attr
.is_bind_c
)
6893 gfc_error ("BIND(C) attribute at %C requires "
6894 "an interface with BIND(C)");
6897 /* Check for C1217. */
6898 if (has_name_equals
&& sym
->attr
.pointer
)
6900 gfc_error ("BIND(C) procedure with NAME may not have "
6901 "POINTER attribute at %C");
6904 if (has_name_equals
&& sym
->attr
.dummy
)
6906 gfc_error ("Dummy procedure at %C may not have "
6907 "BIND(C) attribute with NAME");
6910 /* Set binding label for BIND(C). */
6911 if (!set_binding_label (&sym
->binding_label
, sym
->name
, num
))
6915 if (!gfc_add_external (&sym
->attr
, NULL
))
6918 if (add_hidden_procptr_result (sym
))
6921 if (!gfc_add_proc (&sym
->attr
, sym
->name
, NULL
))
6924 /* Set interface. */
6925 if (proc_if
!= NULL
)
6927 if (sym
->ts
.type
!= BT_UNKNOWN
)
6929 gfc_error ("Procedure %qs at %L already has basic type of %s",
6930 sym
->name
, &gfc_current_locus
,
6931 gfc_basic_typename (sym
->ts
.type
));
6934 sym
->ts
.interface
= proc_if
;
6935 sym
->attr
.untyped
= 1;
6936 sym
->attr
.if_source
= IFSRC_IFBODY
;
6938 else if (current_ts
.type
!= BT_UNKNOWN
)
6940 if (!gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
6942 sym
->ts
.interface
= gfc_new_symbol ("", gfc_current_ns
);
6943 sym
->ts
.interface
->ts
= current_ts
;
6944 sym
->ts
.interface
->attr
.flavor
= FL_PROCEDURE
;
6945 sym
->ts
.interface
->attr
.function
= 1;
6946 sym
->attr
.function
= 1;
6947 sym
->attr
.if_source
= IFSRC_UNKNOWN
;
6950 if (gfc_match (" =>") == MATCH_YES
)
6952 if (!current_attr
.pointer
)
6954 gfc_error ("Initialization at %C isn't for a pointer variable");
6959 m
= match_pointer_init (&initializer
, 1);
6963 if (!add_init_expr_to_sym (sym
->name
, &initializer
, &gfc_current_locus
))
6968 if (gfc_match_eos () == MATCH_YES
)
6970 if (gfc_match_char (',') != MATCH_YES
)
6975 gfc_error ("Syntax error in PROCEDURE statement at %C");
6979 /* Free stuff up and return. */
6980 gfc_free_expr (initializer
);
6986 match_binding_attributes (gfc_typebound_proc
* ba
, bool generic
, bool ppc
);
6989 /* Match a procedure pointer component declaration (R445). */
6992 match_ppc_decl (void)
6995 gfc_symbol
*proc_if
= NULL
;
6999 gfc_expr
*initializer
= NULL
;
7000 gfc_typebound_proc
* tb
;
7001 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7003 /* Parse interface (with brackets). */
7004 m
= match_procedure_interface (&proc_if
);
7008 /* Parse attributes. */
7009 tb
= XCNEW (gfc_typebound_proc
);
7010 tb
->where
= gfc_current_locus
;
7011 m
= match_binding_attributes (tb
, false, true);
7012 if (m
== MATCH_ERROR
)
7015 gfc_clear_attr (¤t_attr
);
7016 current_attr
.procedure
= 1;
7017 current_attr
.proc_pointer
= 1;
7018 current_attr
.access
= tb
->access
;
7019 current_attr
.flavor
= FL_PROCEDURE
;
7021 /* Match the colons (required). */
7022 if (gfc_match (" ::") != MATCH_YES
)
7024 gfc_error ("Expected %<::%> after binding-attributes at %C");
7028 /* Check for C450. */
7029 if (!tb
->nopass
&& proc_if
== NULL
)
7031 gfc_error("NOPASS or explicit interface required at %C");
7035 if (!gfc_notify_std (GFC_STD_F2003
, "Procedure pointer component at %C"))
7038 /* Match PPC names. */
7042 m
= gfc_match_name (name
);
7045 else if (m
== MATCH_ERROR
)
7048 if (!gfc_add_component (gfc_current_block(), name
, &c
))
7051 /* Add current_attr to the symbol attributes. */
7052 if (!gfc_copy_attr (&c
->attr
, ¤t_attr
, NULL
))
7055 if (!gfc_add_external (&c
->attr
, NULL
))
7058 if (!gfc_add_proc (&c
->attr
, name
, NULL
))
7065 c
->tb
= XCNEW (gfc_typebound_proc
);
7066 c
->tb
->where
= gfc_current_locus
;
7070 /* Set interface. */
7071 if (proc_if
!= NULL
)
7073 c
->ts
.interface
= proc_if
;
7074 c
->attr
.untyped
= 1;
7075 c
->attr
.if_source
= IFSRC_IFBODY
;
7077 else if (ts
.type
!= BT_UNKNOWN
)
7080 c
->ts
.interface
= gfc_new_symbol ("", gfc_current_ns
);
7081 c
->ts
.interface
->result
= c
->ts
.interface
;
7082 c
->ts
.interface
->ts
= ts
;
7083 c
->ts
.interface
->attr
.flavor
= FL_PROCEDURE
;
7084 c
->ts
.interface
->attr
.function
= 1;
7085 c
->attr
.function
= 1;
7086 c
->attr
.if_source
= IFSRC_UNKNOWN
;
7089 if (gfc_match (" =>") == MATCH_YES
)
7091 m
= match_pointer_init (&initializer
, 1);
7094 gfc_free_expr (initializer
);
7097 c
->initializer
= initializer
;
7100 if (gfc_match_eos () == MATCH_YES
)
7102 if (gfc_match_char (',') != MATCH_YES
)
7107 gfc_error ("Syntax error in procedure pointer component at %C");
7112 /* Match a PROCEDURE declaration inside an interface (R1206). */
7115 match_procedure_in_interface (void)
7119 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7122 if (current_interface
.type
== INTERFACE_NAMELESS
7123 || current_interface
.type
== INTERFACE_ABSTRACT
)
7125 gfc_error ("PROCEDURE at %C must be in a generic interface");
7129 /* Check if the F2008 optional double colon appears. */
7130 gfc_gobble_whitespace ();
7131 old_locus
= gfc_current_locus
;
7132 if (gfc_match ("::") == MATCH_YES
)
7134 if (!gfc_notify_std (GFC_STD_F2008
, "double colon in "
7135 "MODULE PROCEDURE statement at %L", &old_locus
))
7139 gfc_current_locus
= old_locus
;
7143 m
= gfc_match_name (name
);
7146 else if (m
== MATCH_ERROR
)
7148 if (gfc_get_symbol (name
, gfc_current_ns
->parent
, &sym
))
7151 if (!gfc_add_interface (sym
))
7154 if (gfc_match_eos () == MATCH_YES
)
7156 if (gfc_match_char (',') != MATCH_YES
)
7163 gfc_error ("Syntax error in PROCEDURE statement at %C");
7168 /* General matcher for PROCEDURE declarations. */
7170 static match
match_procedure_in_type (void);
7173 gfc_match_procedure (void)
7177 switch (gfc_current_state ())
7182 case COMP_SUBMODULE
:
7183 case COMP_SUBROUTINE
:
7186 m
= match_procedure_decl ();
7188 case COMP_INTERFACE
:
7189 m
= match_procedure_in_interface ();
7192 m
= match_ppc_decl ();
7194 case COMP_DERIVED_CONTAINS
:
7195 m
= match_procedure_in_type ();
7204 if (!gfc_notify_std (GFC_STD_F2003
, "PROCEDURE statement at %C"))
7211 /* Warn if a matched procedure has the same name as an intrinsic; this is
7212 simply a wrapper around gfc_warn_intrinsic_shadow that interprets the current
7213 parser-state-stack to find out whether we're in a module. */
7216 do_warn_intrinsic_shadow (const gfc_symbol
* sym
, bool func
)
7220 in_module
= (gfc_state_stack
->previous
7221 && (gfc_state_stack
->previous
->state
== COMP_MODULE
7222 || gfc_state_stack
->previous
->state
== COMP_SUBMODULE
));
7224 gfc_warn_intrinsic_shadow (sym
, in_module
, func
);
7228 /* Match a function declaration. */
7231 gfc_match_function_decl (void)
7233 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7234 gfc_symbol
*sym
, *result
;
7238 match found_match
; /* Status returned by match func. */
7240 if (gfc_current_state () != COMP_NONE
7241 && gfc_current_state () != COMP_INTERFACE
7242 && gfc_current_state () != COMP_CONTAINS
)
7245 gfc_clear_ts (¤t_ts
);
7247 old_loc
= gfc_current_locus
;
7249 m
= gfc_match_prefix (¤t_ts
);
7252 gfc_current_locus
= old_loc
;
7256 if (gfc_match ("function% %n", name
) != MATCH_YES
)
7258 gfc_current_locus
= old_loc
;
7262 if (get_proc_name (name
, &sym
, false))
7265 if (add_hidden_procptr_result (sym
))
7268 if (current_attr
.module_procedure
)
7269 sym
->attr
.module_procedure
= 1;
7271 gfc_new_block
= sym
;
7273 m
= gfc_match_formal_arglist (sym
, 0, 0);
7276 gfc_error ("Expected formal argument list in function "
7277 "definition at %C");
7281 else if (m
== MATCH_ERROR
)
7286 /* According to the draft, the bind(c) and result clause can
7287 come in either order after the formal_arg_list (i.e., either
7288 can be first, both can exist together or by themselves or neither
7289 one). Therefore, the match_result can't match the end of the
7290 string, and check for the bind(c) or result clause in either order. */
7291 found_match
= gfc_match_eos ();
7293 /* Make sure that it isn't already declared as BIND(C). If it is, it
7294 must have been marked BIND(C) with a BIND(C) attribute and that is
7295 not allowed for procedures. */
7296 if (sym
->attr
.is_bind_c
== 1)
7298 sym
->attr
.is_bind_c
= 0;
7300 if (gfc_state_stack
->previous
7301 && gfc_state_stack
->previous
->state
!= COMP_SUBMODULE
)
7304 loc
= sym
->old_symbol
!= NULL
7305 ? sym
->old_symbol
->declared_at
: gfc_current_locus
;
7306 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7307 "variables or common blocks", &loc
);
7311 if (found_match
!= MATCH_YES
)
7313 /* If we haven't found the end-of-statement, look for a suffix. */
7314 suffix_match
= gfc_match_suffix (sym
, &result
);
7315 if (suffix_match
== MATCH_YES
)
7316 /* Need to get the eos now. */
7317 found_match
= gfc_match_eos ();
7319 found_match
= suffix_match
;
7322 /* F2018 C1550 (R1526) If MODULE appears in the prefix of a module
7323 subprogram and a binding label is specified, it shall be the
7324 same as the binding label specified in the corresponding module
7325 procedure interface body. */
7326 if (sym
->attr
.is_bind_c
&& sym
->attr
.module_procedure
&& sym
->old_symbol
7327 && strcmp (sym
->name
, sym
->old_symbol
->name
) == 0
7328 && strcmp (sym
->binding_label
, sym
->old_symbol
->binding_label
) != 0)
7330 const char *null
= "NULL", *s1
, *s2
;
7331 s1
= sym
->binding_label
;
7333 s2
= sym
->old_symbol
->binding_label
;
7335 gfc_error ("Mismatch in BIND(C) names (%qs/%qs) at %C", s1
, s2
);
7336 sym
->refs
++; /* Needed to avoid an ICE in gfc_release_symbol */
7340 if(found_match
!= MATCH_YES
)
7344 /* Make changes to the symbol. */
7347 if (!gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
7350 if (!gfc_missing_attr (&sym
->attr
, NULL
))
7353 if (!copy_prefix (&sym
->attr
, &sym
->declared_at
))
7355 if(!sym
->attr
.module_procedure
)
7361 /* Delay matching the function characteristics until after the
7362 specification block by signalling kind=-1. */
7363 sym
->declared_at
= old_loc
;
7364 if (current_ts
.type
!= BT_UNKNOWN
)
7365 current_ts
.kind
= -1;
7367 current_ts
.kind
= 0;
7371 if (current_ts
.type
!= BT_UNKNOWN
7372 && !gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
7378 if (current_ts
.type
!= BT_UNKNOWN
7379 && !gfc_add_type (result
, ¤t_ts
, &gfc_current_locus
))
7381 sym
->result
= result
;
7384 /* Warn if this procedure has the same name as an intrinsic. */
7385 do_warn_intrinsic_shadow (sym
, true);
7391 gfc_current_locus
= old_loc
;
7396 /* This is mostly a copy of parse.c(add_global_procedure) but modified to
7397 pass the name of the entry, rather than the gfc_current_block name, and
7398 to return false upon finding an existing global entry. */
7401 add_global_entry (const char *name
, const char *binding_label
, bool sub
,
7405 enum gfc_symbol_type type
;
7407 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
7409 /* Only in Fortran 2003: For procedures with a binding label also the Fortran
7410 name is a global identifier. */
7411 if (!binding_label
|| gfc_notification_std (GFC_STD_F2008
))
7413 s
= gfc_get_gsymbol (name
, false);
7415 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= type
))
7417 gfc_global_used (s
, where
);
7426 s
->ns
= gfc_current_ns
;
7430 /* Don't add the symbol multiple times. */
7432 && (!gfc_notification_std (GFC_STD_F2008
)
7433 || strcmp (name
, binding_label
) != 0))
7435 s
= gfc_get_gsymbol (binding_label
, true);
7437 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= type
))
7439 gfc_global_used (s
, where
);
7446 s
->binding_label
= binding_label
;
7449 s
->ns
= gfc_current_ns
;
7457 /* Match an ENTRY statement. */
7460 gfc_match_entry (void)
7465 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7466 gfc_compile_state state
;
7470 bool module_procedure
;
7474 m
= gfc_match_name (name
);
7478 if (!gfc_notify_std (GFC_STD_F2008_OBS
, "ENTRY statement at %C"))
7481 state
= gfc_current_state ();
7482 if (state
!= COMP_SUBROUTINE
&& state
!= COMP_FUNCTION
)
7487 gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
7490 gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
7492 case COMP_SUBMODULE
:
7493 gfc_error ("ENTRY statement at %C cannot appear within a SUBMODULE");
7495 case COMP_BLOCK_DATA
:
7496 gfc_error ("ENTRY statement at %C cannot appear within "
7499 case COMP_INTERFACE
:
7500 gfc_error ("ENTRY statement at %C cannot appear within "
7503 case COMP_STRUCTURE
:
7504 gfc_error ("ENTRY statement at %C cannot appear within "
7505 "a STRUCTURE block");
7508 gfc_error ("ENTRY statement at %C cannot appear within "
7509 "a DERIVED TYPE block");
7512 gfc_error ("ENTRY statement at %C cannot appear within "
7513 "an IF-THEN block");
7516 case COMP_DO_CONCURRENT
:
7517 gfc_error ("ENTRY statement at %C cannot appear within "
7521 gfc_error ("ENTRY statement at %C cannot appear within "
7525 gfc_error ("ENTRY statement at %C cannot appear within "
7529 gfc_error ("ENTRY statement at %C cannot appear within "
7533 gfc_error ("ENTRY statement at %C cannot appear within "
7534 "a contained subprogram");
7537 gfc_error ("Unexpected ENTRY statement at %C");
7542 if ((state
== COMP_SUBROUTINE
|| state
== COMP_FUNCTION
)
7543 && gfc_state_stack
->previous
->state
== COMP_INTERFACE
)
7545 gfc_error ("ENTRY statement at %C cannot appear within an INTERFACE");
7549 module_procedure
= gfc_current_ns
->parent
!= NULL
7550 && gfc_current_ns
->parent
->proc_name
7551 && gfc_current_ns
->parent
->proc_name
->attr
.flavor
7554 if (gfc_current_ns
->parent
!= NULL
7555 && gfc_current_ns
->parent
->proc_name
7556 && !module_procedure
)
7558 gfc_error("ENTRY statement at %C cannot appear in a "
7559 "contained procedure");
7563 /* Module function entries need special care in get_proc_name
7564 because previous references within the function will have
7565 created symbols attached to the current namespace. */
7566 if (get_proc_name (name
, &entry
,
7567 gfc_current_ns
->parent
!= NULL
7568 && module_procedure
))
7571 proc
= gfc_current_block ();
7573 /* Make sure that it isn't already declared as BIND(C). If it is, it
7574 must have been marked BIND(C) with a BIND(C) attribute and that is
7575 not allowed for procedures. */
7576 if (entry
->attr
.is_bind_c
== 1)
7580 entry
->attr
.is_bind_c
= 0;
7582 loc
= entry
->old_symbol
!= NULL
7583 ? entry
->old_symbol
->declared_at
: gfc_current_locus
;
7584 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7585 "variables or common blocks", &loc
);
7588 /* Check what next non-whitespace character is so we can tell if there
7589 is the required parens if we have a BIND(C). */
7590 old_loc
= gfc_current_locus
;
7591 gfc_gobble_whitespace ();
7592 peek_char
= gfc_peek_ascii_char ();
7594 if (state
== COMP_SUBROUTINE
)
7596 m
= gfc_match_formal_arglist (entry
, 0, 1);
7600 /* Call gfc_match_bind_c with allow_binding_name = true as ENTRY can
7601 never be an internal procedure. */
7602 is_bind_c
= gfc_match_bind_c (entry
, true);
7603 if (is_bind_c
== MATCH_ERROR
)
7605 if (is_bind_c
== MATCH_YES
)
7607 if (peek_char
!= '(')
7609 gfc_error ("Missing required parentheses before BIND(C) at %C");
7613 if (!gfc_add_is_bind_c (&(entry
->attr
), entry
->name
,
7614 &(entry
->declared_at
), 1))
7619 if (!gfc_current_ns
->parent
7620 && !add_global_entry (name
, entry
->binding_label
, true,
7624 /* An entry in a subroutine. */
7625 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
7626 || !gfc_add_subroutine (&entry
->attr
, entry
->name
, NULL
))
7631 /* An entry in a function.
7632 We need to take special care because writing
7637 ENTRY f() RESULT (r)
7639 ENTRY f RESULT (r). */
7640 if (gfc_match_eos () == MATCH_YES
)
7642 gfc_current_locus
= old_loc
;
7643 /* Match the empty argument list, and add the interface to
7645 m
= gfc_match_formal_arglist (entry
, 0, 1);
7648 m
= gfc_match_formal_arglist (entry
, 0, 0);
7655 if (gfc_match_eos () == MATCH_YES
)
7657 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
7658 || !gfc_add_function (&entry
->attr
, entry
->name
, NULL
))
7661 entry
->result
= entry
;
7665 m
= gfc_match_suffix (entry
, &result
);
7667 gfc_syntax_error (ST_ENTRY
);
7673 if (!gfc_add_result (&result
->attr
, result
->name
, NULL
)
7674 || !gfc_add_entry (&entry
->attr
, result
->name
, NULL
)
7675 || !gfc_add_function (&entry
->attr
, result
->name
, NULL
))
7677 entry
->result
= result
;
7681 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
7682 || !gfc_add_function (&entry
->attr
, entry
->name
, NULL
))
7684 entry
->result
= entry
;
7688 if (!gfc_current_ns
->parent
7689 && !add_global_entry (name
, entry
->binding_label
, false,
7694 if (gfc_match_eos () != MATCH_YES
)
7696 gfc_syntax_error (ST_ENTRY
);
7700 /* F2018:C1546 An elemental procedure shall not have the BIND attribute. */
7701 if (proc
->attr
.elemental
&& entry
->attr
.is_bind_c
)
7703 gfc_error ("ENTRY statement at %L with BIND(C) prohibited in an "
7704 "elemental procedure", &entry
->declared_at
);
7708 entry
->attr
.recursive
= proc
->attr
.recursive
;
7709 entry
->attr
.elemental
= proc
->attr
.elemental
;
7710 entry
->attr
.pure
= proc
->attr
.pure
;
7712 el
= gfc_get_entry_list ();
7714 el
->next
= gfc_current_ns
->entries
;
7715 gfc_current_ns
->entries
= el
;
7717 el
->id
= el
->next
->id
+ 1;
7721 new_st
.op
= EXEC_ENTRY
;
7722 new_st
.ext
.entry
= el
;
7728 /* Match a subroutine statement, including optional prefixes. */
7731 gfc_match_subroutine (void)
7733 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7738 bool allow_binding_name
;
7741 if (gfc_current_state () != COMP_NONE
7742 && gfc_current_state () != COMP_INTERFACE
7743 && gfc_current_state () != COMP_CONTAINS
)
7746 m
= gfc_match_prefix (NULL
);
7750 m
= gfc_match ("subroutine% %n", name
);
7754 if (get_proc_name (name
, &sym
, false))
7757 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
7758 the symbol existed before. */
7759 sym
->declared_at
= gfc_current_locus
;
7761 if (current_attr
.module_procedure
)
7762 sym
->attr
.module_procedure
= 1;
7764 if (add_hidden_procptr_result (sym
))
7767 gfc_new_block
= sym
;
7769 /* Check what next non-whitespace character is so we can tell if there
7770 is the required parens if we have a BIND(C). */
7771 gfc_gobble_whitespace ();
7772 peek_char
= gfc_peek_ascii_char ();
7774 if (!gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
))
7777 if (gfc_match_formal_arglist (sym
, 0, 1) != MATCH_YES
)
7780 /* Make sure that it isn't already declared as BIND(C). If it is, it
7781 must have been marked BIND(C) with a BIND(C) attribute and that is
7782 not allowed for procedures. */
7783 if (sym
->attr
.is_bind_c
== 1)
7785 sym
->attr
.is_bind_c
= 0;
7787 if (gfc_state_stack
->previous
7788 && gfc_state_stack
->previous
->state
!= COMP_SUBMODULE
)
7791 loc
= sym
->old_symbol
!= NULL
7792 ? sym
->old_symbol
->declared_at
: gfc_current_locus
;
7793 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7794 "variables or common blocks", &loc
);
7798 /* C binding names are not allowed for internal procedures. */
7799 if (gfc_current_state () == COMP_CONTAINS
7800 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
7801 allow_binding_name
= false;
7803 allow_binding_name
= true;
7805 /* Here, we are just checking if it has the bind(c) attribute, and if
7806 so, then we need to make sure it's all correct. If it doesn't,
7807 we still need to continue matching the rest of the subroutine line. */
7808 gfc_gobble_whitespace ();
7809 loc
= gfc_current_locus
;
7810 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
7811 if (is_bind_c
== MATCH_ERROR
)
7813 /* There was an attempt at the bind(c), but it was wrong. An
7814 error message should have been printed w/in the gfc_match_bind_c
7815 so here we'll just return the MATCH_ERROR. */
7819 if (is_bind_c
== MATCH_YES
)
7821 gfc_formal_arglist
*arg
;
7823 /* The following is allowed in the Fortran 2008 draft. */
7824 if (gfc_current_state () == COMP_CONTAINS
7825 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
7826 && !gfc_notify_std (GFC_STD_F2008
, "BIND(C) attribute "
7827 "at %L may not be specified for an internal "
7828 "procedure", &gfc_current_locus
))
7831 if (peek_char
!= '(')
7833 gfc_error ("Missing required parentheses before BIND(C) at %C");
7837 /* F2018 C1550 (R1526) If MODULE appears in the prefix of a module
7838 subprogram and a binding label is specified, it shall be the
7839 same as the binding label specified in the corresponding module
7840 procedure interface body. */
7841 if (sym
->attr
.module_procedure
&& sym
->old_symbol
7842 && strcmp (sym
->name
, sym
->old_symbol
->name
) == 0
7843 && strcmp (sym
->binding_label
, sym
->old_symbol
->binding_label
) != 0)
7845 const char *null
= "NULL", *s1
, *s2
;
7846 s1
= sym
->binding_label
;
7848 s2
= sym
->old_symbol
->binding_label
;
7850 gfc_error ("Mismatch in BIND(C) names (%qs/%qs) at %C", s1
, s2
);
7851 sym
->refs
++; /* Needed to avoid an ICE in gfc_release_symbol */
7855 /* Scan the dummy arguments for an alternate return. */
7856 for (arg
= sym
->formal
; arg
; arg
= arg
->next
)
7859 gfc_error ("Alternate return dummy argument cannot appear in a "
7860 "SUBROUTINE with the BIND(C) attribute at %L", &loc
);
7864 if (!gfc_add_is_bind_c (&(sym
->attr
), sym
->name
, &(sym
->declared_at
), 1))
7868 if (gfc_match_eos () != MATCH_YES
)
7870 gfc_syntax_error (ST_SUBROUTINE
);
7874 if (!copy_prefix (&sym
->attr
, &sym
->declared_at
))
7876 if(!sym
->attr
.module_procedure
)
7882 /* Warn if it has the same name as an intrinsic. */
7883 do_warn_intrinsic_shadow (sym
, false);
7889 /* Check that the NAME identifier in a BIND attribute or statement
7890 is conform to C identifier rules. */
7893 check_bind_name_identifier (char **name
)
7895 char *n
= *name
, *p
;
7897 /* Remove leading spaces. */
7901 /* On an empty string, free memory and set name to NULL. */
7909 /* Remove trailing spaces. */
7910 p
= n
+ strlen(n
) - 1;
7914 /* Insert the identifier into the symbol table. */
7919 /* Now check that identifier is valid under C rules. */
7922 gfc_error ("Invalid C identifier in NAME= specifier at %C");
7927 if (!(ISALNUM (*p
) || *p
== '_' || *p
== '$'))
7929 gfc_error ("Invalid C identifier in NAME= specifier at %C");
7937 /* Match a BIND(C) specifier, with the optional 'name=' specifier if
7938 given, and set the binding label in either the given symbol (if not
7939 NULL), or in the current_ts. The symbol may be NULL because we may
7940 encounter the BIND(C) before the declaration itself. Return
7941 MATCH_NO if what we're looking at isn't a BIND(C) specifier,
7942 MATCH_ERROR if it is a BIND(C) clause but an error was encountered,
7943 or MATCH_YES if the specifier was correct and the binding label and
7944 bind(c) fields were set correctly for the given symbol or the
7945 current_ts. If allow_binding_name is false, no binding name may be
7949 gfc_match_bind_c (gfc_symbol
*sym
, bool allow_binding_name
)
7951 char *binding_label
= NULL
;
7954 /* Initialize the flag that specifies whether we encountered a NAME=
7955 specifier or not. */
7956 has_name_equals
= 0;
7958 /* This much we have to be able to match, in this order, if
7959 there is a bind(c) label. */
7960 if (gfc_match (" bind ( c ") != MATCH_YES
)
7963 /* Now see if there is a binding label, or if we've reached the
7964 end of the bind(c) attribute without one. */
7965 if (gfc_match_char (',') == MATCH_YES
)
7967 if (gfc_match (" name = ") != MATCH_YES
)
7969 gfc_error ("Syntax error in NAME= specifier for binding label "
7971 /* should give an error message here */
7975 has_name_equals
= 1;
7977 if (gfc_match_init_expr (&e
) != MATCH_YES
)
7983 if (!gfc_simplify_expr(e
, 0))
7985 gfc_error ("NAME= specifier at %C should be a constant expression");
7990 if (e
->expr_type
!= EXPR_CONSTANT
|| e
->ts
.type
!= BT_CHARACTER
7991 || e
->ts
.kind
!= gfc_default_character_kind
|| e
->rank
!= 0)
7993 gfc_error ("NAME= specifier at %C should be a scalar of "
7994 "default character kind");
7999 // Get a C string from the Fortran string constant
8000 binding_label
= gfc_widechar_to_char (e
->value
.character
.string
,
8001 e
->value
.character
.length
);
8004 // Check that it is valid (old gfc_match_name_C)
8005 if (check_bind_name_identifier (&binding_label
) != MATCH_YES
)
8009 /* Get the required right paren. */
8010 if (gfc_match_char (')') != MATCH_YES
)
8012 gfc_error ("Missing closing paren for binding label at %C");
8016 if (has_name_equals
&& !allow_binding_name
)
8018 gfc_error ("No binding name is allowed in BIND(C) at %C");
8022 if (has_name_equals
&& sym
!= NULL
&& sym
->attr
.dummy
)
8024 gfc_error ("For dummy procedure %s, no binding name is "
8025 "allowed in BIND(C) at %C", sym
->name
);
8030 /* Save the binding label to the symbol. If sym is null, we're
8031 probably matching the typespec attributes of a declaration and
8032 haven't gotten the name yet, and therefore, no symbol yet. */
8036 sym
->binding_label
= binding_label
;
8038 curr_binding_label
= binding_label
;
8040 else if (allow_binding_name
)
8042 /* No binding label, but if symbol isn't null, we
8043 can set the label for it here.
8044 If name="" or allow_binding_name is false, no C binding name is
8046 if (sym
!= NULL
&& sym
->name
!= NULL
&& has_name_equals
== 0)
8047 sym
->binding_label
= IDENTIFIER_POINTER (get_identifier (sym
->name
));
8050 if (has_name_equals
&& gfc_current_state () == COMP_INTERFACE
8051 && current_interface
.type
== INTERFACE_ABSTRACT
)
8053 gfc_error ("NAME not allowed on BIND(C) for ABSTRACT INTERFACE at %C");
8061 /* Return nonzero if we're currently compiling a contained procedure. */
8064 contained_procedure (void)
8066 gfc_state_data
*s
= gfc_state_stack
;
8068 if ((s
->state
== COMP_SUBROUTINE
|| s
->state
== COMP_FUNCTION
)
8069 && s
->previous
!= NULL
&& s
->previous
->state
== COMP_CONTAINS
)
8075 /* Set the kind of each enumerator. The kind is selected such that it is
8076 interoperable with the corresponding C enumeration type, making
8077 sure that -fshort-enums is honored. */
8082 enumerator_history
*current_history
= NULL
;
8086 if (max_enum
== NULL
|| enum_history
== NULL
)
8089 if (!flag_short_enums
)
8095 kind
= gfc_integer_kinds
[i
++].kind
;
8097 while (kind
< gfc_c_int_kind
8098 && gfc_check_integer_range (max_enum
->initializer
->value
.integer
,
8101 current_history
= enum_history
;
8102 while (current_history
!= NULL
)
8104 current_history
->sym
->ts
.kind
= kind
;
8105 current_history
= current_history
->next
;
8110 /* Match any of the various end-block statements. Returns the type of
8111 END to the caller. The END INTERFACE, END IF, END DO, END SELECT
8112 and END BLOCK statements cannot be replaced by a single END statement. */
8115 gfc_match_end (gfc_statement
*st
)
8117 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8118 gfc_compile_state state
;
8120 const char *block_name
;
8124 gfc_namespace
*parent_ns
, *ns
, *prev_ns
;
8125 gfc_namespace
**nsp
;
8126 bool abreviated_modproc_decl
= false;
8127 bool got_matching_end
= false;
8129 old_loc
= gfc_current_locus
;
8130 if (gfc_match ("end") != MATCH_YES
)
8133 state
= gfc_current_state ();
8134 block_name
= gfc_current_block () == NULL
8135 ? NULL
: gfc_current_block ()->name
;
8139 case COMP_ASSOCIATE
:
8141 if (gfc_str_startswith (block_name
, "block@"))
8146 case COMP_DERIVED_CONTAINS
:
8147 state
= gfc_state_stack
->previous
->state
;
8148 block_name
= gfc_state_stack
->previous
->sym
== NULL
8149 ? NULL
: gfc_state_stack
->previous
->sym
->name
;
8150 abreviated_modproc_decl
= gfc_state_stack
->previous
->sym
8151 && gfc_state_stack
->previous
->sym
->abr_modproc_decl
;
8158 if (!abreviated_modproc_decl
)
8159 abreviated_modproc_decl
= gfc_current_block ()
8160 && gfc_current_block ()->abr_modproc_decl
;
8166 *st
= ST_END_PROGRAM
;
8167 target
= " program";
8171 case COMP_SUBROUTINE
:
8172 *st
= ST_END_SUBROUTINE
;
8173 if (!abreviated_modproc_decl
)
8174 target
= " subroutine";
8176 target
= " procedure";
8177 eos_ok
= !contained_procedure ();
8181 *st
= ST_END_FUNCTION
;
8182 if (!abreviated_modproc_decl
)
8183 target
= " function";
8185 target
= " procedure";
8186 eos_ok
= !contained_procedure ();
8189 case COMP_BLOCK_DATA
:
8190 *st
= ST_END_BLOCK_DATA
;
8191 target
= " block data";
8196 *st
= ST_END_MODULE
;
8201 case COMP_SUBMODULE
:
8202 *st
= ST_END_SUBMODULE
;
8203 target
= " submodule";
8207 case COMP_INTERFACE
:
8208 *st
= ST_END_INTERFACE
;
8209 target
= " interface";
8225 case COMP_STRUCTURE
:
8226 *st
= ST_END_STRUCTURE
;
8227 target
= " structure";
8232 case COMP_DERIVED_CONTAINS
:
8238 case COMP_ASSOCIATE
:
8239 *st
= ST_END_ASSOCIATE
;
8240 target
= " associate";
8257 case COMP_DO_CONCURRENT
:
8264 *st
= ST_END_CRITICAL
;
8265 target
= " critical";
8270 case COMP_SELECT_TYPE
:
8271 case COMP_SELECT_RANK
:
8272 *st
= ST_END_SELECT
;
8278 *st
= ST_END_FORALL
;
8293 last_initializer
= NULL
;
8295 gfc_free_enum_history ();
8299 gfc_error ("Unexpected END statement at %C");
8303 old_loc
= gfc_current_locus
;
8304 if (gfc_match_eos () == MATCH_YES
)
8306 if (!eos_ok
&& (*st
== ST_END_SUBROUTINE
|| *st
== ST_END_FUNCTION
))
8308 if (!gfc_notify_std (GFC_STD_F2008
, "END statement "
8309 "instead of %s statement at %L",
8310 abreviated_modproc_decl
? "END PROCEDURE"
8311 : gfc_ascii_statement(*st
), &old_loc
))
8316 /* We would have required END [something]. */
8317 gfc_error ("%s statement expected at %L",
8318 gfc_ascii_statement (*st
), &old_loc
);
8325 /* Verify that we've got the sort of end-block that we're expecting. */
8326 if (gfc_match (target
) != MATCH_YES
)
8328 gfc_error ("Expecting %s statement at %L", abreviated_modproc_decl
8329 ? "END PROCEDURE" : gfc_ascii_statement(*st
), &old_loc
);
8333 got_matching_end
= true;
8335 old_loc
= gfc_current_locus
;
8336 /* If we're at the end, make sure a block name wasn't required. */
8337 if (gfc_match_eos () == MATCH_YES
)
8340 if (*st
!= ST_ENDDO
&& *st
!= ST_ENDIF
&& *st
!= ST_END_SELECT
8341 && *st
!= ST_END_FORALL
&& *st
!= ST_END_WHERE
&& *st
!= ST_END_BLOCK
8342 && *st
!= ST_END_ASSOCIATE
&& *st
!= ST_END_CRITICAL
)
8348 gfc_error ("Expected block name of %qs in %s statement at %L",
8349 block_name
, gfc_ascii_statement (*st
), &old_loc
);
8354 /* END INTERFACE has a special handler for its several possible endings. */
8355 if (*st
== ST_END_INTERFACE
)
8356 return gfc_match_end_interface ();
8358 /* We haven't hit the end of statement, so what is left must be an
8360 m
= gfc_match_space ();
8362 m
= gfc_match_name (name
);
8365 gfc_error ("Expected terminating name at %C");
8369 if (block_name
== NULL
)
8372 /* We have to pick out the declared submodule name from the composite
8373 required by F2008:11.2.3 para 2, which ends in the declared name. */
8374 if (state
== COMP_SUBMODULE
)
8375 block_name
= strchr (block_name
, '.') + 1;
8377 if (strcmp (name
, block_name
) != 0 && strcmp (block_name
, "ppr@") != 0)
8379 gfc_error ("Expected label %qs for %s statement at %C", block_name
,
8380 gfc_ascii_statement (*st
));
8383 /* Procedure pointer as function result. */
8384 else if (strcmp (block_name
, "ppr@") == 0
8385 && strcmp (name
, gfc_current_block ()->ns
->proc_name
->name
) != 0)
8387 gfc_error ("Expected label %qs for %s statement at %C",
8388 gfc_current_block ()->ns
->proc_name
->name
,
8389 gfc_ascii_statement (*st
));
8393 if (gfc_match_eos () == MATCH_YES
)
8397 gfc_syntax_error (*st
);
8400 gfc_current_locus
= old_loc
;
8402 /* If we are missing an END BLOCK, we created a half-ready namespace.
8403 Remove it from the parent namespace's sibling list. */
8405 while (state
== COMP_BLOCK
&& !got_matching_end
)
8407 parent_ns
= gfc_current_ns
->parent
;
8409 nsp
= &(gfc_state_stack
->previous
->tail
->ext
.block
.ns
);
8415 if (ns
== gfc_current_ns
)
8417 if (prev_ns
== NULL
)
8420 prev_ns
->sibling
= ns
->sibling
;
8426 gfc_free_namespace (gfc_current_ns
);
8427 gfc_current_ns
= parent_ns
;
8428 gfc_state_stack
= gfc_state_stack
->previous
;
8429 state
= gfc_current_state ();
8437 /***************** Attribute declaration statements ****************/
8439 /* Set the attribute of a single variable. */
8444 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8447 /* Workaround -Wmaybe-uninitialized false positive during
8448 profiledbootstrap by initializing them. */
8449 gfc_symbol
*sym
= NULL
;
8455 m
= gfc_match_name (name
);
8459 if (find_special (name
, &sym
, false))
8462 if (!check_function_name (name
))
8468 var_locus
= gfc_current_locus
;
8470 /* Deal with possible array specification for certain attributes. */
8471 if (current_attr
.dimension
8472 || current_attr
.codimension
8473 || current_attr
.allocatable
8474 || current_attr
.pointer
8475 || current_attr
.target
)
8477 m
= gfc_match_array_spec (&as
, !current_attr
.codimension
,
8478 !current_attr
.dimension
8479 && !current_attr
.pointer
8480 && !current_attr
.target
);
8481 if (m
== MATCH_ERROR
)
8484 if (current_attr
.dimension
&& m
== MATCH_NO
)
8486 gfc_error ("Missing array specification at %L in DIMENSION "
8487 "statement", &var_locus
);
8492 if (current_attr
.dimension
&& sym
->value
)
8494 gfc_error ("Dimensions specified for %s at %L after its "
8495 "initialization", sym
->name
, &var_locus
);
8500 if (current_attr
.codimension
&& m
== MATCH_NO
)
8502 gfc_error ("Missing array specification at %L in CODIMENSION "
8503 "statement", &var_locus
);
8508 if ((current_attr
.allocatable
|| current_attr
.pointer
)
8509 && (m
== MATCH_YES
) && (as
->type
!= AS_DEFERRED
))
8511 gfc_error ("Array specification must be deferred at %L", &var_locus
);
8517 /* Update symbol table. DIMENSION attribute is set in
8518 gfc_set_array_spec(). For CLASS variables, this must be applied
8519 to the first component, or '_data' field. */
8520 if (sym
->ts
.type
== BT_CLASS
&& sym
->ts
.u
.derived
->attr
.is_class
)
8522 /* gfc_set_array_spec sets sym->attr not CLASS_DATA(sym)->attr. Check
8523 for duplicate attribute here. */
8524 if (CLASS_DATA(sym
)->attr
.dimension
== 1 && as
)
8526 gfc_error ("Duplicate DIMENSION attribute at %C");
8531 if (!gfc_copy_attr (&CLASS_DATA(sym
)->attr
, ¤t_attr
, &var_locus
))
8539 if (current_attr
.dimension
== 0 && current_attr
.codimension
== 0
8540 && !gfc_copy_attr (&sym
->attr
, ¤t_attr
, &var_locus
))
8547 if (sym
->ts
.type
== BT_CLASS
8548 && !gfc_build_class_symbol (&sym
->ts
, &sym
->attr
, &sym
->as
))
8554 if (!gfc_set_array_spec (sym
, as
, &var_locus
))
8560 if (sym
->attr
.cray_pointee
&& sym
->as
!= NULL
)
8562 /* Fix the array spec. */
8563 m
= gfc_mod_pointee_as (sym
->as
);
8564 if (m
== MATCH_ERROR
)
8568 if (!gfc_add_attribute (&sym
->attr
, &var_locus
))
8574 if ((current_attr
.external
|| current_attr
.intrinsic
)
8575 && sym
->attr
.flavor
!= FL_PROCEDURE
8576 && !gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, NULL
))
8582 add_hidden_procptr_result (sym
);
8587 gfc_free_array_spec (as
);
8592 /* Generic attribute declaration subroutine. Used for attributes that
8593 just have a list of names. */
8600 /* Gobble the optional double colon, by simply ignoring the result
8610 if (gfc_match_eos () == MATCH_YES
)
8616 if (gfc_match_char (',') != MATCH_YES
)
8618 gfc_error ("Unexpected character in variable list at %C");
8628 /* This routine matches Cray Pointer declarations of the form:
8629 pointer ( <pointer>, <pointee> )
8631 pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...
8632 The pointer, if already declared, should be an integer. Otherwise, we
8633 set it as BT_INTEGER with kind gfc_index_integer_kind. The pointee may
8634 be either a scalar, or an array declaration. No space is allocated for
8635 the pointee. For the statement
8636 pointer (ipt, ar(10))
8637 any subsequent uses of ar will be translated (in C-notation) as
8638 ar(i) => ((<type> *) ipt)(i)
8639 After gimplification, pointee variable will disappear in the code. */
8642 cray_pointer_decl (void)
8645 gfc_array_spec
*as
= NULL
;
8646 gfc_symbol
*cptr
; /* Pointer symbol. */
8647 gfc_symbol
*cpte
; /* Pointee symbol. */
8653 if (gfc_match_char ('(') != MATCH_YES
)
8655 gfc_error ("Expected %<(%> at %C");
8659 /* Match pointer. */
8660 var_locus
= gfc_current_locus
;
8661 gfc_clear_attr (¤t_attr
);
8662 gfc_add_cray_pointer (¤t_attr
, &var_locus
);
8663 current_ts
.type
= BT_INTEGER
;
8664 current_ts
.kind
= gfc_index_integer_kind
;
8666 m
= gfc_match_symbol (&cptr
, 0);
8669 gfc_error ("Expected variable name at %C");
8673 if (!gfc_add_cray_pointer (&cptr
->attr
, &var_locus
))
8676 gfc_set_sym_referenced (cptr
);
8678 if (cptr
->ts
.type
== BT_UNKNOWN
) /* Override the type, if necessary. */
8680 cptr
->ts
.type
= BT_INTEGER
;
8681 cptr
->ts
.kind
= gfc_index_integer_kind
;
8683 else if (cptr
->ts
.type
!= BT_INTEGER
)
8685 gfc_error ("Cray pointer at %C must be an integer");
8688 else if (cptr
->ts
.kind
< gfc_index_integer_kind
)
8689 gfc_warning (0, "Cray pointer at %C has %d bytes of precision;"
8690 " memory addresses require %d bytes",
8691 cptr
->ts
.kind
, gfc_index_integer_kind
);
8693 if (gfc_match_char (',') != MATCH_YES
)
8695 gfc_error ("Expected \",\" at %C");
8699 /* Match Pointee. */
8700 var_locus
= gfc_current_locus
;
8701 gfc_clear_attr (¤t_attr
);
8702 gfc_add_cray_pointee (¤t_attr
, &var_locus
);
8703 current_ts
.type
= BT_UNKNOWN
;
8704 current_ts
.kind
= 0;
8706 m
= gfc_match_symbol (&cpte
, 0);
8709 gfc_error ("Expected variable name at %C");
8713 /* Check for an optional array spec. */
8714 m
= gfc_match_array_spec (&as
, true, false);
8715 if (m
== MATCH_ERROR
)
8717 gfc_free_array_spec (as
);
8720 else if (m
== MATCH_NO
)
8722 gfc_free_array_spec (as
);
8726 if (!gfc_add_cray_pointee (&cpte
->attr
, &var_locus
))
8729 gfc_set_sym_referenced (cpte
);
8731 if (cpte
->as
== NULL
)
8733 if (!gfc_set_array_spec (cpte
, as
, &var_locus
))
8734 gfc_internal_error ("Cannot set Cray pointee array spec.");
8736 else if (as
!= NULL
)
8738 gfc_error ("Duplicate array spec for Cray pointee at %C");
8739 gfc_free_array_spec (as
);
8745 if (cpte
->as
!= NULL
)
8747 /* Fix array spec. */
8748 m
= gfc_mod_pointee_as (cpte
->as
);
8749 if (m
== MATCH_ERROR
)
8753 /* Point the Pointee at the Pointer. */
8754 cpte
->cp_pointer
= cptr
;
8756 if (gfc_match_char (')') != MATCH_YES
)
8758 gfc_error ("Expected \")\" at %C");
8761 m
= gfc_match_char (',');
8763 done
= true; /* Stop searching for more declarations. */
8767 if (m
== MATCH_ERROR
/* Failed when trying to find ',' above. */
8768 || gfc_match_eos () != MATCH_YES
)
8770 gfc_error ("Expected %<,%> or end of statement at %C");
8778 gfc_match_external (void)
8781 gfc_clear_attr (¤t_attr
);
8782 current_attr
.external
= 1;
8784 return attr_decl ();
8789 gfc_match_intent (void)
8793 /* This is not allowed within a BLOCK construct! */
8794 if (gfc_current_state () == COMP_BLOCK
)
8796 gfc_error ("INTENT is not allowed inside of BLOCK at %C");
8800 intent
= match_intent_spec ();
8801 if (intent
== INTENT_UNKNOWN
)
8804 gfc_clear_attr (¤t_attr
);
8805 current_attr
.intent
= intent
;
8807 return attr_decl ();
8812 gfc_match_intrinsic (void)
8815 gfc_clear_attr (¤t_attr
);
8816 current_attr
.intrinsic
= 1;
8818 return attr_decl ();
8823 gfc_match_optional (void)
8825 /* This is not allowed within a BLOCK construct! */
8826 if (gfc_current_state () == COMP_BLOCK
)
8828 gfc_error ("OPTIONAL is not allowed inside of BLOCK at %C");
8832 gfc_clear_attr (¤t_attr
);
8833 current_attr
.optional
= 1;
8835 return attr_decl ();
8840 gfc_match_pointer (void)
8842 gfc_gobble_whitespace ();
8843 if (gfc_peek_ascii_char () == '(')
8845 if (!flag_cray_pointer
)
8847 gfc_error ("Cray pointer declaration at %C requires "
8848 "%<-fcray-pointer%> flag");
8851 return cray_pointer_decl ();
8855 gfc_clear_attr (¤t_attr
);
8856 current_attr
.pointer
= 1;
8858 return attr_decl ();
8864 gfc_match_allocatable (void)
8866 gfc_clear_attr (¤t_attr
);
8867 current_attr
.allocatable
= 1;
8869 return attr_decl ();
8874 gfc_match_codimension (void)
8876 gfc_clear_attr (¤t_attr
);
8877 current_attr
.codimension
= 1;
8879 return attr_decl ();
8884 gfc_match_contiguous (void)
8886 if (!gfc_notify_std (GFC_STD_F2008
, "CONTIGUOUS statement at %C"))
8889 gfc_clear_attr (¤t_attr
);
8890 current_attr
.contiguous
= 1;
8892 return attr_decl ();
8897 gfc_match_dimension (void)
8899 gfc_clear_attr (¤t_attr
);
8900 current_attr
.dimension
= 1;
8902 return attr_decl ();
8907 gfc_match_target (void)
8909 gfc_clear_attr (¤t_attr
);
8910 current_attr
.target
= 1;
8912 return attr_decl ();
8916 /* Match the list of entities being specified in a PUBLIC or PRIVATE
8920 access_attr_decl (gfc_statement st
)
8922 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8923 interface_type type
;
8925 gfc_symbol
*sym
, *dt_sym
;
8926 gfc_intrinsic_op op
;
8928 gfc_access access
= (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
8930 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
8935 m
= gfc_match_generic_spec (&type
, name
, &op
);
8938 if (m
== MATCH_ERROR
)
8943 case INTERFACE_NAMELESS
:
8944 case INTERFACE_ABSTRACT
:
8947 case INTERFACE_GENERIC
:
8948 case INTERFACE_DTIO
:
8950 if (gfc_get_symbol (name
, NULL
, &sym
))
8953 if (type
== INTERFACE_DTIO
8954 && gfc_current_ns
->proc_name
8955 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
8956 && sym
->attr
.flavor
== FL_UNKNOWN
)
8957 sym
->attr
.flavor
= FL_PROCEDURE
;
8959 if (!gfc_add_access (&sym
->attr
, access
, sym
->name
, NULL
))
8962 if (sym
->attr
.generic
&& (dt_sym
= gfc_find_dt_in_generic (sym
))
8963 && !gfc_add_access (&dt_sym
->attr
, access
, sym
->name
, NULL
))
8968 case INTERFACE_INTRINSIC_OP
:
8969 if (gfc_current_ns
->operator_access
[op
] == ACCESS_UNKNOWN
)
8971 gfc_intrinsic_op other_op
;
8973 gfc_current_ns
->operator_access
[op
] = access
;
8975 /* Handle the case if there is another op with the same
8976 function, for INTRINSIC_EQ vs. INTRINSIC_EQ_OS and so on. */
8977 other_op
= gfc_equivalent_op (op
);
8979 if (other_op
!= INTRINSIC_NONE
)
8980 gfc_current_ns
->operator_access
[other_op
] = access
;
8984 gfc_error ("Access specification of the %s operator at %C has "
8985 "already been specified", gfc_op2string (op
));
8991 case INTERFACE_USER_OP
:
8992 uop
= gfc_get_uop (name
);
8994 if (uop
->access
== ACCESS_UNKNOWN
)
8996 uop
->access
= access
;
9000 gfc_error ("Access specification of the .%s. operator at %C "
9001 "has already been specified", sym
->name
);
9008 if (gfc_match_char (',') == MATCH_NO
)
9012 if (gfc_match_eos () != MATCH_YES
)
9017 gfc_syntax_error (st
);
9025 gfc_match_protected (void)
9031 /* PROTECTED has already been seen, but must be followed by whitespace
9033 c
= gfc_peek_ascii_char ();
9034 if (!gfc_is_whitespace (c
) && c
!= ':')
9037 if (!gfc_current_ns
->proc_name
9038 || gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
9040 gfc_error ("PROTECTED at %C only allowed in specification "
9041 "part of a module");
9048 if (!gfc_notify_std (GFC_STD_F2003
, "PROTECTED statement at %C"))
9051 /* PROTECTED has an entity-list. */
9052 if (gfc_match_eos () == MATCH_YES
)
9057 m
= gfc_match_symbol (&sym
, 0);
9061 if (!gfc_add_protected (&sym
->attr
, sym
->name
, &gfc_current_locus
))
9073 if (gfc_match_eos () == MATCH_YES
)
9075 if (gfc_match_char (',') != MATCH_YES
)
9082 gfc_error ("Syntax error in PROTECTED statement at %C");
9087 /* The PRIVATE statement is a bit weird in that it can be an attribute
9088 declaration, but also works as a standalone statement inside of a
9089 type declaration or a module. */
9092 gfc_match_private (gfc_statement
*st
)
9094 gfc_state_data
*prev
;
9096 if (gfc_match ("private") != MATCH_YES
)
9099 /* Try matching PRIVATE without an access-list. */
9100 if (gfc_match_eos () == MATCH_YES
)
9102 prev
= gfc_state_stack
->previous
;
9103 if (gfc_current_state () != COMP_MODULE
9104 && !(gfc_current_state () == COMP_DERIVED
9105 && prev
&& prev
->state
== COMP_MODULE
)
9106 && !(gfc_current_state () == COMP_DERIVED_CONTAINS
9107 && prev
->previous
&& prev
->previous
->state
== COMP_MODULE
))
9109 gfc_error ("PRIVATE statement at %C is only allowed in the "
9110 "specification part of a module");
9118 /* At this point in free-form source code, PRIVATE must be followed
9119 by whitespace or ::. */
9120 if (gfc_current_form
== FORM_FREE
)
9122 char c
= gfc_peek_ascii_char ();
9123 if (!gfc_is_whitespace (c
) && c
!= ':')
9127 prev
= gfc_state_stack
->previous
;
9128 if (gfc_current_state () != COMP_MODULE
9129 && !(gfc_current_state () == COMP_DERIVED
9130 && prev
&& prev
->state
== COMP_MODULE
)
9131 && !(gfc_current_state () == COMP_DERIVED_CONTAINS
9132 && prev
->previous
&& prev
->previous
->state
== COMP_MODULE
))
9134 gfc_error ("PRIVATE statement at %C is only allowed in the "
9135 "specification part of a module");
9140 return access_attr_decl (ST_PRIVATE
);
9145 gfc_match_public (gfc_statement
*st
)
9147 if (gfc_match ("public") != MATCH_YES
)
9150 /* Try matching PUBLIC without an access-list. */
9151 if (gfc_match_eos () == MATCH_YES
)
9153 if (gfc_current_state () != COMP_MODULE
)
9155 gfc_error ("PUBLIC statement at %C is only allowed in the "
9156 "specification part of a module");
9164 /* At this point in free-form source code, PUBLIC must be followed
9165 by whitespace or ::. */
9166 if (gfc_current_form
== FORM_FREE
)
9168 char c
= gfc_peek_ascii_char ();
9169 if (!gfc_is_whitespace (c
) && c
!= ':')
9173 if (gfc_current_state () != COMP_MODULE
)
9175 gfc_error ("PUBLIC statement at %C is only allowed in the "
9176 "specification part of a module");
9181 return access_attr_decl (ST_PUBLIC
);
9185 /* Workhorse for gfc_match_parameter. */
9195 m
= gfc_match_symbol (&sym
, 0);
9197 gfc_error ("Expected variable name at %C in PARAMETER statement");
9202 if (gfc_match_char ('=') == MATCH_NO
)
9204 gfc_error ("Expected = sign in PARAMETER statement at %C");
9208 m
= gfc_match_init_expr (&init
);
9210 gfc_error ("Expected expression at %C in PARAMETER statement");
9214 if (sym
->ts
.type
== BT_UNKNOWN
9215 && !gfc_set_default_type (sym
, 1, NULL
))
9221 if (!gfc_check_assign_symbol (sym
, NULL
, init
)
9222 || !gfc_add_flavor (&sym
->attr
, FL_PARAMETER
, sym
->name
, NULL
))
9230 gfc_error ("Initializing already initialized variable at %C");
9235 t
= add_init_expr_to_sym (sym
->name
, &init
, &gfc_current_locus
);
9236 return (t
) ? MATCH_YES
: MATCH_ERROR
;
9239 gfc_free_expr (init
);
9244 /* Match a parameter statement, with the weird syntax that these have. */
9247 gfc_match_parameter (void)
9249 const char *term
= " )%t";
9252 if (gfc_match_char ('(') == MATCH_NO
)
9254 /* With legacy PARAMETER statements, don't expect a terminating ')'. */
9255 if (!gfc_notify_std (GFC_STD_LEGACY
, "PARAMETER without '()' at %C"))
9266 if (gfc_match (term
) == MATCH_YES
)
9269 if (gfc_match_char (',') != MATCH_YES
)
9271 gfc_error ("Unexpected characters in PARAMETER statement at %C");
9282 gfc_match_automatic (void)
9286 bool seen_symbol
= false;
9288 if (!flag_dec_static
)
9290 gfc_error ("%s at %C is a DEC extension, enable with "
9301 m
= gfc_match_symbol (&sym
, 0);
9311 if (!gfc_add_automatic (&sym
->attr
, sym
->name
, &gfc_current_locus
))
9317 if (gfc_match_eos () == MATCH_YES
)
9319 if (gfc_match_char (',') != MATCH_YES
)
9325 gfc_error ("Expected entity-list in AUTOMATIC statement at %C");
9332 gfc_error ("Syntax error in AUTOMATIC statement at %C");
9338 gfc_match_static (void)
9342 bool seen_symbol
= false;
9344 if (!flag_dec_static
)
9346 gfc_error ("%s at %C is a DEC extension, enable with "
9356 m
= gfc_match_symbol (&sym
, 0);
9366 if (!gfc_add_save (&sym
->attr
, SAVE_EXPLICIT
, sym
->name
,
9367 &gfc_current_locus
))
9373 if (gfc_match_eos () == MATCH_YES
)
9375 if (gfc_match_char (',') != MATCH_YES
)
9381 gfc_error ("Expected entity-list in STATIC statement at %C");
9388 gfc_error ("Syntax error in STATIC statement at %C");
9393 /* Save statements have a special syntax. */
9396 gfc_match_save (void)
9398 char n
[GFC_MAX_SYMBOL_LEN
+1];
9403 if (gfc_match_eos () == MATCH_YES
)
9405 if (gfc_current_ns
->seen_save
)
9407 if (!gfc_notify_std (GFC_STD_LEGACY
, "Blanket SAVE statement at %C "
9408 "follows previous SAVE statement"))
9412 gfc_current_ns
->save_all
= gfc_current_ns
->seen_save
= 1;
9416 if (gfc_current_ns
->save_all
)
9418 if (!gfc_notify_std (GFC_STD_LEGACY
, "SAVE statement at %C follows "
9419 "blanket SAVE statement"))
9427 m
= gfc_match_symbol (&sym
, 0);
9431 if (!gfc_add_save (&sym
->attr
, SAVE_EXPLICIT
, sym
->name
,
9432 &gfc_current_locus
))
9443 m
= gfc_match (" / %n /", &n
);
9444 if (m
== MATCH_ERROR
)
9449 c
= gfc_get_common (n
, 0);
9452 gfc_current_ns
->seen_save
= 1;
9455 if (gfc_match_eos () == MATCH_YES
)
9457 if (gfc_match_char (',') != MATCH_YES
)
9464 if (gfc_current_ns
->seen_save
)
9466 gfc_error ("Syntax error in SAVE statement at %C");
9475 gfc_match_value (void)
9480 /* This is not allowed within a BLOCK construct! */
9481 if (gfc_current_state () == COMP_BLOCK
)
9483 gfc_error ("VALUE is not allowed inside of BLOCK at %C");
9487 if (!gfc_notify_std (GFC_STD_F2003
, "VALUE statement at %C"))
9490 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
9495 if (gfc_match_eos () == MATCH_YES
)
9500 m
= gfc_match_symbol (&sym
, 0);
9504 if (!gfc_add_value (&sym
->attr
, sym
->name
, &gfc_current_locus
))
9516 if (gfc_match_eos () == MATCH_YES
)
9518 if (gfc_match_char (',') != MATCH_YES
)
9525 gfc_error ("Syntax error in VALUE statement at %C");
9531 gfc_match_volatile (void)
9537 if (!gfc_notify_std (GFC_STD_F2003
, "VOLATILE statement at %C"))
9540 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
9545 if (gfc_match_eos () == MATCH_YES
)
9550 /* VOLATILE is special because it can be added to host-associated
9551 symbols locally. Except for coarrays. */
9552 m
= gfc_match_symbol (&sym
, 1);
9556 name
= XCNEWVAR (char, strlen (sym
->name
) + 1);
9557 strcpy (name
, sym
->name
);
9558 if (!check_function_name (name
))
9560 /* F2008, C560+C561. VOLATILE for host-/use-associated variable or
9561 for variable in a BLOCK which is defined outside of the BLOCK. */
9562 if (sym
->ns
!= gfc_current_ns
&& sym
->attr
.codimension
)
9564 gfc_error ("Specifying VOLATILE for coarray variable %qs at "
9565 "%C, which is use-/host-associated", sym
->name
);
9568 if (!gfc_add_volatile (&sym
->attr
, sym
->name
, &gfc_current_locus
))
9580 if (gfc_match_eos () == MATCH_YES
)
9582 if (gfc_match_char (',') != MATCH_YES
)
9589 gfc_error ("Syntax error in VOLATILE statement at %C");
9595 gfc_match_asynchronous (void)
9601 if (!gfc_notify_std (GFC_STD_F2003
, "ASYNCHRONOUS statement at %C"))
9604 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
9609 if (gfc_match_eos () == MATCH_YES
)
9614 /* ASYNCHRONOUS is special because it can be added to host-associated
9616 m
= gfc_match_symbol (&sym
, 1);
9620 name
= XCNEWVAR (char, strlen (sym
->name
) + 1);
9621 strcpy (name
, sym
->name
);
9622 if (!check_function_name (name
))
9624 if (!gfc_add_asynchronous (&sym
->attr
, sym
->name
, &gfc_current_locus
))
9636 if (gfc_match_eos () == MATCH_YES
)
9638 if (gfc_match_char (',') != MATCH_YES
)
9645 gfc_error ("Syntax error in ASYNCHRONOUS statement at %C");
9650 /* Match a module procedure statement in a submodule. */
9653 gfc_match_submod_proc (void)
9655 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9656 gfc_symbol
*sym
, *fsym
;
9658 gfc_formal_arglist
*formal
, *head
, *tail
;
9660 if (gfc_current_state () != COMP_CONTAINS
9661 || !(gfc_state_stack
->previous
9662 && (gfc_state_stack
->previous
->state
== COMP_SUBMODULE
9663 || gfc_state_stack
->previous
->state
== COMP_MODULE
)))
9666 m
= gfc_match (" module% procedure% %n", name
);
9670 if (!gfc_notify_std (GFC_STD_F2008
, "MODULE PROCEDURE declaration "
9674 if (get_proc_name (name
, &sym
, false))
9677 /* Make sure that the result field is appropriately filled, even though
9678 the result symbol will be replaced later on. */
9679 if (sym
->tlink
&& sym
->tlink
->attr
.function
)
9681 if (sym
->tlink
->result
9682 && sym
->tlink
->result
!= sym
->tlink
)
9683 sym
->result
= sym
->tlink
->result
;
9688 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
9689 the symbol existed before. */
9690 sym
->declared_at
= gfc_current_locus
;
9692 if (!sym
->attr
.module_procedure
)
9695 /* Signal match_end to expect "end procedure". */
9696 sym
->abr_modproc_decl
= 1;
9698 /* Change from IFSRC_IFBODY coming from the interface declaration. */
9699 sym
->attr
.if_source
= IFSRC_DECL
;
9701 gfc_new_block
= sym
;
9703 /* Make a new formal arglist with the symbols in the procedure
9706 for (formal
= sym
->formal
; formal
&& formal
->sym
; formal
= formal
->next
)
9708 if (formal
== sym
->formal
)
9709 head
= tail
= gfc_get_formal_arglist ();
9712 tail
->next
= gfc_get_formal_arglist ();
9716 if (gfc_copy_dummy_sym (&fsym
, formal
->sym
, 0))
9720 gfc_set_sym_referenced (fsym
);
9723 /* The dummy symbols get cleaned up, when the formal_namespace of the
9724 interface declaration is cleared. This allows us to add the
9725 explicit interface as is done for other type of procedure. */
9726 if (!gfc_add_explicit_interface (sym
, IFSRC_DECL
, head
,
9727 &gfc_current_locus
))
9730 if (gfc_match_eos () != MATCH_YES
)
9732 gfc_syntax_error (ST_MODULE_PROC
);
9739 gfc_free_formal_arglist (head
);
9744 /* Match a module procedure statement. Note that we have to modify
9745 symbols in the parent's namespace because the current one was there
9746 to receive symbols that are in an interface's formal argument list. */
9749 gfc_match_modproc (void)
9751 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9755 gfc_namespace
*module_ns
;
9756 gfc_interface
*old_interface_head
, *interface
;
9758 if (gfc_state_stack
->state
!= COMP_INTERFACE
9759 || gfc_state_stack
->previous
== NULL
9760 || current_interface
.type
== INTERFACE_NAMELESS
9761 || current_interface
.type
== INTERFACE_ABSTRACT
)
9763 gfc_error ("MODULE PROCEDURE at %C must be in a generic module "
9768 module_ns
= gfc_current_ns
->parent
;
9769 for (; module_ns
; module_ns
= module_ns
->parent
)
9770 if (module_ns
->proc_name
->attr
.flavor
== FL_MODULE
9771 || module_ns
->proc_name
->attr
.flavor
== FL_PROGRAM
9772 || (module_ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
9773 && !module_ns
->proc_name
->attr
.contained
))
9776 if (module_ns
== NULL
)
9779 /* Store the current state of the interface. We will need it if we
9780 end up with a syntax error and need to recover. */
9781 old_interface_head
= gfc_current_interface_head ();
9783 /* Check if the F2008 optional double colon appears. */
9784 gfc_gobble_whitespace ();
9785 old_locus
= gfc_current_locus
;
9786 if (gfc_match ("::") == MATCH_YES
)
9788 if (!gfc_notify_std (GFC_STD_F2008
, "double colon in "
9789 "MODULE PROCEDURE statement at %L", &old_locus
))
9793 gfc_current_locus
= old_locus
;
9798 old_locus
= gfc_current_locus
;
9800 m
= gfc_match_name (name
);
9806 /* Check for syntax error before starting to add symbols to the
9807 current namespace. */
9808 if (gfc_match_eos () == MATCH_YES
)
9811 if (!last
&& gfc_match_char (',') != MATCH_YES
)
9814 /* Now we're sure the syntax is valid, we process this item
9816 if (gfc_get_symbol (name
, module_ns
, &sym
))
9819 if (sym
->attr
.intrinsic
)
9821 gfc_error ("Intrinsic procedure at %L cannot be a MODULE "
9822 "PROCEDURE", &old_locus
);
9826 if (sym
->attr
.proc
!= PROC_MODULE
9827 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
9830 if (!gfc_add_interface (sym
))
9833 sym
->attr
.mod_proc
= 1;
9834 sym
->declared_at
= old_locus
;
9843 /* Restore the previous state of the interface. */
9844 interface
= gfc_current_interface_head ();
9845 gfc_set_current_interface_head (old_interface_head
);
9847 /* Free the new interfaces. */
9848 while (interface
!= old_interface_head
)
9850 gfc_interface
*i
= interface
->next
;
9855 /* And issue a syntax error. */
9856 gfc_syntax_error (ST_MODULE_PROC
);
9861 /* Check a derived type that is being extended. */
9864 check_extended_derived_type (char *name
)
9866 gfc_symbol
*extended
;
9868 if (gfc_find_symbol (name
, gfc_current_ns
, 1, &extended
))
9870 gfc_error ("Ambiguous symbol in TYPE definition at %C");
9874 extended
= gfc_find_dt_in_generic (extended
);
9879 gfc_error ("Symbol %qs at %C has not been previously defined", name
);
9883 if (extended
->attr
.flavor
!= FL_DERIVED
)
9885 gfc_error ("%qs in EXTENDS expression at %C is not a "
9886 "derived type", name
);
9890 if (extended
->attr
.is_bind_c
)
9892 gfc_error ("%qs cannot be extended at %C because it "
9893 "is BIND(C)", extended
->name
);
9897 if (extended
->attr
.sequence
)
9899 gfc_error ("%qs cannot be extended at %C because it "
9900 "is a SEQUENCE type", extended
->name
);
9908 /* Match the optional attribute specifiers for a type declaration.
9909 Return MATCH_ERROR if an error is encountered in one of the handled
9910 attributes (public, private, bind(c)), MATCH_NO if what's found is
9911 not a handled attribute, and MATCH_YES otherwise. TODO: More error
9912 checking on attribute conflicts needs to be done. */
9915 gfc_get_type_attr_spec (symbol_attribute
*attr
, char *name
)
9917 /* See if the derived type is marked as private. */
9918 if (gfc_match (" , private") == MATCH_YES
)
9920 if (gfc_current_state () != COMP_MODULE
)
9922 gfc_error ("Derived type at %C can only be PRIVATE in the "
9923 "specification part of a module");
9927 if (!gfc_add_access (attr
, ACCESS_PRIVATE
, NULL
, NULL
))
9930 else if (gfc_match (" , public") == MATCH_YES
)
9932 if (gfc_current_state () != COMP_MODULE
)
9934 gfc_error ("Derived type at %C can only be PUBLIC in the "
9935 "specification part of a module");
9939 if (!gfc_add_access (attr
, ACCESS_PUBLIC
, NULL
, NULL
))
9942 else if (gfc_match (" , bind ( c )") == MATCH_YES
)
9944 /* If the type is defined to be bind(c) it then needs to make
9945 sure that all fields are interoperable. This will
9946 need to be a semantic check on the finished derived type.
9947 See 15.2.3 (lines 9-12) of F2003 draft. */
9948 if (!gfc_add_is_bind_c (attr
, NULL
, &gfc_current_locus
, 0))
9951 /* TODO: attr conflicts need to be checked, probably in symbol.c. */
9953 else if (gfc_match (" , abstract") == MATCH_YES
)
9955 if (!gfc_notify_std (GFC_STD_F2003
, "ABSTRACT type at %C"))
9958 if (!gfc_add_abstract (attr
, &gfc_current_locus
))
9961 else if (name
&& gfc_match (" , extends ( %n )", name
) == MATCH_YES
)
9963 if (!gfc_add_extension (attr
, &gfc_current_locus
))
9969 /* If we get here, something matched. */
9974 /* Common function for type declaration blocks similar to derived types, such
9975 as STRUCTURES and MAPs. Unlike derived types, a structure type
9976 does NOT have a generic symbol matching the name given by the user.
9977 STRUCTUREs can share names with variables and PARAMETERs so we must allow
9978 for the creation of an independent symbol.
9979 Other parameters are a message to prefix errors with, the name of the new
9980 type to be created, and the flavor to add to the resulting symbol. */
9983 get_struct_decl (const char *name
, sym_flavor fl
, locus
*decl
,
9984 gfc_symbol
**result
)
9989 gcc_assert (name
[0] == (char) TOUPPER (name
[0]));
9994 where
= gfc_current_locus
;
9996 if (gfc_get_symbol (name
, NULL
, &sym
))
10001 gfc_internal_error ("Failed to create structure type '%s' at %C", name
);
10005 if (sym
->components
!= NULL
|| sym
->attr
.zero_comp
)
10007 gfc_error ("Type definition of %qs at %C was already defined at %L",
10008 sym
->name
, &sym
->declared_at
);
10012 sym
->declared_at
= where
;
10014 if (sym
->attr
.flavor
!= fl
10015 && !gfc_add_flavor (&sym
->attr
, fl
, sym
->name
, NULL
))
10018 if (!sym
->hash_value
)
10019 /* Set the hash for the compound name for this type. */
10020 sym
->hash_value
= gfc_hash_value (sym
);
10022 /* Normally the type is expected to have been completely parsed by the time
10023 a field declaration with this type is seen. For unions, maps, and nested
10024 structure declarations, we need to indicate that it is okay that we
10025 haven't seen any components yet. This will be updated after the structure
10026 is fully parsed. */
10027 sym
->attr
.zero_comp
= 0;
10029 /* Structures always act like derived-types with the SEQUENCE attribute */
10030 gfc_add_sequence (&sym
->attr
, sym
->name
, NULL
);
10032 if (result
) *result
= sym
;
10038 /* Match the opening of a MAP block. Like a struct within a union in C;
10039 behaves identical to STRUCTURE blocks. */
10042 gfc_match_map (void)
10044 /* Counter used to give unique internal names to map structures. */
10045 static unsigned int gfc_map_id
= 0;
10046 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10050 old_loc
= gfc_current_locus
;
10052 if (gfc_match_eos () != MATCH_YES
)
10054 gfc_error ("Junk after MAP statement at %C");
10055 gfc_current_locus
= old_loc
;
10056 return MATCH_ERROR
;
10059 /* Map blocks are anonymous so we make up unique names for the symbol table
10060 which are invalid Fortran identifiers. */
10061 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "MM$%u", gfc_map_id
++);
10063 if (!get_struct_decl (name
, FL_STRUCT
, &old_loc
, &sym
))
10064 return MATCH_ERROR
;
10066 gfc_new_block
= sym
;
10072 /* Match the opening of a UNION block. */
10075 gfc_match_union (void)
10077 /* Counter used to give unique internal names to union types. */
10078 static unsigned int gfc_union_id
= 0;
10079 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10083 old_loc
= gfc_current_locus
;
10085 if (gfc_match_eos () != MATCH_YES
)
10087 gfc_error ("Junk after UNION statement at %C");
10088 gfc_current_locus
= old_loc
;
10089 return MATCH_ERROR
;
10092 /* Unions are anonymous so we make up unique names for the symbol table
10093 which are invalid Fortran identifiers. */
10094 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "UU$%u", gfc_union_id
++);
10096 if (!get_struct_decl (name
, FL_UNION
, &old_loc
, &sym
))
10097 return MATCH_ERROR
;
10099 gfc_new_block
= sym
;
10105 /* Match the beginning of a STRUCTURE declaration. This is similar to
10106 matching the beginning of a derived type declaration with a few
10107 twists. The resulting type symbol has no access control or other
10108 interesting attributes. */
10111 gfc_match_structure_decl (void)
10113 /* Counter used to give unique internal names to anonymous structures. */
10114 static unsigned int gfc_structure_id
= 0;
10115 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10120 if (!flag_dec_structure
)
10122 gfc_error ("%s at %C is a DEC extension, enable with "
10123 "%<-fdec-structure%>",
10125 return MATCH_ERROR
;
10130 m
= gfc_match (" /%n/", name
);
10131 if (m
!= MATCH_YES
)
10133 /* Non-nested structure declarations require a structure name. */
10134 if (!gfc_comp_struct (gfc_current_state ()))
10136 gfc_error ("Structure name expected in non-nested structure "
10137 "declaration at %C");
10138 return MATCH_ERROR
;
10140 /* This is an anonymous structure; make up a unique name for it
10141 (upper-case letters never make it to symbol names from the source).
10142 The important thing is initializing the type variable
10143 and setting gfc_new_symbol, which is immediately used by
10144 parse_structure () and variable_decl () to add components of
10146 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "SS$%u", gfc_structure_id
++);
10149 where
= gfc_current_locus
;
10150 /* No field list allowed after non-nested structure declaration. */
10151 if (!gfc_comp_struct (gfc_current_state ())
10152 && gfc_match_eos () != MATCH_YES
)
10154 gfc_error ("Junk after non-nested STRUCTURE statement at %C");
10155 return MATCH_ERROR
;
10158 /* Make sure the name is not the name of an intrinsic type. */
10159 if (gfc_is_intrinsic_typename (name
))
10161 gfc_error ("Structure name %qs at %C cannot be the same as an"
10162 " intrinsic type", name
);
10163 return MATCH_ERROR
;
10166 /* Store the actual type symbol for the structure with an upper-case first
10167 letter (an invalid Fortran identifier). */
10169 if (!get_struct_decl (gfc_dt_upper_string (name
), FL_STRUCT
, &where
, &sym
))
10170 return MATCH_ERROR
;
10172 gfc_new_block
= sym
;
10177 /* This function does some work to determine which matcher should be used to
10178 * match a statement beginning with "TYPE". This is used to disambiguate TYPE
10179 * as an alias for PRINT from derived type declarations, TYPE IS statements,
10180 * and [parameterized] derived type declarations. */
10183 gfc_match_type (gfc_statement
*st
)
10185 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10189 /* Requires -fdec. */
10193 m
= gfc_match ("type");
10194 if (m
!= MATCH_YES
)
10196 /* If we already have an error in the buffer, it is probably from failing to
10197 * match a derived type data declaration. Let it happen. */
10198 else if (gfc_error_flag_test ())
10201 old_loc
= gfc_current_locus
;
10204 /* If we see an attribute list before anything else it's definitely a derived
10205 * type declaration. */
10206 if (gfc_match (" ,") == MATCH_YES
|| gfc_match (" ::") == MATCH_YES
)
10209 /* By now "TYPE" has already been matched. If we do not see a name, this may
10210 * be something like "TYPE *" or "TYPE <fmt>". */
10211 m
= gfc_match_name (name
);
10212 if (m
!= MATCH_YES
)
10214 /* Let print match if it can, otherwise throw an error from
10215 * gfc_match_derived_decl. */
10216 gfc_current_locus
= old_loc
;
10217 if (gfc_match_print () == MATCH_YES
)
10225 /* Check for EOS. */
10226 if (gfc_match_eos () == MATCH_YES
)
10228 /* By now we have "TYPE <name> <EOS>". Check first if the name is an
10229 * intrinsic typename - if so let gfc_match_derived_decl dump an error.
10230 * Otherwise if gfc_match_derived_decl fails it's probably an existing
10231 * symbol which can be printed. */
10232 gfc_current_locus
= old_loc
;
10233 m
= gfc_match_derived_decl ();
10234 if (gfc_is_intrinsic_typename (name
) || m
== MATCH_YES
)
10236 *st
= ST_DERIVED_DECL
;
10242 /* Here we have "TYPE <name>". Check for <TYPE IS (> or a PDT declaration
10243 like <type name(parameter)>. */
10244 gfc_gobble_whitespace ();
10245 bool paren
= gfc_peek_ascii_char () == '(';
10248 if (strcmp ("is", name
) == 0)
10255 /* Treat TYPE... like PRINT... */
10256 gfc_current_locus
= old_loc
;
10258 return gfc_match_print ();
10261 gfc_current_locus
= old_loc
;
10262 *st
= ST_DERIVED_DECL
;
10263 return gfc_match_derived_decl ();
10266 gfc_current_locus
= old_loc
;
10268 return gfc_match_type_is ();
10272 /* Match the beginning of a derived type declaration. If a type name
10273 was the result of a function, then it is possible to have a symbol
10274 already to be known as a derived type yet have no components. */
10277 gfc_match_derived_decl (void)
10279 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10280 char parent
[GFC_MAX_SYMBOL_LEN
+ 1];
10281 symbol_attribute attr
;
10282 gfc_symbol
*sym
, *gensym
;
10283 gfc_symbol
*extended
;
10285 match is_type_attr_spec
= MATCH_NO
;
10286 bool seen_attr
= false;
10287 gfc_interface
*intr
= NULL
, *head
;
10288 bool parameterized_type
= false;
10289 bool seen_colons
= false;
10291 if (gfc_comp_struct (gfc_current_state ()))
10296 gfc_clear_attr (&attr
);
10301 is_type_attr_spec
= gfc_get_type_attr_spec (&attr
, parent
);
10302 if (is_type_attr_spec
== MATCH_ERROR
)
10303 return MATCH_ERROR
;
10304 if (is_type_attr_spec
== MATCH_YES
)
10306 } while (is_type_attr_spec
== MATCH_YES
);
10308 /* Deal with derived type extensions. The extension attribute has
10309 been added to 'attr' but now the parent type must be found and
10312 extended
= check_extended_derived_type (parent
);
10314 if (parent
[0] && !extended
)
10315 return MATCH_ERROR
;
10317 m
= gfc_match (" ::");
10318 if (m
== MATCH_YES
)
10320 seen_colons
= true;
10322 else if (seen_attr
)
10324 gfc_error ("Expected :: in TYPE definition at %C");
10325 return MATCH_ERROR
;
10328 /* In free source form, need to check for TYPE XXX as oppose to TYPEXXX.
10329 But, we need to simply return for TYPE(. */
10330 if (m
== MATCH_NO
&& gfc_current_form
== FORM_FREE
)
10332 char c
= gfc_peek_ascii_char ();
10335 if (!gfc_is_whitespace (c
))
10337 gfc_error ("Mangled derived type definition at %C");
10342 m
= gfc_match (" %n ", name
);
10343 if (m
!= MATCH_YES
)
10346 /* Make sure that we don't identify TYPE IS (...) as a parameterized
10347 derived type named 'is'.
10348 TODO Expand the check, when 'name' = "is" by matching " (tname) "
10349 and checking if this is a(n intrinsic) typename. This picks up
10350 misplaced TYPE IS statements such as in select_type_1.f03. */
10351 if (gfc_peek_ascii_char () == '(')
10353 if (gfc_current_state () == COMP_SELECT_TYPE
10354 || (!seen_colons
&& !strcmp (name
, "is")))
10356 parameterized_type
= true;
10359 m
= gfc_match_eos ();
10360 if (m
!= MATCH_YES
&& !parameterized_type
)
10363 /* Make sure the name is not the name of an intrinsic type. */
10364 if (gfc_is_intrinsic_typename (name
))
10366 gfc_error ("Type name %qs at %C cannot be the same as an intrinsic "
10368 return MATCH_ERROR
;
10371 if (gfc_get_symbol (name
, NULL
, &gensym
))
10372 return MATCH_ERROR
;
10374 if (!gensym
->attr
.generic
&& gensym
->ts
.type
!= BT_UNKNOWN
)
10376 if (gensym
->ts
.u
.derived
)
10377 gfc_error ("Derived type name %qs at %C already has a basic type "
10378 "of %s", gensym
->name
, gfc_typename (&gensym
->ts
));
10380 gfc_error ("Derived type name %qs at %C already has a basic type",
10382 return MATCH_ERROR
;
10385 if (!gensym
->attr
.generic
10386 && !gfc_add_generic (&gensym
->attr
, gensym
->name
, NULL
))
10387 return MATCH_ERROR
;
10389 if (!gensym
->attr
.function
10390 && !gfc_add_function (&gensym
->attr
, gensym
->name
, NULL
))
10391 return MATCH_ERROR
;
10393 if (gensym
->attr
.dummy
)
10395 gfc_error ("Dummy argument %qs at %L cannot be a derived type at %C",
10396 name
, &gensym
->declared_at
);
10397 return MATCH_ERROR
;
10400 sym
= gfc_find_dt_in_generic (gensym
);
10402 if (sym
&& (sym
->components
!= NULL
|| sym
->attr
.zero_comp
))
10404 gfc_error ("Derived type definition of %qs at %C has already been "
10405 "defined", sym
->name
);
10406 return MATCH_ERROR
;
10411 /* Use upper case to save the actual derived-type symbol. */
10412 gfc_get_symbol (gfc_dt_upper_string (gensym
->name
), NULL
, &sym
);
10413 sym
->name
= gfc_get_string ("%s", gensym
->name
);
10414 head
= gensym
->generic
;
10415 intr
= gfc_get_interface ();
10417 intr
->where
= gfc_current_locus
;
10418 intr
->sym
->declared_at
= gfc_current_locus
;
10420 gensym
->generic
= intr
;
10421 gensym
->attr
.if_source
= IFSRC_DECL
;
10424 /* The symbol may already have the derived attribute without the
10425 components. The ways this can happen is via a function
10426 definition, an INTRINSIC statement or a subtype in another
10427 derived type that is a pointer. The first part of the AND clause
10428 is true if the symbol is not the return value of a function. */
10429 if (sym
->attr
.flavor
!= FL_DERIVED
10430 && !gfc_add_flavor (&sym
->attr
, FL_DERIVED
, sym
->name
, NULL
))
10431 return MATCH_ERROR
;
10433 if (attr
.access
!= ACCESS_UNKNOWN
10434 && !gfc_add_access (&sym
->attr
, attr
.access
, sym
->name
, NULL
))
10435 return MATCH_ERROR
;
10436 else if (sym
->attr
.access
== ACCESS_UNKNOWN
10437 && gensym
->attr
.access
!= ACCESS_UNKNOWN
10438 && !gfc_add_access (&sym
->attr
, gensym
->attr
.access
,
10440 return MATCH_ERROR
;
10442 if (sym
->attr
.access
!= ACCESS_UNKNOWN
10443 && gensym
->attr
.access
== ACCESS_UNKNOWN
)
10444 gensym
->attr
.access
= sym
->attr
.access
;
10446 /* See if the derived type was labeled as bind(c). */
10447 if (attr
.is_bind_c
!= 0)
10448 sym
->attr
.is_bind_c
= attr
.is_bind_c
;
10450 /* Construct the f2k_derived namespace if it is not yet there. */
10451 if (!sym
->f2k_derived
)
10452 sym
->f2k_derived
= gfc_get_namespace (NULL
, 0);
10454 if (parameterized_type
)
10456 /* Ignore error or mismatches by going to the end of the statement
10457 in order to avoid the component declarations causing problems. */
10458 m
= gfc_match_formal_arglist (sym
, 0, 0, true);
10459 if (m
!= MATCH_YES
)
10460 gfc_error_recovery ();
10462 sym
->attr
.pdt_template
= 1;
10463 m
= gfc_match_eos ();
10464 if (m
!= MATCH_YES
)
10466 gfc_error_recovery ();
10467 gfc_error_now ("Garbage after PARAMETERIZED TYPE declaration at %C");
10471 if (extended
&& !sym
->components
)
10474 gfc_formal_arglist
*f
, *g
, *h
;
10476 /* Add the extended derived type as the first component. */
10477 gfc_add_component (sym
, parent
, &p
);
10479 gfc_set_sym_referenced (extended
);
10481 p
->ts
.type
= BT_DERIVED
;
10482 p
->ts
.u
.derived
= extended
;
10483 p
->initializer
= gfc_default_initializer (&p
->ts
);
10485 /* Set extension level. */
10486 if (extended
->attr
.extension
== 255)
10488 /* Since the extension field is 8 bit wide, we can only have
10489 up to 255 extension levels. */
10490 gfc_error ("Maximum extension level reached with type %qs at %L",
10491 extended
->name
, &extended
->declared_at
);
10492 return MATCH_ERROR
;
10494 sym
->attr
.extension
= extended
->attr
.extension
+ 1;
10496 /* Provide the links between the extended type and its extension. */
10497 if (!extended
->f2k_derived
)
10498 extended
->f2k_derived
= gfc_get_namespace (NULL
, 0);
10500 /* Copy the extended type-param-name-list from the extended type,
10501 append those of the extension and add the whole lot to the
10503 if (extended
->attr
.pdt_template
)
10506 sym
->attr
.pdt_template
= 1;
10507 for (f
= extended
->formal
; f
; f
= f
->next
)
10509 if (f
== extended
->formal
)
10511 g
= gfc_get_formal_arglist ();
10516 g
->next
= gfc_get_formal_arglist ();
10521 g
->next
= sym
->formal
;
10526 if (!sym
->hash_value
)
10527 /* Set the hash for the compound name for this type. */
10528 sym
->hash_value
= gfc_hash_value (sym
);
10530 /* Take over the ABSTRACT attribute. */
10531 sym
->attr
.abstract
= attr
.abstract
;
10533 gfc_new_block
= sym
;
10539 /* Cray Pointees can be declared as:
10540 pointer (ipt, a (n,m,...,*)) */
10543 gfc_mod_pointee_as (gfc_array_spec
*as
)
10545 as
->cray_pointee
= true; /* This will be useful to know later. */
10546 if (as
->type
== AS_ASSUMED_SIZE
)
10547 as
->cp_was_assumed
= true;
10548 else if (as
->type
== AS_ASSUMED_SHAPE
)
10550 gfc_error ("Cray Pointee at %C cannot be assumed shape array");
10551 return MATCH_ERROR
;
10557 /* Match the enum definition statement, here we are trying to match
10558 the first line of enum definition statement.
10559 Returns MATCH_YES if match is found. */
10562 gfc_match_enum (void)
10566 m
= gfc_match_eos ();
10567 if (m
!= MATCH_YES
)
10570 if (!gfc_notify_std (GFC_STD_F2003
, "ENUM and ENUMERATOR at %C"))
10571 return MATCH_ERROR
;
10577 /* Returns an initializer whose value is one higher than the value of the
10578 LAST_INITIALIZER argument. If the argument is NULL, the
10579 initializers value will be set to zero. The initializer's kind
10580 will be set to gfc_c_int_kind.
10582 If -fshort-enums is given, the appropriate kind will be selected
10583 later after all enumerators have been parsed. A warning is issued
10584 here if an initializer exceeds gfc_c_int_kind. */
10587 enum_initializer (gfc_expr
*last_initializer
, locus where
)
10590 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_c_int_kind
, &where
);
10592 mpz_init (result
->value
.integer
);
10594 if (last_initializer
!= NULL
)
10596 mpz_add_ui (result
->value
.integer
, last_initializer
->value
.integer
, 1);
10597 result
->where
= last_initializer
->where
;
10599 if (gfc_check_integer_range (result
->value
.integer
,
10600 gfc_c_int_kind
) != ARITH_OK
)
10602 gfc_error ("Enumerator exceeds the C integer type at %C");
10608 /* Control comes here, if it's the very first enumerator and no
10609 initializer has been given. It will be initialized to zero. */
10610 mpz_set_si (result
->value
.integer
, 0);
10617 /* Match a variable name with an optional initializer. When this
10618 subroutine is called, a variable is expected to be parsed next.
10619 Depending on what is happening at the moment, updates either the
10620 symbol table or the current interface. */
10623 enumerator_decl (void)
10625 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10626 gfc_expr
*initializer
;
10627 gfc_array_spec
*as
= NULL
;
10634 initializer
= NULL
;
10635 old_locus
= gfc_current_locus
;
10637 /* When we get here, we've just matched a list of attributes and
10638 maybe a type and a double colon. The next thing we expect to see
10639 is the name of the symbol. */
10640 m
= gfc_match_name (name
);
10641 if (m
!= MATCH_YES
)
10644 var_locus
= gfc_current_locus
;
10646 /* OK, we've successfully matched the declaration. Now put the
10647 symbol in the current namespace. If we fail to create the symbol,
10649 if (!build_sym (name
, NULL
, false, &as
, &var_locus
))
10655 /* The double colon must be present in order to have initializers.
10656 Otherwise the statement is ambiguous with an assignment statement. */
10659 if (gfc_match_char ('=') == MATCH_YES
)
10661 m
= gfc_match_init_expr (&initializer
);
10664 gfc_error ("Expected an initialization expression at %C");
10668 if (m
!= MATCH_YES
)
10673 /* If we do not have an initializer, the initialization value of the
10674 previous enumerator (stored in last_initializer) is incremented
10675 by 1 and is used to initialize the current enumerator. */
10676 if (initializer
== NULL
)
10677 initializer
= enum_initializer (last_initializer
, old_locus
);
10679 if (initializer
== NULL
|| initializer
->ts
.type
!= BT_INTEGER
)
10681 gfc_error ("ENUMERATOR %L not initialized with integer expression",
10687 /* Store this current initializer, for the next enumerator variable
10688 to be parsed. add_init_expr_to_sym() zeros initializer, so we
10689 use last_initializer below. */
10690 last_initializer
= initializer
;
10691 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
10693 /* Maintain enumerator history. */
10694 gfc_find_symbol (name
, NULL
, 0, &sym
);
10695 create_enum_history (sym
, last_initializer
);
10697 return (t
) ? MATCH_YES
: MATCH_ERROR
;
10700 /* Free stuff up and return. */
10701 gfc_free_expr (initializer
);
10707 /* Match the enumerator definition statement. */
10710 gfc_match_enumerator_def (void)
10715 gfc_clear_ts (¤t_ts
);
10717 m
= gfc_match (" enumerator");
10718 if (m
!= MATCH_YES
)
10721 m
= gfc_match (" :: ");
10722 if (m
== MATCH_ERROR
)
10725 colon_seen
= (m
== MATCH_YES
);
10727 if (gfc_current_state () != COMP_ENUM
)
10729 gfc_error ("ENUM definition statement expected before %C");
10730 gfc_free_enum_history ();
10731 return MATCH_ERROR
;
10734 (¤t_ts
)->type
= BT_INTEGER
;
10735 (¤t_ts
)->kind
= gfc_c_int_kind
;
10737 gfc_clear_attr (¤t_attr
);
10738 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, NULL
);
10747 m
= enumerator_decl ();
10748 if (m
== MATCH_ERROR
)
10750 gfc_free_enum_history ();
10756 if (gfc_match_eos () == MATCH_YES
)
10758 if (gfc_match_char (',') != MATCH_YES
)
10762 if (gfc_current_state () == COMP_ENUM
)
10764 gfc_free_enum_history ();
10765 gfc_error ("Syntax error in ENUMERATOR definition at %C");
10770 gfc_free_array_spec (current_as
);
10777 /* Match binding attributes. */
10780 match_binding_attributes (gfc_typebound_proc
* ba
, bool generic
, bool ppc
)
10782 bool found_passing
= false;
10783 bool seen_ptr
= false;
10784 match m
= MATCH_YES
;
10786 /* Initialize to defaults. Do so even before the MATCH_NO check so that in
10787 this case the defaults are in there. */
10788 ba
->access
= ACCESS_UNKNOWN
;
10789 ba
->pass_arg
= NULL
;
10790 ba
->pass_arg_num
= 0;
10792 ba
->non_overridable
= 0;
10796 /* If we find a comma, we believe there are binding attributes. */
10797 m
= gfc_match_char (',');
10803 /* Access specifier. */
10805 m
= gfc_match (" public");
10806 if (m
== MATCH_ERROR
)
10808 if (m
== MATCH_YES
)
10810 if (ba
->access
!= ACCESS_UNKNOWN
)
10812 gfc_error ("Duplicate access-specifier at %C");
10816 ba
->access
= ACCESS_PUBLIC
;
10820 m
= gfc_match (" private");
10821 if (m
== MATCH_ERROR
)
10823 if (m
== MATCH_YES
)
10825 if (ba
->access
!= ACCESS_UNKNOWN
)
10827 gfc_error ("Duplicate access-specifier at %C");
10831 ba
->access
= ACCESS_PRIVATE
;
10835 /* If inside GENERIC, the following is not allowed. */
10840 m
= gfc_match (" nopass");
10841 if (m
== MATCH_ERROR
)
10843 if (m
== MATCH_YES
)
10847 gfc_error ("Binding attributes already specify passing,"
10848 " illegal NOPASS at %C");
10852 found_passing
= true;
10857 /* PASS possibly including argument. */
10858 m
= gfc_match (" pass");
10859 if (m
== MATCH_ERROR
)
10861 if (m
== MATCH_YES
)
10863 char arg
[GFC_MAX_SYMBOL_LEN
+ 1];
10867 gfc_error ("Binding attributes already specify passing,"
10868 " illegal PASS at %C");
10872 m
= gfc_match (" ( %n )", arg
);
10873 if (m
== MATCH_ERROR
)
10875 if (m
== MATCH_YES
)
10876 ba
->pass_arg
= gfc_get_string ("%s", arg
);
10877 gcc_assert ((m
== MATCH_YES
) == (ba
->pass_arg
!= NULL
));
10879 found_passing
= true;
10886 /* POINTER flag. */
10887 m
= gfc_match (" pointer");
10888 if (m
== MATCH_ERROR
)
10890 if (m
== MATCH_YES
)
10894 gfc_error ("Duplicate POINTER attribute at %C");
10904 /* NON_OVERRIDABLE flag. */
10905 m
= gfc_match (" non_overridable");
10906 if (m
== MATCH_ERROR
)
10908 if (m
== MATCH_YES
)
10910 if (ba
->non_overridable
)
10912 gfc_error ("Duplicate NON_OVERRIDABLE at %C");
10916 ba
->non_overridable
= 1;
10920 /* DEFERRED flag. */
10921 m
= gfc_match (" deferred");
10922 if (m
== MATCH_ERROR
)
10924 if (m
== MATCH_YES
)
10928 gfc_error ("Duplicate DEFERRED at %C");
10939 /* Nothing matching found. */
10941 gfc_error ("Expected access-specifier at %C");
10943 gfc_error ("Expected binding attribute at %C");
10946 while (gfc_match_char (',') == MATCH_YES
);
10948 /* NON_OVERRIDABLE and DEFERRED exclude themselves. */
10949 if (ba
->non_overridable
&& ba
->deferred
)
10951 gfc_error ("NON_OVERRIDABLE and DEFERRED cannot both appear at %C");
10958 if (ba
->access
== ACCESS_UNKNOWN
)
10959 ba
->access
= ppc
? gfc_current_block()->component_access
10960 : gfc_typebound_default_access
;
10962 if (ppc
&& !seen_ptr
)
10964 gfc_error ("POINTER attribute is required for procedure pointer component"
10972 return MATCH_ERROR
;
10976 /* Match a PROCEDURE specific binding inside a derived type. */
10979 match_procedure_in_type (void)
10981 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10982 char target_buf
[GFC_MAX_SYMBOL_LEN
+ 1];
10983 char* target
= NULL
, *ifc
= NULL
;
10984 gfc_typebound_proc tb
;
10988 gfc_symtree
* stree
;
10993 /* Check current state. */
10994 gcc_assert (gfc_state_stack
->state
== COMP_DERIVED_CONTAINS
);
10995 block
= gfc_state_stack
->previous
->sym
;
10996 gcc_assert (block
);
10998 /* Try to match PROCEDURE(interface). */
10999 if (gfc_match (" (") == MATCH_YES
)
11001 m
= gfc_match_name (target_buf
);
11002 if (m
== MATCH_ERROR
)
11004 if (m
!= MATCH_YES
)
11006 gfc_error ("Interface-name expected after %<(%> at %C");
11007 return MATCH_ERROR
;
11010 if (gfc_match (" )") != MATCH_YES
)
11012 gfc_error ("%<)%> expected at %C");
11013 return MATCH_ERROR
;
11019 /* Construct the data structure. */
11020 memset (&tb
, 0, sizeof (tb
));
11021 tb
.where
= gfc_current_locus
;
11023 /* Match binding attributes. */
11024 m
= match_binding_attributes (&tb
, false, false);
11025 if (m
== MATCH_ERROR
)
11027 seen_attrs
= (m
== MATCH_YES
);
11029 /* Check that attribute DEFERRED is given if an interface is specified. */
11030 if (tb
.deferred
&& !ifc
)
11032 gfc_error ("Interface must be specified for DEFERRED binding at %C");
11033 return MATCH_ERROR
;
11035 if (ifc
&& !tb
.deferred
)
11037 gfc_error ("PROCEDURE(interface) at %C should be declared DEFERRED");
11038 return MATCH_ERROR
;
11041 /* Match the colons. */
11042 m
= gfc_match (" ::");
11043 if (m
== MATCH_ERROR
)
11045 seen_colons
= (m
== MATCH_YES
);
11046 if (seen_attrs
&& !seen_colons
)
11048 gfc_error ("Expected %<::%> after binding-attributes at %C");
11049 return MATCH_ERROR
;
11052 /* Match the binding names. */
11055 m
= gfc_match_name (name
);
11056 if (m
== MATCH_ERROR
)
11060 gfc_error ("Expected binding name at %C");
11061 return MATCH_ERROR
;
11064 if (num
>1 && !gfc_notify_std (GFC_STD_F2008
, "PROCEDURE list at %C"))
11065 return MATCH_ERROR
;
11067 /* Try to match the '=> target', if it's there. */
11069 m
= gfc_match (" =>");
11070 if (m
== MATCH_ERROR
)
11072 if (m
== MATCH_YES
)
11076 gfc_error ("%<=> target%> is invalid for DEFERRED binding at %C");
11077 return MATCH_ERROR
;
11082 gfc_error ("%<::%> needed in PROCEDURE binding with explicit target"
11084 return MATCH_ERROR
;
11087 m
= gfc_match_name (target_buf
);
11088 if (m
== MATCH_ERROR
)
11092 gfc_error ("Expected binding target after %<=>%> at %C");
11093 return MATCH_ERROR
;
11095 target
= target_buf
;
11098 /* If no target was found, it has the same name as the binding. */
11102 /* Get the namespace to insert the symbols into. */
11103 ns
= block
->f2k_derived
;
11106 /* If the binding is DEFERRED, check that the containing type is ABSTRACT. */
11107 if (tb
.deferred
&& !block
->attr
.abstract
)
11109 gfc_error ("Type %qs containing DEFERRED binding at %C "
11110 "is not ABSTRACT", block
->name
);
11111 return MATCH_ERROR
;
11114 /* See if we already have a binding with this name in the symtree which
11115 would be an error. If a GENERIC already targeted this binding, it may
11116 be already there but then typebound is still NULL. */
11117 stree
= gfc_find_symtree (ns
->tb_sym_root
, name
);
11118 if (stree
&& stree
->n
.tb
)
11120 gfc_error ("There is already a procedure with binding name %qs for "
11121 "the derived type %qs at %C", name
, block
->name
);
11122 return MATCH_ERROR
;
11125 /* Insert it and set attributes. */
11129 stree
= gfc_new_symtree (&ns
->tb_sym_root
, name
);
11130 gcc_assert (stree
);
11132 stree
->n
.tb
= gfc_get_typebound_proc (&tb
);
11134 if (gfc_get_sym_tree (target
, gfc_current_ns
, &stree
->n
.tb
->u
.specific
,
11136 return MATCH_ERROR
;
11137 gfc_set_sym_referenced (stree
->n
.tb
->u
.specific
->n
.sym
);
11138 gfc_add_flavor(&stree
->n
.tb
->u
.specific
->n
.sym
->attr
, FL_PROCEDURE
,
11139 target
, &stree
->n
.tb
->u
.specific
->n
.sym
->declared_at
);
11141 if (gfc_match_eos () == MATCH_YES
)
11143 if (gfc_match_char (',') != MATCH_YES
)
11148 gfc_error ("Syntax error in PROCEDURE statement at %C");
11149 return MATCH_ERROR
;
11153 /* Match a GENERIC procedure binding inside a derived type. */
11156 gfc_match_generic (void)
11158 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
11159 char bind_name
[GFC_MAX_SYMBOL_LEN
+ 16]; /* Allow space for OPERATOR(...). */
11161 gfc_typebound_proc tbattr
; /* Used for match_binding_attributes. */
11162 gfc_typebound_proc
* tb
;
11164 interface_type op_type
;
11165 gfc_intrinsic_op op
;
11168 /* Check current state. */
11169 if (gfc_current_state () == COMP_DERIVED
)
11171 gfc_error ("GENERIC at %C must be inside a derived-type CONTAINS");
11172 return MATCH_ERROR
;
11174 if (gfc_current_state () != COMP_DERIVED_CONTAINS
)
11176 block
= gfc_state_stack
->previous
->sym
;
11177 ns
= block
->f2k_derived
;
11178 gcc_assert (block
&& ns
);
11180 memset (&tbattr
, 0, sizeof (tbattr
));
11181 tbattr
.where
= gfc_current_locus
;
11183 /* See if we get an access-specifier. */
11184 m
= match_binding_attributes (&tbattr
, true, false);
11185 if (m
== MATCH_ERROR
)
11188 /* Now the colons, those are required. */
11189 if (gfc_match (" ::") != MATCH_YES
)
11191 gfc_error ("Expected %<::%> at %C");
11195 /* Match the binding name; depending on type (operator / generic) format
11196 it for future error messages into bind_name. */
11198 m
= gfc_match_generic_spec (&op_type
, name
, &op
);
11199 if (m
== MATCH_ERROR
)
11200 return MATCH_ERROR
;
11203 gfc_error ("Expected generic name or operator descriptor at %C");
11209 case INTERFACE_GENERIC
:
11210 case INTERFACE_DTIO
:
11211 snprintf (bind_name
, sizeof (bind_name
), "%s", name
);
11214 case INTERFACE_USER_OP
:
11215 snprintf (bind_name
, sizeof (bind_name
), "OPERATOR(.%s.)", name
);
11218 case INTERFACE_INTRINSIC_OP
:
11219 snprintf (bind_name
, sizeof (bind_name
), "OPERATOR(%s)",
11220 gfc_op2string (op
));
11223 case INTERFACE_NAMELESS
:
11224 gfc_error ("Malformed GENERIC statement at %C");
11229 gcc_unreachable ();
11232 /* Match the required =>. */
11233 if (gfc_match (" =>") != MATCH_YES
)
11235 gfc_error ("Expected %<=>%> at %C");
11239 /* Try to find existing GENERIC binding with this name / for this operator;
11240 if there is something, check that it is another GENERIC and then extend
11241 it rather than building a new node. Otherwise, create it and put it
11242 at the right position. */
11246 case INTERFACE_DTIO
:
11247 case INTERFACE_USER_OP
:
11248 case INTERFACE_GENERIC
:
11250 const bool is_op
= (op_type
== INTERFACE_USER_OP
);
11253 st
= gfc_find_symtree (is_op
? ns
->tb_uop_root
: ns
->tb_sym_root
, name
);
11254 tb
= st
? st
->n
.tb
: NULL
;
11258 case INTERFACE_INTRINSIC_OP
:
11259 tb
= ns
->tb_op
[op
];
11263 gcc_unreachable ();
11268 if (!tb
->is_generic
)
11270 gcc_assert (op_type
== INTERFACE_GENERIC
);
11271 gfc_error ("There's already a non-generic procedure with binding name"
11272 " %qs for the derived type %qs at %C",
11273 bind_name
, block
->name
);
11277 if (tb
->access
!= tbattr
.access
)
11279 gfc_error ("Binding at %C must have the same access as already"
11280 " defined binding %qs", bind_name
);
11286 tb
= gfc_get_typebound_proc (NULL
);
11287 tb
->where
= gfc_current_locus
;
11288 tb
->access
= tbattr
.access
;
11289 tb
->is_generic
= 1;
11290 tb
->u
.generic
= NULL
;
11294 case INTERFACE_DTIO
:
11295 case INTERFACE_GENERIC
:
11296 case INTERFACE_USER_OP
:
11298 const bool is_op
= (op_type
== INTERFACE_USER_OP
);
11299 gfc_symtree
* st
= gfc_get_tbp_symtree (is_op
? &ns
->tb_uop_root
:
11300 &ns
->tb_sym_root
, name
);
11307 case INTERFACE_INTRINSIC_OP
:
11308 ns
->tb_op
[op
] = tb
;
11312 gcc_unreachable ();
11316 /* Now, match all following names as specific targets. */
11319 gfc_symtree
* target_st
;
11320 gfc_tbp_generic
* target
;
11322 m
= gfc_match_name (name
);
11323 if (m
== MATCH_ERROR
)
11327 gfc_error ("Expected specific binding name at %C");
11331 target_st
= gfc_get_tbp_symtree (&ns
->tb_sym_root
, name
);
11333 /* See if this is a duplicate specification. */
11334 for (target
= tb
->u
.generic
; target
; target
= target
->next
)
11335 if (target_st
== target
->specific_st
)
11337 gfc_error ("%qs already defined as specific binding for the"
11338 " generic %qs at %C", name
, bind_name
);
11342 target
= gfc_get_tbp_generic ();
11343 target
->specific_st
= target_st
;
11344 target
->specific
= NULL
;
11345 target
->next
= tb
->u
.generic
;
11346 target
->is_operator
= ((op_type
== INTERFACE_USER_OP
)
11347 || (op_type
== INTERFACE_INTRINSIC_OP
));
11348 tb
->u
.generic
= target
;
11350 while (gfc_match (" ,") == MATCH_YES
);
11352 /* Here should be the end. */
11353 if (gfc_match_eos () != MATCH_YES
)
11355 gfc_error ("Junk after GENERIC binding at %C");
11362 return MATCH_ERROR
;
11366 /* Match a FINAL declaration inside a derived type. */
11369 gfc_match_final_decl (void)
11371 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
11374 gfc_namespace
* module_ns
;
11378 if (gfc_current_form
== FORM_FREE
)
11380 char c
= gfc_peek_ascii_char ();
11381 if (!gfc_is_whitespace (c
) && c
!= ':')
11385 if (gfc_state_stack
->state
!= COMP_DERIVED_CONTAINS
)
11387 if (gfc_current_form
== FORM_FIXED
)
11390 gfc_error ("FINAL declaration at %C must be inside a derived type "
11391 "CONTAINS section");
11392 return MATCH_ERROR
;
11395 block
= gfc_state_stack
->previous
->sym
;
11396 gcc_assert (block
);
11398 if (!gfc_state_stack
->previous
|| !gfc_state_stack
->previous
->previous
11399 || gfc_state_stack
->previous
->previous
->state
!= COMP_MODULE
)
11401 gfc_error ("Derived type declaration with FINAL at %C must be in the"
11402 " specification part of a MODULE");
11403 return MATCH_ERROR
;
11406 module_ns
= gfc_current_ns
;
11407 gcc_assert (module_ns
);
11408 gcc_assert (module_ns
->proc_name
->attr
.flavor
== FL_MODULE
);
11410 /* Match optional ::, don't care about MATCH_YES or MATCH_NO. */
11411 if (gfc_match (" ::") == MATCH_ERROR
)
11412 return MATCH_ERROR
;
11414 /* Match the sequence of procedure names. */
11421 if (first
&& gfc_match_eos () == MATCH_YES
)
11423 gfc_error ("Empty FINAL at %C");
11424 return MATCH_ERROR
;
11427 m
= gfc_match_name (name
);
11430 gfc_error ("Expected module procedure name at %C");
11431 return MATCH_ERROR
;
11433 else if (m
!= MATCH_YES
)
11434 return MATCH_ERROR
;
11436 if (gfc_match_eos () == MATCH_YES
)
11438 if (!last
&& gfc_match_char (',') != MATCH_YES
)
11440 gfc_error ("Expected %<,%> at %C");
11441 return MATCH_ERROR
;
11444 if (gfc_get_symbol (name
, module_ns
, &sym
))
11446 gfc_error ("Unknown procedure name %qs at %C", name
);
11447 return MATCH_ERROR
;
11450 /* Mark the symbol as module procedure. */
11451 if (sym
->attr
.proc
!= PROC_MODULE
11452 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
11453 return MATCH_ERROR
;
11455 /* Check if we already have this symbol in the list, this is an error. */
11456 for (f
= block
->f2k_derived
->finalizers
; f
; f
= f
->next
)
11457 if (f
->proc_sym
== sym
)
11459 gfc_error ("%qs at %C is already defined as FINAL procedure",
11461 return MATCH_ERROR
;
11464 /* Add this symbol to the list of finalizers. */
11465 gcc_assert (block
->f2k_derived
);
11467 f
= XCNEW (gfc_finalizer
);
11469 f
->proc_tree
= NULL
;
11470 f
->where
= gfc_current_locus
;
11471 f
->next
= block
->f2k_derived
->finalizers
;
11472 block
->f2k_derived
->finalizers
= f
;
11482 const ext_attr_t ext_attr_list
[] = {
11483 { "dllimport", EXT_ATTR_DLLIMPORT
, "dllimport" },
11484 { "dllexport", EXT_ATTR_DLLEXPORT
, "dllexport" },
11485 { "cdecl", EXT_ATTR_CDECL
, "cdecl" },
11486 { "stdcall", EXT_ATTR_STDCALL
, "stdcall" },
11487 { "fastcall", EXT_ATTR_FASTCALL
, "fastcall" },
11488 { "no_arg_check", EXT_ATTR_NO_ARG_CHECK
, NULL
},
11489 { NULL
, EXT_ATTR_LAST
, NULL
}
11492 /* Match a !GCC$ ATTRIBUTES statement of the form:
11493 !GCC$ ATTRIBUTES attribute-list :: var-name [, var-name] ...
11494 When we come here, we have already matched the !GCC$ ATTRIBUTES string.
11496 TODO: We should support all GCC attributes using the same syntax for
11497 the attribute list, i.e. the list in C
11498 __attributes(( attribute-list ))
11500 !GCC$ ATTRIBUTES attribute-list ::
11501 Cf. c-parser.c's c_parser_attributes; the data can then directly be
11504 As there is absolutely no risk of confusion, we should never return
11507 gfc_match_gcc_attributes (void)
11509 symbol_attribute attr
;
11510 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
11515 gfc_clear_attr (&attr
);
11520 if (gfc_match_name (name
) != MATCH_YES
)
11521 return MATCH_ERROR
;
11523 for (id
= 0; id
< EXT_ATTR_LAST
; id
++)
11524 if (strcmp (name
, ext_attr_list
[id
].name
) == 0)
11527 if (id
== EXT_ATTR_LAST
)
11529 gfc_error ("Unknown attribute in !GCC$ ATTRIBUTES statement at %C");
11530 return MATCH_ERROR
;
11533 if (!gfc_add_ext_attribute (&attr
, (ext_attr_id_t
)id
, &gfc_current_locus
))
11534 return MATCH_ERROR
;
11536 gfc_gobble_whitespace ();
11537 ch
= gfc_next_ascii_char ();
11540 /* This is the successful exit condition for the loop. */
11541 if (gfc_next_ascii_char () == ':')
11551 if (gfc_match_eos () == MATCH_YES
)
11556 m
= gfc_match_name (name
);
11557 if (m
!= MATCH_YES
)
11560 if (find_special (name
, &sym
, true))
11561 return MATCH_ERROR
;
11563 sym
->attr
.ext_attr
|= attr
.ext_attr
;
11565 if (gfc_match_eos () == MATCH_YES
)
11568 if (gfc_match_char (',') != MATCH_YES
)
11575 gfc_error ("Syntax error in !GCC$ ATTRIBUTES statement at %C");
11576 return MATCH_ERROR
;
11580 /* Match a !GCC$ UNROLL statement of the form:
11583 The parameter n is the number of times we are supposed to unroll.
11585 When we come here, we have already matched the !GCC$ UNROLL string. */
11587 gfc_match_gcc_unroll (void)
11591 if (gfc_match_small_int (&value
) == MATCH_YES
)
11593 if (value
< 0 || value
> USHRT_MAX
)
11595 gfc_error ("%<GCC unroll%> directive requires a"
11596 " non-negative integral constant"
11597 " less than or equal to %u at %C",
11600 return MATCH_ERROR
;
11602 if (gfc_match_eos () == MATCH_YES
)
11604 directive_unroll
= value
== 0 ? 1 : value
;
11609 gfc_error ("Syntax error in !GCC$ UNROLL directive at %C");
11610 return MATCH_ERROR
;
11613 /* Match a !GCC$ builtin (b) attributes simd flags if('target') form:
11615 The parameter b is name of a middle-end built-in.
11616 FLAGS is optional and must be one of:
11620 IF('target') is optional and TARGET is a name of a multilib ABI.
11622 When we come here, we have already matched the !GCC$ builtin string. */
11625 gfc_match_gcc_builtin (void)
11627 char builtin
[GFC_MAX_SYMBOL_LEN
+ 1];
11628 char target
[GFC_MAX_SYMBOL_LEN
+ 1];
11630 if (gfc_match (" ( %n ) attributes simd", builtin
) != MATCH_YES
)
11631 return MATCH_ERROR
;
11633 gfc_simd_clause clause
= SIMD_NONE
;
11634 if (gfc_match (" ( notinbranch ) ") == MATCH_YES
)
11635 clause
= SIMD_NOTINBRANCH
;
11636 else if (gfc_match (" ( inbranch ) ") == MATCH_YES
)
11637 clause
= SIMD_INBRANCH
;
11639 if (gfc_match (" if ( '%n' ) ", target
) == MATCH_YES
)
11641 const char *abi
= targetm
.get_multilib_abi_name ();
11642 if (abi
== NULL
|| strcmp (abi
, target
) != 0)
11646 if (gfc_vectorized_builtins
== NULL
)
11647 gfc_vectorized_builtins
= new hash_map
<nofree_string_hash
, int> ();
11649 char *r
= XNEWVEC (char, strlen (builtin
) + 32);
11650 sprintf (r
, "__builtin_%s", builtin
);
11653 int &value
= gfc_vectorized_builtins
->get_or_insert (r
, &existed
);
11661 /* Match an !GCC$ IVDEP statement.
11662 When we come here, we have already matched the !GCC$ IVDEP string. */
11665 gfc_match_gcc_ivdep (void)
11667 if (gfc_match_eos () == MATCH_YES
)
11669 directive_ivdep
= true;
11673 gfc_error ("Syntax error in !GCC$ IVDEP directive at %C");
11674 return MATCH_ERROR
;
11677 /* Match an !GCC$ VECTOR statement.
11678 When we come here, we have already matched the !GCC$ VECTOR string. */
11681 gfc_match_gcc_vector (void)
11683 if (gfc_match_eos () == MATCH_YES
)
11685 directive_vector
= true;
11686 directive_novector
= false;
11690 gfc_error ("Syntax error in !GCC$ VECTOR directive at %C");
11691 return MATCH_ERROR
;
11694 /* Match an !GCC$ NOVECTOR statement.
11695 When we come here, we have already matched the !GCC$ NOVECTOR string. */
11698 gfc_match_gcc_novector (void)
11700 if (gfc_match_eos () == MATCH_YES
)
11702 directive_novector
= true;
11703 directive_vector
= false;
11707 gfc_error ("Syntax error in !GCC$ NOVECTOR directive at %C");
11708 return MATCH_ERROR
;