1 /* Declaration statement matcher
2 Copyright (C) 2002-2019 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 /* Map of middle-end built-ins that should be vectorized. */
103 hash_map
<nofree_string_hash
, int> *gfc_vectorized_builtins
;
105 /* If a kind expression of a component of a parameterized derived type is
106 parameterized, temporarily store the expression here. */
107 static gfc_expr
*saved_kind_expr
= NULL
;
109 /* Used to store the parameter list arising in a PDT declaration and
110 in the typespec of a PDT variable or component. */
111 static gfc_actual_arglist
*decl_type_param_list
;
112 static gfc_actual_arglist
*type_param_spec_list
;
114 /********************* DATA statement subroutines *********************/
116 static bool in_match_data
= false;
119 gfc_in_match_data (void)
121 return in_match_data
;
125 set_in_match_data (bool set_value
)
127 in_match_data
= set_value
;
130 /* Free a gfc_data_variable structure and everything beneath it. */
133 free_variable (gfc_data_variable
*p
)
135 gfc_data_variable
*q
;
140 gfc_free_expr (p
->expr
);
141 gfc_free_iterator (&p
->iter
, 0);
142 free_variable (p
->list
);
148 /* Free a gfc_data_value structure and everything beneath it. */
151 free_value (gfc_data_value
*p
)
158 mpz_clear (p
->repeat
);
159 gfc_free_expr (p
->expr
);
165 /* Free a list of gfc_data structures. */
168 gfc_free_data (gfc_data
*p
)
175 free_variable (p
->var
);
176 free_value (p
->value
);
182 /* Free all data in a namespace. */
185 gfc_free_data_all (gfc_namespace
*ns
)
197 /* Reject data parsed since the last restore point was marked. */
200 gfc_reject_data (gfc_namespace
*ns
)
204 while (ns
->data
&& ns
->data
!= ns
->old_data
)
212 static match
var_element (gfc_data_variable
*);
214 /* Match a list of variables terminated by an iterator and a right
218 var_list (gfc_data_variable
*parent
)
220 gfc_data_variable
*tail
, var
;
223 m
= var_element (&var
);
224 if (m
== MATCH_ERROR
)
229 tail
= gfc_get_data_variable ();
236 if (gfc_match_char (',') != MATCH_YES
)
239 m
= gfc_match_iterator (&parent
->iter
, 1);
242 if (m
== MATCH_ERROR
)
245 m
= var_element (&var
);
246 if (m
== MATCH_ERROR
)
251 tail
->next
= gfc_get_data_variable ();
257 if (gfc_match_char (')') != MATCH_YES
)
262 gfc_syntax_error (ST_DATA
);
267 /* Match a single element in a data variable list, which can be a
268 variable-iterator list. */
271 var_element (gfc_data_variable
*new_var
)
276 memset (new_var
, 0, sizeof (gfc_data_variable
));
278 if (gfc_match_char ('(') == MATCH_YES
)
279 return var_list (new_var
);
281 m
= gfc_match_variable (&new_var
->expr
, 0);
285 if (new_var
->expr
->expr_type
== EXPR_CONSTANT
286 && new_var
->expr
->symtree
== NULL
)
288 gfc_error ("Inquiry parameter cannot appear in a "
289 "data-stmt-object-list at %C");
293 sym
= new_var
->expr
->symtree
->n
.sym
;
295 /* Symbol should already have an associated type. */
296 if (!gfc_check_symbol_typed (sym
, gfc_current_ns
, false, gfc_current_locus
))
299 if (!sym
->attr
.function
&& gfc_current_ns
->parent
300 && gfc_current_ns
->parent
== sym
->ns
)
302 gfc_error ("Host associated variable %qs may not be in the DATA "
303 "statement at %C", sym
->name
);
307 if (gfc_current_state () != COMP_BLOCK_DATA
308 && sym
->attr
.in_common
309 && !gfc_notify_std (GFC_STD_GNU
, "initialization of "
310 "common block variable %qs in DATA statement at %C",
314 if (!gfc_add_data (&sym
->attr
, sym
->name
, &new_var
->expr
->where
))
321 /* Match the top-level list of data variables. */
324 top_var_list (gfc_data
*d
)
326 gfc_data_variable var
, *tail
, *new_var
;
333 m
= var_element (&var
);
336 if (m
== MATCH_ERROR
)
339 new_var
= gfc_get_data_variable ();
342 new_var
->expr
->where
= gfc_current_locus
;
347 tail
->next
= new_var
;
351 if (gfc_match_char ('/') == MATCH_YES
)
353 if (gfc_match_char (',') != MATCH_YES
)
360 gfc_syntax_error (ST_DATA
);
361 gfc_free_data_all (gfc_current_ns
);
367 match_data_constant (gfc_expr
**result
)
369 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
370 gfc_symbol
*sym
, *dt_sym
= NULL
;
375 m
= gfc_match_literal_constant (&expr
, 1);
382 if (m
== MATCH_ERROR
)
385 m
= gfc_match_null (result
);
389 old_loc
= gfc_current_locus
;
391 /* Should this be a structure component, try to match it
392 before matching a name. */
393 m
= gfc_match_rvalue (result
);
394 if (m
== MATCH_ERROR
)
397 if (m
== MATCH_YES
&& (*result
)->expr_type
== EXPR_STRUCTURE
)
399 if (!gfc_simplify_expr (*result
, 0))
403 else if (m
== MATCH_YES
)
405 /* If a parameter inquiry ends up here, symtree is NULL but **result
406 contains the right constant expression. Check here. */
407 if ((*result
)->symtree
== NULL
408 && (*result
)->expr_type
== EXPR_CONSTANT
409 && ((*result
)->ts
.type
== BT_INTEGER
410 || (*result
)->ts
.type
== BT_REAL
))
413 /* F2018:R845 data-stmt-constant is initial-data-target.
414 A data-stmt-constant shall be ... initial-data-target if and
415 only if the corresponding data-stmt-object has the POINTER
416 attribute. ... If data-stmt-constant is initial-data-target
417 the corresponding data statement object shall be
418 data-pointer-initialization compatible (7.5.4.6) with the initial
419 data target; the data statement object is initially associated
421 if ((*result
)->symtree
->n
.sym
->attr
.save
422 && (*result
)->symtree
->n
.sym
->attr
.target
)
424 gfc_free_expr (*result
);
427 gfc_current_locus
= old_loc
;
429 m
= gfc_match_name (name
);
433 if (gfc_find_symbol (name
, NULL
, 1, &sym
))
436 if (sym
&& sym
->attr
.generic
)
437 dt_sym
= gfc_find_dt_in_generic (sym
);
440 || (sym
->attr
.flavor
!= FL_PARAMETER
441 && (!dt_sym
|| !gfc_fl_struct (dt_sym
->attr
.flavor
))))
443 gfc_error ("Symbol %qs must be a PARAMETER in DATA statement at %C",
448 else if (dt_sym
&& gfc_fl_struct (dt_sym
->attr
.flavor
))
449 return gfc_match_structure_constructor (dt_sym
, result
);
451 /* Check to see if the value is an initialization array expression. */
452 if (sym
->value
->expr_type
== EXPR_ARRAY
)
454 gfc_current_locus
= old_loc
;
456 m
= gfc_match_init_expr (result
);
457 if (m
== MATCH_ERROR
)
462 if (!gfc_simplify_expr (*result
, 0))
465 if ((*result
)->expr_type
== EXPR_CONSTANT
)
469 gfc_error ("Invalid initializer %s in Data statement at %C", name
);
475 *result
= gfc_copy_expr (sym
->value
);
480 /* Match a list of values in a DATA statement. The leading '/' has
481 already been seen at this point. */
484 top_val_list (gfc_data
*data
)
486 gfc_data_value
*new_val
, *tail
;
494 m
= match_data_constant (&expr
);
497 if (m
== MATCH_ERROR
)
500 new_val
= gfc_get_data_value ();
501 mpz_init (new_val
->repeat
);
504 data
->value
= new_val
;
506 tail
->next
= new_val
;
510 if (expr
->ts
.type
!= BT_INTEGER
|| gfc_match_char ('*') != MATCH_YES
)
513 mpz_set_ui (tail
->repeat
, 1);
517 mpz_set (tail
->repeat
, expr
->value
.integer
);
518 gfc_free_expr (expr
);
520 m
= match_data_constant (&tail
->expr
);
523 if (m
== MATCH_ERROR
)
527 if (gfc_match_char ('/') == MATCH_YES
)
529 if (gfc_match_char (',') == MATCH_NO
)
536 gfc_syntax_error (ST_DATA
);
537 gfc_free_data_all (gfc_current_ns
);
542 /* Matches an old style initialization. */
545 match_old_style_init (const char *name
)
550 gfc_data
*newdata
, *nd
;
552 /* Set up data structure to hold initializers. */
553 gfc_find_sym_tree (name
, NULL
, 0, &st
);
556 newdata
= gfc_get_data ();
557 newdata
->var
= gfc_get_data_variable ();
558 newdata
->var
->expr
= gfc_get_variable_expr (st
);
559 newdata
->var
->expr
->where
= sym
->declared_at
;
560 newdata
->where
= gfc_current_locus
;
562 /* Match initial value list. This also eats the terminal '/'. */
563 m
= top_val_list (newdata
);
570 /* Check that a BOZ did not creep into an old-style initialization. */
571 for (nd
= newdata
; nd
; nd
= nd
->next
)
573 if (nd
->value
->expr
->ts
.type
== BT_BOZ
574 && gfc_invalid_boz ("BOZ at %L cannot appear in an old-style "
575 "initialization", &nd
->value
->expr
->where
))
578 if (nd
->var
->expr
->ts
.type
!= BT_INTEGER
579 && nd
->var
->expr
->ts
.type
!= BT_REAL
580 && nd
->value
->expr
->ts
.type
== BT_BOZ
)
582 gfc_error ("Mismatch in variable type and BOZ literal constant "
583 "at %L in an old-style initialization",
584 &nd
->value
->expr
->where
);
591 gfc_error ("Initialization at %C is not allowed in a PURE procedure");
595 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
597 /* Mark the variable as having appeared in a data statement. */
598 if (!gfc_add_data (&sym
->attr
, sym
->name
, &sym
->declared_at
))
604 /* Chain in namespace list of DATA initializers. */
605 newdata
->next
= gfc_current_ns
->data
;
606 gfc_current_ns
->data
= newdata
;
612 /* Match the stuff following a DATA statement. If ERROR_FLAG is set,
613 we are matching a DATA statement and are therefore issuing an error
614 if we encounter something unexpected, if not, we're trying to match
615 an old-style initialization expression of the form INTEGER I /2/. */
618 gfc_match_data (void)
625 /* Before parsing the rest of a DATA statement, check F2008:c1206. */
626 if ((gfc_current_state () == COMP_FUNCTION
627 || gfc_current_state () == COMP_SUBROUTINE
)
628 && gfc_state_stack
->previous
->state
== COMP_INTERFACE
)
630 gfc_error ("DATA statement at %C cannot appear within an INTERFACE");
634 set_in_match_data (true);
638 new_data
= gfc_get_data ();
639 new_data
->where
= gfc_current_locus
;
641 m
= top_var_list (new_data
);
645 if (new_data
->var
->iter
.var
646 && new_data
->var
->iter
.var
->ts
.type
== BT_INTEGER
647 && new_data
->var
->iter
.var
->symtree
->n
.sym
->attr
.implied_index
== 1
648 && new_data
->var
->list
649 && new_data
->var
->list
->expr
650 && new_data
->var
->list
->expr
->ts
.type
== BT_CHARACTER
651 && new_data
->var
->list
->expr
->ref
652 && new_data
->var
->list
->expr
->ref
->type
== REF_SUBSTRING
)
654 gfc_error ("Invalid substring in data-implied-do at %L in DATA "
655 "statement", &new_data
->var
->list
->expr
->where
);
659 /* Check for an entity with an allocatable component, which is not
661 e
= new_data
->var
->expr
;
667 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
668 if ((ref
->type
== REF_COMPONENT
669 && ref
->u
.c
.component
->attr
.allocatable
)
670 || (ref
->type
== REF_ARRAY
671 && e
->symtree
->n
.sym
->attr
.pointer
!= 1
672 && ref
->u
.ar
.as
&& ref
->u
.ar
.as
->type
== AS_DEFERRED
))
677 gfc_error ("Allocatable component or deferred-shaped array "
678 "near %C in DATA statement");
682 /* F2008:C567 (R536) A data-i-do-object or a variable that appears
683 as a data-stmt-object shall not be an object designator in which
684 a pointer appears other than as the entire rightmost part-ref. */
686 if (e
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
687 && e
->symtree
->n
.sym
->attr
.pointer
688 && ref
->type
== REF_COMPONENT
)
691 for (; ref
; ref
= ref
->next
)
692 if (ref
->type
== REF_COMPONENT
693 && ref
->u
.c
.component
->attr
.pointer
698 m
= top_val_list (new_data
);
702 new_data
->next
= gfc_current_ns
->data
;
703 gfc_current_ns
->data
= new_data
;
705 if (gfc_match_eos () == MATCH_YES
)
708 gfc_match_char (','); /* Optional comma */
711 set_in_match_data (false);
715 gfc_error ("DATA statement at %C is not allowed in a PURE procedure");
718 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
724 gfc_error ("part-ref with pointer attribute near %L is not "
725 "rightmost part-ref of data-stmt-object",
729 set_in_match_data (false);
730 gfc_free_data (new_data
);
735 /************************ Declaration statements *********************/
738 /* Like gfc_match_init_expr, but matches a 'clist' (old-style initialization
739 list). The difference here is the expression is a list of constants
740 and is surrounded by '/'.
741 The typespec ts must match the typespec of the variable which the
742 clist is initializing.
743 The arrayspec tells whether this should match a list of constants
744 corresponding to array elements or a scalar (as == NULL). */
747 match_clist_expr (gfc_expr
**result
, gfc_typespec
*ts
, gfc_array_spec
*as
)
749 gfc_constructor_base array_head
= NULL
;
750 gfc_expr
*expr
= NULL
;
751 match m
= MATCH_ERROR
;
753 mpz_t repeat
, cons_size
, as_size
;
759 /* We have already matched '/' - now look for a constant list, as with
760 top_val_list from decl.c, but append the result to an array. */
761 if (gfc_match ("/") == MATCH_YES
)
763 gfc_error ("Empty old style initializer list at %C");
767 where
= gfc_current_locus
;
768 scalar
= !as
|| !as
->rank
;
770 if (!scalar
&& !spec_size (as
, &as_size
))
772 gfc_error ("Array in initializer list at %L must have an explicit shape",
773 as
->type
== AS_EXPLICIT
? &as
->upper
[0]->where
: &where
);
774 /* Nothing to cleanup yet. */
778 mpz_init_set_ui (repeat
, 0);
782 m
= match_data_constant (&expr
);
784 expr
= NULL
; /* match_data_constant may set expr to garbage */
787 if (m
== MATCH_ERROR
)
790 /* Found r in repeat spec r*c; look for the constant to repeat. */
791 if ( gfc_match_char ('*') == MATCH_YES
)
795 gfc_error ("Repeat spec invalid in scalar initializer at %C");
798 if (expr
->ts
.type
!= BT_INTEGER
)
800 gfc_error ("Repeat spec must be an integer at %C");
803 mpz_set (repeat
, expr
->value
.integer
);
804 gfc_free_expr (expr
);
807 m
= match_data_constant (&expr
);
811 gfc_error ("Expected data constant after repeat spec at %C");
816 /* No repeat spec, we matched the data constant itself. */
818 mpz_set_ui (repeat
, 1);
822 /* Add the constant initializer as many times as repeated. */
823 for (; mpz_cmp_ui (repeat
, 0) > 0; mpz_sub_ui (repeat
, repeat
, 1))
825 /* Make sure types of elements match */
826 if(ts
&& !gfc_compare_types (&expr
->ts
, ts
)
827 && !gfc_convert_type (expr
, ts
, 1))
830 gfc_constructor_append_expr (&array_head
,
831 gfc_copy_expr (expr
), &gfc_current_locus
);
834 gfc_free_expr (expr
);
838 /* For scalar initializers quit after one element. */
841 if(gfc_match_char ('/') != MATCH_YES
)
843 gfc_error ("End of scalar initializer expected at %C");
849 if (gfc_match_char ('/') == MATCH_YES
)
851 if (gfc_match_char (',') == MATCH_NO
)
855 /* If we break early from here out, we encountered an error. */
858 /* Set up expr as an array constructor. */
861 expr
= gfc_get_array_expr (ts
->type
, ts
->kind
, &where
);
863 expr
->value
.constructor
= array_head
;
865 expr
->rank
= as
->rank
;
866 expr
->shape
= gfc_get_shape (expr
->rank
);
868 /* Validate sizes. We built expr ourselves, so cons_size will be
869 constant (we fail above for non-constant expressions).
870 We still need to verify that the sizes match. */
871 gcc_assert (gfc_array_size (expr
, &cons_size
));
872 cmp
= mpz_cmp (cons_size
, as_size
);
874 gfc_error ("Not enough elements in array initializer at %C");
876 gfc_error ("Too many elements in array initializer at %C");
877 mpz_clear (cons_size
);
882 /* Make sure scalar types match. */
883 else if (!gfc_compare_types (&expr
->ts
, ts
)
884 && !gfc_convert_type (expr
, ts
, 1))
888 expr
->ts
.u
.cl
->length_from_typespec
= 1;
896 gfc_error ("Syntax error in old style initializer list at %C");
900 expr
->value
.constructor
= NULL
;
901 gfc_free_expr (expr
);
902 gfc_constructor_free (array_head
);
912 /* Auxiliary function to merge DIMENSION and CODIMENSION array specs. */
915 merge_array_spec (gfc_array_spec
*from
, gfc_array_spec
*to
, bool copy
)
919 if ((from
->type
== AS_ASSUMED_RANK
&& to
->corank
)
920 || (to
->type
== AS_ASSUMED_RANK
&& from
->corank
))
922 gfc_error ("The assumed-rank array at %C shall not have a codimension");
926 if (to
->rank
== 0 && from
->rank
> 0)
928 to
->rank
= from
->rank
;
929 to
->type
= from
->type
;
930 to
->cray_pointee
= from
->cray_pointee
;
931 to
->cp_was_assumed
= from
->cp_was_assumed
;
933 for (i
= 0; i
< to
->corank
; i
++)
935 /* Do not exceed the limits on lower[] and upper[]. gfortran
936 cleans up elsewhere. */
938 if (j
>= GFC_MAX_DIMENSIONS
)
941 to
->lower
[j
] = to
->lower
[i
];
942 to
->upper
[j
] = to
->upper
[i
];
944 for (i
= 0; i
< from
->rank
; i
++)
948 to
->lower
[i
] = gfc_copy_expr (from
->lower
[i
]);
949 to
->upper
[i
] = gfc_copy_expr (from
->upper
[i
]);
953 to
->lower
[i
] = from
->lower
[i
];
954 to
->upper
[i
] = from
->upper
[i
];
958 else if (to
->corank
== 0 && from
->corank
> 0)
960 to
->corank
= from
->corank
;
961 to
->cotype
= from
->cotype
;
963 for (i
= 0; i
< from
->corank
; i
++)
965 /* Do not exceed the limits on lower[] and upper[]. gfortran
966 cleans up elsewhere. */
968 if (j
>= GFC_MAX_DIMENSIONS
)
973 to
->lower
[j
] = gfc_copy_expr (from
->lower
[i
]);
974 to
->upper
[j
] = gfc_copy_expr (from
->upper
[i
]);
978 to
->lower
[j
] = from
->lower
[i
];
979 to
->upper
[j
] = from
->upper
[i
];
984 if (to
->rank
+ to
->corank
> GFC_MAX_DIMENSIONS
)
986 gfc_error ("Sum of array rank %d and corank %d at %C exceeds maximum "
987 "allowed dimensions of %d",
988 to
->rank
, to
->corank
, GFC_MAX_DIMENSIONS
);
989 to
->corank
= GFC_MAX_DIMENSIONS
- to
->rank
;
996 /* Match an intent specification. Since this can only happen after an
997 INTENT word, a legal intent-spec must follow. */
1000 match_intent_spec (void)
1003 if (gfc_match (" ( in out )") == MATCH_YES
)
1004 return INTENT_INOUT
;
1005 if (gfc_match (" ( in )") == MATCH_YES
)
1007 if (gfc_match (" ( out )") == MATCH_YES
)
1010 gfc_error ("Bad INTENT specification at %C");
1011 return INTENT_UNKNOWN
;
1015 /* Matches a character length specification, which is either a
1016 specification expression, '*', or ':'. */
1019 char_len_param_value (gfc_expr
**expr
, bool *deferred
)
1026 if (gfc_match_char ('*') == MATCH_YES
)
1029 if (gfc_match_char (':') == MATCH_YES
)
1031 if (!gfc_notify_std (GFC_STD_F2003
, "deferred type parameter at %C"))
1039 m
= gfc_match_expr (expr
);
1041 if (m
== MATCH_NO
|| m
== MATCH_ERROR
)
1044 if (!gfc_expr_check_typed (*expr
, gfc_current_ns
, false))
1047 if ((*expr
)->expr_type
== EXPR_FUNCTION
)
1049 if ((*expr
)->ts
.type
== BT_INTEGER
1050 || ((*expr
)->ts
.type
== BT_UNKNOWN
1051 && strcmp((*expr
)->symtree
->name
, "null") != 0))
1056 else if ((*expr
)->expr_type
== EXPR_CONSTANT
)
1058 /* F2008, 4.4.3.1: The length is a type parameter; its kind is
1059 processor dependent and its value is greater than or equal to zero.
1060 F2008, 4.4.3.2: If the character length parameter value evaluates
1061 to a negative value, the length of character entities declared
1064 if ((*expr
)->ts
.type
== BT_INTEGER
)
1066 if (mpz_cmp_si ((*expr
)->value
.integer
, 0) < 0)
1067 mpz_set_si ((*expr
)->value
.integer
, 0);
1072 else if ((*expr
)->expr_type
== EXPR_ARRAY
)
1074 else if ((*expr
)->expr_type
== EXPR_VARIABLE
)
1079 e
= gfc_copy_expr (*expr
);
1081 /* This catches the invalid code "[character(m(2:3)) :: 'x', 'y']",
1082 which causes an ICE if gfc_reduce_init_expr() is called. */
1083 if (e
->ref
&& e
->ref
->type
== REF_ARRAY
1084 && e
->ref
->u
.ar
.type
== AR_UNKNOWN
1085 && e
->ref
->u
.ar
.dimen_type
[0] == DIMEN_RANGE
)
1088 t
= gfc_reduce_init_expr (e
);
1090 if (!t
&& e
->ts
.type
== BT_UNKNOWN
1091 && e
->symtree
->n
.sym
->attr
.untyped
== 1
1092 && (flag_implicit_none
1093 || e
->symtree
->n
.sym
->ns
->seen_implicit_none
== 1
1094 || e
->symtree
->n
.sym
->ns
->parent
->seen_implicit_none
== 1))
1100 if ((e
->ref
&& e
->ref
->type
== REF_ARRAY
1101 && e
->ref
->u
.ar
.type
!= AR_ELEMENT
)
1102 || (!e
->ref
&& e
->expr_type
== EXPR_ARRAY
))
1114 gfc_error ("Scalar INTEGER expression expected at %L", &(*expr
)->where
);
1119 /* A character length is a '*' followed by a literal integer or a
1120 char_len_param_value in parenthesis. */
1123 match_char_length (gfc_expr
**expr
, bool *deferred
, bool obsolescent_check
)
1129 m
= gfc_match_char ('*');
1133 m
= gfc_match_small_literal_int (&length
, NULL
);
1134 if (m
== MATCH_ERROR
)
1139 if (obsolescent_check
1140 && !gfc_notify_std (GFC_STD_F95_OBS
, "Old-style character length at %C"))
1142 *expr
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
, length
);
1146 if (gfc_match_char ('(') == MATCH_NO
)
1149 m
= char_len_param_value (expr
, deferred
);
1150 if (m
!= MATCH_YES
&& gfc_matching_function
)
1152 gfc_undo_symbols ();
1156 if (m
== MATCH_ERROR
)
1161 if (gfc_match_char (')') == MATCH_NO
)
1163 gfc_free_expr (*expr
);
1171 gfc_error ("Syntax error in character length specification at %C");
1176 /* Special subroutine for finding a symbol. Check if the name is found
1177 in the current name space. If not, and we're compiling a function or
1178 subroutine and the parent compilation unit is an interface, then check
1179 to see if the name we've been given is the name of the interface
1180 (located in another namespace). */
1183 find_special (const char *name
, gfc_symbol
**result
, bool allow_subroutine
)
1189 i
= gfc_get_sym_tree (name
, NULL
, &st
, allow_subroutine
);
1192 *result
= st
? st
->n
.sym
: NULL
;
1196 if (gfc_current_state () != COMP_SUBROUTINE
1197 && gfc_current_state () != COMP_FUNCTION
)
1200 s
= gfc_state_stack
->previous
;
1204 if (s
->state
!= COMP_INTERFACE
)
1207 goto end
; /* Nameless interface. */
1209 if (strcmp (name
, s
->sym
->name
) == 0)
1220 /* Special subroutine for getting a symbol node associated with a
1221 procedure name, used in SUBROUTINE and FUNCTION statements. The
1222 symbol is created in the parent using with symtree node in the
1223 child unit pointing to the symbol. If the current namespace has no
1224 parent, then the symbol is just created in the current unit. */
1227 get_proc_name (const char *name
, gfc_symbol
**result
, bool module_fcn_entry
)
1233 /* Module functions have to be left in their own namespace because
1234 they have potentially (almost certainly!) already been referenced.
1235 In this sense, they are rather like external functions. This is
1236 fixed up in resolve.c(resolve_entries), where the symbol name-
1237 space is set to point to the master function, so that the fake
1238 result mechanism can work. */
1239 if (module_fcn_entry
)
1241 /* Present if entry is declared to be a module procedure. */
1242 rc
= gfc_find_symbol (name
, gfc_current_ns
->parent
, 0, result
);
1244 if (*result
== NULL
)
1245 rc
= gfc_get_symbol (name
, NULL
, result
);
1246 else if (!gfc_get_symbol (name
, NULL
, &sym
) && sym
1247 && (*result
)->ts
.type
== BT_UNKNOWN
1248 && sym
->attr
.flavor
== FL_UNKNOWN
)
1249 /* Pick up the typespec for the entry, if declared in the function
1250 body. Note that this symbol is FL_UNKNOWN because it will
1251 only have appeared in a type declaration. The local symtree
1252 is set to point to the module symbol and a unique symtree
1253 to the local version. This latter ensures a correct clearing
1256 /* If the ENTRY proceeds its specification, we need to ensure
1257 that this does not raise a "has no IMPLICIT type" error. */
1258 if (sym
->ts
.type
== BT_UNKNOWN
)
1259 sym
->attr
.untyped
= 1;
1261 (*result
)->ts
= sym
->ts
;
1263 /* Put the symbol in the procedure namespace so that, should
1264 the ENTRY precede its specification, the specification
1266 (*result
)->ns
= gfc_current_ns
;
1268 gfc_find_sym_tree (name
, gfc_current_ns
, 0, &st
);
1269 st
->n
.sym
= *result
;
1270 st
= gfc_get_unique_symtree (gfc_current_ns
);
1276 rc
= gfc_get_symbol (name
, gfc_current_ns
->parent
, result
);
1282 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
1285 if (sym
->attr
.module_procedure
&& sym
->attr
.if_source
== IFSRC_IFBODY
)
1287 /* Create a partially populated interface symbol to carry the
1288 characteristics of the procedure and the result. */
1289 sym
->tlink
= gfc_new_symbol (name
, sym
->ns
);
1290 gfc_add_type (sym
->tlink
, &(sym
->ts
), &gfc_current_locus
);
1291 gfc_copy_attr (&sym
->tlink
->attr
, &sym
->attr
, NULL
);
1292 if (sym
->attr
.dimension
)
1293 sym
->tlink
->as
= gfc_copy_array_spec (sym
->as
);
1295 /* Ideally, at this point, a copy would be made of the formal
1296 arguments and their namespace. However, this does not appear
1297 to be necessary, albeit at the expense of not being able to
1298 use gfc_compare_interfaces directly. */
1300 if (sym
->result
&& sym
->result
!= sym
)
1302 sym
->tlink
->result
= sym
->result
;
1305 else if (sym
->result
)
1307 sym
->tlink
->result
= sym
->tlink
;
1310 else if (sym
&& !sym
->gfc_new
1311 && gfc_current_state () != COMP_INTERFACE
)
1313 /* Trap another encompassed procedure with the same name. All
1314 these conditions are necessary to avoid picking up an entry
1315 whose name clashes with that of the encompassing procedure;
1316 this is handled using gsymbols to register unique, globally
1317 accessible names. */
1318 if (sym
->attr
.flavor
!= 0
1319 && sym
->attr
.proc
!= 0
1320 && (sym
->attr
.subroutine
|| sym
->attr
.function
|| sym
->attr
.entry
)
1321 && sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
1323 gfc_error_now ("Procedure %qs at %C is already defined at %L",
1324 name
, &sym
->declared_at
);
1327 if (sym
->attr
.flavor
!= 0
1328 && sym
->attr
.entry
&& sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
1330 gfc_error_now ("Procedure %qs at %C is already defined at %L",
1331 name
, &sym
->declared_at
);
1335 if (sym
->attr
.external
&& sym
->attr
.procedure
1336 && gfc_current_state () == COMP_CONTAINS
)
1338 gfc_error_now ("Contained procedure %qs at %C clashes with "
1339 "procedure defined at %L",
1340 name
, &sym
->declared_at
);
1344 /* Trap a procedure with a name the same as interface in the
1345 encompassing scope. */
1346 if (sym
->attr
.generic
!= 0
1347 && (sym
->attr
.subroutine
|| sym
->attr
.function
)
1348 && !sym
->attr
.mod_proc
)
1350 gfc_error_now ("Name %qs at %C is already defined"
1351 " as a generic interface at %L",
1352 name
, &sym
->declared_at
);
1356 /* Trap declarations of attributes in encompassing scope. The
1357 signature for this is that ts.kind is set. Legitimate
1358 references only set ts.type. */
1359 if (sym
->ts
.kind
!= 0
1360 && !sym
->attr
.implicit_type
1361 && sym
->attr
.proc
== 0
1362 && gfc_current_ns
->parent
!= NULL
1363 && sym
->attr
.access
== 0
1364 && !module_fcn_entry
)
1366 gfc_error_now ("Procedure %qs at %C has an explicit interface "
1367 "from a previous declaration", name
);
1372 /* C1246 (R1225) MODULE shall appear only in the function-stmt or
1373 subroutine-stmt of a module subprogram or of a nonabstract interface
1374 body that is declared in the scoping unit of a module or submodule. */
1375 if (sym
->attr
.external
1376 && (sym
->attr
.subroutine
|| sym
->attr
.function
)
1377 && sym
->attr
.if_source
== IFSRC_IFBODY
1378 && !current_attr
.module_procedure
1379 && sym
->attr
.proc
== PROC_MODULE
1380 && gfc_state_stack
->state
== COMP_CONTAINS
)
1382 gfc_error_now ("Procedure %qs defined in interface body at %L "
1383 "clashes with internal procedure defined at %C",
1384 name
, &sym
->declared_at
);
1388 if (sym
&& !sym
->gfc_new
1389 && sym
->attr
.flavor
!= FL_UNKNOWN
1390 && sym
->attr
.referenced
== 0 && sym
->attr
.subroutine
== 1
1391 && gfc_state_stack
->state
== COMP_CONTAINS
1392 && gfc_state_stack
->previous
->state
== COMP_SUBROUTINE
)
1394 gfc_error_now ("Procedure %qs at %C is already defined at %L",
1395 name
, &sym
->declared_at
);
1399 if (gfc_current_ns
->parent
== NULL
|| *result
== NULL
)
1402 /* Module function entries will already have a symtree in
1403 the current namespace but will need one at module level. */
1404 if (module_fcn_entry
)
1406 /* Present if entry is declared to be a module procedure. */
1407 rc
= gfc_find_sym_tree (name
, gfc_current_ns
->parent
, 0, &st
);
1409 st
= gfc_new_symtree (&gfc_current_ns
->parent
->sym_root
, name
);
1412 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, name
);
1417 /* See if the procedure should be a module procedure. */
1419 if (((sym
->ns
->proc_name
!= NULL
1420 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
1421 && sym
->attr
.proc
!= PROC_MODULE
)
1422 || (module_fcn_entry
&& sym
->attr
.proc
!= PROC_MODULE
))
1423 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
1430 /* Verify that the given symbol representing a parameter is C
1431 interoperable, by checking to see if it was marked as such after
1432 its declaration. If the given symbol is not interoperable, a
1433 warning is reported, thus removing the need to return the status to
1434 the calling function. The standard does not require the user use
1435 one of the iso_c_binding named constants to declare an
1436 interoperable parameter, but we can't be sure if the param is C
1437 interop or not if the user doesn't. For example, integer(4) may be
1438 legal Fortran, but doesn't have meaning in C. It may interop with
1439 a number of the C types, which causes a problem because the
1440 compiler can't know which one. This code is almost certainly not
1441 portable, and the user will get what they deserve if the C type
1442 across platforms isn't always interoperable with integer(4). If
1443 the user had used something like integer(c_int) or integer(c_long),
1444 the compiler could have automatically handled the varying sizes
1445 across platforms. */
1448 gfc_verify_c_interop_param (gfc_symbol
*sym
)
1450 int is_c_interop
= 0;
1453 /* We check implicitly typed variables in symbol.c:gfc_set_default_type().
1454 Don't repeat the checks here. */
1455 if (sym
->attr
.implicit_type
)
1458 /* For subroutines or functions that are passed to a BIND(C) procedure,
1459 they're interoperable if they're BIND(C) and their params are all
1461 if (sym
->attr
.flavor
== FL_PROCEDURE
)
1463 if (sym
->attr
.is_bind_c
== 0)
1465 gfc_error_now ("Procedure %qs at %L must have the BIND(C) "
1466 "attribute to be C interoperable", sym
->name
,
1467 &(sym
->declared_at
));
1472 if (sym
->attr
.is_c_interop
== 1)
1473 /* We've already checked this procedure; don't check it again. */
1476 return verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
1481 /* See if we've stored a reference to a procedure that owns sym. */
1482 if (sym
->ns
!= NULL
&& sym
->ns
->proc_name
!= NULL
)
1484 if (sym
->ns
->proc_name
->attr
.is_bind_c
== 1)
1486 is_c_interop
= (gfc_verify_c_interop(&(sym
->ts
)) ? 1 : 0);
1488 if (is_c_interop
!= 1)
1490 /* Make personalized messages to give better feedback. */
1491 if (sym
->ts
.type
== BT_DERIVED
)
1492 gfc_error ("Variable %qs at %L is a dummy argument to the "
1493 "BIND(C) procedure %qs but is not C interoperable "
1494 "because derived type %qs is not C interoperable",
1495 sym
->name
, &(sym
->declared_at
),
1496 sym
->ns
->proc_name
->name
,
1497 sym
->ts
.u
.derived
->name
);
1498 else if (sym
->ts
.type
== BT_CLASS
)
1499 gfc_error ("Variable %qs at %L is a dummy argument to the "
1500 "BIND(C) procedure %qs but is not C interoperable "
1501 "because it is polymorphic",
1502 sym
->name
, &(sym
->declared_at
),
1503 sym
->ns
->proc_name
->name
);
1504 else if (warn_c_binding_type
)
1505 gfc_warning (OPT_Wc_binding_type
,
1506 "Variable %qs at %L is a dummy argument of the "
1507 "BIND(C) procedure %qs but may not be C "
1509 sym
->name
, &(sym
->declared_at
),
1510 sym
->ns
->proc_name
->name
);
1513 /* Character strings are only C interoperable if they have a
1515 if (sym
->ts
.type
== BT_CHARACTER
&& !sym
->attr
.dimension
)
1517 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
1518 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
1519 || mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
1521 gfc_error ("Character argument %qs at %L "
1522 "must be length 1 because "
1523 "procedure %qs is BIND(C)",
1524 sym
->name
, &sym
->declared_at
,
1525 sym
->ns
->proc_name
->name
);
1530 /* We have to make sure that any param to a bind(c) routine does
1531 not have the allocatable, pointer, or optional attributes,
1532 according to J3/04-007, section 5.1. */
1533 if (sym
->attr
.allocatable
== 1
1534 && !gfc_notify_std (GFC_STD_F2018
, "Variable %qs at %L with "
1535 "ALLOCATABLE attribute in procedure %qs "
1536 "with BIND(C)", sym
->name
,
1537 &(sym
->declared_at
),
1538 sym
->ns
->proc_name
->name
))
1541 if (sym
->attr
.pointer
== 1
1542 && !gfc_notify_std (GFC_STD_F2018
, "Variable %qs at %L with "
1543 "POINTER attribute in procedure %qs "
1544 "with BIND(C)", sym
->name
,
1545 &(sym
->declared_at
),
1546 sym
->ns
->proc_name
->name
))
1549 if ((sym
->attr
.allocatable
|| sym
->attr
.pointer
) && !sym
->as
)
1551 gfc_error ("Scalar variable %qs at %L with POINTER or "
1552 "ALLOCATABLE in procedure %qs with BIND(C) is not yet"
1553 " supported", sym
->name
, &(sym
->declared_at
),
1554 sym
->ns
->proc_name
->name
);
1558 if (sym
->attr
.optional
== 1 && sym
->attr
.value
)
1560 gfc_error ("Variable %qs at %L cannot have both the OPTIONAL "
1561 "and the VALUE attribute because procedure %qs "
1562 "is BIND(C)", sym
->name
, &(sym
->declared_at
),
1563 sym
->ns
->proc_name
->name
);
1566 else if (sym
->attr
.optional
== 1
1567 && !gfc_notify_std (GFC_STD_F2018
, "Variable %qs "
1568 "at %L with OPTIONAL attribute in "
1569 "procedure %qs which is BIND(C)",
1570 sym
->name
, &(sym
->declared_at
),
1571 sym
->ns
->proc_name
->name
))
1574 /* Make sure that if it has the dimension attribute, that it is
1575 either assumed size or explicit shape. Deferred shape is already
1576 covered by the pointer/allocatable attribute. */
1577 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SHAPE
1578 && !gfc_notify_std (GFC_STD_F2018
, "Assumed-shape array %qs "
1579 "at %L as dummy argument to the BIND(C) "
1580 "procedure %qs at %L", sym
->name
,
1581 &(sym
->declared_at
),
1582 sym
->ns
->proc_name
->name
,
1583 &(sym
->ns
->proc_name
->declared_at
)))
1593 /* Function called by variable_decl() that adds a name to the symbol table. */
1596 build_sym (const char *name
, gfc_charlen
*cl
, bool cl_deferred
,
1597 gfc_array_spec
**as
, locus
*var_locus
)
1599 symbol_attribute attr
;
1604 /* Symbols in a submodule are host associated from the parent module or
1605 submodules. Therefore, they can be overridden by declarations in the
1606 submodule scope. Deal with this by attaching the existing symbol to
1607 a new symtree and recycling the old symtree with a new symbol... */
1608 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
1609 if (st
!= NULL
&& gfc_state_stack
->state
== COMP_SUBMODULE
1610 && st
->n
.sym
!= NULL
1611 && st
->n
.sym
->attr
.host_assoc
&& st
->n
.sym
->attr
.used_in_submodule
)
1613 gfc_symtree
*s
= gfc_get_unique_symtree (gfc_current_ns
);
1614 s
->n
.sym
= st
->n
.sym
;
1615 sym
= gfc_new_symbol (name
, gfc_current_ns
);
1620 gfc_set_sym_referenced (sym
);
1622 /* ...Otherwise generate a new symtree and new symbol. */
1623 else if (gfc_get_symbol (name
, NULL
, &sym
))
1626 /* Check if the name has already been defined as a type. The
1627 first letter of the symtree will be in upper case then. Of
1628 course, this is only necessary if the upper case letter is
1629 actually different. */
1631 upper
= TOUPPER(name
[0]);
1632 if (upper
!= name
[0])
1634 char u_name
[GFC_MAX_SYMBOL_LEN
+ 1];
1637 gcc_assert (strlen(name
) <= GFC_MAX_SYMBOL_LEN
);
1638 strcpy (u_name
, name
);
1641 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, u_name
);
1643 /* STRUCTURE types can alias symbol names */
1644 if (st
!= 0 && st
->n
.sym
->attr
.flavor
!= FL_STRUCT
)
1646 gfc_error ("Symbol %qs at %C also declared as a type at %L", name
,
1647 &st
->n
.sym
->declared_at
);
1652 /* Start updating the symbol table. Add basic type attribute if present. */
1653 if (current_ts
.type
!= BT_UNKNOWN
1654 && (sym
->attr
.implicit_type
== 0
1655 || !gfc_compare_types (&sym
->ts
, ¤t_ts
))
1656 && !gfc_add_type (sym
, ¤t_ts
, var_locus
))
1659 if (sym
->ts
.type
== BT_CHARACTER
)
1662 sym
->ts
.deferred
= cl_deferred
;
1665 /* Add dimension attribute if present. */
1666 if (!gfc_set_array_spec (sym
, *as
, var_locus
))
1670 /* Add attribute to symbol. The copy is so that we can reset the
1671 dimension attribute. */
1672 attr
= current_attr
;
1674 attr
.codimension
= 0;
1676 if (!gfc_copy_attr (&sym
->attr
, &attr
, var_locus
))
1679 /* Finish any work that may need to be done for the binding label,
1680 if it's a bind(c). The bind(c) attr is found before the symbol
1681 is made, and before the symbol name (for data decls), so the
1682 current_ts is holding the binding label, or nothing if the
1683 name= attr wasn't given. Therefore, test here if we're dealing
1684 with a bind(c) and make sure the binding label is set correctly. */
1685 if (sym
->attr
.is_bind_c
== 1)
1687 if (!sym
->binding_label
)
1689 /* Set the binding label and verify that if a NAME= was specified
1690 then only one identifier was in the entity-decl-list. */
1691 if (!set_binding_label (&sym
->binding_label
, sym
->name
,
1692 num_idents_on_line
))
1697 /* See if we know we're in a common block, and if it's a bind(c)
1698 common then we need to make sure we're an interoperable type. */
1699 if (sym
->attr
.in_common
== 1)
1701 /* Test the common block object. */
1702 if (sym
->common_block
!= NULL
&& sym
->common_block
->is_bind_c
== 1
1703 && sym
->ts
.is_c_interop
!= 1)
1705 gfc_error_now ("Variable %qs in common block %qs at %C "
1706 "must be declared with a C interoperable "
1707 "kind since common block %qs is BIND(C)",
1708 sym
->name
, sym
->common_block
->name
,
1709 sym
->common_block
->name
);
1714 sym
->attr
.implied_index
= 0;
1716 /* Use the parameter expressions for a parameterized derived type. */
1717 if ((sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
1718 && sym
->ts
.u
.derived
->attr
.pdt_type
&& type_param_spec_list
)
1719 sym
->param_list
= gfc_copy_actual_arglist (type_param_spec_list
);
1721 if (sym
->ts
.type
== BT_CLASS
)
1722 return gfc_build_class_symbol (&sym
->ts
, &sym
->attr
, &sym
->as
);
1728 /* Set character constant to the given length. The constant will be padded or
1729 truncated. If we're inside an array constructor without a typespec, we
1730 additionally check that all elements have the same length; check_len -1
1731 means no checking. */
1734 gfc_set_constant_character_len (gfc_charlen_t len
, gfc_expr
*expr
,
1735 gfc_charlen_t check_len
)
1740 if (expr
->ts
.type
!= BT_CHARACTER
)
1743 if (expr
->expr_type
!= EXPR_CONSTANT
)
1745 gfc_error_now ("CHARACTER length must be a constant at %L", &expr
->where
);
1749 slen
= expr
->value
.character
.length
;
1752 s
= gfc_get_wide_string (len
+ 1);
1753 memcpy (s
, expr
->value
.character
.string
,
1754 MIN (len
, slen
) * sizeof (gfc_char_t
));
1756 gfc_wide_memset (&s
[slen
], ' ', len
- slen
);
1758 if (warn_character_truncation
&& slen
> len
)
1759 gfc_warning_now (OPT_Wcharacter_truncation
,
1760 "CHARACTER expression at %L is being truncated "
1761 "(%ld/%ld)", &expr
->where
,
1762 (long) slen
, (long) len
);
1764 /* Apply the standard by 'hand' otherwise it gets cleared for
1766 if (check_len
!= -1 && slen
!= check_len
1767 && !(gfc_option
.allow_std
& GFC_STD_GNU
))
1768 gfc_error_now ("The CHARACTER elements of the array constructor "
1769 "at %L must have the same length (%ld/%ld)",
1770 &expr
->where
, (long) slen
,
1774 free (expr
->value
.character
.string
);
1775 expr
->value
.character
.string
= s
;
1776 expr
->value
.character
.length
= len
;
1777 /* If explicit representation was given, clear it
1778 as it is no longer needed after padding. */
1779 if (expr
->representation
.length
)
1781 expr
->representation
.length
= 0;
1782 free (expr
->representation
.string
);
1783 expr
->representation
.string
= NULL
;
1789 /* Function to create and update the enumerator history
1790 using the information passed as arguments.
1791 Pointer "max_enum" is also updated, to point to
1792 enum history node containing largest initializer.
1794 SYM points to the symbol node of enumerator.
1795 INIT points to its enumerator value. */
1798 create_enum_history (gfc_symbol
*sym
, gfc_expr
*init
)
1800 enumerator_history
*new_enum_history
;
1801 gcc_assert (sym
!= NULL
&& init
!= NULL
);
1803 new_enum_history
= XCNEW (enumerator_history
);
1805 new_enum_history
->sym
= sym
;
1806 new_enum_history
->initializer
= init
;
1807 new_enum_history
->next
= NULL
;
1809 if (enum_history
== NULL
)
1811 enum_history
= new_enum_history
;
1812 max_enum
= enum_history
;
1816 new_enum_history
->next
= enum_history
;
1817 enum_history
= new_enum_history
;
1819 if (mpz_cmp (max_enum
->initializer
->value
.integer
,
1820 new_enum_history
->initializer
->value
.integer
) < 0)
1821 max_enum
= new_enum_history
;
1826 /* Function to free enum kind history. */
1829 gfc_free_enum_history (void)
1831 enumerator_history
*current
= enum_history
;
1832 enumerator_history
*next
;
1834 while (current
!= NULL
)
1836 next
= current
->next
;
1841 enum_history
= NULL
;
1845 /* Function called by variable_decl() that adds an initialization
1846 expression to a symbol. */
1849 add_init_expr_to_sym (const char *name
, gfc_expr
**initp
, locus
*var_locus
)
1851 symbol_attribute attr
;
1856 if (find_special (name
, &sym
, false))
1861 /* If this symbol is confirming an implicit parameter type,
1862 then an initialization expression is not allowed. */
1863 if (attr
.flavor
== FL_PARAMETER
1864 && sym
->value
!= NULL
1867 gfc_error ("Initializer not allowed for PARAMETER %qs at %C",
1874 /* An initializer is required for PARAMETER declarations. */
1875 if (attr
.flavor
== FL_PARAMETER
)
1877 gfc_error ("PARAMETER at %L is missing an initializer", var_locus
);
1883 /* If a variable appears in a DATA block, it cannot have an
1887 gfc_error ("Variable %qs at %C with an initializer already "
1888 "appears in a DATA statement", sym
->name
);
1892 /* Check if the assignment can happen. This has to be put off
1893 until later for derived type variables and procedure pointers. */
1894 if (!gfc_bt_struct (sym
->ts
.type
) && !gfc_bt_struct (init
->ts
.type
)
1895 && sym
->ts
.type
!= BT_CLASS
&& init
->ts
.type
!= BT_CLASS
1896 && !sym
->attr
.proc_pointer
1897 && !gfc_check_assign_symbol (sym
, NULL
, init
))
1900 if (sym
->ts
.type
== BT_CHARACTER
&& sym
->ts
.u
.cl
1901 && init
->ts
.type
== BT_CHARACTER
)
1903 /* Update symbol character length according initializer. */
1904 if (!gfc_check_assign_symbol (sym
, NULL
, init
))
1907 if (sym
->ts
.u
.cl
->length
== NULL
)
1910 /* If there are multiple CHARACTER variables declared on the
1911 same line, we don't want them to share the same length. */
1912 sym
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1914 if (sym
->attr
.flavor
== FL_PARAMETER
)
1916 if (init
->expr_type
== EXPR_CONSTANT
)
1918 clen
= init
->value
.character
.length
;
1919 sym
->ts
.u
.cl
->length
1920 = gfc_get_int_expr (gfc_charlen_int_kind
,
1923 else if (init
->expr_type
== EXPR_ARRAY
)
1925 if (init
->ts
.u
.cl
&& init
->ts
.u
.cl
->length
)
1927 const gfc_expr
*length
= init
->ts
.u
.cl
->length
;
1928 if (length
->expr_type
!= EXPR_CONSTANT
)
1930 gfc_error ("Cannot initialize parameter array "
1932 "with variable length elements",
1936 clen
= mpz_get_si (length
->value
.integer
);
1938 else if (init
->value
.constructor
)
1941 c
= gfc_constructor_first (init
->value
.constructor
);
1942 clen
= c
->expr
->value
.character
.length
;
1946 sym
->ts
.u
.cl
->length
1947 = gfc_get_int_expr (gfc_charlen_int_kind
,
1950 else if (init
->ts
.u
.cl
&& init
->ts
.u
.cl
->length
)
1951 sym
->ts
.u
.cl
->length
=
1952 gfc_copy_expr (init
->ts
.u
.cl
->length
);
1955 /* Update initializer character length according symbol. */
1956 else if (sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1958 if (!gfc_specification_expr (sym
->ts
.u
.cl
->length
))
1961 int k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
,
1963 /* resolve_charlen will complain later on if the length
1964 is too large. Just skeep the initialization in that case. */
1965 if (mpz_cmp (sym
->ts
.u
.cl
->length
->value
.integer
,
1966 gfc_integer_kinds
[k
].huge
) <= 0)
1969 = gfc_mpz_get_hwi (sym
->ts
.u
.cl
->length
->value
.integer
);
1971 if (init
->expr_type
== EXPR_CONSTANT
)
1972 gfc_set_constant_character_len (len
, init
, -1);
1973 else if (init
->expr_type
== EXPR_ARRAY
)
1977 /* Build a new charlen to prevent simplification from
1978 deleting the length before it is resolved. */
1979 init
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1980 init
->ts
.u
.cl
->length
1981 = gfc_copy_expr (sym
->ts
.u
.cl
->length
);
1983 for (c
= gfc_constructor_first (init
->value
.constructor
);
1984 c
; c
= gfc_constructor_next (c
))
1985 gfc_set_constant_character_len (len
, c
->expr
, -1);
1991 /* If sym is implied-shape, set its upper bounds from init. */
1992 if (sym
->attr
.flavor
== FL_PARAMETER
&& sym
->attr
.dimension
1993 && sym
->as
->type
== AS_IMPLIED_SHAPE
)
1997 if (init
->rank
== 0)
1999 gfc_error ("Cannot initialize implied-shape array at %L"
2000 " with scalar", &sym
->declared_at
);
2004 /* The shape may be NULL for EXPR_ARRAY, set it. */
2005 if (init
->shape
== NULL
)
2007 gcc_assert (init
->expr_type
== EXPR_ARRAY
);
2008 init
->shape
= gfc_get_shape (1);
2009 if (!gfc_array_size (init
, &init
->shape
[0]))
2010 gfc_internal_error ("gfc_array_size failed");
2013 for (dim
= 0; dim
< sym
->as
->rank
; ++dim
)
2016 gfc_expr
*e
, *lower
;
2018 lower
= sym
->as
->lower
[dim
];
2020 /* If the lower bound is an array element from another
2021 parameterized array, then it is marked with EXPR_VARIABLE and
2022 is an initialization expression. Try to reduce it. */
2023 if (lower
->expr_type
== EXPR_VARIABLE
)
2024 gfc_reduce_init_expr (lower
);
2026 if (lower
->expr_type
== EXPR_CONSTANT
)
2028 /* All dimensions must be without upper bound. */
2029 gcc_assert (!sym
->as
->upper
[dim
]);
2032 e
= gfc_get_constant_expr (BT_INTEGER
, k
, &sym
->declared_at
);
2033 mpz_add (e
->value
.integer
, lower
->value
.integer
,
2035 mpz_sub_ui (e
->value
.integer
, e
->value
.integer
, 1);
2036 sym
->as
->upper
[dim
] = e
;
2040 gfc_error ("Non-constant lower bound in implied-shape"
2041 " declaration at %L", &lower
->where
);
2046 sym
->as
->type
= AS_EXPLICIT
;
2049 /* Need to check if the expression we initialized this
2050 to was one of the iso_c_binding named constants. If so,
2051 and we're a parameter (constant), let it be iso_c.
2053 integer(c_int), parameter :: my_int = c_int
2054 integer(my_int) :: my_int_2
2055 If we mark my_int as iso_c (since we can see it's value
2056 is equal to one of the named constants), then my_int_2
2057 will be considered C interoperable. */
2058 if (sym
->ts
.type
!= BT_CHARACTER
&& !gfc_bt_struct (sym
->ts
.type
))
2060 sym
->ts
.is_iso_c
|= init
->ts
.is_iso_c
;
2061 sym
->ts
.is_c_interop
|= init
->ts
.is_c_interop
;
2062 /* attr bits needed for module files. */
2063 sym
->attr
.is_iso_c
|= init
->ts
.is_iso_c
;
2064 sym
->attr
.is_c_interop
|= init
->ts
.is_c_interop
;
2065 if (init
->ts
.is_iso_c
)
2066 sym
->ts
.f90_type
= init
->ts
.f90_type
;
2069 /* Add initializer. Make sure we keep the ranks sane. */
2070 if (sym
->attr
.dimension
&& init
->rank
== 0)
2075 if (sym
->attr
.flavor
== FL_PARAMETER
2076 && init
->expr_type
== EXPR_CONSTANT
2077 && spec_size (sym
->as
, &size
)
2078 && mpz_cmp_si (size
, 0) > 0)
2080 array
= gfc_get_array_expr (init
->ts
.type
, init
->ts
.kind
,
2082 for (n
= 0; n
< (int)mpz_get_si (size
); n
++)
2083 gfc_constructor_append_expr (&array
->value
.constructor
,
2086 : gfc_copy_expr (init
),
2089 array
->shape
= gfc_get_shape (sym
->as
->rank
);
2090 for (n
= 0; n
< sym
->as
->rank
; n
++)
2091 spec_dimen_size (sym
->as
, n
, &array
->shape
[n
]);
2096 init
->rank
= sym
->as
->rank
;
2100 if (sym
->attr
.save
== SAVE_NONE
)
2101 sym
->attr
.save
= SAVE_IMPLICIT
;
2109 /* Function called by variable_decl() that adds a name to a structure
2113 build_struct (const char *name
, gfc_charlen
*cl
, gfc_expr
**init
,
2114 gfc_array_spec
**as
)
2119 /* F03:C438/C439. If the current symbol is of the same derived type that we're
2120 constructing, it must have the pointer attribute. */
2121 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
2122 && current_ts
.u
.derived
== gfc_current_block ()
2123 && current_attr
.pointer
== 0)
2125 if (current_attr
.allocatable
2126 && !gfc_notify_std(GFC_STD_F2008
, "Component at %C "
2127 "must have the POINTER attribute"))
2131 else if (current_attr
.allocatable
== 0)
2133 gfc_error ("Component at %C must have the POINTER attribute");
2139 if (current_ts
.type
== BT_CLASS
2140 && !(current_attr
.pointer
|| current_attr
.allocatable
))
2142 gfc_error ("Component %qs with CLASS at %C must be allocatable "
2143 "or pointer", name
);
2147 if (gfc_current_block ()->attr
.pointer
&& (*as
)->rank
!= 0)
2149 if ((*as
)->type
!= AS_DEFERRED
&& (*as
)->type
!= AS_EXPLICIT
)
2151 gfc_error ("Array component of structure at %C must have explicit "
2152 "or deferred shape");
2157 /* If we are in a nested union/map definition, gfc_add_component will not
2158 properly find repeated components because:
2159 (i) gfc_add_component does a flat search, where components of unions
2160 and maps are implicity chained so nested components may conflict.
2161 (ii) Unions and maps are not linked as components of their parent
2162 structures until after they are parsed.
2163 For (i) we use gfc_find_component which searches recursively, and for (ii)
2164 we search each block directly from the parse stack until we find the top
2167 s
= gfc_state_stack
;
2168 if (s
->state
== COMP_UNION
|| s
->state
== COMP_MAP
)
2170 while (s
->state
== COMP_UNION
|| gfc_comp_struct (s
->state
))
2172 c
= gfc_find_component (s
->sym
, name
, true, true, NULL
);
2175 gfc_error_now ("Component %qs at %C already declared at %L",
2179 /* Break after we've searched the entire chain. */
2180 if (s
->state
== COMP_DERIVED
|| s
->state
== COMP_STRUCTURE
)
2186 if (!gfc_add_component (gfc_current_block(), name
, &c
))
2190 if (c
->ts
.type
== BT_CHARACTER
)
2193 if (c
->ts
.type
!= BT_CLASS
&& c
->ts
.type
!= BT_DERIVED
2194 && (c
->ts
.kind
== 0 || c
->ts
.type
== BT_CHARACTER
)
2195 && saved_kind_expr
!= NULL
)
2196 c
->kind_expr
= gfc_copy_expr (saved_kind_expr
);
2198 c
->attr
= current_attr
;
2200 c
->initializer
= *init
;
2207 c
->attr
.codimension
= 1;
2209 c
->attr
.dimension
= 1;
2213 gfc_apply_init (&c
->ts
, &c
->attr
, c
->initializer
);
2215 /* Check array components. */
2216 if (!c
->attr
.dimension
)
2219 if (c
->attr
.pointer
)
2221 if (c
->as
->type
!= AS_DEFERRED
)
2223 gfc_error ("Pointer array component of structure at %C must have a "
2228 else if (c
->attr
.allocatable
)
2230 if (c
->as
->type
!= AS_DEFERRED
)
2232 gfc_error ("Allocatable component of structure at %C must have a "
2239 if (c
->as
->type
!= AS_EXPLICIT
)
2241 gfc_error ("Array component of structure at %C must have an "
2248 if (c
->ts
.type
== BT_CLASS
)
2249 return gfc_build_class_symbol (&c
->ts
, &c
->attr
, &c
->as
);
2251 if (c
->attr
.pdt_kind
|| c
->attr
.pdt_len
)
2254 gfc_find_symbol (c
->name
, gfc_current_block ()->f2k_derived
,
2258 gfc_error ("Type parameter %qs at %C has no corresponding entry "
2259 "in the type parameter name list at %L",
2260 c
->name
, &gfc_current_block ()->declared_at
);
2264 sym
->attr
.pdt_kind
= c
->attr
.pdt_kind
;
2265 sym
->attr
.pdt_len
= c
->attr
.pdt_len
;
2267 sym
->value
= gfc_copy_expr (c
->initializer
);
2268 sym
->attr
.flavor
= FL_VARIABLE
;
2271 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
2272 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_template
2273 && decl_type_param_list
)
2274 c
->param_list
= gfc_copy_actual_arglist (decl_type_param_list
);
2280 /* Match a 'NULL()', and possibly take care of some side effects. */
2283 gfc_match_null (gfc_expr
**result
)
2286 match m
, m2
= MATCH_NO
;
2288 if ((m
= gfc_match (" null ( )")) == MATCH_ERROR
)
2294 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2296 if ((m2
= gfc_match (" null (")) != MATCH_YES
)
2299 old_loc
= gfc_current_locus
;
2300 if ((m2
= gfc_match (" %n ) ", name
)) == MATCH_ERROR
)
2303 && ((m2
= gfc_match (" mold = %n )", name
)) == MATCH_ERROR
))
2307 gfc_current_locus
= old_loc
;
2312 /* The NULL symbol now has to be/become an intrinsic function. */
2313 if (gfc_get_symbol ("null", NULL
, &sym
))
2315 gfc_error ("NULL() initialization at %C is ambiguous");
2319 gfc_intrinsic_symbol (sym
);
2321 if (sym
->attr
.proc
!= PROC_INTRINSIC
2322 && !(sym
->attr
.use_assoc
&& sym
->attr
.intrinsic
)
2323 && (!gfc_add_procedure(&sym
->attr
, PROC_INTRINSIC
, sym
->name
, NULL
)
2324 || !gfc_add_function (&sym
->attr
, sym
->name
, NULL
)))
2327 *result
= gfc_get_null_expr (&gfc_current_locus
);
2329 /* Invalid per F2008, C512. */
2330 if (m2
== MATCH_YES
)
2332 gfc_error ("NULL() initialization at %C may not have MOLD");
2340 /* Match the initialization expr for a data pointer or procedure pointer. */
2343 match_pointer_init (gfc_expr
**init
, int procptr
)
2347 if (gfc_pure (NULL
) && !gfc_comp_struct (gfc_state_stack
->state
))
2349 gfc_error ("Initialization of pointer at %C is not allowed in "
2350 "a PURE procedure");
2353 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
2355 /* Match NULL() initialization. */
2356 m
= gfc_match_null (init
);
2360 /* Match non-NULL initialization. */
2361 gfc_matching_ptr_assignment
= !procptr
;
2362 gfc_matching_procptr_assignment
= procptr
;
2363 m
= gfc_match_rvalue (init
);
2364 gfc_matching_ptr_assignment
= 0;
2365 gfc_matching_procptr_assignment
= 0;
2366 if (m
== MATCH_ERROR
)
2368 else if (m
== MATCH_NO
)
2370 gfc_error ("Error in pointer initialization at %C");
2374 if (!procptr
&& !gfc_resolve_expr (*init
))
2377 if (!gfc_notify_std (GFC_STD_F2008
, "non-NULL pointer "
2378 "initialization at %C"))
2386 check_function_name (char *name
)
2388 /* In functions that have a RESULT variable defined, the function name always
2389 refers to function calls. Therefore, the name is not allowed to appear in
2390 specification statements. When checking this, be careful about
2391 'hidden' procedure pointer results ('ppr@'). */
2393 if (gfc_current_state () == COMP_FUNCTION
)
2395 gfc_symbol
*block
= gfc_current_block ();
2396 if (block
&& block
->result
&& block
->result
!= block
2397 && strcmp (block
->result
->name
, "ppr@") != 0
2398 && strcmp (block
->name
, name
) == 0)
2400 gfc_error ("RESULT variable %qs at %L prohibits FUNCTION name %qs at %C "
2401 "from appearing in a specification statement",
2402 block
->result
->name
, &block
->result
->declared_at
, name
);
2411 /* Match a variable name with an optional initializer. When this
2412 subroutine is called, a variable is expected to be parsed next.
2413 Depending on what is happening at the moment, updates either the
2414 symbol table or the current interface. */
2417 variable_decl (int elem
)
2419 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2420 static unsigned int fill_id
= 0;
2421 gfc_expr
*initializer
, *char_len
;
2423 gfc_array_spec
*cp_as
; /* Extra copy for Cray Pointees. */
2435 /* When we get here, we've just matched a list of attributes and
2436 maybe a type and a double colon. The next thing we expect to see
2437 is the name of the symbol. */
2439 /* If we are parsing a structure with legacy support, we allow the symbol
2440 name to be '%FILL' which gives it an anonymous (inaccessible) name. */
2442 gfc_gobble_whitespace ();
2443 if (gfc_peek_ascii_char () == '%')
2445 gfc_next_ascii_char ();
2446 m
= gfc_match ("fill");
2451 m
= gfc_match_name (name
);
2459 if (gfc_current_state () != COMP_STRUCTURE
)
2461 if (flag_dec_structure
)
2462 gfc_error ("%qs not allowed outside STRUCTURE at %C", "%FILL");
2464 gfc_error ("%qs at %C is a DEC extension, enable with "
2465 "%<-fdec-structure%>", "%FILL");
2471 gfc_error ("%qs entity cannot have attributes at %C", "%FILL");
2475 /* %FILL components are given invalid fortran names. */
2476 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "%%FILL%u", fill_id
++);
2479 var_locus
= gfc_current_locus
;
2481 /* Now we could see the optional array spec. or character length. */
2482 m
= gfc_match_array_spec (&as
, true, true);
2483 if (m
== MATCH_ERROR
)
2487 as
= gfc_copy_array_spec (current_as
);
2489 && !merge_array_spec (current_as
, as
, true))
2495 if (flag_cray_pointer
)
2496 cp_as
= gfc_copy_array_spec (as
);
2498 /* At this point, we know for sure if the symbol is PARAMETER and can thus
2499 determine (and check) whether it can be implied-shape. If it
2500 was parsed as assumed-size, change it because PARAMETERs cannot
2503 An explicit-shape-array cannot appear under several conditions.
2504 That check is done here as well. */
2507 if (as
->type
== AS_IMPLIED_SHAPE
&& current_attr
.flavor
!= FL_PARAMETER
)
2510 gfc_error ("Non-PARAMETER symbol %qs at %L cannot be implied-shape",
2515 if (as
->type
== AS_ASSUMED_SIZE
&& as
->rank
== 1
2516 && current_attr
.flavor
== FL_PARAMETER
)
2517 as
->type
= AS_IMPLIED_SHAPE
;
2519 if (as
->type
== AS_IMPLIED_SHAPE
2520 && !gfc_notify_std (GFC_STD_F2008
, "Implied-shape array at %L",
2527 /* F2018:C830 (R816) An explicit-shape-spec whose bounds are not
2528 constant expressions shall appear only in a subprogram, derived
2529 type definition, BLOCK construct, or interface body. */
2530 if (as
->type
== AS_EXPLICIT
2531 && gfc_current_state () != COMP_BLOCK
2532 && gfc_current_state () != COMP_DERIVED
2533 && gfc_current_state () != COMP_FUNCTION
2534 && gfc_current_state () != COMP_INTERFACE
2535 && gfc_current_state () != COMP_SUBROUTINE
)
2538 bool not_constant
= false;
2540 for (int i
= 0; i
< as
->rank
; i
++)
2542 e
= gfc_copy_expr (as
->lower
[i
]);
2543 gfc_resolve_expr (e
);
2544 gfc_simplify_expr (e
, 0);
2545 if (e
&& (e
->expr_type
!= EXPR_CONSTANT
))
2547 not_constant
= true;
2552 e
= gfc_copy_expr (as
->upper
[i
]);
2553 gfc_resolve_expr (e
);
2554 gfc_simplify_expr (e
, 0);
2555 if (e
&& (e
->expr_type
!= EXPR_CONSTANT
))
2557 not_constant
= true;
2565 gfc_error ("Explicit shaped array with nonconstant bounds at %C");
2570 if (as
->type
== AS_EXPLICIT
)
2572 for (int i
= 0; i
< as
->rank
; i
++)
2576 if (e
->expr_type
!= EXPR_CONSTANT
)
2578 n
= gfc_copy_expr (e
);
2579 gfc_simplify_expr (n
, 1);
2580 if (n
->expr_type
== EXPR_CONSTANT
)
2581 gfc_replace_expr (e
, n
);
2586 if (e
->expr_type
!= EXPR_CONSTANT
)
2588 n
= gfc_copy_expr (e
);
2589 gfc_simplify_expr (n
, 1);
2590 if (n
->expr_type
== EXPR_CONSTANT
)
2591 gfc_replace_expr (e
, n
);
2601 cl_deferred
= false;
2603 if (current_ts
.type
== BT_CHARACTER
)
2605 switch (match_char_length (&char_len
, &cl_deferred
, false))
2608 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2610 cl
->length
= char_len
;
2613 /* Non-constant lengths need to be copied after the first
2614 element. Also copy assumed lengths. */
2617 && (current_ts
.u
.cl
->length
== NULL
2618 || current_ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
2620 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2621 cl
->length
= gfc_copy_expr (current_ts
.u
.cl
->length
);
2624 cl
= current_ts
.u
.cl
;
2626 cl_deferred
= current_ts
.deferred
;
2635 /* The dummy arguments and result of the abreviated form of MODULE
2636 PROCEDUREs, used in SUBMODULES should not be redefined. */
2637 if (gfc_current_ns
->proc_name
2638 && gfc_current_ns
->proc_name
->abr_modproc_decl
)
2640 gfc_find_symbol (name
, gfc_current_ns
, 1, &sym
);
2641 if (sym
!= NULL
&& (sym
->attr
.dummy
|| sym
->attr
.result
))
2644 gfc_error ("%qs at %C is a redefinition of the declaration "
2645 "in the corresponding interface for MODULE "
2646 "PROCEDURE %qs", sym
->name
,
2647 gfc_current_ns
->proc_name
->name
);
2652 /* %FILL components may not have initializers. */
2653 if (gfc_str_startswith (name
, "%FILL") && gfc_match_eos () != MATCH_YES
)
2655 gfc_error ("%qs entity cannot have an initializer at %C", "%FILL");
2660 /* If this symbol has already shown up in a Cray Pointer declaration,
2661 and this is not a component declaration,
2662 then we want to set the type & bail out. */
2663 if (flag_cray_pointer
&& !gfc_comp_struct (gfc_current_state ()))
2665 gfc_find_symbol (name
, gfc_current_ns
, 1, &sym
);
2666 if (sym
!= NULL
&& sym
->attr
.cray_pointee
)
2669 if (!gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
2675 /* Check to see if we have an array specification. */
2678 if (sym
->as
!= NULL
)
2680 gfc_error ("Duplicate array spec for Cray pointee at %C");
2681 gfc_free_array_spec (cp_as
);
2687 if (!gfc_set_array_spec (sym
, cp_as
, &var_locus
))
2688 gfc_internal_error ("Cannot set pointee array spec.");
2690 /* Fix the array spec. */
2691 m
= gfc_mod_pointee_as (sym
->as
);
2692 if (m
== MATCH_ERROR
)
2700 gfc_free_array_spec (cp_as
);
2704 /* Procedure pointer as function result. */
2705 if (gfc_current_state () == COMP_FUNCTION
2706 && strcmp ("ppr@", gfc_current_block ()->name
) == 0
2707 && strcmp (name
, gfc_current_block ()->ns
->proc_name
->name
) == 0)
2708 strcpy (name
, "ppr@");
2710 if (gfc_current_state () == COMP_FUNCTION
2711 && strcmp (name
, gfc_current_block ()->name
) == 0
2712 && gfc_current_block ()->result
2713 && strcmp ("ppr@", gfc_current_block ()->result
->name
) == 0)
2714 strcpy (name
, "ppr@");
2716 /* OK, we've successfully matched the declaration. Now put the
2717 symbol in the current namespace, because it might be used in the
2718 optional initialization expression for this symbol, e.g. this is
2721 integer, parameter :: i = huge(i)
2723 This is only true for parameters or variables of a basic type.
2724 For components of derived types, it is not true, so we don't
2725 create a symbol for those yet. If we fail to create the symbol,
2727 if (!gfc_comp_struct (gfc_current_state ())
2728 && !build_sym (name
, cl
, cl_deferred
, &as
, &var_locus
))
2734 if (!check_function_name (name
))
2740 /* We allow old-style initializations of the form
2741 integer i /2/, j(4) /3*3, 1/
2742 (if no colon has been seen). These are different from data
2743 statements in that initializers are only allowed to apply to the
2744 variable immediately preceding, i.e.
2746 is not allowed. Therefore we have to do some work manually, that
2747 could otherwise be left to the matchers for DATA statements. */
2749 if (!colon_seen
&& gfc_match (" /") == MATCH_YES
)
2751 if (!gfc_notify_std (GFC_STD_GNU
, "Old-style "
2752 "initialization at %C"))
2755 /* Allow old style initializations for components of STRUCTUREs and MAPs
2756 but not components of derived types. */
2757 else if (gfc_current_state () == COMP_DERIVED
)
2759 gfc_error ("Invalid old style initialization for derived type "
2765 /* For structure components, read the initializer as a special
2766 expression and let the rest of this function apply the initializer
2768 else if (gfc_comp_struct (gfc_current_state ()))
2770 m
= match_clist_expr (&initializer
, ¤t_ts
, as
);
2772 gfc_error ("Syntax error in old style initialization of %s at %C",
2778 /* Otherwise we treat the old style initialization just like a
2779 DATA declaration for the current variable. */
2781 return match_old_style_init (name
);
2784 /* The double colon must be present in order to have initializers.
2785 Otherwise the statement is ambiguous with an assignment statement. */
2788 if (gfc_match (" =>") == MATCH_YES
)
2790 if (!current_attr
.pointer
)
2792 gfc_error ("Initialization at %C isn't for a pointer variable");
2797 m
= match_pointer_init (&initializer
, 0);
2801 /* The target of a pointer initialization must have the SAVE
2802 attribute. A variable in PROGRAM, MODULE, or SUBMODULE scope
2803 is implicit SAVEd. Explicitly, set the SAVE_IMPLICIT value. */
2804 if (initializer
->expr_type
== EXPR_VARIABLE
2805 && initializer
->symtree
->n
.sym
->attr
.save
== SAVE_NONE
2806 && (gfc_current_state () == COMP_PROGRAM
2807 || gfc_current_state () == COMP_MODULE
2808 || gfc_current_state () == COMP_SUBMODULE
))
2809 initializer
->symtree
->n
.sym
->attr
.save
= SAVE_IMPLICIT
;
2811 else if (gfc_match_char ('=') == MATCH_YES
)
2813 if (current_attr
.pointer
)
2815 gfc_error ("Pointer initialization at %C requires %<=>%>, "
2821 m
= gfc_match_init_expr (&initializer
);
2824 gfc_error ("Expected an initialization expression at %C");
2828 if (current_attr
.flavor
!= FL_PARAMETER
&& gfc_pure (NULL
)
2829 && !gfc_comp_struct (gfc_state_stack
->state
))
2831 gfc_error ("Initialization of variable at %C is not allowed in "
2832 "a PURE procedure");
2836 if (current_attr
.flavor
!= FL_PARAMETER
2837 && !gfc_comp_struct (gfc_state_stack
->state
))
2838 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
2845 if (initializer
!= NULL
&& current_attr
.allocatable
2846 && gfc_comp_struct (gfc_current_state ()))
2848 gfc_error ("Initialization of allocatable component at %C is not "
2854 if (gfc_current_state () == COMP_DERIVED
2855 && gfc_current_block ()->attr
.pdt_template
)
2858 gfc_find_symbol (name
, gfc_current_block ()->f2k_derived
,
2860 if (!param
&& (current_attr
.pdt_kind
|| current_attr
.pdt_len
))
2862 gfc_error ("The component with KIND or LEN attribute at %C does not "
2863 "not appear in the type parameter list at %L",
2864 &gfc_current_block ()->declared_at
);
2868 else if (param
&& !(current_attr
.pdt_kind
|| current_attr
.pdt_len
))
2870 gfc_error ("The component at %C that appears in the type parameter "
2871 "list at %L has neither the KIND nor LEN attribute",
2872 &gfc_current_block ()->declared_at
);
2876 else if (as
&& (current_attr
.pdt_kind
|| current_attr
.pdt_len
))
2878 gfc_error ("The component at %C which is a type parameter must be "
2883 else if (param
&& initializer
)
2884 param
->value
= gfc_copy_expr (initializer
);
2887 /* Before adding a possible initilizer, do a simple check for compatibility
2888 of lhs and rhs types. Assigning a REAL value to a derived type is not a
2890 if (current_ts
.type
== BT_DERIVED
&& initializer
2891 && (gfc_numeric_ts (&initializer
->ts
)
2892 || initializer
->ts
.type
== BT_LOGICAL
2893 || initializer
->ts
.type
== BT_CHARACTER
))
2895 gfc_error ("Incompatible initialization between a derived type "
2896 "entity and an entity with %qs type at %C",
2897 gfc_typename (&initializer
->ts
));
2903 /* Add the initializer. Note that it is fine if initializer is
2904 NULL here, because we sometimes also need to check if a
2905 declaration *must* have an initialization expression. */
2906 if (!gfc_comp_struct (gfc_current_state ()))
2907 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
2910 if (current_ts
.type
== BT_DERIVED
2911 && !current_attr
.pointer
&& !initializer
)
2912 initializer
= gfc_default_initializer (¤t_ts
);
2913 t
= build_struct (name
, cl
, &initializer
, &as
);
2915 /* If we match a nested structure definition we expect to see the
2916 * body even if the variable declarations blow up, so we need to keep
2917 * the structure declaration around. */
2918 if (gfc_new_block
&& gfc_new_block
->attr
.flavor
== FL_STRUCT
)
2919 gfc_commit_symbol (gfc_new_block
);
2922 m
= (t
) ? MATCH_YES
: MATCH_ERROR
;
2925 /* Free stuff up and return. */
2926 gfc_free_expr (initializer
);
2927 gfc_free_array_spec (as
);
2933 /* Match an extended-f77 "TYPESPEC*bytesize"-style kind specification.
2934 This assumes that the byte size is equal to the kind number for
2935 non-COMPLEX types, and equal to twice the kind number for COMPLEX. */
2938 gfc_match_old_kind_spec (gfc_typespec
*ts
)
2943 if (gfc_match_char ('*') != MATCH_YES
)
2946 m
= gfc_match_small_literal_int (&ts
->kind
, NULL
);
2950 original_kind
= ts
->kind
;
2952 /* Massage the kind numbers for complex types. */
2953 if (ts
->type
== BT_COMPLEX
)
2957 gfc_error ("Old-style type declaration %s*%d not supported at %C",
2958 gfc_basic_typename (ts
->type
), original_kind
);
2965 if (ts
->type
== BT_INTEGER
&& ts
->kind
== 4 && flag_integer4_kind
== 8)
2968 if (ts
->type
== BT_REAL
|| ts
->type
== BT_COMPLEX
)
2972 if (flag_real4_kind
== 8)
2974 if (flag_real4_kind
== 10)
2976 if (flag_real4_kind
== 16)
2982 if (flag_real8_kind
== 4)
2984 if (flag_real8_kind
== 10)
2986 if (flag_real8_kind
== 16)
2991 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
2993 gfc_error ("Old-style type declaration %s*%d not supported at %C",
2994 gfc_basic_typename (ts
->type
), original_kind
);
2998 if (!gfc_notify_std (GFC_STD_GNU
,
2999 "Nonstandard type declaration %s*%d at %C",
3000 gfc_basic_typename(ts
->type
), original_kind
))
3007 /* Match a kind specification. Since kinds are generally optional, we
3008 usually return MATCH_NO if something goes wrong. If a "kind="
3009 string is found, then we know we have an error. */
3012 gfc_match_kind_spec (gfc_typespec
*ts
, bool kind_expr_only
)
3022 saved_kind_expr
= NULL
;
3024 where
= loc
= gfc_current_locus
;
3029 if (gfc_match_char ('(') == MATCH_NO
)
3032 /* Also gobbles optional text. */
3033 if (gfc_match (" kind = ") == MATCH_YES
)
3036 loc
= gfc_current_locus
;
3040 n
= gfc_match_init_expr (&e
);
3042 if (gfc_derived_parameter_expr (e
))
3045 saved_kind_expr
= gfc_copy_expr (e
);
3046 goto close_brackets
;
3051 if (gfc_matching_function
)
3053 /* The function kind expression might include use associated or
3054 imported parameters and try again after the specification
3056 if (gfc_match_char (')') != MATCH_YES
)
3058 gfc_error ("Missing right parenthesis at %C");
3064 gfc_undo_symbols ();
3069 /* ....or else, the match is real. */
3071 gfc_error ("Expected initialization expression at %C");
3079 gfc_error ("Expected scalar initialization expression at %C");
3084 if (gfc_extract_int (e
, &ts
->kind
, 1))
3090 /* Before throwing away the expression, let's see if we had a
3091 C interoperable kind (and store the fact). */
3092 if (e
->ts
.is_c_interop
== 1)
3094 /* Mark this as C interoperable if being declared with one
3095 of the named constants from iso_c_binding. */
3096 ts
->is_c_interop
= e
->ts
.is_iso_c
;
3097 ts
->f90_type
= e
->ts
.f90_type
;
3099 ts
->interop_kind
= e
->symtree
->n
.sym
;
3105 /* Ignore errors to this point, if we've gotten here. This means
3106 we ignore the m=MATCH_ERROR from above. */
3107 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
3109 gfc_error ("Kind %d not supported for type %s at %C", ts
->kind
,
3110 gfc_basic_typename (ts
->type
));
3111 gfc_current_locus
= where
;
3115 /* Warn if, e.g., c_int is used for a REAL variable, but not
3116 if, e.g., c_double is used for COMPLEX as the standard
3117 explicitly says that the kind type parameter for complex and real
3118 variable is the same, i.e. c_float == c_float_complex. */
3119 if (ts
->f90_type
!= BT_UNKNOWN
&& ts
->f90_type
!= ts
->type
3120 && !((ts
->f90_type
== BT_REAL
&& ts
->type
== BT_COMPLEX
)
3121 || (ts
->f90_type
== BT_COMPLEX
&& ts
->type
== BT_REAL
)))
3122 gfc_warning_now (0, "C kind type parameter is for type %s but type at %L "
3123 "is %s", gfc_basic_typename (ts
->f90_type
), &where
,
3124 gfc_basic_typename (ts
->type
));
3128 gfc_gobble_whitespace ();
3129 if ((c
= gfc_next_ascii_char ()) != ')'
3130 && (ts
->type
!= BT_CHARACTER
|| c
!= ','))
3132 if (ts
->type
== BT_CHARACTER
)
3133 gfc_error ("Missing right parenthesis or comma at %C");
3135 gfc_error ("Missing right parenthesis at %C");
3139 /* All tests passed. */
3142 if(m
== MATCH_ERROR
)
3143 gfc_current_locus
= where
;
3145 if (ts
->type
== BT_INTEGER
&& ts
->kind
== 4 && flag_integer4_kind
== 8)
3148 if (ts
->type
== BT_REAL
|| ts
->type
== BT_COMPLEX
)
3152 if (flag_real4_kind
== 8)
3154 if (flag_real4_kind
== 10)
3156 if (flag_real4_kind
== 16)
3162 if (flag_real8_kind
== 4)
3164 if (flag_real8_kind
== 10)
3166 if (flag_real8_kind
== 16)
3171 /* Return what we know from the test(s). */
3176 gfc_current_locus
= where
;
3182 match_char_kind (int * kind
, int * is_iso_c
)
3191 where
= gfc_current_locus
;
3193 n
= gfc_match_init_expr (&e
);
3195 if (n
!= MATCH_YES
&& gfc_matching_function
)
3197 /* The expression might include use-associated or imported
3198 parameters and try again after the specification
3201 gfc_undo_symbols ();
3206 gfc_error ("Expected initialization expression at %C");
3212 gfc_error ("Expected scalar initialization expression at %C");
3217 if (gfc_derived_parameter_expr (e
))
3219 saved_kind_expr
= e
;
3224 fail
= gfc_extract_int (e
, kind
, 1);
3225 *is_iso_c
= e
->ts
.is_iso_c
;
3234 /* Ignore errors to this point, if we've gotten here. This means
3235 we ignore the m=MATCH_ERROR from above. */
3236 if (gfc_validate_kind (BT_CHARACTER
, *kind
, true) < 0)
3238 gfc_error ("Kind %d is not supported for CHARACTER at %C", *kind
);
3242 /* All tests passed. */
3245 if (m
== MATCH_ERROR
)
3246 gfc_current_locus
= where
;
3248 /* Return what we know from the test(s). */
3253 gfc_current_locus
= where
;
3258 /* Match the various kind/length specifications in a CHARACTER
3259 declaration. We don't return MATCH_NO. */
3262 gfc_match_char_spec (gfc_typespec
*ts
)
3264 int kind
, seen_length
, is_iso_c
;
3276 /* Try the old-style specification first. */
3277 old_char_selector
= 0;
3279 m
= match_char_length (&len
, &deferred
, true);
3283 old_char_selector
= 1;
3288 m
= gfc_match_char ('(');
3291 m
= MATCH_YES
; /* Character without length is a single char. */
3295 /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ). */
3296 if (gfc_match (" kind =") == MATCH_YES
)
3298 m
= match_char_kind (&kind
, &is_iso_c
);
3300 if (m
== MATCH_ERROR
)
3305 if (gfc_match (" , len =") == MATCH_NO
)
3308 m
= char_len_param_value (&len
, &deferred
);
3311 if (m
== MATCH_ERROR
)
3318 /* Try to match "LEN = <len-param>" or "LEN = <len-param>, KIND = <int>". */
3319 if (gfc_match (" len =") == MATCH_YES
)
3321 m
= char_len_param_value (&len
, &deferred
);
3324 if (m
== MATCH_ERROR
)
3328 if (gfc_match_char (')') == MATCH_YES
)
3331 if (gfc_match (" , kind =") != MATCH_YES
)
3334 if (match_char_kind (&kind
, &is_iso_c
) == MATCH_ERROR
)
3340 /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ). */
3341 m
= char_len_param_value (&len
, &deferred
);
3344 if (m
== MATCH_ERROR
)
3348 m
= gfc_match_char (')');
3352 if (gfc_match_char (',') != MATCH_YES
)
3355 gfc_match (" kind ="); /* Gobble optional text. */
3357 m
= match_char_kind (&kind
, &is_iso_c
);
3358 if (m
== MATCH_ERROR
)
3364 /* Require a right-paren at this point. */
3365 m
= gfc_match_char (')');
3370 gfc_error ("Syntax error in CHARACTER declaration at %C");
3372 gfc_free_expr (len
);
3376 /* Deal with character functions after USE and IMPORT statements. */
3377 if (gfc_matching_function
)
3379 gfc_free_expr (len
);
3380 gfc_undo_symbols ();
3386 gfc_free_expr (len
);
3390 /* Do some final massaging of the length values. */
3391 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
3393 if (seen_length
== 0)
3394 cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
, 1);
3397 /* If gfortran ends up here, then len may be reducible to a constant.
3398 Try to do that here. If it does not reduce, simply assign len to
3399 charlen. A complication occurs with user-defined generic functions,
3400 which are not resolved. Use a private namespace to deal with
3401 generic functions. */
3403 if (len
&& len
->expr_type
!= EXPR_CONSTANT
)
3405 gfc_namespace
*old_ns
;
3408 old_ns
= gfc_current_ns
;
3409 gfc_current_ns
= gfc_get_namespace (NULL
, 0);
3411 e
= gfc_copy_expr (len
);
3412 gfc_reduce_init_expr (e
);
3413 if (e
->expr_type
== EXPR_CONSTANT
)
3415 gfc_replace_expr (len
, e
);
3416 if (mpz_cmp_si (len
->value
.integer
, 0) < 0)
3417 mpz_set_ui (len
->value
.integer
, 0);
3422 gfc_free_namespace (gfc_current_ns
);
3423 gfc_current_ns
= old_ns
;
3430 ts
->kind
= kind
== 0 ? gfc_default_character_kind
: kind
;
3431 ts
->deferred
= deferred
;
3433 /* We have to know if it was a C interoperable kind so we can
3434 do accurate type checking of bind(c) procs, etc. */
3436 /* Mark this as C interoperable if being declared with one
3437 of the named constants from iso_c_binding. */
3438 ts
->is_c_interop
= is_iso_c
;
3439 else if (len
!= NULL
)
3440 /* Here, we might have parsed something such as: character(c_char)
3441 In this case, the parsing code above grabs the c_char when
3442 looking for the length (line 1690, roughly). it's the last
3443 testcase for parsing the kind params of a character variable.
3444 However, it's not actually the length. this seems like it
3446 To see if the user used a C interop kind, test the expr
3447 of the so called length, and see if it's C interoperable. */
3448 ts
->is_c_interop
= len
->ts
.is_iso_c
;
3454 /* Matches a RECORD declaration. */
3457 match_record_decl (char *name
)
3460 old_loc
= gfc_current_locus
;
3463 m
= gfc_match (" record /");
3466 if (!flag_dec_structure
)
3468 gfc_current_locus
= old_loc
;
3469 gfc_error ("RECORD at %C is an extension, enable it with "
3470 "%<-fdec-structure%>");
3473 m
= gfc_match (" %n/", name
);
3478 gfc_current_locus
= old_loc
;
3479 if (flag_dec_structure
3480 && (gfc_match (" record% ") == MATCH_YES
3481 || gfc_match (" record%t") == MATCH_YES
))
3482 gfc_error ("Structure name expected after RECORD at %C");
3490 /* This function uses the gfc_actual_arglist 'type_param_spec_list' as a source
3491 of expressions to substitute into the possibly parameterized expression
3492 'e'. Using a list is inefficient but should not be too bad since the
3493 number of type parameters is not likely to be large. */
3495 insert_parameter_exprs (gfc_expr
* e
, gfc_symbol
* sym ATTRIBUTE_UNUSED
,
3498 gfc_actual_arglist
*param
;
3501 if (e
->expr_type
!= EXPR_VARIABLE
)
3504 gcc_assert (e
->symtree
);
3505 if (e
->symtree
->n
.sym
->attr
.pdt_kind
3506 || (*f
!= 0 && e
->symtree
->n
.sym
->attr
.pdt_len
))
3508 for (param
= type_param_spec_list
; param
; param
= param
->next
)
3509 if (strcmp (e
->symtree
->n
.sym
->name
, param
->name
) == 0)
3514 copy
= gfc_copy_expr (param
->expr
);
3525 gfc_insert_kind_parameter_exprs (gfc_expr
*e
)
3527 return gfc_traverse_expr (e
, NULL
, &insert_parameter_exprs
, 0);
3532 gfc_insert_parameter_exprs (gfc_expr
*e
, gfc_actual_arglist
*param_list
)
3534 gfc_actual_arglist
*old_param_spec_list
= type_param_spec_list
;
3535 type_param_spec_list
= param_list
;
3536 return gfc_traverse_expr (e
, NULL
, &insert_parameter_exprs
, 1);
3537 type_param_spec_list
= NULL
;
3538 type_param_spec_list
= old_param_spec_list
;
3541 /* Determines the instance of a parameterized derived type to be used by
3542 matching determining the values of the kind parameters and using them
3543 in the name of the instance. If the instance exists, it is used, otherwise
3544 a new derived type is created. */
3546 gfc_get_pdt_instance (gfc_actual_arglist
*param_list
, gfc_symbol
**sym
,
3547 gfc_actual_arglist
**ext_param_list
)
3549 /* The PDT template symbol. */
3550 gfc_symbol
*pdt
= *sym
;
3551 /* The symbol for the parameter in the template f2k_namespace. */
3553 /* The hoped for instance of the PDT. */
3554 gfc_symbol
*instance
;
3555 /* The list of parameters appearing in the PDT declaration. */
3556 gfc_formal_arglist
*type_param_name_list
;
3557 /* Used to store the parameter specification list during recursive calls. */
3558 gfc_actual_arglist
*old_param_spec_list
;
3559 /* Pointers to the parameter specification being used. */
3560 gfc_actual_arglist
*actual_param
;
3561 gfc_actual_arglist
*tail
= NULL
;
3562 /* Used to build up the name of the PDT instance. The prefix uses 4
3563 characters and each KIND parameter 2 more. Allow 8 of the latter. */
3564 char name
[GFC_MAX_SYMBOL_LEN
+ 21];
3566 bool name_seen
= (param_list
== NULL
);
3567 bool assumed_seen
= false;
3568 bool deferred_seen
= false;
3569 bool spec_error
= false;
3571 gfc_expr
*kind_expr
;
3572 gfc_component
*c1
, *c2
;
3575 type_param_spec_list
= NULL
;
3577 type_param_name_list
= pdt
->formal
;
3578 actual_param
= param_list
;
3579 sprintf (name
, "Pdt%s", pdt
->name
);
3581 /* Run through the parameter name list and pick up the actual
3582 parameter values or use the default values in the PDT declaration. */
3583 for (; type_param_name_list
;
3584 type_param_name_list
= type_param_name_list
->next
)
3586 if (actual_param
&& actual_param
->spec_type
!= SPEC_EXPLICIT
)
3588 if (actual_param
->spec_type
== SPEC_ASSUMED
)
3589 spec_error
= deferred_seen
;
3591 spec_error
= assumed_seen
;
3595 gfc_error ("The type parameter spec list at %C cannot contain "
3596 "both ASSUMED and DEFERRED parameters");
3601 if (actual_param
&& actual_param
->name
)
3603 param
= type_param_name_list
->sym
;
3605 if (!param
|| !param
->name
)
3608 c1
= gfc_find_component (pdt
, param
->name
, false, true, NULL
);
3609 /* An error should already have been thrown in resolve.c
3610 (resolve_fl_derived0). */
3611 if (!pdt
->attr
.use_assoc
&& !c1
)
3617 if (!actual_param
&& !(c1
&& c1
->initializer
))
3619 gfc_error ("The type parameter spec list at %C does not contain "
3620 "enough parameter expressions");
3623 else if (!actual_param
&& c1
&& c1
->initializer
)
3624 kind_expr
= gfc_copy_expr (c1
->initializer
);
3625 else if (actual_param
&& actual_param
->spec_type
== SPEC_EXPLICIT
)
3626 kind_expr
= gfc_copy_expr (actual_param
->expr
);
3630 actual_param
= param_list
;
3631 for (;actual_param
; actual_param
= actual_param
->next
)
3632 if (actual_param
->name
3633 && strcmp (actual_param
->name
, param
->name
) == 0)
3635 if (actual_param
&& actual_param
->spec_type
== SPEC_EXPLICIT
)
3636 kind_expr
= gfc_copy_expr (actual_param
->expr
);
3639 if (c1
->initializer
)
3640 kind_expr
= gfc_copy_expr (c1
->initializer
);
3641 else if (!(actual_param
&& param
->attr
.pdt_len
))
3643 gfc_error ("The derived parameter %qs at %C does not "
3644 "have a default value", param
->name
);
3650 /* Store the current parameter expressions in a temporary actual
3651 arglist 'list' so that they can be substituted in the corresponding
3652 expressions in the PDT instance. */
3653 if (type_param_spec_list
== NULL
)
3655 type_param_spec_list
= gfc_get_actual_arglist ();
3656 tail
= type_param_spec_list
;
3660 tail
->next
= gfc_get_actual_arglist ();
3663 tail
->name
= param
->name
;
3667 /* Try simplification even for LEN expressions. */
3668 gfc_resolve_expr (kind_expr
);
3669 gfc_simplify_expr (kind_expr
, 1);
3670 /* Variable expressions seem to default to BT_PROCEDURE.
3671 TODO find out why this is and fix it. */
3672 if (kind_expr
->ts
.type
!= BT_INTEGER
3673 && kind_expr
->ts
.type
!= BT_PROCEDURE
)
3675 gfc_error ("The parameter expression at %C must be of "
3676 "INTEGER type and not %s type",
3677 gfc_basic_typename (kind_expr
->ts
.type
));
3681 tail
->expr
= gfc_copy_expr (kind_expr
);
3685 tail
->spec_type
= actual_param
->spec_type
;
3687 if (!param
->attr
.pdt_kind
)
3689 if (!name_seen
&& actual_param
)
3690 actual_param
= actual_param
->next
;
3693 gfc_free_expr (kind_expr
);
3700 && (actual_param
->spec_type
== SPEC_ASSUMED
3701 || actual_param
->spec_type
== SPEC_DEFERRED
))
3703 gfc_error ("The KIND parameter %qs at %C cannot either be "
3704 "ASSUMED or DEFERRED", param
->name
);
3708 if (!kind_expr
|| !gfc_is_constant_expr (kind_expr
))
3710 gfc_error ("The value for the KIND parameter %qs at %C does not "
3711 "reduce to a constant expression", param
->name
);
3715 gfc_extract_int (kind_expr
, &kind_value
);
3716 sprintf (name
+ strlen (name
), "_%d", kind_value
);
3718 if (!name_seen
&& actual_param
)
3719 actual_param
= actual_param
->next
;
3720 gfc_free_expr (kind_expr
);
3723 if (!name_seen
&& actual_param
)
3725 gfc_error ("The type parameter spec list at %C contains too many "
3726 "parameter expressions");
3730 /* Now we search for the PDT instance 'name'. If it doesn't exist, we
3731 build it, using 'pdt' as a template. */
3732 if (gfc_get_symbol (name
, pdt
->ns
, &instance
))
3734 gfc_error ("Parameterized derived type at %C is ambiguous");
3740 if (instance
->attr
.flavor
== FL_DERIVED
3741 && instance
->attr
.pdt_type
)
3745 *ext_param_list
= type_param_spec_list
;
3747 gfc_commit_symbols ();
3751 /* Start building the new instance of the parameterized type. */
3752 gfc_copy_attr (&instance
->attr
, &pdt
->attr
, &pdt
->declared_at
);
3753 instance
->attr
.pdt_template
= 0;
3754 instance
->attr
.pdt_type
= 1;
3755 instance
->declared_at
= gfc_current_locus
;
3757 /* Add the components, replacing the parameters in all expressions
3758 with the expressions for their values in 'type_param_spec_list'. */
3759 c1
= pdt
->components
;
3760 tail
= type_param_spec_list
;
3761 for (; c1
; c1
= c1
->next
)
3763 gfc_add_component (instance
, c1
->name
, &c2
);
3766 c2
->attr
= c1
->attr
;
3768 /* The order of declaration of the type_specs might not be the
3769 same as that of the components. */
3770 if (c1
->attr
.pdt_kind
|| c1
->attr
.pdt_len
)
3772 for (tail
= type_param_spec_list
; tail
; tail
= tail
->next
)
3773 if (strcmp (c1
->name
, tail
->name
) == 0)
3777 /* Deal with type extension by recursively calling this function
3778 to obtain the instance of the extended type. */
3779 if (gfc_current_state () != COMP_DERIVED
3780 && c1
== pdt
->components
3781 && (c1
->ts
.type
== BT_DERIVED
|| c1
->ts
.type
== BT_CLASS
)
3782 && c1
->ts
.u
.derived
&& c1
->ts
.u
.derived
->attr
.pdt_template
3783 && gfc_get_derived_super_type (*sym
) == c2
->ts
.u
.derived
)
3785 gfc_formal_arglist
*f
;
3787 old_param_spec_list
= type_param_spec_list
;
3789 /* Obtain a spec list appropriate to the extended type..*/
3790 actual_param
= gfc_copy_actual_arglist (type_param_spec_list
);
3791 type_param_spec_list
= actual_param
;
3792 for (f
= c1
->ts
.u
.derived
->formal
; f
&& f
->next
; f
= f
->next
)
3793 actual_param
= actual_param
->next
;
3796 gfc_free_actual_arglist (actual_param
->next
);
3797 actual_param
->next
= NULL
;
3800 /* Now obtain the PDT instance for the extended type. */
3801 c2
->param_list
= type_param_spec_list
;
3802 m
= gfc_get_pdt_instance (type_param_spec_list
, &c2
->ts
.u
.derived
,
3804 type_param_spec_list
= old_param_spec_list
;
3806 c2
->ts
.u
.derived
->refs
++;
3807 gfc_set_sym_referenced (c2
->ts
.u
.derived
);
3809 /* Set extension level. */
3810 if (c2
->ts
.u
.derived
->attr
.extension
== 255)
3812 /* Since the extension field is 8 bit wide, we can only have
3813 up to 255 extension levels. */
3814 gfc_error ("Maximum extension level reached with type %qs at %L",
3815 c2
->ts
.u
.derived
->name
,
3816 &c2
->ts
.u
.derived
->declared_at
);
3819 instance
->attr
.extension
= c2
->ts
.u
.derived
->attr
.extension
+ 1;
3824 /* Set the component kind using the parameterized expression. */
3825 if ((c1
->ts
.kind
== 0 || c1
->ts
.type
== BT_CHARACTER
)
3826 && c1
->kind_expr
!= NULL
)
3828 gfc_expr
*e
= gfc_copy_expr (c1
->kind_expr
);
3829 gfc_insert_kind_parameter_exprs (e
);
3830 gfc_simplify_expr (e
, 1);
3831 gfc_extract_int (e
, &c2
->ts
.kind
);
3833 if (gfc_validate_kind (c2
->ts
.type
, c2
->ts
.kind
, true) < 0)
3835 gfc_error ("Kind %d not supported for type %s at %C",
3836 c2
->ts
.kind
, gfc_basic_typename (c2
->ts
.type
));
3841 /* Similarly, set the string length if parameterized. */
3842 if (c1
->ts
.type
== BT_CHARACTER
3843 && c1
->ts
.u
.cl
->length
3844 && gfc_derived_parameter_expr (c1
->ts
.u
.cl
->length
))
3847 e
= gfc_copy_expr (c1
->ts
.u
.cl
->length
);
3848 gfc_insert_kind_parameter_exprs (e
);
3849 gfc_simplify_expr (e
, 1);
3850 c2
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
3851 c2
->ts
.u
.cl
->length
= e
;
3852 c2
->attr
.pdt_string
= 1;
3855 /* Set up either the KIND/LEN initializer, if constant,
3856 or the parameterized expression. Use the template
3857 initializer if one is not already set in this instance. */
3858 if (c2
->attr
.pdt_kind
|| c2
->attr
.pdt_len
)
3860 if (tail
&& tail
->expr
&& gfc_is_constant_expr (tail
->expr
))
3861 c2
->initializer
= gfc_copy_expr (tail
->expr
);
3862 else if (tail
&& tail
->expr
)
3864 c2
->param_list
= gfc_get_actual_arglist ();
3865 c2
->param_list
->name
= tail
->name
;
3866 c2
->param_list
->expr
= gfc_copy_expr (tail
->expr
);
3867 c2
->param_list
->next
= NULL
;
3870 if (!c2
->initializer
&& c1
->initializer
)
3871 c2
->initializer
= gfc_copy_expr (c1
->initializer
);
3874 /* Copy the array spec. */
3875 c2
->as
= gfc_copy_array_spec (c1
->as
);
3876 if (c1
->ts
.type
== BT_CLASS
)
3877 CLASS_DATA (c2
)->as
= gfc_copy_array_spec (CLASS_DATA (c1
)->as
);
3879 /* Determine if an array spec is parameterized. If so, substitute
3880 in the parameter expressions for the bounds and set the pdt_array
3881 attribute. Notice that this attribute must be unconditionally set
3882 if this is an array of parameterized character length. */
3883 if (c1
->as
&& c1
->as
->type
== AS_EXPLICIT
)
3885 bool pdt_array
= false;
3887 /* Are the bounds of the array parameterized? */
3888 for (i
= 0; i
< c1
->as
->rank
; i
++)
3890 if (gfc_derived_parameter_expr (c1
->as
->lower
[i
]))
3892 if (gfc_derived_parameter_expr (c1
->as
->upper
[i
]))
3896 /* If they are, free the expressions for the bounds and
3897 replace them with the template expressions with substitute
3899 for (i
= 0; pdt_array
&& i
< c1
->as
->rank
; i
++)
3902 e
= gfc_copy_expr (c1
->as
->lower
[i
]);
3903 gfc_insert_kind_parameter_exprs (e
);
3904 gfc_simplify_expr (e
, 1);
3905 gfc_free_expr (c2
->as
->lower
[i
]);
3906 c2
->as
->lower
[i
] = e
;
3907 e
= gfc_copy_expr (c1
->as
->upper
[i
]);
3908 gfc_insert_kind_parameter_exprs (e
);
3909 gfc_simplify_expr (e
, 1);
3910 gfc_free_expr (c2
->as
->upper
[i
]);
3911 c2
->as
->upper
[i
] = e
;
3913 c2
->attr
.pdt_array
= pdt_array
? 1 : c2
->attr
.pdt_string
;
3914 if (c1
->initializer
)
3916 c2
->initializer
= gfc_copy_expr (c1
->initializer
);
3917 gfc_insert_kind_parameter_exprs (c2
->initializer
);
3918 gfc_simplify_expr (c2
->initializer
, 1);
3922 /* Recurse into this function for PDT components. */
3923 if ((c1
->ts
.type
== BT_DERIVED
|| c1
->ts
.type
== BT_CLASS
)
3924 && c1
->ts
.u
.derived
&& c1
->ts
.u
.derived
->attr
.pdt_template
)
3926 gfc_actual_arglist
*params
;
3927 /* The component in the template has a list of specification
3928 expressions derived from its declaration. */
3929 params
= gfc_copy_actual_arglist (c1
->param_list
);
3930 actual_param
= params
;
3931 /* Substitute the template parameters with the expressions
3932 from the specification list. */
3933 for (;actual_param
; actual_param
= actual_param
->next
)
3934 gfc_insert_parameter_exprs (actual_param
->expr
,
3935 type_param_spec_list
);
3937 /* Now obtain the PDT instance for the component. */
3938 old_param_spec_list
= type_param_spec_list
;
3939 m
= gfc_get_pdt_instance (params
, &c2
->ts
.u
.derived
, NULL
);
3940 type_param_spec_list
= old_param_spec_list
;
3942 c2
->param_list
= params
;
3943 if (!(c2
->attr
.pointer
|| c2
->attr
.allocatable
))
3944 c2
->initializer
= gfc_default_initializer (&c2
->ts
);
3946 if (c2
->attr
.allocatable
)
3947 instance
->attr
.alloc_comp
= 1;
3951 gfc_commit_symbol (instance
);
3953 *ext_param_list
= type_param_spec_list
;
3958 gfc_free_actual_arglist (type_param_spec_list
);
3963 /* Matches a declaration-type-spec (F03:R502). If successful, sets the ts
3964 structure to the matched specification. This is necessary for FUNCTION and
3965 IMPLICIT statements.
3967 If implicit_flag is nonzero, then we don't check for the optional
3968 kind specification. Not doing so is needed for matching an IMPLICIT
3969 statement correctly. */
3972 gfc_match_decl_type_spec (gfc_typespec
*ts
, int implicit_flag
)
3974 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3975 gfc_symbol
*sym
, *dt_sym
;
3978 bool seen_deferred_kind
, matched_type
;
3979 const char *dt_name
;
3981 decl_type_param_list
= NULL
;
3983 /* A belt and braces check that the typespec is correctly being treated
3984 as a deferred characteristic association. */
3985 seen_deferred_kind
= (gfc_current_state () == COMP_FUNCTION
)
3986 && (gfc_current_block ()->result
->ts
.kind
== -1)
3987 && (ts
->kind
== -1);
3989 if (seen_deferred_kind
)
3992 /* Clear the current binding label, in case one is given. */
3993 curr_binding_label
= NULL
;
3995 if (gfc_match (" byte") == MATCH_YES
)
3997 if (!gfc_notify_std (GFC_STD_GNU
, "BYTE type at %C"))
4000 if (gfc_validate_kind (BT_INTEGER
, 1, true) < 0)
4002 gfc_error ("BYTE type used at %C "
4003 "is not available on the target machine");
4007 ts
->type
= BT_INTEGER
;
4013 m
= gfc_match (" type (");
4014 matched_type
= (m
== MATCH_YES
);
4017 gfc_gobble_whitespace ();
4018 if (gfc_peek_ascii_char () == '*')
4020 if ((m
= gfc_match ("*)")) != MATCH_YES
)
4022 if (gfc_comp_struct (gfc_current_state ()))
4024 gfc_error ("Assumed type at %C is not allowed for components");
4027 if (!gfc_notify_std (GFC_STD_F2018
, "Assumed type at %C"))
4029 ts
->type
= BT_ASSUMED
;
4033 m
= gfc_match ("%n", name
);
4034 matched_type
= (m
== MATCH_YES
);
4037 if ((matched_type
&& strcmp ("integer", name
) == 0)
4038 || (!matched_type
&& gfc_match (" integer") == MATCH_YES
))
4040 ts
->type
= BT_INTEGER
;
4041 ts
->kind
= gfc_default_integer_kind
;
4045 if ((matched_type
&& strcmp ("character", name
) == 0)
4046 || (!matched_type
&& gfc_match (" character") == MATCH_YES
))
4049 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
4050 "intrinsic-type-spec at %C"))
4053 ts
->type
= BT_CHARACTER
;
4054 if (implicit_flag
== 0)
4055 m
= gfc_match_char_spec (ts
);
4059 if (matched_type
&& m
== MATCH_YES
&& gfc_match_char (')') != MATCH_YES
)
4065 if ((matched_type
&& strcmp ("real", name
) == 0)
4066 || (!matched_type
&& gfc_match (" real") == MATCH_YES
))
4069 ts
->kind
= gfc_default_real_kind
;
4074 && (strcmp ("doubleprecision", name
) == 0
4075 || (strcmp ("double", name
) == 0
4076 && gfc_match (" precision") == MATCH_YES
)))
4077 || (!matched_type
&& gfc_match (" double precision") == MATCH_YES
))
4080 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
4081 "intrinsic-type-spec at %C"))
4083 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
4087 ts
->kind
= gfc_default_double_kind
;
4091 if ((matched_type
&& strcmp ("complex", name
) == 0)
4092 || (!matched_type
&& gfc_match (" complex") == MATCH_YES
))
4094 ts
->type
= BT_COMPLEX
;
4095 ts
->kind
= gfc_default_complex_kind
;
4100 && (strcmp ("doublecomplex", name
) == 0
4101 || (strcmp ("double", name
) == 0
4102 && gfc_match (" complex") == MATCH_YES
)))
4103 || (!matched_type
&& gfc_match (" double complex") == MATCH_YES
))
4105 if (!gfc_notify_std (GFC_STD_GNU
, "DOUBLE COMPLEX at %C"))
4109 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
4110 "intrinsic-type-spec at %C"))
4113 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
4116 ts
->type
= BT_COMPLEX
;
4117 ts
->kind
= gfc_default_double_kind
;
4121 if ((matched_type
&& strcmp ("logical", name
) == 0)
4122 || (!matched_type
&& gfc_match (" logical") == MATCH_YES
))
4124 ts
->type
= BT_LOGICAL
;
4125 ts
->kind
= gfc_default_logical_kind
;
4131 m
= gfc_match_actual_arglist (1, &decl_type_param_list
, true);
4132 if (m
== MATCH_ERROR
)
4135 m
= gfc_match_char (')');
4139 m
= match_record_decl (name
);
4141 if (matched_type
|| m
== MATCH_YES
)
4143 ts
->type
= BT_DERIVED
;
4144 /* We accept record/s/ or type(s) where s is a structure, but we
4145 * don't need all the extra derived-type stuff for structures. */
4146 if (gfc_find_symbol (gfc_dt_upper_string (name
), NULL
, 1, &sym
))
4148 gfc_error ("Type name %qs at %C is ambiguous", name
);
4152 if (sym
&& sym
->attr
.flavor
== FL_DERIVED
4153 && sym
->attr
.pdt_template
4154 && gfc_current_state () != COMP_DERIVED
)
4156 m
= gfc_get_pdt_instance (decl_type_param_list
, &sym
, NULL
);
4159 gcc_assert (!sym
->attr
.pdt_template
&& sym
->attr
.pdt_type
);
4160 ts
->u
.derived
= sym
;
4161 strcpy (name
, gfc_dt_lower_string (sym
->name
));
4164 if (sym
&& sym
->attr
.flavor
== FL_STRUCT
)
4166 ts
->u
.derived
= sym
;
4169 /* Actually a derived type. */
4174 /* Match nested STRUCTURE declarations; only valid within another
4175 structure declaration. */
4176 if (flag_dec_structure
4177 && (gfc_current_state () == COMP_STRUCTURE
4178 || gfc_current_state () == COMP_MAP
))
4180 m
= gfc_match (" structure");
4183 m
= gfc_match_structure_decl ();
4186 /* gfc_new_block is updated by match_structure_decl. */
4187 ts
->type
= BT_DERIVED
;
4188 ts
->u
.derived
= gfc_new_block
;
4192 if (m
== MATCH_ERROR
)
4196 /* Match CLASS declarations. */
4197 m
= gfc_match (" class ( * )");
4198 if (m
== MATCH_ERROR
)
4200 else if (m
== MATCH_YES
)
4204 ts
->type
= BT_CLASS
;
4205 gfc_find_symbol ("STAR", gfc_current_ns
, 1, &upe
);
4208 upe
= gfc_new_symbol ("STAR", gfc_current_ns
);
4209 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "STAR");
4211 gfc_set_sym_referenced (upe
);
4213 upe
->ts
.type
= BT_VOID
;
4214 upe
->attr
.unlimited_polymorphic
= 1;
4215 /* This is essential to force the construction of
4216 unlimited polymorphic component class containers. */
4217 upe
->attr
.zero_comp
= 1;
4218 if (!gfc_add_flavor (&upe
->attr
, FL_DERIVED
, NULL
,
4219 &gfc_current_locus
))
4224 st
= gfc_get_tbp_symtree (&gfc_current_ns
->sym_root
, "STAR");
4228 ts
->u
.derived
= upe
;
4232 m
= gfc_match (" class (");
4235 m
= gfc_match ("%n", name
);
4241 ts
->type
= BT_CLASS
;
4243 if (!gfc_notify_std (GFC_STD_F2003
, "CLASS statement at %C"))
4246 m
= gfc_match_actual_arglist (1, &decl_type_param_list
, true);
4247 if (m
== MATCH_ERROR
)
4250 m
= gfc_match_char (')');
4255 /* Defer association of the derived type until the end of the
4256 specification block. However, if the derived type can be
4257 found, add it to the typespec. */
4258 if (gfc_matching_function
)
4260 ts
->u
.derived
= NULL
;
4261 if (gfc_current_state () != COMP_INTERFACE
4262 && !gfc_find_symbol (name
, NULL
, 1, &sym
) && sym
)
4264 sym
= gfc_find_dt_in_generic (sym
);
4265 ts
->u
.derived
= sym
;
4270 /* Search for the name but allow the components to be defined later. If
4271 type = -1, this typespec has been seen in a function declaration but
4272 the type could not be accessed at that point. The actual derived type is
4273 stored in a symtree with the first letter of the name capitalized; the
4274 symtree with the all lower-case name contains the associated
4275 generic function. */
4276 dt_name
= gfc_dt_upper_string (name
);
4281 gfc_get_ha_symbol (name
, &sym
);
4282 if (sym
->generic
&& gfc_find_symbol (dt_name
, NULL
, 0, &dt_sym
))
4284 gfc_error ("Type name %qs at %C is ambiguous", name
);
4287 if (sym
->generic
&& !dt_sym
)
4288 dt_sym
= gfc_find_dt_in_generic (sym
);
4290 /* Host associated PDTs can get confused with their constructors
4291 because they ar instantiated in the template's namespace. */
4294 if (gfc_find_symbol (dt_name
, NULL
, 1, &dt_sym
))
4296 gfc_error ("Type name %qs at %C is ambiguous", name
);
4299 if (dt_sym
&& !dt_sym
->attr
.pdt_type
)
4303 else if (ts
->kind
== -1)
4305 int iface
= gfc_state_stack
->previous
->state
!= COMP_INTERFACE
4306 || gfc_current_ns
->has_import_set
;
4307 gfc_find_symbol (name
, NULL
, iface
, &sym
);
4308 if (sym
&& sym
->generic
&& gfc_find_symbol (dt_name
, NULL
, 1, &dt_sym
))
4310 gfc_error ("Type name %qs at %C is ambiguous", name
);
4313 if (sym
&& sym
->generic
&& !dt_sym
)
4314 dt_sym
= gfc_find_dt_in_generic (sym
);
4321 if ((sym
->attr
.flavor
!= FL_UNKNOWN
&& sym
->attr
.flavor
!= FL_STRUCT
4322 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.generic
))
4323 || sym
->attr
.subroutine
)
4325 gfc_error ("Type name %qs at %C conflicts with previously declared "
4326 "entity at %L, which has the same name", name
,
4331 if (sym
&& sym
->attr
.flavor
== FL_DERIVED
4332 && sym
->attr
.pdt_template
4333 && gfc_current_state () != COMP_DERIVED
)
4335 m
= gfc_get_pdt_instance (decl_type_param_list
, &sym
, NULL
);
4338 gcc_assert (!sym
->attr
.pdt_template
&& sym
->attr
.pdt_type
);
4339 ts
->u
.derived
= sym
;
4340 strcpy (name
, gfc_dt_lower_string (sym
->name
));
4343 gfc_save_symbol_data (sym
);
4344 gfc_set_sym_referenced (sym
);
4345 if (!sym
->attr
.generic
4346 && !gfc_add_generic (&sym
->attr
, sym
->name
, NULL
))
4349 if (!sym
->attr
.function
4350 && !gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
4353 if (dt_sym
&& dt_sym
->attr
.flavor
== FL_DERIVED
4354 && dt_sym
->attr
.pdt_template
4355 && gfc_current_state () != COMP_DERIVED
)
4357 m
= gfc_get_pdt_instance (decl_type_param_list
, &dt_sym
, NULL
);
4360 gcc_assert (!dt_sym
->attr
.pdt_template
&& dt_sym
->attr
.pdt_type
);
4365 gfc_interface
*intr
, *head
;
4367 /* Use upper case to save the actual derived-type symbol. */
4368 gfc_get_symbol (dt_name
, NULL
, &dt_sym
);
4369 dt_sym
->name
= gfc_get_string ("%s", sym
->name
);
4370 head
= sym
->generic
;
4371 intr
= gfc_get_interface ();
4373 intr
->where
= gfc_current_locus
;
4375 sym
->generic
= intr
;
4376 sym
->attr
.if_source
= IFSRC_DECL
;
4379 gfc_save_symbol_data (dt_sym
);
4381 gfc_set_sym_referenced (dt_sym
);
4383 if (dt_sym
->attr
.flavor
!= FL_DERIVED
&& dt_sym
->attr
.flavor
!= FL_STRUCT
4384 && !gfc_add_flavor (&dt_sym
->attr
, FL_DERIVED
, sym
->name
, NULL
))
4387 ts
->u
.derived
= dt_sym
;
4393 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
4394 "intrinsic-type-spec at %C"))
4397 /* For all types except double, derived and character, look for an
4398 optional kind specifier. MATCH_NO is actually OK at this point. */
4399 if (implicit_flag
== 1)
4401 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
4407 if (gfc_current_form
== FORM_FREE
)
4409 c
= gfc_peek_ascii_char ();
4410 if (!gfc_is_whitespace (c
) && c
!= '*' && c
!= '('
4411 && c
!= ':' && c
!= ',')
4413 if (matched_type
&& c
== ')')
4415 gfc_next_ascii_char ();
4422 m
= gfc_match_kind_spec (ts
, false);
4423 if (m
== MATCH_NO
&& ts
->type
!= BT_CHARACTER
)
4425 m
= gfc_match_old_kind_spec (ts
);
4426 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) == -1)
4430 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
4433 /* Defer association of the KIND expression of function results
4434 until after USE and IMPORT statements. */
4435 if ((gfc_current_state () == COMP_NONE
&& gfc_error_flag_test ())
4436 || gfc_matching_function
)
4440 m
= MATCH_YES
; /* No kind specifier found. */
4446 /* Match an IMPLICIT NONE statement. Actually, this statement is
4447 already matched in parse.c, or we would not end up here in the
4448 first place. So the only thing we need to check, is if there is
4449 trailing garbage. If not, the match is successful. */
4452 gfc_match_implicit_none (void)
4456 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4458 bool external
= false;
4459 locus cur_loc
= gfc_current_locus
;
4461 if (gfc_current_ns
->seen_implicit_none
4462 || gfc_current_ns
->has_implicit_none_export
)
4464 gfc_error ("Duplicate IMPLICIT NONE statement at %C");
4468 gfc_gobble_whitespace ();
4469 c
= gfc_peek_ascii_char ();
4472 (void) gfc_next_ascii_char ();
4473 if (!gfc_notify_std (GFC_STD_F2018
, "IMPORT NONE with spec list at %C"))
4476 gfc_gobble_whitespace ();
4477 if (gfc_peek_ascii_char () == ')')
4479 (void) gfc_next_ascii_char ();
4485 m
= gfc_match (" %n", name
);
4489 if (strcmp (name
, "type") == 0)
4491 else if (strcmp (name
, "external") == 0)
4496 gfc_gobble_whitespace ();
4497 c
= gfc_next_ascii_char ();
4508 if (gfc_match_eos () != MATCH_YES
)
4511 gfc_set_implicit_none (type
, external
, &cur_loc
);
4517 /* Match the letter range(s) of an IMPLICIT statement. */
4520 match_implicit_range (void)
4526 cur_loc
= gfc_current_locus
;
4528 gfc_gobble_whitespace ();
4529 c
= gfc_next_ascii_char ();
4532 gfc_error ("Missing character range in IMPLICIT at %C");
4539 gfc_gobble_whitespace ();
4540 c1
= gfc_next_ascii_char ();
4544 gfc_gobble_whitespace ();
4545 c
= gfc_next_ascii_char ();
4550 inner
= 0; /* Fall through. */
4557 gfc_gobble_whitespace ();
4558 c2
= gfc_next_ascii_char ();
4562 gfc_gobble_whitespace ();
4563 c
= gfc_next_ascii_char ();
4565 if ((c
!= ',') && (c
!= ')'))
4578 gfc_error ("Letters must be in alphabetic order in "
4579 "IMPLICIT statement at %C");
4583 /* See if we can add the newly matched range to the pending
4584 implicits from this IMPLICIT statement. We do not check for
4585 conflicts with whatever earlier IMPLICIT statements may have
4586 set. This is done when we've successfully finished matching
4588 if (!gfc_add_new_implicit_range (c1
, c2
))
4595 gfc_syntax_error (ST_IMPLICIT
);
4597 gfc_current_locus
= cur_loc
;
4602 /* Match an IMPLICIT statement, storing the types for
4603 gfc_set_implicit() if the statement is accepted by the parser.
4604 There is a strange looking, but legal syntactic construction
4605 possible. It looks like:
4607 IMPLICIT INTEGER (a-b) (c-d)
4609 This is legal if "a-b" is a constant expression that happens to
4610 equal one of the legal kinds for integers. The real problem
4611 happens with an implicit specification that looks like:
4613 IMPLICIT INTEGER (a-b)
4615 In this case, a typespec matcher that is "greedy" (as most of the
4616 matchers are) gobbles the character range as a kindspec, leaving
4617 nothing left. We therefore have to go a bit more slowly in the
4618 matching process by inhibiting the kindspec checking during
4619 typespec matching and checking for a kind later. */
4622 gfc_match_implicit (void)
4629 if (gfc_current_ns
->seen_implicit_none
)
4631 gfc_error ("IMPLICIT statement at %C following an IMPLICIT NONE (type) "
4638 /* We don't allow empty implicit statements. */
4639 if (gfc_match_eos () == MATCH_YES
)
4641 gfc_error ("Empty IMPLICIT statement at %C");
4647 /* First cleanup. */
4648 gfc_clear_new_implicit ();
4650 /* A basic type is mandatory here. */
4651 m
= gfc_match_decl_type_spec (&ts
, 1);
4652 if (m
== MATCH_ERROR
)
4657 cur_loc
= gfc_current_locus
;
4658 m
= match_implicit_range ();
4662 /* We may have <TYPE> (<RANGE>). */
4663 gfc_gobble_whitespace ();
4664 c
= gfc_peek_ascii_char ();
4665 if (c
== ',' || c
== '\n' || c
== ';' || c
== '!')
4667 /* Check for CHARACTER with no length parameter. */
4668 if (ts
.type
== BT_CHARACTER
&& !ts
.u
.cl
)
4670 ts
.kind
= gfc_default_character_kind
;
4671 ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4672 ts
.u
.cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
,
4676 /* Record the Successful match. */
4677 if (!gfc_merge_new_implicit (&ts
))
4680 c
= gfc_next_ascii_char ();
4681 else if (gfc_match_eos () == MATCH_ERROR
)
4686 gfc_current_locus
= cur_loc
;
4689 /* Discard the (incorrectly) matched range. */
4690 gfc_clear_new_implicit ();
4692 /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
4693 if (ts
.type
== BT_CHARACTER
)
4694 m
= gfc_match_char_spec (&ts
);
4697 m
= gfc_match_kind_spec (&ts
, false);
4700 m
= gfc_match_old_kind_spec (&ts
);
4701 if (m
== MATCH_ERROR
)
4707 if (m
== MATCH_ERROR
)
4710 m
= match_implicit_range ();
4711 if (m
== MATCH_ERROR
)
4716 gfc_gobble_whitespace ();
4717 c
= gfc_next_ascii_char ();
4718 if (c
!= ',' && gfc_match_eos () != MATCH_YES
)
4721 if (!gfc_merge_new_implicit (&ts
))
4729 gfc_syntax_error (ST_IMPLICIT
);
4737 gfc_match_import (void)
4739 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4744 if (gfc_current_ns
->proc_name
== NULL
4745 || gfc_current_ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
4747 gfc_error ("IMPORT statement at %C only permitted in "
4748 "an INTERFACE body");
4752 if (gfc_current_ns
->proc_name
->attr
.module_procedure
)
4754 gfc_error ("F2008: C1210 IMPORT statement at %C is not permitted "
4755 "in a module procedure interface body");
4759 if (!gfc_notify_std (GFC_STD_F2003
, "IMPORT statement at %C"))
4762 if (gfc_match_eos () == MATCH_YES
)
4764 /* All host variables should be imported. */
4765 gfc_current_ns
->has_import_set
= 1;
4769 if (gfc_match (" ::") == MATCH_YES
)
4771 if (gfc_match_eos () == MATCH_YES
)
4773 gfc_error ("Expecting list of named entities at %C");
4781 m
= gfc_match (" %n", name
);
4785 if (gfc_current_ns
->parent
!= NULL
4786 && gfc_find_symbol (name
, gfc_current_ns
->parent
, 1, &sym
))
4788 gfc_error ("Type name %qs at %C is ambiguous", name
);
4791 else if (!sym
&& gfc_current_ns
->proc_name
->ns
->parent
!= NULL
4792 && gfc_find_symbol (name
,
4793 gfc_current_ns
->proc_name
->ns
->parent
,
4796 gfc_error ("Type name %qs at %C is ambiguous", name
);
4802 gfc_error ("Cannot IMPORT %qs from host scoping unit "
4803 "at %C - does not exist.", name
);
4807 if (gfc_find_symtree (gfc_current_ns
->sym_root
, name
))
4809 gfc_warning (0, "%qs is already IMPORTed from host scoping unit "
4814 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, name
);
4817 sym
->attr
.imported
= 1;
4819 if (sym
->attr
.generic
&& (sym
= gfc_find_dt_in_generic (sym
)))
4821 /* The actual derived type is stored in a symtree with the first
4822 letter of the name capitalized; the symtree with the all
4823 lower-case name contains the associated generic function. */
4824 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
,
4825 gfc_dt_upper_string (name
));
4828 sym
->attr
.imported
= 1;
4841 if (gfc_match_eos () == MATCH_YES
)
4843 if (gfc_match_char (',') != MATCH_YES
)
4850 gfc_error ("Syntax error in IMPORT statement at %C");
4855 /* A minimal implementation of gfc_match without whitespace, escape
4856 characters or variable arguments. Returns true if the next
4857 characters match the TARGET template exactly. */
4860 match_string_p (const char *target
)
4864 for (p
= target
; *p
; p
++)
4865 if ((char) gfc_next_ascii_char () != *p
)
4870 /* Matches an attribute specification including array specs. If
4871 successful, leaves the variables current_attr and current_as
4872 holding the specification. Also sets the colon_seen variable for
4873 later use by matchers associated with initializations.
4875 This subroutine is a little tricky in the sense that we don't know
4876 if we really have an attr-spec until we hit the double colon.
4877 Until that time, we can only return MATCH_NO. This forces us to
4878 check for duplicate specification at this level. */
4881 match_attr_spec (void)
4883 /* Modifiers that can exist in a type statement. */
4885 { GFC_DECL_BEGIN
= 0, DECL_ALLOCATABLE
= GFC_DECL_BEGIN
,
4886 DECL_IN
= INTENT_IN
, DECL_OUT
= INTENT_OUT
, DECL_INOUT
= INTENT_INOUT
,
4887 DECL_DIMENSION
, DECL_EXTERNAL
,
4888 DECL_INTRINSIC
, DECL_OPTIONAL
,
4889 DECL_PARAMETER
, DECL_POINTER
, DECL_PROTECTED
, DECL_PRIVATE
,
4890 DECL_STATIC
, DECL_AUTOMATIC
,
4891 DECL_PUBLIC
, DECL_SAVE
, DECL_TARGET
, DECL_VALUE
, DECL_VOLATILE
,
4892 DECL_IS_BIND_C
, DECL_CODIMENSION
, DECL_ASYNCHRONOUS
, DECL_CONTIGUOUS
,
4893 DECL_LEN
, DECL_KIND
, DECL_NONE
, GFC_DECL_END
/* Sentinel */
4896 /* GFC_DECL_END is the sentinel, index starts at 0. */
4897 #define NUM_DECL GFC_DECL_END
4899 /* Make sure that values from sym_intent are safe to be used here. */
4900 gcc_assert (INTENT_IN
> 0);
4902 locus start
, seen_at
[NUM_DECL
];
4909 gfc_clear_attr (¤t_attr
);
4910 start
= gfc_current_locus
;
4916 /* See if we get all of the keywords up to the final double colon. */
4917 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
4925 gfc_gobble_whitespace ();
4927 ch
= gfc_next_ascii_char ();
4930 /* This is the successful exit condition for the loop. */
4931 if (gfc_next_ascii_char () == ':')
4936 gfc_gobble_whitespace ();
4937 switch (gfc_peek_ascii_char ())
4940 gfc_next_ascii_char ();
4941 switch (gfc_next_ascii_char ())
4944 if (match_string_p ("locatable"))
4946 /* Matched "allocatable". */
4947 d
= DECL_ALLOCATABLE
;
4952 if (match_string_p ("ynchronous"))
4954 /* Matched "asynchronous". */
4955 d
= DECL_ASYNCHRONOUS
;
4960 if (match_string_p ("tomatic"))
4962 /* Matched "automatic". */
4970 /* Try and match the bind(c). */
4971 m
= gfc_match_bind_c (NULL
, true);
4974 else if (m
== MATCH_ERROR
)
4979 gfc_next_ascii_char ();
4980 if ('o' != gfc_next_ascii_char ())
4982 switch (gfc_next_ascii_char ())
4985 if (match_string_p ("imension"))
4987 d
= DECL_CODIMENSION
;
4992 if (match_string_p ("tiguous"))
4994 d
= DECL_CONTIGUOUS
;
5001 if (match_string_p ("dimension"))
5006 if (match_string_p ("external"))
5011 if (match_string_p ("int"))
5013 ch
= gfc_next_ascii_char ();
5016 if (match_string_p ("nt"))
5018 /* Matched "intent". */
5019 d
= match_intent_spec ();
5020 if (d
== INTENT_UNKNOWN
)
5029 if (match_string_p ("insic"))
5031 /* Matched "intrinsic". */
5039 if (match_string_p ("kind"))
5044 if (match_string_p ("len"))
5049 if (match_string_p ("optional"))
5054 gfc_next_ascii_char ();
5055 switch (gfc_next_ascii_char ())
5058 if (match_string_p ("rameter"))
5060 /* Matched "parameter". */
5066 if (match_string_p ("inter"))
5068 /* Matched "pointer". */
5074 ch
= gfc_next_ascii_char ();
5077 if (match_string_p ("vate"))
5079 /* Matched "private". */
5085 if (match_string_p ("tected"))
5087 /* Matched "protected". */
5094 if (match_string_p ("blic"))
5096 /* Matched "public". */
5104 gfc_next_ascii_char ();
5105 switch (gfc_next_ascii_char ())
5108 if (match_string_p ("ve"))
5110 /* Matched "save". */
5116 if (match_string_p ("atic"))
5118 /* Matched "static". */
5126 if (match_string_p ("target"))
5131 gfc_next_ascii_char ();
5132 ch
= gfc_next_ascii_char ();
5135 if (match_string_p ("lue"))
5137 /* Matched "value". */
5143 if (match_string_p ("latile"))
5145 /* Matched "volatile". */
5153 /* No double colon and no recognizable decl_type, so assume that
5154 we've been looking at something else the whole time. */
5161 /* Check to make sure any parens are paired up correctly. */
5162 if (gfc_match_parens () == MATCH_ERROR
)
5169 seen_at
[d
] = gfc_current_locus
;
5171 if (d
== DECL_DIMENSION
|| d
== DECL_CODIMENSION
)
5173 gfc_array_spec
*as
= NULL
;
5175 m
= gfc_match_array_spec (&as
, d
== DECL_DIMENSION
,
5176 d
== DECL_CODIMENSION
);
5178 if (current_as
== NULL
)
5180 else if (m
== MATCH_YES
)
5182 if (!merge_array_spec (as
, current_as
, false))
5189 if (d
== DECL_CODIMENSION
)
5190 gfc_error ("Missing codimension specification at %C");
5192 gfc_error ("Missing dimension specification at %C");
5196 if (m
== MATCH_ERROR
)
5201 /* Since we've seen a double colon, we have to be looking at an
5202 attr-spec. This means that we can now issue errors. */
5203 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
5208 case DECL_ALLOCATABLE
:
5209 attr
= "ALLOCATABLE";
5211 case DECL_ASYNCHRONOUS
:
5212 attr
= "ASYNCHRONOUS";
5214 case DECL_CODIMENSION
:
5215 attr
= "CODIMENSION";
5217 case DECL_CONTIGUOUS
:
5218 attr
= "CONTIGUOUS";
5220 case DECL_DIMENSION
:
5227 attr
= "INTENT (IN)";
5230 attr
= "INTENT (OUT)";
5233 attr
= "INTENT (IN OUT)";
5235 case DECL_INTRINSIC
:
5247 case DECL_PARAMETER
:
5253 case DECL_PROTECTED
:
5268 case DECL_AUTOMATIC
:
5274 case DECL_IS_BIND_C
:
5284 attr
= NULL
; /* This shouldn't happen. */
5287 gfc_error ("Duplicate %s attribute at %L", attr
, &seen_at
[d
]);
5292 /* Now that we've dealt with duplicate attributes, add the attributes
5293 to the current attribute. */
5294 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
5301 if ((d
== DECL_STATIC
|| d
== DECL_AUTOMATIC
)
5302 && !flag_dec_static
)
5304 gfc_error ("%s at %L is a DEC extension, enable with "
5306 d
== DECL_STATIC
? "STATIC" : "AUTOMATIC", &seen_at
[d
]);
5310 /* Allow SAVE with STATIC, but don't complain. */
5311 if (d
== DECL_STATIC
&& seen
[DECL_SAVE
])
5314 if (gfc_current_state () == COMP_DERIVED
5315 && d
!= DECL_DIMENSION
&& d
!= DECL_CODIMENSION
5316 && d
!= DECL_POINTER
&& d
!= DECL_PRIVATE
5317 && d
!= DECL_PUBLIC
&& d
!= DECL_CONTIGUOUS
&& d
!= DECL_NONE
)
5319 if (d
== DECL_ALLOCATABLE
)
5321 if (!gfc_notify_std (GFC_STD_F2003
, "ALLOCATABLE "
5322 "attribute at %C in a TYPE definition"))
5328 else if (d
== DECL_KIND
)
5330 if (!gfc_notify_std (GFC_STD_F2003
, "KIND "
5331 "attribute at %C in a TYPE definition"))
5336 if (current_ts
.type
!= BT_INTEGER
)
5338 gfc_error ("Component with KIND attribute at %C must be "
5343 if (current_ts
.kind
!= gfc_default_integer_kind
)
5345 gfc_error ("Component with KIND attribute at %C must be "
5346 "default integer kind (%d)",
5347 gfc_default_integer_kind
);
5352 else if (d
== DECL_LEN
)
5354 if (!gfc_notify_std (GFC_STD_F2003
, "LEN "
5355 "attribute at %C in a TYPE definition"))
5360 if (current_ts
.type
!= BT_INTEGER
)
5362 gfc_error ("Component with LEN attribute at %C must be "
5367 if (current_ts
.kind
!= gfc_default_integer_kind
)
5369 gfc_error ("Component with LEN attribute at %C must be "
5370 "default integer kind (%d)",
5371 gfc_default_integer_kind
);
5378 gfc_error ("Attribute at %L is not allowed in a TYPE definition",
5385 if ((d
== DECL_PRIVATE
|| d
== DECL_PUBLIC
)
5386 && gfc_current_state () != COMP_MODULE
)
5388 if (d
== DECL_PRIVATE
)
5392 if (gfc_current_state () == COMP_DERIVED
5393 && gfc_state_stack
->previous
5394 && gfc_state_stack
->previous
->state
== COMP_MODULE
)
5396 if (!gfc_notify_std (GFC_STD_F2003
, "Attribute %s "
5397 "at %L in a TYPE definition", attr
,
5406 gfc_error ("%s attribute at %L is not allowed outside of the "
5407 "specification part of a module", attr
, &seen_at
[d
]);
5413 if (gfc_current_state () != COMP_DERIVED
5414 && (d
== DECL_KIND
|| d
== DECL_LEN
))
5416 gfc_error ("Attribute at %L is not allowed outside a TYPE "
5417 "definition", &seen_at
[d
]);
5424 case DECL_ALLOCATABLE
:
5425 t
= gfc_add_allocatable (¤t_attr
, &seen_at
[d
]);
5428 case DECL_ASYNCHRONOUS
:
5429 if (!gfc_notify_std (GFC_STD_F2003
, "ASYNCHRONOUS attribute at %C"))
5432 t
= gfc_add_asynchronous (¤t_attr
, NULL
, &seen_at
[d
]);
5435 case DECL_CODIMENSION
:
5436 t
= gfc_add_codimension (¤t_attr
, NULL
, &seen_at
[d
]);
5439 case DECL_CONTIGUOUS
:
5440 if (!gfc_notify_std (GFC_STD_F2008
, "CONTIGUOUS attribute at %C"))
5443 t
= gfc_add_contiguous (¤t_attr
, NULL
, &seen_at
[d
]);
5446 case DECL_DIMENSION
:
5447 t
= gfc_add_dimension (¤t_attr
, NULL
, &seen_at
[d
]);
5451 t
= gfc_add_external (¤t_attr
, &seen_at
[d
]);
5455 t
= gfc_add_intent (¤t_attr
, INTENT_IN
, &seen_at
[d
]);
5459 t
= gfc_add_intent (¤t_attr
, INTENT_OUT
, &seen_at
[d
]);
5463 t
= gfc_add_intent (¤t_attr
, INTENT_INOUT
, &seen_at
[d
]);
5466 case DECL_INTRINSIC
:
5467 t
= gfc_add_intrinsic (¤t_attr
, &seen_at
[d
]);
5471 t
= gfc_add_optional (¤t_attr
, &seen_at
[d
]);
5475 t
= gfc_add_kind (¤t_attr
, &seen_at
[d
]);
5479 t
= gfc_add_len (¤t_attr
, &seen_at
[d
]);
5482 case DECL_PARAMETER
:
5483 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, &seen_at
[d
]);
5487 t
= gfc_add_pointer (¤t_attr
, &seen_at
[d
]);
5490 case DECL_PROTECTED
:
5491 if (gfc_current_state () != COMP_MODULE
5492 || (gfc_current_ns
->proc_name
5493 && gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
))
5495 gfc_error ("PROTECTED at %C only allowed in specification "
5496 "part of a module");
5501 if (!gfc_notify_std (GFC_STD_F2003
, "PROTECTED attribute at %C"))
5504 t
= gfc_add_protected (¤t_attr
, NULL
, &seen_at
[d
]);
5508 t
= gfc_add_access (¤t_attr
, ACCESS_PRIVATE
, NULL
,
5513 t
= gfc_add_access (¤t_attr
, ACCESS_PUBLIC
, NULL
,
5519 t
= gfc_add_save (¤t_attr
, SAVE_EXPLICIT
, NULL
, &seen_at
[d
]);
5522 case DECL_AUTOMATIC
:
5523 t
= gfc_add_automatic (¤t_attr
, NULL
, &seen_at
[d
]);
5527 t
= gfc_add_target (¤t_attr
, &seen_at
[d
]);
5530 case DECL_IS_BIND_C
:
5531 t
= gfc_add_is_bind_c(¤t_attr
, NULL
, &seen_at
[d
], 0);
5535 if (!gfc_notify_std (GFC_STD_F2003
, "VALUE attribute at %C"))
5538 t
= gfc_add_value (¤t_attr
, NULL
, &seen_at
[d
]);
5542 if (!gfc_notify_std (GFC_STD_F2003
, "VOLATILE attribute at %C"))
5545 t
= gfc_add_volatile (¤t_attr
, NULL
, &seen_at
[d
]);
5549 gfc_internal_error ("match_attr_spec(): Bad attribute");
5559 /* Since Fortran 2008 module variables implicitly have the SAVE attribute. */
5560 if ((gfc_current_state () == COMP_MODULE
5561 || gfc_current_state () == COMP_SUBMODULE
)
5562 && !current_attr
.save
5563 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
5564 current_attr
.save
= SAVE_IMPLICIT
;
5570 gfc_current_locus
= start
;
5571 gfc_free_array_spec (current_as
);
5578 /* Set the binding label, dest_label, either with the binding label
5579 stored in the given gfc_typespec, ts, or if none was provided, it
5580 will be the symbol name in all lower case, as required by the draft
5581 (J3/04-007, section 15.4.1). If a binding label was given and
5582 there is more than one argument (num_idents), it is an error. */
5585 set_binding_label (const char **dest_label
, const char *sym_name
,
5588 if (num_idents
> 1 && has_name_equals
)
5590 gfc_error ("Multiple identifiers provided with "
5591 "single NAME= specifier at %C");
5595 if (curr_binding_label
)
5596 /* Binding label given; store in temp holder till have sym. */
5597 *dest_label
= curr_binding_label
;
5600 /* No binding label given, and the NAME= specifier did not exist,
5601 which means there was no NAME="". */
5602 if (sym_name
!= NULL
&& has_name_equals
== 0)
5603 *dest_label
= IDENTIFIER_POINTER (get_identifier (sym_name
));
5610 /* Set the status of the given common block as being BIND(C) or not,
5611 depending on the given parameter, is_bind_c. */
5614 set_com_block_bind_c (gfc_common_head
*com_block
, int is_bind_c
)
5616 com_block
->is_bind_c
= is_bind_c
;
5621 /* Verify that the given gfc_typespec is for a C interoperable type. */
5624 gfc_verify_c_interop (gfc_typespec
*ts
)
5626 if (ts
->type
== BT_DERIVED
&& ts
->u
.derived
!= NULL
)
5627 return (ts
->u
.derived
->ts
.is_c_interop
|| ts
->u
.derived
->attr
.is_bind_c
)
5629 else if (ts
->type
== BT_CLASS
)
5631 else if (ts
->is_c_interop
!= 1 && ts
->type
!= BT_ASSUMED
)
5638 /* Verify that the variables of a given common block, which has been
5639 defined with the attribute specifier bind(c), to be of a C
5640 interoperable type. Errors will be reported here, if
5644 verify_com_block_vars_c_interop (gfc_common_head
*com_block
)
5646 gfc_symbol
*curr_sym
= NULL
;
5649 curr_sym
= com_block
->head
;
5651 /* Make sure we have at least one symbol. */
5652 if (curr_sym
== NULL
)
5655 /* Here we know we have a symbol, so we'll execute this loop
5659 /* The second to last param, 1, says this is in a common block. */
5660 retval
= verify_bind_c_sym (curr_sym
, &(curr_sym
->ts
), 1, com_block
);
5661 curr_sym
= curr_sym
->common_next
;
5662 } while (curr_sym
!= NULL
);
5668 /* Verify that a given BIND(C) symbol is C interoperable. If it is not,
5669 an appropriate error message is reported. */
5672 verify_bind_c_sym (gfc_symbol
*tmp_sym
, gfc_typespec
*ts
,
5673 int is_in_common
, gfc_common_head
*com_block
)
5675 bool bind_c_function
= false;
5678 if (tmp_sym
->attr
.function
&& tmp_sym
->attr
.is_bind_c
)
5679 bind_c_function
= true;
5681 if (tmp_sym
->attr
.function
&& tmp_sym
->result
!= NULL
)
5683 tmp_sym
= tmp_sym
->result
;
5684 /* Make sure it wasn't an implicitly typed result. */
5685 if (tmp_sym
->attr
.implicit_type
&& warn_c_binding_type
)
5687 gfc_warning (OPT_Wc_binding_type
,
5688 "Implicitly declared BIND(C) function %qs at "
5689 "%L may not be C interoperable", tmp_sym
->name
,
5690 &tmp_sym
->declared_at
);
5691 tmp_sym
->ts
.f90_type
= tmp_sym
->ts
.type
;
5692 /* Mark it as C interoperable to prevent duplicate warnings. */
5693 tmp_sym
->ts
.is_c_interop
= 1;
5694 tmp_sym
->attr
.is_c_interop
= 1;
5698 /* Here, we know we have the bind(c) attribute, so if we have
5699 enough type info, then verify that it's a C interop kind.
5700 The info could be in the symbol already, or possibly still in
5701 the given ts (current_ts), so look in both. */
5702 if (tmp_sym
->ts
.type
!= BT_UNKNOWN
|| ts
->type
!= BT_UNKNOWN
)
5704 if (!gfc_verify_c_interop (&(tmp_sym
->ts
)))
5706 /* See if we're dealing with a sym in a common block or not. */
5707 if (is_in_common
== 1 && warn_c_binding_type
)
5709 gfc_warning (OPT_Wc_binding_type
,
5710 "Variable %qs in common block %qs at %L "
5711 "may not be a C interoperable "
5712 "kind though common block %qs is BIND(C)",
5713 tmp_sym
->name
, com_block
->name
,
5714 &(tmp_sym
->declared_at
), com_block
->name
);
5718 if (tmp_sym
->ts
.type
== BT_DERIVED
|| ts
->type
== BT_DERIVED
)
5719 gfc_error ("Type declaration %qs at %L is not C "
5720 "interoperable but it is BIND(C)",
5721 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5722 else if (warn_c_binding_type
)
5723 gfc_warning (OPT_Wc_binding_type
, "Variable %qs at %L "
5724 "may not be a C interoperable "
5725 "kind but it is BIND(C)",
5726 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5730 /* Variables declared w/in a common block can't be bind(c)
5731 since there's no way for C to see these variables, so there's
5732 semantically no reason for the attribute. */
5733 if (is_in_common
== 1 && tmp_sym
->attr
.is_bind_c
== 1)
5735 gfc_error ("Variable %qs in common block %qs at "
5736 "%L cannot be declared with BIND(C) "
5737 "since it is not a global",
5738 tmp_sym
->name
, com_block
->name
,
5739 &(tmp_sym
->declared_at
));
5743 /* Scalar variables that are bind(c) cannot have the pointer
5744 or allocatable attributes. */
5745 if (tmp_sym
->attr
.is_bind_c
== 1)
5747 if (tmp_sym
->attr
.pointer
== 1)
5749 gfc_error ("Variable %qs at %L cannot have both the "
5750 "POINTER and BIND(C) attributes",
5751 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5755 if (tmp_sym
->attr
.allocatable
== 1)
5757 gfc_error ("Variable %qs at %L cannot have both the "
5758 "ALLOCATABLE and BIND(C) attributes",
5759 tmp_sym
->name
, &(tmp_sym
->declared_at
));
5765 /* If it is a BIND(C) function, make sure the return value is a
5766 scalar value. The previous tests in this function made sure
5767 the type is interoperable. */
5768 if (bind_c_function
&& tmp_sym
->as
!= NULL
)
5769 gfc_error ("Return type of BIND(C) function %qs at %L cannot "
5770 "be an array", tmp_sym
->name
, &(tmp_sym
->declared_at
));
5772 /* BIND(C) functions cannot return a character string. */
5773 if (bind_c_function
&& tmp_sym
->ts
.type
== BT_CHARACTER
)
5774 if (tmp_sym
->ts
.u
.cl
== NULL
|| tmp_sym
->ts
.u
.cl
->length
== NULL
5775 || tmp_sym
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
5776 || mpz_cmp_si (tmp_sym
->ts
.u
.cl
->length
->value
.integer
, 1) != 0)
5777 gfc_error ("Return type of BIND(C) function %qs of character "
5778 "type at %L must have length 1", tmp_sym
->name
,
5779 &(tmp_sym
->declared_at
));
5782 /* See if the symbol has been marked as private. If it has, make sure
5783 there is no binding label and warn the user if there is one. */
5784 if (tmp_sym
->attr
.access
== ACCESS_PRIVATE
5785 && tmp_sym
->binding_label
)
5786 /* Use gfc_warning_now because we won't say that the symbol fails
5787 just because of this. */
5788 gfc_warning_now (0, "Symbol %qs at %L is marked PRIVATE but has been "
5789 "given the binding label %qs", tmp_sym
->name
,
5790 &(tmp_sym
->declared_at
), tmp_sym
->binding_label
);
5796 /* Set the appropriate fields for a symbol that's been declared as
5797 BIND(C) (the is_bind_c flag and the binding label), and verify that
5798 the type is C interoperable. Errors are reported by the functions
5799 used to set/test these fields. */
5802 set_verify_bind_c_sym (gfc_symbol
*tmp_sym
, int num_idents
)
5806 /* TODO: Do we need to make sure the vars aren't marked private? */
5808 /* Set the is_bind_c bit in symbol_attribute. */
5809 gfc_add_is_bind_c (&(tmp_sym
->attr
), tmp_sym
->name
, &gfc_current_locus
, 0);
5811 if (!set_binding_label (&tmp_sym
->binding_label
, tmp_sym
->name
, num_idents
))
5818 /* Set the fields marking the given common block as BIND(C), including
5819 a binding label, and report any errors encountered. */
5822 set_verify_bind_c_com_block (gfc_common_head
*com_block
, int num_idents
)
5826 /* destLabel, common name, typespec (which may have binding label). */
5827 if (!set_binding_label (&com_block
->binding_label
, com_block
->name
,
5831 /* Set the given common block (com_block) to being bind(c) (1). */
5832 set_com_block_bind_c (com_block
, 1);
5838 /* Retrieve the list of one or more identifiers that the given bind(c)
5839 attribute applies to. */
5842 get_bind_c_idents (void)
5844 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5846 gfc_symbol
*tmp_sym
= NULL
;
5848 gfc_common_head
*com_block
= NULL
;
5850 if (gfc_match_name (name
) == MATCH_YES
)
5852 found_id
= MATCH_YES
;
5853 gfc_get_ha_symbol (name
, &tmp_sym
);
5855 else if (match_common_name (name
) == MATCH_YES
)
5857 found_id
= MATCH_YES
;
5858 com_block
= gfc_get_common (name
, 0);
5862 gfc_error ("Need either entity or common block name for "
5863 "attribute specification statement at %C");
5867 /* Save the current identifier and look for more. */
5870 /* Increment the number of identifiers found for this spec stmt. */
5873 /* Make sure we have a sym or com block, and verify that it can
5874 be bind(c). Set the appropriate field(s) and look for more
5876 if (tmp_sym
!= NULL
|| com_block
!= NULL
)
5878 if (tmp_sym
!= NULL
)
5880 if (!set_verify_bind_c_sym (tmp_sym
, num_idents
))
5885 if (!set_verify_bind_c_com_block (com_block
, num_idents
))
5889 /* Look to see if we have another identifier. */
5891 if (gfc_match_eos () == MATCH_YES
)
5892 found_id
= MATCH_NO
;
5893 else if (gfc_match_char (',') != MATCH_YES
)
5894 found_id
= MATCH_NO
;
5895 else if (gfc_match_name (name
) == MATCH_YES
)
5897 found_id
= MATCH_YES
;
5898 gfc_get_ha_symbol (name
, &tmp_sym
);
5900 else if (match_common_name (name
) == MATCH_YES
)
5902 found_id
= MATCH_YES
;
5903 com_block
= gfc_get_common (name
, 0);
5907 gfc_error ("Missing entity or common block name for "
5908 "attribute specification statement at %C");
5914 gfc_internal_error ("Missing symbol");
5916 } while (found_id
== MATCH_YES
);
5918 /* if we get here we were successful */
5923 /* Try and match a BIND(C) attribute specification statement. */
5926 gfc_match_bind_c_stmt (void)
5928 match found_match
= MATCH_NO
;
5933 /* This may not be necessary. */
5935 /* Clear the temporary binding label holder. */
5936 curr_binding_label
= NULL
;
5938 /* Look for the bind(c). */
5939 found_match
= gfc_match_bind_c (NULL
, true);
5941 if (found_match
== MATCH_YES
)
5943 if (!gfc_notify_std (GFC_STD_F2003
, "BIND(C) statement at %C"))
5946 /* Look for the :: now, but it is not required. */
5949 /* Get the identifier(s) that needs to be updated. This may need to
5950 change to hand the flag(s) for the attr specified so all identifiers
5951 found can have all appropriate parts updated (assuming that the same
5952 spec stmt can have multiple attrs, such as both bind(c) and
5954 if (!get_bind_c_idents ())
5955 /* Error message should have printed already. */
5963 /* Match a data declaration statement. */
5966 gfc_match_data_decl (void)
5972 type_param_spec_list
= NULL
;
5973 decl_type_param_list
= NULL
;
5975 num_idents_on_line
= 0;
5977 m
= gfc_match_decl_type_spec (¤t_ts
, 0);
5981 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
5982 && !gfc_comp_struct (gfc_current_state ()))
5984 sym
= gfc_use_derived (current_ts
.u
.derived
);
5992 current_ts
.u
.derived
= sym
;
5995 m
= match_attr_spec ();
5996 if (m
== MATCH_ERROR
)
6002 if (current_ts
.type
== BT_CLASS
6003 && current_ts
.u
.derived
->attr
.unlimited_polymorphic
)
6006 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
6007 && current_ts
.u
.derived
->components
== NULL
6008 && !current_ts
.u
.derived
->attr
.zero_comp
)
6011 if (current_attr
.pointer
&& gfc_comp_struct (gfc_current_state ()))
6014 if (current_attr
.allocatable
&& gfc_current_state () == COMP_DERIVED
)
6017 gfc_find_symbol (current_ts
.u
.derived
->name
,
6018 current_ts
.u
.derived
->ns
, 1, &sym
);
6020 /* Any symbol that we find had better be a type definition
6021 which has its components defined, or be a structure definition
6022 actively being parsed. */
6023 if (sym
!= NULL
&& gfc_fl_struct (sym
->attr
.flavor
)
6024 && (current_ts
.u
.derived
->components
!= NULL
6025 || current_ts
.u
.derived
->attr
.zero_comp
6026 || current_ts
.u
.derived
== gfc_new_block
))
6029 gfc_error ("Derived type at %C has not been previously defined "
6030 "and so cannot appear in a derived type definition");
6036 /* If we have an old-style character declaration, and no new-style
6037 attribute specifications, then there a comma is optional between
6038 the type specification and the variable list. */
6039 if (m
== MATCH_NO
&& current_ts
.type
== BT_CHARACTER
&& old_char_selector
)
6040 gfc_match_char (',');
6042 /* Give the types/attributes to symbols that follow. Give the element
6043 a number so that repeat character length expressions can be copied. */
6047 num_idents_on_line
++;
6048 m
= variable_decl (elem
++);
6049 if (m
== MATCH_ERROR
)
6054 if (gfc_match_eos () == MATCH_YES
)
6056 if (gfc_match_char (',') != MATCH_YES
)
6060 if (!gfc_error_flag_test ())
6062 /* An anonymous structure declaration is unambiguous; if we matched one
6063 according to gfc_match_structure_decl, we need to return MATCH_YES
6064 here to avoid confusing the remaining matchers, even if there was an
6065 error during variable_decl. We must flush any such errors. Note this
6066 causes the parser to gracefully continue parsing the remaining input
6067 as a structure body, which likely follows. */
6068 if (current_ts
.type
== BT_DERIVED
&& current_ts
.u
.derived
6069 && gfc_fl_struct (current_ts
.u
.derived
->attr
.flavor
))
6071 gfc_error_now ("Syntax error in anonymous structure declaration"
6073 /* Skip the bad variable_decl and line up for the start of the
6075 gfc_error_recovery ();
6080 gfc_error ("Syntax error in data declaration at %C");
6085 gfc_free_data_all (gfc_current_ns
);
6088 if (saved_kind_expr
)
6089 gfc_free_expr (saved_kind_expr
);
6090 if (type_param_spec_list
)
6091 gfc_free_actual_arglist (type_param_spec_list
);
6092 if (decl_type_param_list
)
6093 gfc_free_actual_arglist (decl_type_param_list
);
6094 saved_kind_expr
= NULL
;
6095 gfc_free_array_spec (current_as
);
6101 in_module_or_interface(void)
6103 if (gfc_current_state () == COMP_MODULE
6104 || gfc_current_state () == COMP_SUBMODULE
6105 || gfc_current_state () == COMP_INTERFACE
)
6108 if (gfc_state_stack
->state
== COMP_CONTAINS
6109 || gfc_state_stack
->state
== COMP_FUNCTION
6110 || gfc_state_stack
->state
== COMP_SUBROUTINE
)
6113 for (p
= gfc_state_stack
->previous
; p
; p
= p
->previous
)
6115 if (p
->state
== COMP_MODULE
|| p
->state
== COMP_SUBMODULE
6116 || p
->state
== COMP_INTERFACE
)
6123 /* Match a prefix associated with a function or subroutine
6124 declaration. If the typespec pointer is nonnull, then a typespec
6125 can be matched. Note that if nothing matches, MATCH_YES is
6126 returned (the null string was matched). */
6129 gfc_match_prefix (gfc_typespec
*ts
)
6135 gfc_clear_attr (¤t_attr
);
6137 seen_impure
= false;
6139 gcc_assert (!gfc_matching_prefix
);
6140 gfc_matching_prefix
= true;
6144 found_prefix
= false;
6146 /* MODULE is a prefix like PURE, ELEMENTAL, etc., having a
6147 corresponding attribute seems natural and distinguishes these
6148 procedures from procedure types of PROC_MODULE, which these are
6150 if (gfc_match ("module% ") == MATCH_YES
)
6152 if (!gfc_notify_std (GFC_STD_F2008
, "MODULE prefix at %C"))
6155 if (!in_module_or_interface ())
6157 gfc_error ("MODULE prefix at %C found outside of a module, "
6158 "submodule, or interface");
6162 current_attr
.module_procedure
= 1;
6163 found_prefix
= true;
6166 if (!seen_type
&& ts
!= NULL
6167 && gfc_match_decl_type_spec (ts
, 0) == MATCH_YES
6168 && gfc_match_space () == MATCH_YES
)
6172 found_prefix
= true;
6175 if (gfc_match ("elemental% ") == MATCH_YES
)
6177 if (!gfc_add_elemental (¤t_attr
, NULL
))
6180 found_prefix
= true;
6183 if (gfc_match ("pure% ") == MATCH_YES
)
6185 if (!gfc_add_pure (¤t_attr
, NULL
))
6188 found_prefix
= true;
6191 if (gfc_match ("recursive% ") == MATCH_YES
)
6193 if (!gfc_add_recursive (¤t_attr
, NULL
))
6196 found_prefix
= true;
6199 /* IMPURE is a somewhat special case, as it needs not set an actual
6200 attribute but rather only prevents ELEMENTAL routines from being
6201 automatically PURE. */
6202 if (gfc_match ("impure% ") == MATCH_YES
)
6204 if (!gfc_notify_std (GFC_STD_F2008
, "IMPURE procedure at %C"))
6208 found_prefix
= true;
6211 while (found_prefix
);
6213 /* IMPURE and PURE must not both appear, of course. */
6214 if (seen_impure
&& current_attr
.pure
)
6216 gfc_error ("PURE and IMPURE must not appear both at %C");
6220 /* If IMPURE it not seen but the procedure is ELEMENTAL, mark it as PURE. */
6221 if (!seen_impure
&& current_attr
.elemental
&& !current_attr
.pure
)
6223 if (!gfc_add_pure (¤t_attr
, NULL
))
6227 /* At this point, the next item is not a prefix. */
6228 gcc_assert (gfc_matching_prefix
);
6230 gfc_matching_prefix
= false;
6234 gcc_assert (gfc_matching_prefix
);
6235 gfc_matching_prefix
= false;
6240 /* Copy attributes matched by gfc_match_prefix() to attributes on a symbol. */
6243 copy_prefix (symbol_attribute
*dest
, locus
*where
)
6245 if (dest
->module_procedure
)
6247 if (current_attr
.elemental
)
6248 dest
->elemental
= 1;
6250 if (current_attr
.pure
)
6253 if (current_attr
.recursive
)
6254 dest
->recursive
= 1;
6256 /* Module procedures are unusual in that the 'dest' is copied from
6257 the interface declaration. However, this is an oportunity to
6258 check that the submodule declaration is compliant with the
6260 if (dest
->elemental
&& !current_attr
.elemental
)
6262 gfc_error ("ELEMENTAL prefix in MODULE PROCEDURE interface is "
6263 "missing at %L", where
);
6267 if (dest
->pure
&& !current_attr
.pure
)
6269 gfc_error ("PURE prefix in MODULE PROCEDURE interface is "
6270 "missing at %L", where
);
6274 if (dest
->recursive
&& !current_attr
.recursive
)
6276 gfc_error ("RECURSIVE prefix in MODULE PROCEDURE interface is "
6277 "missing at %L", where
);
6284 if (current_attr
.elemental
&& !gfc_add_elemental (dest
, where
))
6287 if (current_attr
.pure
&& !gfc_add_pure (dest
, where
))
6290 if (current_attr
.recursive
&& !gfc_add_recursive (dest
, where
))
6297 /* Match a formal argument list or, if typeparam is true, a
6298 type_param_name_list. */
6301 gfc_match_formal_arglist (gfc_symbol
*progname
, int st_flag
,
6302 int null_flag
, bool typeparam
)
6304 gfc_formal_arglist
*head
, *tail
, *p
, *q
;
6305 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6308 gfc_formal_arglist
*formal
= NULL
;
6312 /* Keep the interface formal argument list and null it so that the
6313 matching for the new declaration can be done. The numbers and
6314 names of the arguments are checked here. The interface formal
6315 arguments are retained in formal_arglist and the characteristics
6316 are compared in resolve.c(resolve_fl_procedure). See the remark
6317 in get_proc_name about the eventual need to copy the formal_arglist
6318 and populate the formal namespace of the interface symbol. */
6319 if (progname
->attr
.module_procedure
6320 && progname
->attr
.host_assoc
)
6322 formal
= progname
->formal
;
6323 progname
->formal
= NULL
;
6326 if (gfc_match_char ('(') != MATCH_YES
)
6333 if (gfc_match_char (')') == MATCH_YES
)
6337 gfc_error_now ("A type parameter list is required at %C");
6347 if (gfc_match_char ('*') == MATCH_YES
)
6350 if (!typeparam
&& !gfc_notify_std (GFC_STD_F95_OBS
,
6351 "Alternate-return argument at %C"))
6357 gfc_error_now ("A parameter name is required at %C");
6361 m
= gfc_match_name (name
);
6365 gfc_error_now ("A parameter name is required at %C");
6369 if (!typeparam
&& gfc_get_symbol (name
, NULL
, &sym
))
6372 && gfc_get_symbol (name
, progname
->f2k_derived
, &sym
))
6376 p
= gfc_get_formal_arglist ();
6388 /* We don't add the VARIABLE flavor because the name could be a
6389 dummy procedure. We don't apply these attributes to formal
6390 arguments of statement functions. */
6391 if (sym
!= NULL
&& !st_flag
6392 && (!gfc_add_dummy(&sym
->attr
, sym
->name
, NULL
)
6393 || !gfc_missing_attr (&sym
->attr
, NULL
)))
6399 /* The name of a program unit can be in a different namespace,
6400 so check for it explicitly. After the statement is accepted,
6401 the name is checked for especially in gfc_get_symbol(). */
6402 if (gfc_new_block
!= NULL
&& sym
!= NULL
&& !typeparam
6403 && strcmp (sym
->name
, gfc_new_block
->name
) == 0)
6405 gfc_error ("Name %qs at %C is the name of the procedure",
6411 if (gfc_match_char (')') == MATCH_YES
)
6414 m
= gfc_match_char (',');
6418 gfc_error_now ("Expected parameter list in type declaration "
6421 gfc_error ("Unexpected junk in formal argument list at %C");
6427 /* Check for duplicate symbols in the formal argument list. */
6430 for (p
= head
; p
->next
; p
= p
->next
)
6435 for (q
= p
->next
; q
; q
= q
->next
)
6436 if (p
->sym
== q
->sym
)
6439 gfc_error_now ("Duplicate name %qs in parameter "
6440 "list at %C", p
->sym
->name
);
6442 gfc_error ("Duplicate symbol %qs in formal argument "
6443 "list at %C", p
->sym
->name
);
6451 if (!gfc_add_explicit_interface (progname
, IFSRC_DECL
, head
, NULL
))
6457 /* gfc_error_now used in following and return with MATCH_YES because
6458 doing otherwise results in a cascade of extraneous errors and in
6459 some cases an ICE in symbol.c(gfc_release_symbol). */
6460 if (progname
->attr
.module_procedure
&& progname
->attr
.host_assoc
)
6462 bool arg_count_mismatch
= false;
6464 if (!formal
&& head
)
6465 arg_count_mismatch
= true;
6467 /* Abbreviated module procedure declaration is not meant to have any
6468 formal arguments! */
6469 if (!progname
->abr_modproc_decl
&& formal
&& !head
)
6470 arg_count_mismatch
= true;
6472 for (p
= formal
, q
= head
; p
&& q
; p
= p
->next
, q
= q
->next
)
6474 if ((p
->next
!= NULL
&& q
->next
== NULL
)
6475 || (p
->next
== NULL
&& q
->next
!= NULL
))
6476 arg_count_mismatch
= true;
6477 else if ((p
->sym
== NULL
&& q
->sym
== NULL
)
6478 || strcmp (p
->sym
->name
, q
->sym
->name
) == 0)
6481 gfc_error_now ("Mismatch in MODULE PROCEDURE formal "
6482 "argument names (%s/%s) at %C",
6483 p
->sym
->name
, q
->sym
->name
);
6486 if (arg_count_mismatch
)
6487 gfc_error_now ("Mismatch in number of MODULE PROCEDURE "
6488 "formal arguments at %C");
6494 gfc_free_formal_arglist (head
);
6499 /* Match a RESULT specification following a function declaration or
6500 ENTRY statement. Also matches the end-of-statement. */
6503 match_result (gfc_symbol
*function
, gfc_symbol
**result
)
6505 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6509 if (gfc_match (" result (") != MATCH_YES
)
6512 m
= gfc_match_name (name
);
6516 /* Get the right paren, and that's it because there could be the
6517 bind(c) attribute after the result clause. */
6518 if (gfc_match_char (')') != MATCH_YES
)
6520 /* TODO: should report the missing right paren here. */
6524 if (strcmp (function
->name
, name
) == 0)
6526 gfc_error ("RESULT variable at %C must be different than function name");
6530 if (gfc_get_symbol (name
, NULL
, &r
))
6533 if (!gfc_add_result (&r
->attr
, r
->name
, NULL
))
6542 /* Match a function suffix, which could be a combination of a result
6543 clause and BIND(C), either one, or neither. The draft does not
6544 require them to come in a specific order. */
6547 gfc_match_suffix (gfc_symbol
*sym
, gfc_symbol
**result
)
6549 match is_bind_c
; /* Found bind(c). */
6550 match is_result
; /* Found result clause. */
6551 match found_match
; /* Status of whether we've found a good match. */
6552 char peek_char
; /* Character we're going to peek at. */
6553 bool allow_binding_name
;
6555 /* Initialize to having found nothing. */
6556 found_match
= MATCH_NO
;
6557 is_bind_c
= MATCH_NO
;
6558 is_result
= MATCH_NO
;
6560 /* Get the next char to narrow between result and bind(c). */
6561 gfc_gobble_whitespace ();
6562 peek_char
= gfc_peek_ascii_char ();
6564 /* C binding names are not allowed for internal procedures. */
6565 if (gfc_current_state () == COMP_CONTAINS
6566 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
6567 allow_binding_name
= false;
6569 allow_binding_name
= true;
6574 /* Look for result clause. */
6575 is_result
= match_result (sym
, result
);
6576 if (is_result
== MATCH_YES
)
6578 /* Now see if there is a bind(c) after it. */
6579 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
6580 /* We've found the result clause and possibly bind(c). */
6581 found_match
= MATCH_YES
;
6584 /* This should only be MATCH_ERROR. */
6585 found_match
= is_result
;
6588 /* Look for bind(c) first. */
6589 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
6590 if (is_bind_c
== MATCH_YES
)
6592 /* Now see if a result clause followed it. */
6593 is_result
= match_result (sym
, result
);
6594 found_match
= MATCH_YES
;
6598 /* Should only be a MATCH_ERROR if we get here after seeing 'b'. */
6599 found_match
= MATCH_ERROR
;
6603 gfc_error ("Unexpected junk after function declaration at %C");
6604 found_match
= MATCH_ERROR
;
6608 if (is_bind_c
== MATCH_YES
)
6610 /* Fortran 2008 draft allows BIND(C) for internal procedures. */
6611 if (gfc_current_state () == COMP_CONTAINS
6612 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
6613 && !gfc_notify_std (GFC_STD_F2008
, "BIND(C) attribute "
6614 "at %L may not be specified for an internal "
6615 "procedure", &gfc_current_locus
))
6618 if (!gfc_add_is_bind_c (&(sym
->attr
), sym
->name
, &gfc_current_locus
, 1))
6626 /* Procedure pointer return value without RESULT statement:
6627 Add "hidden" result variable named "ppr@". */
6630 add_hidden_procptr_result (gfc_symbol
*sym
)
6634 if (gfc_notification_std (GFC_STD_F2003
) == ERROR
)
6637 /* First usage case: PROCEDURE and EXTERNAL statements. */
6638 case1
= gfc_current_state () == COMP_FUNCTION
&& gfc_current_block ()
6639 && strcmp (gfc_current_block ()->name
, sym
->name
) == 0
6640 && sym
->attr
.external
;
6641 /* Second usage case: INTERFACE statements. */
6642 case2
= gfc_current_state () == COMP_INTERFACE
&& gfc_state_stack
->previous
6643 && gfc_state_stack
->previous
->state
== COMP_FUNCTION
6644 && strcmp (gfc_state_stack
->previous
->sym
->name
, sym
->name
) == 0;
6650 gfc_get_sym_tree ("ppr@", gfc_current_ns
, &stree
, false);
6654 gfc_get_sym_tree ("ppr@", gfc_current_ns
->parent
, &stree
, false);
6655 st2
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "ppr@");
6656 st2
->n
.sym
= stree
->n
.sym
;
6657 stree
->n
.sym
->refs
++;
6659 sym
->result
= stree
->n
.sym
;
6661 sym
->result
->attr
.proc_pointer
= sym
->attr
.proc_pointer
;
6662 sym
->result
->attr
.pointer
= sym
->attr
.pointer
;
6663 sym
->result
->attr
.external
= sym
->attr
.external
;
6664 sym
->result
->attr
.referenced
= sym
->attr
.referenced
;
6665 sym
->result
->ts
= sym
->ts
;
6666 sym
->attr
.proc_pointer
= 0;
6667 sym
->attr
.pointer
= 0;
6668 sym
->attr
.external
= 0;
6669 if (sym
->result
->attr
.external
&& sym
->result
->attr
.pointer
)
6671 sym
->result
->attr
.pointer
= 0;
6672 sym
->result
->attr
.proc_pointer
= 1;
6675 return gfc_add_result (&sym
->result
->attr
, sym
->result
->name
, NULL
);
6677 /* POINTER after PROCEDURE/EXTERNAL/INTERFACE statement. */
6678 else if (sym
->attr
.function
&& !sym
->attr
.external
&& sym
->attr
.pointer
6679 && sym
->result
&& sym
->result
!= sym
&& sym
->result
->attr
.external
6680 && sym
== gfc_current_ns
->proc_name
6681 && sym
== sym
->result
->ns
->proc_name
6682 && strcmp ("ppr@", sym
->result
->name
) == 0)
6684 sym
->result
->attr
.proc_pointer
= 1;
6685 sym
->attr
.pointer
= 0;
6693 /* Match the interface for a PROCEDURE declaration,
6694 including brackets (R1212). */
6697 match_procedure_interface (gfc_symbol
**proc_if
)
6701 locus old_loc
, entry_loc
;
6702 gfc_namespace
*old_ns
= gfc_current_ns
;
6703 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6705 old_loc
= entry_loc
= gfc_current_locus
;
6706 gfc_clear_ts (¤t_ts
);
6708 if (gfc_match (" (") != MATCH_YES
)
6710 gfc_current_locus
= entry_loc
;
6714 /* Get the type spec. for the procedure interface. */
6715 old_loc
= gfc_current_locus
;
6716 m
= gfc_match_decl_type_spec (¤t_ts
, 0);
6717 gfc_gobble_whitespace ();
6718 if (m
== MATCH_YES
|| (m
== MATCH_NO
&& gfc_peek_ascii_char () == ')'))
6721 if (m
== MATCH_ERROR
)
6724 /* Procedure interface is itself a procedure. */
6725 gfc_current_locus
= old_loc
;
6726 m
= gfc_match_name (name
);
6728 /* First look to see if it is already accessible in the current
6729 namespace because it is use associated or contained. */
6731 if (gfc_find_sym_tree (name
, NULL
, 0, &st
))
6734 /* If it is still not found, then try the parent namespace, if it
6735 exists and create the symbol there if it is still not found. */
6736 if (gfc_current_ns
->parent
)
6737 gfc_current_ns
= gfc_current_ns
->parent
;
6738 if (st
== NULL
&& gfc_get_ha_sym_tree (name
, &st
))
6741 gfc_current_ns
= old_ns
;
6742 *proc_if
= st
->n
.sym
;
6747 /* Resolve interface if possible. That way, attr.procedure is only set
6748 if it is declared by a later procedure-declaration-stmt, which is
6749 invalid per F08:C1216 (cf. resolve_procedure_interface). */
6750 while ((*proc_if
)->ts
.interface
6751 && *proc_if
!= (*proc_if
)->ts
.interface
)
6752 *proc_if
= (*proc_if
)->ts
.interface
;
6754 if ((*proc_if
)->attr
.flavor
== FL_UNKNOWN
6755 && (*proc_if
)->ts
.type
== BT_UNKNOWN
6756 && !gfc_add_flavor (&(*proc_if
)->attr
, FL_PROCEDURE
,
6757 (*proc_if
)->name
, NULL
))
6762 if (gfc_match (" )") != MATCH_YES
)
6764 gfc_current_locus
= entry_loc
;
6772 /* Match a PROCEDURE declaration (R1211). */
6775 match_procedure_decl (void)
6778 gfc_symbol
*sym
, *proc_if
= NULL
;
6780 gfc_expr
*initializer
= NULL
;
6782 /* Parse interface (with brackets). */
6783 m
= match_procedure_interface (&proc_if
);
6787 /* Parse attributes (with colons). */
6788 m
= match_attr_spec();
6789 if (m
== MATCH_ERROR
)
6792 if (proc_if
&& proc_if
->attr
.is_bind_c
&& !current_attr
.is_bind_c
)
6794 current_attr
.is_bind_c
= 1;
6795 has_name_equals
= 0;
6796 curr_binding_label
= NULL
;
6799 /* Get procedure symbols. */
6802 m
= gfc_match_symbol (&sym
, 0);
6805 else if (m
== MATCH_ERROR
)
6808 /* Add current_attr to the symbol attributes. */
6809 if (!gfc_copy_attr (&sym
->attr
, ¤t_attr
, NULL
))
6812 if (sym
->attr
.is_bind_c
)
6814 /* Check for C1218. */
6815 if (!proc_if
|| !proc_if
->attr
.is_bind_c
)
6817 gfc_error ("BIND(C) attribute at %C requires "
6818 "an interface with BIND(C)");
6821 /* Check for C1217. */
6822 if (has_name_equals
&& sym
->attr
.pointer
)
6824 gfc_error ("BIND(C) procedure with NAME may not have "
6825 "POINTER attribute at %C");
6828 if (has_name_equals
&& sym
->attr
.dummy
)
6830 gfc_error ("Dummy procedure at %C may not have "
6831 "BIND(C) attribute with NAME");
6834 /* Set binding label for BIND(C). */
6835 if (!set_binding_label (&sym
->binding_label
, sym
->name
, num
))
6839 if (!gfc_add_external (&sym
->attr
, NULL
))
6842 if (add_hidden_procptr_result (sym
))
6845 if (!gfc_add_proc (&sym
->attr
, sym
->name
, NULL
))
6848 /* Set interface. */
6849 if (proc_if
!= NULL
)
6851 if (sym
->ts
.type
!= BT_UNKNOWN
)
6853 gfc_error ("Procedure %qs at %L already has basic type of %s",
6854 sym
->name
, &gfc_current_locus
,
6855 gfc_basic_typename (sym
->ts
.type
));
6858 sym
->ts
.interface
= proc_if
;
6859 sym
->attr
.untyped
= 1;
6860 sym
->attr
.if_source
= IFSRC_IFBODY
;
6862 else if (current_ts
.type
!= BT_UNKNOWN
)
6864 if (!gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
6866 sym
->ts
.interface
= gfc_new_symbol ("", gfc_current_ns
);
6867 sym
->ts
.interface
->ts
= current_ts
;
6868 sym
->ts
.interface
->attr
.flavor
= FL_PROCEDURE
;
6869 sym
->ts
.interface
->attr
.function
= 1;
6870 sym
->attr
.function
= 1;
6871 sym
->attr
.if_source
= IFSRC_UNKNOWN
;
6874 if (gfc_match (" =>") == MATCH_YES
)
6876 if (!current_attr
.pointer
)
6878 gfc_error ("Initialization at %C isn't for a pointer variable");
6883 m
= match_pointer_init (&initializer
, 1);
6887 if (!add_init_expr_to_sym (sym
->name
, &initializer
, &gfc_current_locus
))
6892 if (gfc_match_eos () == MATCH_YES
)
6894 if (gfc_match_char (',') != MATCH_YES
)
6899 gfc_error ("Syntax error in PROCEDURE statement at %C");
6903 /* Free stuff up and return. */
6904 gfc_free_expr (initializer
);
6910 match_binding_attributes (gfc_typebound_proc
* ba
, bool generic
, bool ppc
);
6913 /* Match a procedure pointer component declaration (R445). */
6916 match_ppc_decl (void)
6919 gfc_symbol
*proc_if
= NULL
;
6923 gfc_expr
*initializer
= NULL
;
6924 gfc_typebound_proc
* tb
;
6925 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6927 /* Parse interface (with brackets). */
6928 m
= match_procedure_interface (&proc_if
);
6932 /* Parse attributes. */
6933 tb
= XCNEW (gfc_typebound_proc
);
6934 tb
->where
= gfc_current_locus
;
6935 m
= match_binding_attributes (tb
, false, true);
6936 if (m
== MATCH_ERROR
)
6939 gfc_clear_attr (¤t_attr
);
6940 current_attr
.procedure
= 1;
6941 current_attr
.proc_pointer
= 1;
6942 current_attr
.access
= tb
->access
;
6943 current_attr
.flavor
= FL_PROCEDURE
;
6945 /* Match the colons (required). */
6946 if (gfc_match (" ::") != MATCH_YES
)
6948 gfc_error ("Expected %<::%> after binding-attributes at %C");
6952 /* Check for C450. */
6953 if (!tb
->nopass
&& proc_if
== NULL
)
6955 gfc_error("NOPASS or explicit interface required at %C");
6959 if (!gfc_notify_std (GFC_STD_F2003
, "Procedure pointer component at %C"))
6962 /* Match PPC names. */
6966 m
= gfc_match_name (name
);
6969 else if (m
== MATCH_ERROR
)
6972 if (!gfc_add_component (gfc_current_block(), name
, &c
))
6975 /* Add current_attr to the symbol attributes. */
6976 if (!gfc_copy_attr (&c
->attr
, ¤t_attr
, NULL
))
6979 if (!gfc_add_external (&c
->attr
, NULL
))
6982 if (!gfc_add_proc (&c
->attr
, name
, NULL
))
6989 c
->tb
= XCNEW (gfc_typebound_proc
);
6990 c
->tb
->where
= gfc_current_locus
;
6994 /* Set interface. */
6995 if (proc_if
!= NULL
)
6997 c
->ts
.interface
= proc_if
;
6998 c
->attr
.untyped
= 1;
6999 c
->attr
.if_source
= IFSRC_IFBODY
;
7001 else if (ts
.type
!= BT_UNKNOWN
)
7004 c
->ts
.interface
= gfc_new_symbol ("", gfc_current_ns
);
7005 c
->ts
.interface
->result
= c
->ts
.interface
;
7006 c
->ts
.interface
->ts
= ts
;
7007 c
->ts
.interface
->attr
.flavor
= FL_PROCEDURE
;
7008 c
->ts
.interface
->attr
.function
= 1;
7009 c
->attr
.function
= 1;
7010 c
->attr
.if_source
= IFSRC_UNKNOWN
;
7013 if (gfc_match (" =>") == MATCH_YES
)
7015 m
= match_pointer_init (&initializer
, 1);
7018 gfc_free_expr (initializer
);
7021 c
->initializer
= initializer
;
7024 if (gfc_match_eos () == MATCH_YES
)
7026 if (gfc_match_char (',') != MATCH_YES
)
7031 gfc_error ("Syntax error in procedure pointer component at %C");
7036 /* Match a PROCEDURE declaration inside an interface (R1206). */
7039 match_procedure_in_interface (void)
7043 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7046 if (current_interface
.type
== INTERFACE_NAMELESS
7047 || current_interface
.type
== INTERFACE_ABSTRACT
)
7049 gfc_error ("PROCEDURE at %C must be in a generic interface");
7053 /* Check if the F2008 optional double colon appears. */
7054 gfc_gobble_whitespace ();
7055 old_locus
= gfc_current_locus
;
7056 if (gfc_match ("::") == MATCH_YES
)
7058 if (!gfc_notify_std (GFC_STD_F2008
, "double colon in "
7059 "MODULE PROCEDURE statement at %L", &old_locus
))
7063 gfc_current_locus
= old_locus
;
7067 m
= gfc_match_name (name
);
7070 else if (m
== MATCH_ERROR
)
7072 if (gfc_get_symbol (name
, gfc_current_ns
->parent
, &sym
))
7075 if (!gfc_add_interface (sym
))
7078 if (gfc_match_eos () == MATCH_YES
)
7080 if (gfc_match_char (',') != MATCH_YES
)
7087 gfc_error ("Syntax error in PROCEDURE statement at %C");
7092 /* General matcher for PROCEDURE declarations. */
7094 static match
match_procedure_in_type (void);
7097 gfc_match_procedure (void)
7101 switch (gfc_current_state ())
7106 case COMP_SUBMODULE
:
7107 case COMP_SUBROUTINE
:
7110 m
= match_procedure_decl ();
7112 case COMP_INTERFACE
:
7113 m
= match_procedure_in_interface ();
7116 m
= match_ppc_decl ();
7118 case COMP_DERIVED_CONTAINS
:
7119 m
= match_procedure_in_type ();
7128 if (!gfc_notify_std (GFC_STD_F2003
, "PROCEDURE statement at %C"))
7135 /* Warn if a matched procedure has the same name as an intrinsic; this is
7136 simply a wrapper around gfc_warn_intrinsic_shadow that interprets the current
7137 parser-state-stack to find out whether we're in a module. */
7140 do_warn_intrinsic_shadow (const gfc_symbol
* sym
, bool func
)
7144 in_module
= (gfc_state_stack
->previous
7145 && (gfc_state_stack
->previous
->state
== COMP_MODULE
7146 || gfc_state_stack
->previous
->state
== COMP_SUBMODULE
));
7148 gfc_warn_intrinsic_shadow (sym
, in_module
, func
);
7152 /* Match a function declaration. */
7155 gfc_match_function_decl (void)
7157 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7158 gfc_symbol
*sym
, *result
;
7162 match found_match
; /* Status returned by match func. */
7164 if (gfc_current_state () != COMP_NONE
7165 && gfc_current_state () != COMP_INTERFACE
7166 && gfc_current_state () != COMP_CONTAINS
)
7169 gfc_clear_ts (¤t_ts
);
7171 old_loc
= gfc_current_locus
;
7173 m
= gfc_match_prefix (¤t_ts
);
7176 gfc_current_locus
= old_loc
;
7180 if (gfc_match ("function% %n", name
) != MATCH_YES
)
7182 gfc_current_locus
= old_loc
;
7186 if (get_proc_name (name
, &sym
, false))
7189 if (add_hidden_procptr_result (sym
))
7192 if (current_attr
.module_procedure
)
7193 sym
->attr
.module_procedure
= 1;
7195 gfc_new_block
= sym
;
7197 m
= gfc_match_formal_arglist (sym
, 0, 0);
7200 gfc_error ("Expected formal argument list in function "
7201 "definition at %C");
7205 else if (m
== MATCH_ERROR
)
7210 /* According to the draft, the bind(c) and result clause can
7211 come in either order after the formal_arg_list (i.e., either
7212 can be first, both can exist together or by themselves or neither
7213 one). Therefore, the match_result can't match the end of the
7214 string, and check for the bind(c) or result clause in either order. */
7215 found_match
= gfc_match_eos ();
7217 /* Make sure that it isn't already declared as BIND(C). If it is, it
7218 must have been marked BIND(C) with a BIND(C) attribute and that is
7219 not allowed for procedures. */
7220 if (sym
->attr
.is_bind_c
== 1)
7222 sym
->attr
.is_bind_c
= 0;
7223 if (sym
->old_symbol
!= NULL
)
7224 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7225 "variables or common blocks",
7226 &(sym
->old_symbol
->declared_at
));
7228 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7229 "variables or common blocks", &gfc_current_locus
);
7232 if (found_match
!= MATCH_YES
)
7234 /* If we haven't found the end-of-statement, look for a suffix. */
7235 suffix_match
= gfc_match_suffix (sym
, &result
);
7236 if (suffix_match
== MATCH_YES
)
7237 /* Need to get the eos now. */
7238 found_match
= gfc_match_eos ();
7240 found_match
= suffix_match
;
7243 if(found_match
!= MATCH_YES
)
7247 /* Make changes to the symbol. */
7250 if (!gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
7253 if (!gfc_missing_attr (&sym
->attr
, NULL
))
7256 if (!copy_prefix (&sym
->attr
, &sym
->declared_at
))
7258 if(!sym
->attr
.module_procedure
)
7264 /* Delay matching the function characteristics until after the
7265 specification block by signalling kind=-1. */
7266 sym
->declared_at
= old_loc
;
7267 if (current_ts
.type
!= BT_UNKNOWN
)
7268 current_ts
.kind
= -1;
7270 current_ts
.kind
= 0;
7274 if (current_ts
.type
!= BT_UNKNOWN
7275 && !gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
7281 if (current_ts
.type
!= BT_UNKNOWN
7282 && !gfc_add_type (result
, ¤t_ts
, &gfc_current_locus
))
7284 sym
->result
= result
;
7287 /* Warn if this procedure has the same name as an intrinsic. */
7288 do_warn_intrinsic_shadow (sym
, true);
7294 gfc_current_locus
= old_loc
;
7299 /* This is mostly a copy of parse.c(add_global_procedure) but modified to
7300 pass the name of the entry, rather than the gfc_current_block name, and
7301 to return false upon finding an existing global entry. */
7304 add_global_entry (const char *name
, const char *binding_label
, bool sub
,
7308 enum gfc_symbol_type type
;
7310 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
7312 /* Only in Fortran 2003: For procedures with a binding label also the Fortran
7313 name is a global identifier. */
7314 if (!binding_label
|| gfc_notification_std (GFC_STD_F2008
))
7316 s
= gfc_get_gsymbol (name
, false);
7318 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= type
))
7320 gfc_global_used (s
, where
);
7329 s
->ns
= gfc_current_ns
;
7333 /* Don't add the symbol multiple times. */
7335 && (!gfc_notification_std (GFC_STD_F2008
)
7336 || strcmp (name
, binding_label
) != 0))
7338 s
= gfc_get_gsymbol (binding_label
, true);
7340 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= type
))
7342 gfc_global_used (s
, where
);
7349 s
->binding_label
= binding_label
;
7352 s
->ns
= gfc_current_ns
;
7360 /* Match an ENTRY statement. */
7363 gfc_match_entry (void)
7368 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7369 gfc_compile_state state
;
7373 bool module_procedure
;
7377 m
= gfc_match_name (name
);
7381 if (!gfc_notify_std (GFC_STD_F2008_OBS
, "ENTRY statement at %C"))
7384 state
= gfc_current_state ();
7385 if (state
!= COMP_SUBROUTINE
&& state
!= COMP_FUNCTION
)
7390 gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
7393 gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
7395 case COMP_SUBMODULE
:
7396 gfc_error ("ENTRY statement at %C cannot appear within a SUBMODULE");
7398 case COMP_BLOCK_DATA
:
7399 gfc_error ("ENTRY statement at %C cannot appear within "
7402 case COMP_INTERFACE
:
7403 gfc_error ("ENTRY statement at %C cannot appear within "
7406 case COMP_STRUCTURE
:
7407 gfc_error ("ENTRY statement at %C cannot appear within "
7408 "a STRUCTURE block");
7411 gfc_error ("ENTRY statement at %C cannot appear within "
7412 "a DERIVED TYPE block");
7415 gfc_error ("ENTRY statement at %C cannot appear within "
7416 "an IF-THEN block");
7419 case COMP_DO_CONCURRENT
:
7420 gfc_error ("ENTRY statement at %C cannot appear within "
7424 gfc_error ("ENTRY statement at %C cannot appear within "
7428 gfc_error ("ENTRY statement at %C cannot appear within "
7432 gfc_error ("ENTRY statement at %C cannot appear within "
7436 gfc_error ("ENTRY statement at %C cannot appear within "
7437 "a contained subprogram");
7440 gfc_error ("Unexpected ENTRY statement at %C");
7445 if ((state
== COMP_SUBROUTINE
|| state
== COMP_FUNCTION
)
7446 && gfc_state_stack
->previous
->state
== COMP_INTERFACE
)
7448 gfc_error ("ENTRY statement at %C cannot appear within an INTERFACE");
7452 module_procedure
= gfc_current_ns
->parent
!= NULL
7453 && gfc_current_ns
->parent
->proc_name
7454 && gfc_current_ns
->parent
->proc_name
->attr
.flavor
7457 if (gfc_current_ns
->parent
!= NULL
7458 && gfc_current_ns
->parent
->proc_name
7459 && !module_procedure
)
7461 gfc_error("ENTRY statement at %C cannot appear in a "
7462 "contained procedure");
7466 /* Module function entries need special care in get_proc_name
7467 because previous references within the function will have
7468 created symbols attached to the current namespace. */
7469 if (get_proc_name (name
, &entry
,
7470 gfc_current_ns
->parent
!= NULL
7471 && module_procedure
))
7474 proc
= gfc_current_block ();
7476 /* Make sure that it isn't already declared as BIND(C). If it is, it
7477 must have been marked BIND(C) with a BIND(C) attribute and that is
7478 not allowed for procedures. */
7479 if (entry
->attr
.is_bind_c
== 1)
7481 entry
->attr
.is_bind_c
= 0;
7482 if (entry
->old_symbol
!= NULL
)
7483 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7484 "variables or common blocks",
7485 &(entry
->old_symbol
->declared_at
));
7487 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7488 "variables or common blocks", &gfc_current_locus
);
7491 /* Check what next non-whitespace character is so we can tell if there
7492 is the required parens if we have a BIND(C). */
7493 old_loc
= gfc_current_locus
;
7494 gfc_gobble_whitespace ();
7495 peek_char
= gfc_peek_ascii_char ();
7497 if (state
== COMP_SUBROUTINE
)
7499 m
= gfc_match_formal_arglist (entry
, 0, 1);
7503 /* Call gfc_match_bind_c with allow_binding_name = true as ENTRY can
7504 never be an internal procedure. */
7505 is_bind_c
= gfc_match_bind_c (entry
, true);
7506 if (is_bind_c
== MATCH_ERROR
)
7508 if (is_bind_c
== MATCH_YES
)
7510 if (peek_char
!= '(')
7512 gfc_error ("Missing required parentheses before BIND(C) at %C");
7516 if (!gfc_add_is_bind_c (&(entry
->attr
), entry
->name
,
7517 &(entry
->declared_at
), 1))
7522 if (!gfc_current_ns
->parent
7523 && !add_global_entry (name
, entry
->binding_label
, true,
7527 /* An entry in a subroutine. */
7528 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
7529 || !gfc_add_subroutine (&entry
->attr
, entry
->name
, NULL
))
7534 /* An entry in a function.
7535 We need to take special care because writing
7540 ENTRY f() RESULT (r)
7542 ENTRY f RESULT (r). */
7543 if (gfc_match_eos () == MATCH_YES
)
7545 gfc_current_locus
= old_loc
;
7546 /* Match the empty argument list, and add the interface to
7548 m
= gfc_match_formal_arglist (entry
, 0, 1);
7551 m
= gfc_match_formal_arglist (entry
, 0, 0);
7558 if (gfc_match_eos () == MATCH_YES
)
7560 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
7561 || !gfc_add_function (&entry
->attr
, entry
->name
, NULL
))
7564 entry
->result
= entry
;
7568 m
= gfc_match_suffix (entry
, &result
);
7570 gfc_syntax_error (ST_ENTRY
);
7576 if (!gfc_add_result (&result
->attr
, result
->name
, NULL
)
7577 || !gfc_add_entry (&entry
->attr
, result
->name
, NULL
)
7578 || !gfc_add_function (&entry
->attr
, result
->name
, NULL
))
7580 entry
->result
= result
;
7584 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
7585 || !gfc_add_function (&entry
->attr
, entry
->name
, NULL
))
7587 entry
->result
= entry
;
7591 if (!gfc_current_ns
->parent
7592 && !add_global_entry (name
, entry
->binding_label
, false,
7597 if (gfc_match_eos () != MATCH_YES
)
7599 gfc_syntax_error (ST_ENTRY
);
7603 /* F2018:C1546 An elemental procedure shall not have the BIND attribute. */
7604 if (proc
->attr
.elemental
&& entry
->attr
.is_bind_c
)
7606 gfc_error ("ENTRY statement at %L with BIND(C) prohibited in an "
7607 "elemental procedure", &entry
->declared_at
);
7611 entry
->attr
.recursive
= proc
->attr
.recursive
;
7612 entry
->attr
.elemental
= proc
->attr
.elemental
;
7613 entry
->attr
.pure
= proc
->attr
.pure
;
7615 el
= gfc_get_entry_list ();
7617 el
->next
= gfc_current_ns
->entries
;
7618 gfc_current_ns
->entries
= el
;
7620 el
->id
= el
->next
->id
+ 1;
7624 new_st
.op
= EXEC_ENTRY
;
7625 new_st
.ext
.entry
= el
;
7631 /* Match a subroutine statement, including optional prefixes. */
7634 gfc_match_subroutine (void)
7636 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7641 bool allow_binding_name
;
7644 if (gfc_current_state () != COMP_NONE
7645 && gfc_current_state () != COMP_INTERFACE
7646 && gfc_current_state () != COMP_CONTAINS
)
7649 m
= gfc_match_prefix (NULL
);
7653 m
= gfc_match ("subroutine% %n", name
);
7657 if (get_proc_name (name
, &sym
, false))
7660 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
7661 the symbol existed before. */
7662 sym
->declared_at
= gfc_current_locus
;
7664 if (current_attr
.module_procedure
)
7665 sym
->attr
.module_procedure
= 1;
7667 if (add_hidden_procptr_result (sym
))
7670 gfc_new_block
= sym
;
7672 /* Check what next non-whitespace character is so we can tell if there
7673 is the required parens if we have a BIND(C). */
7674 gfc_gobble_whitespace ();
7675 peek_char
= gfc_peek_ascii_char ();
7677 if (!gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
))
7680 if (gfc_match_formal_arglist (sym
, 0, 1) != MATCH_YES
)
7683 /* Make sure that it isn't already declared as BIND(C). If it is, it
7684 must have been marked BIND(C) with a BIND(C) attribute and that is
7685 not allowed for procedures. */
7686 if (sym
->attr
.is_bind_c
== 1)
7688 sym
->attr
.is_bind_c
= 0;
7689 if (sym
->old_symbol
!= NULL
)
7690 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7691 "variables or common blocks",
7692 &(sym
->old_symbol
->declared_at
));
7694 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7695 "variables or common blocks", &gfc_current_locus
);
7698 /* C binding names are not allowed for internal procedures. */
7699 if (gfc_current_state () == COMP_CONTAINS
7700 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
7701 allow_binding_name
= false;
7703 allow_binding_name
= true;
7705 /* Here, we are just checking if it has the bind(c) attribute, and if
7706 so, then we need to make sure it's all correct. If it doesn't,
7707 we still need to continue matching the rest of the subroutine line. */
7708 gfc_gobble_whitespace ();
7709 loc
= gfc_current_locus
;
7710 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
7711 if (is_bind_c
== MATCH_ERROR
)
7713 /* There was an attempt at the bind(c), but it was wrong. An
7714 error message should have been printed w/in the gfc_match_bind_c
7715 so here we'll just return the MATCH_ERROR. */
7719 if (is_bind_c
== MATCH_YES
)
7721 gfc_formal_arglist
*arg
;
7723 /* The following is allowed in the Fortran 2008 draft. */
7724 if (gfc_current_state () == COMP_CONTAINS
7725 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
7726 && !gfc_notify_std (GFC_STD_F2008
, "BIND(C) attribute "
7727 "at %L may not be specified for an internal "
7728 "procedure", &gfc_current_locus
))
7731 if (peek_char
!= '(')
7733 gfc_error ("Missing required parentheses before BIND(C) at %C");
7737 /* Scan the dummy arguments for an alternate return. */
7738 for (arg
= sym
->formal
; arg
; arg
= arg
->next
)
7741 gfc_error ("Alternate return dummy argument cannot appear in a "
7742 "SUBROUTINE with the BIND(C) attribute at %L", &loc
);
7746 if (!gfc_add_is_bind_c (&(sym
->attr
), sym
->name
, &(sym
->declared_at
), 1))
7750 if (gfc_match_eos () != MATCH_YES
)
7752 gfc_syntax_error (ST_SUBROUTINE
);
7756 if (!copy_prefix (&sym
->attr
, &sym
->declared_at
))
7758 if(!sym
->attr
.module_procedure
)
7764 /* Warn if it has the same name as an intrinsic. */
7765 do_warn_intrinsic_shadow (sym
, false);
7771 /* Check that the NAME identifier in a BIND attribute or statement
7772 is conform to C identifier rules. */
7775 check_bind_name_identifier (char **name
)
7777 char *n
= *name
, *p
;
7779 /* Remove leading spaces. */
7783 /* On an empty string, free memory and set name to NULL. */
7791 /* Remove trailing spaces. */
7792 p
= n
+ strlen(n
) - 1;
7796 /* Insert the identifier into the symbol table. */
7801 /* Now check that identifier is valid under C rules. */
7804 gfc_error ("Invalid C identifier in NAME= specifier at %C");
7809 if (!(ISALNUM (*p
) || *p
== '_' || *p
== '$'))
7811 gfc_error ("Invalid C identifier in NAME= specifier at %C");
7819 /* Match a BIND(C) specifier, with the optional 'name=' specifier if
7820 given, and set the binding label in either the given symbol (if not
7821 NULL), or in the current_ts. The symbol may be NULL because we may
7822 encounter the BIND(C) before the declaration itself. Return
7823 MATCH_NO if what we're looking at isn't a BIND(C) specifier,
7824 MATCH_ERROR if it is a BIND(C) clause but an error was encountered,
7825 or MATCH_YES if the specifier was correct and the binding label and
7826 bind(c) fields were set correctly for the given symbol or the
7827 current_ts. If allow_binding_name is false, no binding name may be
7831 gfc_match_bind_c (gfc_symbol
*sym
, bool allow_binding_name
)
7833 char *binding_label
= NULL
;
7836 /* Initialize the flag that specifies whether we encountered a NAME=
7837 specifier or not. */
7838 has_name_equals
= 0;
7840 /* This much we have to be able to match, in this order, if
7841 there is a bind(c) label. */
7842 if (gfc_match (" bind ( c ") != MATCH_YES
)
7845 /* Now see if there is a binding label, or if we've reached the
7846 end of the bind(c) attribute without one. */
7847 if (gfc_match_char (',') == MATCH_YES
)
7849 if (gfc_match (" name = ") != MATCH_YES
)
7851 gfc_error ("Syntax error in NAME= specifier for binding label "
7853 /* should give an error message here */
7857 has_name_equals
= 1;
7859 if (gfc_match_init_expr (&e
) != MATCH_YES
)
7865 if (!gfc_simplify_expr(e
, 0))
7867 gfc_error ("NAME= specifier at %C should be a constant expression");
7872 if (e
->expr_type
!= EXPR_CONSTANT
|| e
->ts
.type
!= BT_CHARACTER
7873 || e
->ts
.kind
!= gfc_default_character_kind
|| e
->rank
!= 0)
7875 gfc_error ("NAME= specifier at %C should be a scalar of "
7876 "default character kind");
7881 // Get a C string from the Fortran string constant
7882 binding_label
= gfc_widechar_to_char (e
->value
.character
.string
,
7883 e
->value
.character
.length
);
7886 // Check that it is valid (old gfc_match_name_C)
7887 if (check_bind_name_identifier (&binding_label
) != MATCH_YES
)
7891 /* Get the required right paren. */
7892 if (gfc_match_char (')') != MATCH_YES
)
7894 gfc_error ("Missing closing paren for binding label at %C");
7898 if (has_name_equals
&& !allow_binding_name
)
7900 gfc_error ("No binding name is allowed in BIND(C) at %C");
7904 if (has_name_equals
&& sym
!= NULL
&& sym
->attr
.dummy
)
7906 gfc_error ("For dummy procedure %s, no binding name is "
7907 "allowed in BIND(C) at %C", sym
->name
);
7912 /* Save the binding label to the symbol. If sym is null, we're
7913 probably matching the typespec attributes of a declaration and
7914 haven't gotten the name yet, and therefore, no symbol yet. */
7918 sym
->binding_label
= binding_label
;
7920 curr_binding_label
= binding_label
;
7922 else if (allow_binding_name
)
7924 /* No binding label, but if symbol isn't null, we
7925 can set the label for it here.
7926 If name="" or allow_binding_name is false, no C binding name is
7928 if (sym
!= NULL
&& sym
->name
!= NULL
&& has_name_equals
== 0)
7929 sym
->binding_label
= IDENTIFIER_POINTER (get_identifier (sym
->name
));
7932 if (has_name_equals
&& gfc_current_state () == COMP_INTERFACE
7933 && current_interface
.type
== INTERFACE_ABSTRACT
)
7935 gfc_error ("NAME not allowed on BIND(C) for ABSTRACT INTERFACE at %C");
7943 /* Return nonzero if we're currently compiling a contained procedure. */
7946 contained_procedure (void)
7948 gfc_state_data
*s
= gfc_state_stack
;
7950 if ((s
->state
== COMP_SUBROUTINE
|| s
->state
== COMP_FUNCTION
)
7951 && s
->previous
!= NULL
&& s
->previous
->state
== COMP_CONTAINS
)
7957 /* Set the kind of each enumerator. The kind is selected such that it is
7958 interoperable with the corresponding C enumeration type, making
7959 sure that -fshort-enums is honored. */
7964 enumerator_history
*current_history
= NULL
;
7968 if (max_enum
== NULL
|| enum_history
== NULL
)
7971 if (!flag_short_enums
)
7977 kind
= gfc_integer_kinds
[i
++].kind
;
7979 while (kind
< gfc_c_int_kind
7980 && gfc_check_integer_range (max_enum
->initializer
->value
.integer
,
7983 current_history
= enum_history
;
7984 while (current_history
!= NULL
)
7986 current_history
->sym
->ts
.kind
= kind
;
7987 current_history
= current_history
->next
;
7992 /* Match any of the various end-block statements. Returns the type of
7993 END to the caller. The END INTERFACE, END IF, END DO, END SELECT
7994 and END BLOCK statements cannot be replaced by a single END statement. */
7997 gfc_match_end (gfc_statement
*st
)
7999 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8000 gfc_compile_state state
;
8002 const char *block_name
;
8006 gfc_namespace
*parent_ns
, *ns
, *prev_ns
;
8007 gfc_namespace
**nsp
;
8008 bool abreviated_modproc_decl
= false;
8009 bool got_matching_end
= false;
8011 old_loc
= gfc_current_locus
;
8012 if (gfc_match ("end") != MATCH_YES
)
8015 state
= gfc_current_state ();
8016 block_name
= gfc_current_block () == NULL
8017 ? NULL
: gfc_current_block ()->name
;
8021 case COMP_ASSOCIATE
:
8023 if (gfc_str_startswith (block_name
, "block@"))
8028 case COMP_DERIVED_CONTAINS
:
8029 state
= gfc_state_stack
->previous
->state
;
8030 block_name
= gfc_state_stack
->previous
->sym
== NULL
8031 ? NULL
: gfc_state_stack
->previous
->sym
->name
;
8032 abreviated_modproc_decl
= gfc_state_stack
->previous
->sym
8033 && gfc_state_stack
->previous
->sym
->abr_modproc_decl
;
8040 if (!abreviated_modproc_decl
)
8041 abreviated_modproc_decl
= gfc_current_block ()
8042 && gfc_current_block ()->abr_modproc_decl
;
8048 *st
= ST_END_PROGRAM
;
8049 target
= " program";
8053 case COMP_SUBROUTINE
:
8054 *st
= ST_END_SUBROUTINE
;
8055 if (!abreviated_modproc_decl
)
8056 target
= " subroutine";
8058 target
= " procedure";
8059 eos_ok
= !contained_procedure ();
8063 *st
= ST_END_FUNCTION
;
8064 if (!abreviated_modproc_decl
)
8065 target
= " function";
8067 target
= " procedure";
8068 eos_ok
= !contained_procedure ();
8071 case COMP_BLOCK_DATA
:
8072 *st
= ST_END_BLOCK_DATA
;
8073 target
= " block data";
8078 *st
= ST_END_MODULE
;
8083 case COMP_SUBMODULE
:
8084 *st
= ST_END_SUBMODULE
;
8085 target
= " submodule";
8089 case COMP_INTERFACE
:
8090 *st
= ST_END_INTERFACE
;
8091 target
= " interface";
8107 case COMP_STRUCTURE
:
8108 *st
= ST_END_STRUCTURE
;
8109 target
= " structure";
8114 case COMP_DERIVED_CONTAINS
:
8120 case COMP_ASSOCIATE
:
8121 *st
= ST_END_ASSOCIATE
;
8122 target
= " associate";
8139 case COMP_DO_CONCURRENT
:
8146 *st
= ST_END_CRITICAL
;
8147 target
= " critical";
8152 case COMP_SELECT_TYPE
:
8153 *st
= ST_END_SELECT
;
8159 *st
= ST_END_FORALL
;
8174 last_initializer
= NULL
;
8176 gfc_free_enum_history ();
8180 gfc_error ("Unexpected END statement at %C");
8184 old_loc
= gfc_current_locus
;
8185 if (gfc_match_eos () == MATCH_YES
)
8187 if (!eos_ok
&& (*st
== ST_END_SUBROUTINE
|| *st
== ST_END_FUNCTION
))
8189 if (!gfc_notify_std (GFC_STD_F2008
, "END statement "
8190 "instead of %s statement at %L",
8191 abreviated_modproc_decl
? "END PROCEDURE"
8192 : gfc_ascii_statement(*st
), &old_loc
))
8197 /* We would have required END [something]. */
8198 gfc_error ("%s statement expected at %L",
8199 gfc_ascii_statement (*st
), &old_loc
);
8206 /* Verify that we've got the sort of end-block that we're expecting. */
8207 if (gfc_match (target
) != MATCH_YES
)
8209 gfc_error ("Expecting %s statement at %L", abreviated_modproc_decl
8210 ? "END PROCEDURE" : gfc_ascii_statement(*st
), &old_loc
);
8214 got_matching_end
= true;
8216 old_loc
= gfc_current_locus
;
8217 /* If we're at the end, make sure a block name wasn't required. */
8218 if (gfc_match_eos () == MATCH_YES
)
8221 if (*st
!= ST_ENDDO
&& *st
!= ST_ENDIF
&& *st
!= ST_END_SELECT
8222 && *st
!= ST_END_FORALL
&& *st
!= ST_END_WHERE
&& *st
!= ST_END_BLOCK
8223 && *st
!= ST_END_ASSOCIATE
&& *st
!= ST_END_CRITICAL
)
8229 gfc_error ("Expected block name of %qs in %s statement at %L",
8230 block_name
, gfc_ascii_statement (*st
), &old_loc
);
8235 /* END INTERFACE has a special handler for its several possible endings. */
8236 if (*st
== ST_END_INTERFACE
)
8237 return gfc_match_end_interface ();
8239 /* We haven't hit the end of statement, so what is left must be an
8241 m
= gfc_match_space ();
8243 m
= gfc_match_name (name
);
8246 gfc_error ("Expected terminating name at %C");
8250 if (block_name
== NULL
)
8253 /* We have to pick out the declared submodule name from the composite
8254 required by F2008:11.2.3 para 2, which ends in the declared name. */
8255 if (state
== COMP_SUBMODULE
)
8256 block_name
= strchr (block_name
, '.') + 1;
8258 if (strcmp (name
, block_name
) != 0 && strcmp (block_name
, "ppr@") != 0)
8260 gfc_error ("Expected label %qs for %s statement at %C", block_name
,
8261 gfc_ascii_statement (*st
));
8264 /* Procedure pointer as function result. */
8265 else if (strcmp (block_name
, "ppr@") == 0
8266 && strcmp (name
, gfc_current_block ()->ns
->proc_name
->name
) != 0)
8268 gfc_error ("Expected label %qs for %s statement at %C",
8269 gfc_current_block ()->ns
->proc_name
->name
,
8270 gfc_ascii_statement (*st
));
8274 if (gfc_match_eos () == MATCH_YES
)
8278 gfc_syntax_error (*st
);
8281 gfc_current_locus
= old_loc
;
8283 /* If we are missing an END BLOCK, we created a half-ready namespace.
8284 Remove it from the parent namespace's sibling list. */
8286 while (state
== COMP_BLOCK
&& !got_matching_end
)
8288 parent_ns
= gfc_current_ns
->parent
;
8290 nsp
= &(gfc_state_stack
->previous
->tail
->ext
.block
.ns
);
8296 if (ns
== gfc_current_ns
)
8298 if (prev_ns
== NULL
)
8301 prev_ns
->sibling
= ns
->sibling
;
8307 gfc_free_namespace (gfc_current_ns
);
8308 gfc_current_ns
= parent_ns
;
8309 gfc_state_stack
= gfc_state_stack
->previous
;
8310 state
= gfc_current_state ();
8318 /***************** Attribute declaration statements ****************/
8320 /* Set the attribute of a single variable. */
8325 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8328 /* Workaround -Wmaybe-uninitialized false positive during
8329 profiledbootstrap by initializing them. */
8330 gfc_symbol
*sym
= NULL
;
8336 m
= gfc_match_name (name
);
8340 if (find_special (name
, &sym
, false))
8343 if (!check_function_name (name
))
8349 var_locus
= gfc_current_locus
;
8351 /* Deal with possible array specification for certain attributes. */
8352 if (current_attr
.dimension
8353 || current_attr
.codimension
8354 || current_attr
.allocatable
8355 || current_attr
.pointer
8356 || current_attr
.target
)
8358 m
= gfc_match_array_spec (&as
, !current_attr
.codimension
,
8359 !current_attr
.dimension
8360 && !current_attr
.pointer
8361 && !current_attr
.target
);
8362 if (m
== MATCH_ERROR
)
8365 if (current_attr
.dimension
&& m
== MATCH_NO
)
8367 gfc_error ("Missing array specification at %L in DIMENSION "
8368 "statement", &var_locus
);
8373 if (current_attr
.dimension
&& sym
->value
)
8375 gfc_error ("Dimensions specified for %s at %L after its "
8376 "initialization", sym
->name
, &var_locus
);
8381 if (current_attr
.codimension
&& m
== MATCH_NO
)
8383 gfc_error ("Missing array specification at %L in CODIMENSION "
8384 "statement", &var_locus
);
8389 if ((current_attr
.allocatable
|| current_attr
.pointer
)
8390 && (m
== MATCH_YES
) && (as
->type
!= AS_DEFERRED
))
8392 gfc_error ("Array specification must be deferred at %L", &var_locus
);
8398 /* Update symbol table. DIMENSION attribute is set in
8399 gfc_set_array_spec(). For CLASS variables, this must be applied
8400 to the first component, or '_data' field. */
8401 if (sym
->ts
.type
== BT_CLASS
&& sym
->ts
.u
.derived
->attr
.is_class
)
8403 /* gfc_set_array_spec sets sym->attr not CLASS_DATA(sym)->attr. Check
8404 for duplicate attribute here. */
8405 if (CLASS_DATA(sym
)->attr
.dimension
== 1 && as
)
8407 gfc_error ("Duplicate DIMENSION attribute at %C");
8412 if (!gfc_copy_attr (&CLASS_DATA(sym
)->attr
, ¤t_attr
, &var_locus
))
8420 if (current_attr
.dimension
== 0 && current_attr
.codimension
== 0
8421 && !gfc_copy_attr (&sym
->attr
, ¤t_attr
, &var_locus
))
8428 if (sym
->ts
.type
== BT_CLASS
8429 && !gfc_build_class_symbol (&sym
->ts
, &sym
->attr
, &sym
->as
))
8435 if (!gfc_set_array_spec (sym
, as
, &var_locus
))
8441 if (sym
->attr
.cray_pointee
&& sym
->as
!= NULL
)
8443 /* Fix the array spec. */
8444 m
= gfc_mod_pointee_as (sym
->as
);
8445 if (m
== MATCH_ERROR
)
8449 if (!gfc_add_attribute (&sym
->attr
, &var_locus
))
8455 if ((current_attr
.external
|| current_attr
.intrinsic
)
8456 && sym
->attr
.flavor
!= FL_PROCEDURE
8457 && !gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, NULL
))
8463 add_hidden_procptr_result (sym
);
8468 gfc_free_array_spec (as
);
8473 /* Generic attribute declaration subroutine. Used for attributes that
8474 just have a list of names. */
8481 /* Gobble the optional double colon, by simply ignoring the result
8491 if (gfc_match_eos () == MATCH_YES
)
8497 if (gfc_match_char (',') != MATCH_YES
)
8499 gfc_error ("Unexpected character in variable list at %C");
8509 /* This routine matches Cray Pointer declarations of the form:
8510 pointer ( <pointer>, <pointee> )
8512 pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...
8513 The pointer, if already declared, should be an integer. Otherwise, we
8514 set it as BT_INTEGER with kind gfc_index_integer_kind. The pointee may
8515 be either a scalar, or an array declaration. No space is allocated for
8516 the pointee. For the statement
8517 pointer (ipt, ar(10))
8518 any subsequent uses of ar will be translated (in C-notation) as
8519 ar(i) => ((<type> *) ipt)(i)
8520 After gimplification, pointee variable will disappear in the code. */
8523 cray_pointer_decl (void)
8526 gfc_array_spec
*as
= NULL
;
8527 gfc_symbol
*cptr
; /* Pointer symbol. */
8528 gfc_symbol
*cpte
; /* Pointee symbol. */
8534 if (gfc_match_char ('(') != MATCH_YES
)
8536 gfc_error ("Expected %<(%> at %C");
8540 /* Match pointer. */
8541 var_locus
= gfc_current_locus
;
8542 gfc_clear_attr (¤t_attr
);
8543 gfc_add_cray_pointer (¤t_attr
, &var_locus
);
8544 current_ts
.type
= BT_INTEGER
;
8545 current_ts
.kind
= gfc_index_integer_kind
;
8547 m
= gfc_match_symbol (&cptr
, 0);
8550 gfc_error ("Expected variable name at %C");
8554 if (!gfc_add_cray_pointer (&cptr
->attr
, &var_locus
))
8557 gfc_set_sym_referenced (cptr
);
8559 if (cptr
->ts
.type
== BT_UNKNOWN
) /* Override the type, if necessary. */
8561 cptr
->ts
.type
= BT_INTEGER
;
8562 cptr
->ts
.kind
= gfc_index_integer_kind
;
8564 else if (cptr
->ts
.type
!= BT_INTEGER
)
8566 gfc_error ("Cray pointer at %C must be an integer");
8569 else if (cptr
->ts
.kind
< gfc_index_integer_kind
)
8570 gfc_warning (0, "Cray pointer at %C has %d bytes of precision;"
8571 " memory addresses require %d bytes",
8572 cptr
->ts
.kind
, gfc_index_integer_kind
);
8574 if (gfc_match_char (',') != MATCH_YES
)
8576 gfc_error ("Expected \",\" at %C");
8580 /* Match Pointee. */
8581 var_locus
= gfc_current_locus
;
8582 gfc_clear_attr (¤t_attr
);
8583 gfc_add_cray_pointee (¤t_attr
, &var_locus
);
8584 current_ts
.type
= BT_UNKNOWN
;
8585 current_ts
.kind
= 0;
8587 m
= gfc_match_symbol (&cpte
, 0);
8590 gfc_error ("Expected variable name at %C");
8594 /* Check for an optional array spec. */
8595 m
= gfc_match_array_spec (&as
, true, false);
8596 if (m
== MATCH_ERROR
)
8598 gfc_free_array_spec (as
);
8601 else if (m
== MATCH_NO
)
8603 gfc_free_array_spec (as
);
8607 if (!gfc_add_cray_pointee (&cpte
->attr
, &var_locus
))
8610 gfc_set_sym_referenced (cpte
);
8612 if (cpte
->as
== NULL
)
8614 if (!gfc_set_array_spec (cpte
, as
, &var_locus
))
8615 gfc_internal_error ("Cannot set Cray pointee array spec.");
8617 else if (as
!= NULL
)
8619 gfc_error ("Duplicate array spec for Cray pointee at %C");
8620 gfc_free_array_spec (as
);
8626 if (cpte
->as
!= NULL
)
8628 /* Fix array spec. */
8629 m
= gfc_mod_pointee_as (cpte
->as
);
8630 if (m
== MATCH_ERROR
)
8634 /* Point the Pointee at the Pointer. */
8635 cpte
->cp_pointer
= cptr
;
8637 if (gfc_match_char (')') != MATCH_YES
)
8639 gfc_error ("Expected \")\" at %C");
8642 m
= gfc_match_char (',');
8644 done
= true; /* Stop searching for more declarations. */
8648 if (m
== MATCH_ERROR
/* Failed when trying to find ',' above. */
8649 || gfc_match_eos () != MATCH_YES
)
8651 gfc_error ("Expected %<,%> or end of statement at %C");
8659 gfc_match_external (void)
8662 gfc_clear_attr (¤t_attr
);
8663 current_attr
.external
= 1;
8665 return attr_decl ();
8670 gfc_match_intent (void)
8674 /* This is not allowed within a BLOCK construct! */
8675 if (gfc_current_state () == COMP_BLOCK
)
8677 gfc_error ("INTENT is not allowed inside of BLOCK at %C");
8681 intent
= match_intent_spec ();
8682 if (intent
== INTENT_UNKNOWN
)
8685 gfc_clear_attr (¤t_attr
);
8686 current_attr
.intent
= intent
;
8688 return attr_decl ();
8693 gfc_match_intrinsic (void)
8696 gfc_clear_attr (¤t_attr
);
8697 current_attr
.intrinsic
= 1;
8699 return attr_decl ();
8704 gfc_match_optional (void)
8706 /* This is not allowed within a BLOCK construct! */
8707 if (gfc_current_state () == COMP_BLOCK
)
8709 gfc_error ("OPTIONAL is not allowed inside of BLOCK at %C");
8713 gfc_clear_attr (¤t_attr
);
8714 current_attr
.optional
= 1;
8716 return attr_decl ();
8721 gfc_match_pointer (void)
8723 gfc_gobble_whitespace ();
8724 if (gfc_peek_ascii_char () == '(')
8726 if (!flag_cray_pointer
)
8728 gfc_error ("Cray pointer declaration at %C requires "
8729 "%<-fcray-pointer%> flag");
8732 return cray_pointer_decl ();
8736 gfc_clear_attr (¤t_attr
);
8737 current_attr
.pointer
= 1;
8739 return attr_decl ();
8745 gfc_match_allocatable (void)
8747 gfc_clear_attr (¤t_attr
);
8748 current_attr
.allocatable
= 1;
8750 return attr_decl ();
8755 gfc_match_codimension (void)
8757 gfc_clear_attr (¤t_attr
);
8758 current_attr
.codimension
= 1;
8760 return attr_decl ();
8765 gfc_match_contiguous (void)
8767 if (!gfc_notify_std (GFC_STD_F2008
, "CONTIGUOUS statement at %C"))
8770 gfc_clear_attr (¤t_attr
);
8771 current_attr
.contiguous
= 1;
8773 return attr_decl ();
8778 gfc_match_dimension (void)
8780 gfc_clear_attr (¤t_attr
);
8781 current_attr
.dimension
= 1;
8783 return attr_decl ();
8788 gfc_match_target (void)
8790 gfc_clear_attr (¤t_attr
);
8791 current_attr
.target
= 1;
8793 return attr_decl ();
8797 /* Match the list of entities being specified in a PUBLIC or PRIVATE
8801 access_attr_decl (gfc_statement st
)
8803 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8804 interface_type type
;
8806 gfc_symbol
*sym
, *dt_sym
;
8807 gfc_intrinsic_op op
;
8809 gfc_access access
= (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
8811 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
8816 m
= gfc_match_generic_spec (&type
, name
, &op
);
8819 if (m
== MATCH_ERROR
)
8824 case INTERFACE_NAMELESS
:
8825 case INTERFACE_ABSTRACT
:
8828 case INTERFACE_GENERIC
:
8829 case INTERFACE_DTIO
:
8831 if (gfc_get_symbol (name
, NULL
, &sym
))
8834 if (type
== INTERFACE_DTIO
8835 && gfc_current_ns
->proc_name
8836 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
8837 && sym
->attr
.flavor
== FL_UNKNOWN
)
8838 sym
->attr
.flavor
= FL_PROCEDURE
;
8840 if (!gfc_add_access (&sym
->attr
, access
, sym
->name
, NULL
))
8843 if (sym
->attr
.generic
&& (dt_sym
= gfc_find_dt_in_generic (sym
))
8844 && !gfc_add_access (&dt_sym
->attr
, access
, sym
->name
, NULL
))
8849 case INTERFACE_INTRINSIC_OP
:
8850 if (gfc_current_ns
->operator_access
[op
] == ACCESS_UNKNOWN
)
8852 gfc_intrinsic_op other_op
;
8854 gfc_current_ns
->operator_access
[op
] = access
;
8856 /* Handle the case if there is another op with the same
8857 function, for INTRINSIC_EQ vs. INTRINSIC_EQ_OS and so on. */
8858 other_op
= gfc_equivalent_op (op
);
8860 if (other_op
!= INTRINSIC_NONE
)
8861 gfc_current_ns
->operator_access
[other_op
] = access
;
8865 gfc_error ("Access specification of the %s operator at %C has "
8866 "already been specified", gfc_op2string (op
));
8872 case INTERFACE_USER_OP
:
8873 uop
= gfc_get_uop (name
);
8875 if (uop
->access
== ACCESS_UNKNOWN
)
8877 uop
->access
= access
;
8881 gfc_error ("Access specification of the .%s. operator at %C "
8882 "has already been specified", sym
->name
);
8889 if (gfc_match_char (',') == MATCH_NO
)
8893 if (gfc_match_eos () != MATCH_YES
)
8898 gfc_syntax_error (st
);
8906 gfc_match_protected (void)
8912 /* PROTECTED has already been seen, but must be followed by whitespace
8914 c
= gfc_peek_ascii_char ();
8915 if (!gfc_is_whitespace (c
) && c
!= ':')
8918 if (!gfc_current_ns
->proc_name
8919 || gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
8921 gfc_error ("PROTECTED at %C only allowed in specification "
8922 "part of a module");
8929 if (!gfc_notify_std (GFC_STD_F2003
, "PROTECTED statement at %C"))
8932 /* PROTECTED has an entity-list. */
8933 if (gfc_match_eos () == MATCH_YES
)
8938 m
= gfc_match_symbol (&sym
, 0);
8942 if (!gfc_add_protected (&sym
->attr
, sym
->name
, &gfc_current_locus
))
8954 if (gfc_match_eos () == MATCH_YES
)
8956 if (gfc_match_char (',') != MATCH_YES
)
8963 gfc_error ("Syntax error in PROTECTED statement at %C");
8968 /* The PRIVATE statement is a bit weird in that it can be an attribute
8969 declaration, but also works as a standalone statement inside of a
8970 type declaration or a module. */
8973 gfc_match_private (gfc_statement
*st
)
8975 gfc_state_data
*prev
;
8978 if (gfc_match ("private") != MATCH_YES
)
8981 /* Try matching PRIVATE without an access-list. */
8982 if (gfc_match_eos () == MATCH_YES
)
8984 prev
= gfc_state_stack
->previous
;
8985 if (gfc_current_state () != COMP_MODULE
8986 && !(gfc_current_state () == COMP_DERIVED
8987 && prev
&& prev
->state
== COMP_MODULE
)
8988 && !(gfc_current_state () == COMP_DERIVED_CONTAINS
8989 && prev
->previous
&& prev
->previous
->state
== COMP_MODULE
))
8991 gfc_error ("PRIVATE statement at %C is only allowed in the "
8992 "specification part of a module");
9000 /* At this point, PRIVATE must be followed by whitespace or ::. */
9001 c
= gfc_peek_ascii_char ();
9002 if (!gfc_is_whitespace (c
) && c
!= ':')
9005 prev
= gfc_state_stack
->previous
;
9006 if (gfc_current_state () != COMP_MODULE
9007 && !(gfc_current_state () == COMP_DERIVED
9008 && prev
&& prev
->state
== COMP_MODULE
)
9009 && !(gfc_current_state () == COMP_DERIVED_CONTAINS
9010 && prev
->previous
&& prev
->previous
->state
== COMP_MODULE
))
9012 gfc_error ("PRIVATE statement at %C is only allowed in the "
9013 "specification part of a module");
9018 return access_attr_decl (ST_PRIVATE
);
9023 gfc_match_public (gfc_statement
*st
)
9027 if (gfc_match ("public") != MATCH_YES
)
9030 /* Try matching PUBLIC without an access-list. */
9031 if (gfc_match_eos () == MATCH_YES
)
9033 if (gfc_current_state () != COMP_MODULE
)
9035 gfc_error ("PUBLIC statement at %C is only allowed in the "
9036 "specification part of a module");
9044 /* At this point, PUBLIC must be followed by whitespace or ::. */
9045 c
= gfc_peek_ascii_char ();
9046 if (!gfc_is_whitespace (c
) && c
!= ':')
9049 if (gfc_current_state () != COMP_MODULE
)
9051 gfc_error ("PUBLIC statement at %C is only allowed in the "
9052 "specification part of a module");
9057 return access_attr_decl (ST_PUBLIC
);
9061 /* Workhorse for gfc_match_parameter. */
9071 m
= gfc_match_symbol (&sym
, 0);
9073 gfc_error ("Expected variable name at %C in PARAMETER statement");
9078 if (gfc_match_char ('=') == MATCH_NO
)
9080 gfc_error ("Expected = sign in PARAMETER statement at %C");
9084 m
= gfc_match_init_expr (&init
);
9086 gfc_error ("Expected expression at %C in PARAMETER statement");
9090 if (sym
->ts
.type
== BT_UNKNOWN
9091 && !gfc_set_default_type (sym
, 1, NULL
))
9097 if (!gfc_check_assign_symbol (sym
, NULL
, init
)
9098 || !gfc_add_flavor (&sym
->attr
, FL_PARAMETER
, sym
->name
, NULL
))
9106 gfc_error ("Initializing already initialized variable at %C");
9111 t
= add_init_expr_to_sym (sym
->name
, &init
, &gfc_current_locus
);
9112 return (t
) ? MATCH_YES
: MATCH_ERROR
;
9115 gfc_free_expr (init
);
9120 /* Match a parameter statement, with the weird syntax that these have. */
9123 gfc_match_parameter (void)
9125 const char *term
= " )%t";
9128 if (gfc_match_char ('(') == MATCH_NO
)
9130 /* With legacy PARAMETER statements, don't expect a terminating ')'. */
9131 if (!gfc_notify_std (GFC_STD_LEGACY
, "PARAMETER without '()' at %C"))
9142 if (gfc_match (term
) == MATCH_YES
)
9145 if (gfc_match_char (',') != MATCH_YES
)
9147 gfc_error ("Unexpected characters in PARAMETER statement at %C");
9158 gfc_match_automatic (void)
9162 bool seen_symbol
= false;
9164 if (!flag_dec_static
)
9166 gfc_error ("%s at %C is a DEC extension, enable with "
9177 m
= gfc_match_symbol (&sym
, 0);
9187 if (!gfc_add_automatic (&sym
->attr
, sym
->name
, &gfc_current_locus
))
9193 if (gfc_match_eos () == MATCH_YES
)
9195 if (gfc_match_char (',') != MATCH_YES
)
9201 gfc_error ("Expected entity-list in AUTOMATIC statement at %C");
9208 gfc_error ("Syntax error in AUTOMATIC statement at %C");
9214 gfc_match_static (void)
9218 bool seen_symbol
= false;
9220 if (!flag_dec_static
)
9222 gfc_error ("%s at %C is a DEC extension, enable with "
9232 m
= gfc_match_symbol (&sym
, 0);
9242 if (!gfc_add_save (&sym
->attr
, SAVE_EXPLICIT
, sym
->name
,
9243 &gfc_current_locus
))
9249 if (gfc_match_eos () == MATCH_YES
)
9251 if (gfc_match_char (',') != MATCH_YES
)
9257 gfc_error ("Expected entity-list in STATIC statement at %C");
9264 gfc_error ("Syntax error in STATIC statement at %C");
9269 /* Save statements have a special syntax. */
9272 gfc_match_save (void)
9274 char n
[GFC_MAX_SYMBOL_LEN
+1];
9279 if (gfc_match_eos () == MATCH_YES
)
9281 if (gfc_current_ns
->seen_save
)
9283 if (!gfc_notify_std (GFC_STD_LEGACY
, "Blanket SAVE statement at %C "
9284 "follows previous SAVE statement"))
9288 gfc_current_ns
->save_all
= gfc_current_ns
->seen_save
= 1;
9292 if (gfc_current_ns
->save_all
)
9294 if (!gfc_notify_std (GFC_STD_LEGACY
, "SAVE statement at %C follows "
9295 "blanket SAVE statement"))
9303 m
= gfc_match_symbol (&sym
, 0);
9307 if (!gfc_add_save (&sym
->attr
, SAVE_EXPLICIT
, sym
->name
,
9308 &gfc_current_locus
))
9319 m
= gfc_match (" / %n /", &n
);
9320 if (m
== MATCH_ERROR
)
9325 c
= gfc_get_common (n
, 0);
9328 gfc_current_ns
->seen_save
= 1;
9331 if (gfc_match_eos () == MATCH_YES
)
9333 if (gfc_match_char (',') != MATCH_YES
)
9340 if (gfc_current_ns
->seen_save
)
9342 gfc_error ("Syntax error in SAVE statement at %C");
9351 gfc_match_value (void)
9356 /* This is not allowed within a BLOCK construct! */
9357 if (gfc_current_state () == COMP_BLOCK
)
9359 gfc_error ("VALUE is not allowed inside of BLOCK at %C");
9363 if (!gfc_notify_std (GFC_STD_F2003
, "VALUE statement at %C"))
9366 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
9371 if (gfc_match_eos () == MATCH_YES
)
9376 m
= gfc_match_symbol (&sym
, 0);
9380 if (!gfc_add_value (&sym
->attr
, sym
->name
, &gfc_current_locus
))
9392 if (gfc_match_eos () == MATCH_YES
)
9394 if (gfc_match_char (',') != MATCH_YES
)
9401 gfc_error ("Syntax error in VALUE statement at %C");
9407 gfc_match_volatile (void)
9413 if (!gfc_notify_std (GFC_STD_F2003
, "VOLATILE statement at %C"))
9416 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
9421 if (gfc_match_eos () == MATCH_YES
)
9426 /* VOLATILE is special because it can be added to host-associated
9427 symbols locally. Except for coarrays. */
9428 m
= gfc_match_symbol (&sym
, 1);
9432 name
= XCNEWVAR (char, strlen (sym
->name
) + 1);
9433 strcpy (name
, sym
->name
);
9434 if (!check_function_name (name
))
9436 /* F2008, C560+C561. VOLATILE for host-/use-associated variable or
9437 for variable in a BLOCK which is defined outside of the BLOCK. */
9438 if (sym
->ns
!= gfc_current_ns
&& sym
->attr
.codimension
)
9440 gfc_error ("Specifying VOLATILE for coarray variable %qs at "
9441 "%C, which is use-/host-associated", sym
->name
);
9444 if (!gfc_add_volatile (&sym
->attr
, sym
->name
, &gfc_current_locus
))
9456 if (gfc_match_eos () == MATCH_YES
)
9458 if (gfc_match_char (',') != MATCH_YES
)
9465 gfc_error ("Syntax error in VOLATILE statement at %C");
9471 gfc_match_asynchronous (void)
9477 if (!gfc_notify_std (GFC_STD_F2003
, "ASYNCHRONOUS statement at %C"))
9480 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
9485 if (gfc_match_eos () == MATCH_YES
)
9490 /* ASYNCHRONOUS is special because it can be added to host-associated
9492 m
= gfc_match_symbol (&sym
, 1);
9496 name
= XCNEWVAR (char, strlen (sym
->name
) + 1);
9497 strcpy (name
, sym
->name
);
9498 if (!check_function_name (name
))
9500 if (!gfc_add_asynchronous (&sym
->attr
, sym
->name
, &gfc_current_locus
))
9512 if (gfc_match_eos () == MATCH_YES
)
9514 if (gfc_match_char (',') != MATCH_YES
)
9521 gfc_error ("Syntax error in ASYNCHRONOUS statement at %C");
9526 /* Match a module procedure statement in a submodule. */
9529 gfc_match_submod_proc (void)
9531 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9532 gfc_symbol
*sym
, *fsym
;
9534 gfc_formal_arglist
*formal
, *head
, *tail
;
9536 if (gfc_current_state () != COMP_CONTAINS
9537 || !(gfc_state_stack
->previous
9538 && (gfc_state_stack
->previous
->state
== COMP_SUBMODULE
9539 || gfc_state_stack
->previous
->state
== COMP_MODULE
)))
9542 m
= gfc_match (" module% procedure% %n", name
);
9546 if (!gfc_notify_std (GFC_STD_F2008
, "MODULE PROCEDURE declaration "
9550 if (get_proc_name (name
, &sym
, false))
9553 /* Make sure that the result field is appropriately filled, even though
9554 the result symbol will be replaced later on. */
9555 if (sym
->tlink
&& sym
->tlink
->attr
.function
)
9557 if (sym
->tlink
->result
9558 && sym
->tlink
->result
!= sym
->tlink
)
9559 sym
->result
= sym
->tlink
->result
;
9564 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
9565 the symbol existed before. */
9566 sym
->declared_at
= gfc_current_locus
;
9568 if (!sym
->attr
.module_procedure
)
9571 /* Signal match_end to expect "end procedure". */
9572 sym
->abr_modproc_decl
= 1;
9574 /* Change from IFSRC_IFBODY coming from the interface declaration. */
9575 sym
->attr
.if_source
= IFSRC_DECL
;
9577 gfc_new_block
= sym
;
9579 /* Make a new formal arglist with the symbols in the procedure
9582 for (formal
= sym
->formal
; formal
&& formal
->sym
; formal
= formal
->next
)
9584 if (formal
== sym
->formal
)
9585 head
= tail
= gfc_get_formal_arglist ();
9588 tail
->next
= gfc_get_formal_arglist ();
9592 if (gfc_copy_dummy_sym (&fsym
, formal
->sym
, 0))
9596 gfc_set_sym_referenced (fsym
);
9599 /* The dummy symbols get cleaned up, when the formal_namespace of the
9600 interface declaration is cleared. This allows us to add the
9601 explicit interface as is done for other type of procedure. */
9602 if (!gfc_add_explicit_interface (sym
, IFSRC_DECL
, head
,
9603 &gfc_current_locus
))
9606 if (gfc_match_eos () != MATCH_YES
)
9608 gfc_syntax_error (ST_MODULE_PROC
);
9615 gfc_free_formal_arglist (head
);
9620 /* Match a module procedure statement. Note that we have to modify
9621 symbols in the parent's namespace because the current one was there
9622 to receive symbols that are in an interface's formal argument list. */
9625 gfc_match_modproc (void)
9627 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9631 gfc_namespace
*module_ns
;
9632 gfc_interface
*old_interface_head
, *interface
;
9634 if (gfc_state_stack
->state
!= COMP_INTERFACE
9635 || gfc_state_stack
->previous
== NULL
9636 || current_interface
.type
== INTERFACE_NAMELESS
9637 || current_interface
.type
== INTERFACE_ABSTRACT
)
9639 gfc_error ("MODULE PROCEDURE at %C must be in a generic module "
9644 module_ns
= gfc_current_ns
->parent
;
9645 for (; module_ns
; module_ns
= module_ns
->parent
)
9646 if (module_ns
->proc_name
->attr
.flavor
== FL_MODULE
9647 || module_ns
->proc_name
->attr
.flavor
== FL_PROGRAM
9648 || (module_ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
9649 && !module_ns
->proc_name
->attr
.contained
))
9652 if (module_ns
== NULL
)
9655 /* Store the current state of the interface. We will need it if we
9656 end up with a syntax error and need to recover. */
9657 old_interface_head
= gfc_current_interface_head ();
9659 /* Check if the F2008 optional double colon appears. */
9660 gfc_gobble_whitespace ();
9661 old_locus
= gfc_current_locus
;
9662 if (gfc_match ("::") == MATCH_YES
)
9664 if (!gfc_notify_std (GFC_STD_F2008
, "double colon in "
9665 "MODULE PROCEDURE statement at %L", &old_locus
))
9669 gfc_current_locus
= old_locus
;
9674 old_locus
= gfc_current_locus
;
9676 m
= gfc_match_name (name
);
9682 /* Check for syntax error before starting to add symbols to the
9683 current namespace. */
9684 if (gfc_match_eos () == MATCH_YES
)
9687 if (!last
&& gfc_match_char (',') != MATCH_YES
)
9690 /* Now we're sure the syntax is valid, we process this item
9692 if (gfc_get_symbol (name
, module_ns
, &sym
))
9695 if (sym
->attr
.intrinsic
)
9697 gfc_error ("Intrinsic procedure at %L cannot be a MODULE "
9698 "PROCEDURE", &old_locus
);
9702 if (sym
->attr
.proc
!= PROC_MODULE
9703 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
9706 if (!gfc_add_interface (sym
))
9709 sym
->attr
.mod_proc
= 1;
9710 sym
->declared_at
= old_locus
;
9719 /* Restore the previous state of the interface. */
9720 interface
= gfc_current_interface_head ();
9721 gfc_set_current_interface_head (old_interface_head
);
9723 /* Free the new interfaces. */
9724 while (interface
!= old_interface_head
)
9726 gfc_interface
*i
= interface
->next
;
9731 /* And issue a syntax error. */
9732 gfc_syntax_error (ST_MODULE_PROC
);
9737 /* Check a derived type that is being extended. */
9740 check_extended_derived_type (char *name
)
9742 gfc_symbol
*extended
;
9744 if (gfc_find_symbol (name
, gfc_current_ns
, 1, &extended
))
9746 gfc_error ("Ambiguous symbol in TYPE definition at %C");
9750 extended
= gfc_find_dt_in_generic (extended
);
9755 gfc_error ("Symbol %qs at %C has not been previously defined", name
);
9759 if (extended
->attr
.flavor
!= FL_DERIVED
)
9761 gfc_error ("%qs in EXTENDS expression at %C is not a "
9762 "derived type", name
);
9766 if (extended
->attr
.is_bind_c
)
9768 gfc_error ("%qs cannot be extended at %C because it "
9769 "is BIND(C)", extended
->name
);
9773 if (extended
->attr
.sequence
)
9775 gfc_error ("%qs cannot be extended at %C because it "
9776 "is a SEQUENCE type", extended
->name
);
9784 /* Match the optional attribute specifiers for a type declaration.
9785 Return MATCH_ERROR if an error is encountered in one of the handled
9786 attributes (public, private, bind(c)), MATCH_NO if what's found is
9787 not a handled attribute, and MATCH_YES otherwise. TODO: More error
9788 checking on attribute conflicts needs to be done. */
9791 gfc_get_type_attr_spec (symbol_attribute
*attr
, char *name
)
9793 /* See if the derived type is marked as private. */
9794 if (gfc_match (" , private") == MATCH_YES
)
9796 if (gfc_current_state () != COMP_MODULE
)
9798 gfc_error ("Derived type at %C can only be PRIVATE in the "
9799 "specification part of a module");
9803 if (!gfc_add_access (attr
, ACCESS_PRIVATE
, NULL
, NULL
))
9806 else if (gfc_match (" , public") == MATCH_YES
)
9808 if (gfc_current_state () != COMP_MODULE
)
9810 gfc_error ("Derived type at %C can only be PUBLIC in the "
9811 "specification part of a module");
9815 if (!gfc_add_access (attr
, ACCESS_PUBLIC
, NULL
, NULL
))
9818 else if (gfc_match (" , bind ( c )") == MATCH_YES
)
9820 /* If the type is defined to be bind(c) it then needs to make
9821 sure that all fields are interoperable. This will
9822 need to be a semantic check on the finished derived type.
9823 See 15.2.3 (lines 9-12) of F2003 draft. */
9824 if (!gfc_add_is_bind_c (attr
, NULL
, &gfc_current_locus
, 0))
9827 /* TODO: attr conflicts need to be checked, probably in symbol.c. */
9829 else if (gfc_match (" , abstract") == MATCH_YES
)
9831 if (!gfc_notify_std (GFC_STD_F2003
, "ABSTRACT type at %C"))
9834 if (!gfc_add_abstract (attr
, &gfc_current_locus
))
9837 else if (name
&& gfc_match (" , extends ( %n )", name
) == MATCH_YES
)
9839 if (!gfc_add_extension (attr
, &gfc_current_locus
))
9845 /* If we get here, something matched. */
9850 /* Common function for type declaration blocks similar to derived types, such
9851 as STRUCTURES and MAPs. Unlike derived types, a structure type
9852 does NOT have a generic symbol matching the name given by the user.
9853 STRUCTUREs can share names with variables and PARAMETERs so we must allow
9854 for the creation of an independent symbol.
9855 Other parameters are a message to prefix errors with, the name of the new
9856 type to be created, and the flavor to add to the resulting symbol. */
9859 get_struct_decl (const char *name
, sym_flavor fl
, locus
*decl
,
9860 gfc_symbol
**result
)
9865 gcc_assert (name
[0] == (char) TOUPPER (name
[0]));
9870 where
= gfc_current_locus
;
9872 if (gfc_get_symbol (name
, NULL
, &sym
))
9877 gfc_internal_error ("Failed to create structure type '%s' at %C", name
);
9881 if (sym
->components
!= NULL
|| sym
->attr
.zero_comp
)
9883 gfc_error ("Type definition of %qs at %C was already defined at %L",
9884 sym
->name
, &sym
->declared_at
);
9888 sym
->declared_at
= where
;
9890 if (sym
->attr
.flavor
!= fl
9891 && !gfc_add_flavor (&sym
->attr
, fl
, sym
->name
, NULL
))
9894 if (!sym
->hash_value
)
9895 /* Set the hash for the compound name for this type. */
9896 sym
->hash_value
= gfc_hash_value (sym
);
9898 /* Normally the type is expected to have been completely parsed by the time
9899 a field declaration with this type is seen. For unions, maps, and nested
9900 structure declarations, we need to indicate that it is okay that we
9901 haven't seen any components yet. This will be updated after the structure
9903 sym
->attr
.zero_comp
= 0;
9905 /* Structures always act like derived-types with the SEQUENCE attribute */
9906 gfc_add_sequence (&sym
->attr
, sym
->name
, NULL
);
9908 if (result
) *result
= sym
;
9914 /* Match the opening of a MAP block. Like a struct within a union in C;
9915 behaves identical to STRUCTURE blocks. */
9918 gfc_match_map (void)
9920 /* Counter used to give unique internal names to map structures. */
9921 static unsigned int gfc_map_id
= 0;
9922 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9926 old_loc
= gfc_current_locus
;
9928 if (gfc_match_eos () != MATCH_YES
)
9930 gfc_error ("Junk after MAP statement at %C");
9931 gfc_current_locus
= old_loc
;
9935 /* Map blocks are anonymous so we make up unique names for the symbol table
9936 which are invalid Fortran identifiers. */
9937 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "MM$%u", gfc_map_id
++);
9939 if (!get_struct_decl (name
, FL_STRUCT
, &old_loc
, &sym
))
9942 gfc_new_block
= sym
;
9948 /* Match the opening of a UNION block. */
9951 gfc_match_union (void)
9953 /* Counter used to give unique internal names to union types. */
9954 static unsigned int gfc_union_id
= 0;
9955 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9959 old_loc
= gfc_current_locus
;
9961 if (gfc_match_eos () != MATCH_YES
)
9963 gfc_error ("Junk after UNION statement at %C");
9964 gfc_current_locus
= old_loc
;
9968 /* Unions are anonymous so we make up unique names for the symbol table
9969 which are invalid Fortran identifiers. */
9970 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "UU$%u", gfc_union_id
++);
9972 if (!get_struct_decl (name
, FL_UNION
, &old_loc
, &sym
))
9975 gfc_new_block
= sym
;
9981 /* Match the beginning of a STRUCTURE declaration. This is similar to
9982 matching the beginning of a derived type declaration with a few
9983 twists. The resulting type symbol has no access control or other
9984 interesting attributes. */
9987 gfc_match_structure_decl (void)
9989 /* Counter used to give unique internal names to anonymous structures. */
9990 static unsigned int gfc_structure_id
= 0;
9991 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9996 if (!flag_dec_structure
)
9998 gfc_error ("%s at %C is a DEC extension, enable with "
9999 "%<-fdec-structure%>",
10001 return MATCH_ERROR
;
10006 m
= gfc_match (" /%n/", name
);
10007 if (m
!= MATCH_YES
)
10009 /* Non-nested structure declarations require a structure name. */
10010 if (!gfc_comp_struct (gfc_current_state ()))
10012 gfc_error ("Structure name expected in non-nested structure "
10013 "declaration at %C");
10014 return MATCH_ERROR
;
10016 /* This is an anonymous structure; make up a unique name for it
10017 (upper-case letters never make it to symbol names from the source).
10018 The important thing is initializing the type variable
10019 and setting gfc_new_symbol, which is immediately used by
10020 parse_structure () and variable_decl () to add components of
10022 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "SS$%u", gfc_structure_id
++);
10025 where
= gfc_current_locus
;
10026 /* No field list allowed after non-nested structure declaration. */
10027 if (!gfc_comp_struct (gfc_current_state ())
10028 && gfc_match_eos () != MATCH_YES
)
10030 gfc_error ("Junk after non-nested STRUCTURE statement at %C");
10031 return MATCH_ERROR
;
10034 /* Make sure the name is not the name of an intrinsic type. */
10035 if (gfc_is_intrinsic_typename (name
))
10037 gfc_error ("Structure name %qs at %C cannot be the same as an"
10038 " intrinsic type", name
);
10039 return MATCH_ERROR
;
10042 /* Store the actual type symbol for the structure with an upper-case first
10043 letter (an invalid Fortran identifier). */
10045 if (!get_struct_decl (gfc_dt_upper_string (name
), FL_STRUCT
, &where
, &sym
))
10046 return MATCH_ERROR
;
10048 gfc_new_block
= sym
;
10053 /* This function does some work to determine which matcher should be used to
10054 * match a statement beginning with "TYPE". This is used to disambiguate TYPE
10055 * as an alias for PRINT from derived type declarations, TYPE IS statements,
10056 * and [parameterized] derived type declarations. */
10059 gfc_match_type (gfc_statement
*st
)
10061 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10065 /* Requires -fdec. */
10069 m
= gfc_match ("type");
10070 if (m
!= MATCH_YES
)
10072 /* If we already have an error in the buffer, it is probably from failing to
10073 * match a derived type data declaration. Let it happen. */
10074 else if (gfc_error_flag_test ())
10077 old_loc
= gfc_current_locus
;
10080 /* If we see an attribute list before anything else it's definitely a derived
10081 * type declaration. */
10082 if (gfc_match (" ,") == MATCH_YES
|| gfc_match (" ::") == MATCH_YES
)
10085 /* By now "TYPE" has already been matched. If we do not see a name, this may
10086 * be something like "TYPE *" or "TYPE <fmt>". */
10087 m
= gfc_match_name (name
);
10088 if (m
!= MATCH_YES
)
10090 /* Let print match if it can, otherwise throw an error from
10091 * gfc_match_derived_decl. */
10092 gfc_current_locus
= old_loc
;
10093 if (gfc_match_print () == MATCH_YES
)
10101 /* Check for EOS. */
10102 if (gfc_match_eos () == MATCH_YES
)
10104 /* By now we have "TYPE <name> <EOS>". Check first if the name is an
10105 * intrinsic typename - if so let gfc_match_derived_decl dump an error.
10106 * Otherwise if gfc_match_derived_decl fails it's probably an existing
10107 * symbol which can be printed. */
10108 gfc_current_locus
= old_loc
;
10109 m
= gfc_match_derived_decl ();
10110 if (gfc_is_intrinsic_typename (name
) || m
== MATCH_YES
)
10112 *st
= ST_DERIVED_DECL
;
10118 /* Here we have "TYPE <name>". Check for <TYPE IS (> or a PDT declaration
10119 like <type name(parameter)>. */
10120 gfc_gobble_whitespace ();
10121 bool paren
= gfc_peek_ascii_char () == '(';
10124 if (strcmp ("is", name
) == 0)
10131 /* Treat TYPE... like PRINT... */
10132 gfc_current_locus
= old_loc
;
10134 return gfc_match_print ();
10137 gfc_current_locus
= old_loc
;
10138 *st
= ST_DERIVED_DECL
;
10139 return gfc_match_derived_decl ();
10142 gfc_current_locus
= old_loc
;
10144 return gfc_match_type_is ();
10148 /* Match the beginning of a derived type declaration. If a type name
10149 was the result of a function, then it is possible to have a symbol
10150 already to be known as a derived type yet have no components. */
10153 gfc_match_derived_decl (void)
10155 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10156 char parent
[GFC_MAX_SYMBOL_LEN
+ 1];
10157 symbol_attribute attr
;
10158 gfc_symbol
*sym
, *gensym
;
10159 gfc_symbol
*extended
;
10161 match is_type_attr_spec
= MATCH_NO
;
10162 bool seen_attr
= false;
10163 gfc_interface
*intr
= NULL
, *head
;
10164 bool parameterized_type
= false;
10165 bool seen_colons
= false;
10167 if (gfc_comp_struct (gfc_current_state ()))
10172 gfc_clear_attr (&attr
);
10177 is_type_attr_spec
= gfc_get_type_attr_spec (&attr
, parent
);
10178 if (is_type_attr_spec
== MATCH_ERROR
)
10179 return MATCH_ERROR
;
10180 if (is_type_attr_spec
== MATCH_YES
)
10182 } while (is_type_attr_spec
== MATCH_YES
);
10184 /* Deal with derived type extensions. The extension attribute has
10185 been added to 'attr' but now the parent type must be found and
10188 extended
= check_extended_derived_type (parent
);
10190 if (parent
[0] && !extended
)
10191 return MATCH_ERROR
;
10193 m
= gfc_match (" ::");
10194 if (m
== MATCH_YES
)
10196 seen_colons
= true;
10198 else if (seen_attr
)
10200 gfc_error ("Expected :: in TYPE definition at %C");
10201 return MATCH_ERROR
;
10204 m
= gfc_match (" %n ", name
);
10205 if (m
!= MATCH_YES
)
10208 /* Make sure that we don't identify TYPE IS (...) as a parameterized
10209 derived type named 'is'.
10210 TODO Expand the check, when 'name' = "is" by matching " (tname) "
10211 and checking if this is a(n intrinsic) typename. his picks up
10212 misplaced TYPE IS statements such as in select_type_1.f03. */
10213 if (gfc_peek_ascii_char () == '(')
10215 if (gfc_current_state () == COMP_SELECT_TYPE
10216 || (!seen_colons
&& !strcmp (name
, "is")))
10218 parameterized_type
= true;
10221 m
= gfc_match_eos ();
10222 if (m
!= MATCH_YES
&& !parameterized_type
)
10225 /* Make sure the name is not the name of an intrinsic type. */
10226 if (gfc_is_intrinsic_typename (name
))
10228 gfc_error ("Type name %qs at %C cannot be the same as an intrinsic "
10230 return MATCH_ERROR
;
10233 if (gfc_get_symbol (name
, NULL
, &gensym
))
10234 return MATCH_ERROR
;
10236 if (!gensym
->attr
.generic
&& gensym
->ts
.type
!= BT_UNKNOWN
)
10238 if (gensym
->ts
.u
.derived
)
10239 gfc_error ("Derived type name %qs at %C already has a basic type "
10240 "of %s", gensym
->name
, gfc_typename (&gensym
->ts
));
10242 gfc_error ("Derived type name %qs at %C already has a basic type",
10244 return MATCH_ERROR
;
10247 if (!gensym
->attr
.generic
10248 && !gfc_add_generic (&gensym
->attr
, gensym
->name
, NULL
))
10249 return MATCH_ERROR
;
10251 if (!gensym
->attr
.function
10252 && !gfc_add_function (&gensym
->attr
, gensym
->name
, NULL
))
10253 return MATCH_ERROR
;
10255 if (gensym
->attr
.dummy
)
10257 gfc_error ("Dummy argument %qs at %L cannot be a derived type at %C",
10258 name
, &gensym
->declared_at
);
10259 return MATCH_ERROR
;
10262 sym
= gfc_find_dt_in_generic (gensym
);
10264 if (sym
&& (sym
->components
!= NULL
|| sym
->attr
.zero_comp
))
10266 gfc_error ("Derived type definition of %qs at %C has already been "
10267 "defined", sym
->name
);
10268 return MATCH_ERROR
;
10273 /* Use upper case to save the actual derived-type symbol. */
10274 gfc_get_symbol (gfc_dt_upper_string (gensym
->name
), NULL
, &sym
);
10275 sym
->name
= gfc_get_string ("%s", gensym
->name
);
10276 head
= gensym
->generic
;
10277 intr
= gfc_get_interface ();
10279 intr
->where
= gfc_current_locus
;
10280 intr
->sym
->declared_at
= gfc_current_locus
;
10282 gensym
->generic
= intr
;
10283 gensym
->attr
.if_source
= IFSRC_DECL
;
10286 /* The symbol may already have the derived attribute without the
10287 components. The ways this can happen is via a function
10288 definition, an INTRINSIC statement or a subtype in another
10289 derived type that is a pointer. The first part of the AND clause
10290 is true if the symbol is not the return value of a function. */
10291 if (sym
->attr
.flavor
!= FL_DERIVED
10292 && !gfc_add_flavor (&sym
->attr
, FL_DERIVED
, sym
->name
, NULL
))
10293 return MATCH_ERROR
;
10295 if (attr
.access
!= ACCESS_UNKNOWN
10296 && !gfc_add_access (&sym
->attr
, attr
.access
, sym
->name
, NULL
))
10297 return MATCH_ERROR
;
10298 else if (sym
->attr
.access
== ACCESS_UNKNOWN
10299 && gensym
->attr
.access
!= ACCESS_UNKNOWN
10300 && !gfc_add_access (&sym
->attr
, gensym
->attr
.access
,
10302 return MATCH_ERROR
;
10304 if (sym
->attr
.access
!= ACCESS_UNKNOWN
10305 && gensym
->attr
.access
== ACCESS_UNKNOWN
)
10306 gensym
->attr
.access
= sym
->attr
.access
;
10308 /* See if the derived type was labeled as bind(c). */
10309 if (attr
.is_bind_c
!= 0)
10310 sym
->attr
.is_bind_c
= attr
.is_bind_c
;
10312 /* Construct the f2k_derived namespace if it is not yet there. */
10313 if (!sym
->f2k_derived
)
10314 sym
->f2k_derived
= gfc_get_namespace (NULL
, 0);
10316 if (parameterized_type
)
10318 /* Ignore error or mismatches by going to the end of the statement
10319 in order to avoid the component declarations causing problems. */
10320 m
= gfc_match_formal_arglist (sym
, 0, 0, true);
10321 if (m
!= MATCH_YES
)
10322 gfc_error_recovery ();
10324 sym
->attr
.pdt_template
= 1;
10325 m
= gfc_match_eos ();
10326 if (m
!= MATCH_YES
)
10328 gfc_error_recovery ();
10329 gfc_error_now ("Garbage after PARAMETERIZED TYPE declaration at %C");
10333 if (extended
&& !sym
->components
)
10336 gfc_formal_arglist
*f
, *g
, *h
;
10338 /* Add the extended derived type as the first component. */
10339 gfc_add_component (sym
, parent
, &p
);
10341 gfc_set_sym_referenced (extended
);
10343 p
->ts
.type
= BT_DERIVED
;
10344 p
->ts
.u
.derived
= extended
;
10345 p
->initializer
= gfc_default_initializer (&p
->ts
);
10347 /* Set extension level. */
10348 if (extended
->attr
.extension
== 255)
10350 /* Since the extension field is 8 bit wide, we can only have
10351 up to 255 extension levels. */
10352 gfc_error ("Maximum extension level reached with type %qs at %L",
10353 extended
->name
, &extended
->declared_at
);
10354 return MATCH_ERROR
;
10356 sym
->attr
.extension
= extended
->attr
.extension
+ 1;
10358 /* Provide the links between the extended type and its extension. */
10359 if (!extended
->f2k_derived
)
10360 extended
->f2k_derived
= gfc_get_namespace (NULL
, 0);
10362 /* Copy the extended type-param-name-list from the extended type,
10363 append those of the extension and add the whole lot to the
10365 if (extended
->attr
.pdt_template
)
10368 sym
->attr
.pdt_template
= 1;
10369 for (f
= extended
->formal
; f
; f
= f
->next
)
10371 if (f
== extended
->formal
)
10373 g
= gfc_get_formal_arglist ();
10378 g
->next
= gfc_get_formal_arglist ();
10383 g
->next
= sym
->formal
;
10388 if (!sym
->hash_value
)
10389 /* Set the hash for the compound name for this type. */
10390 sym
->hash_value
= gfc_hash_value (sym
);
10392 /* Take over the ABSTRACT attribute. */
10393 sym
->attr
.abstract
= attr
.abstract
;
10395 gfc_new_block
= sym
;
10401 /* Cray Pointees can be declared as:
10402 pointer (ipt, a (n,m,...,*)) */
10405 gfc_mod_pointee_as (gfc_array_spec
*as
)
10407 as
->cray_pointee
= true; /* This will be useful to know later. */
10408 if (as
->type
== AS_ASSUMED_SIZE
)
10409 as
->cp_was_assumed
= true;
10410 else if (as
->type
== AS_ASSUMED_SHAPE
)
10412 gfc_error ("Cray Pointee at %C cannot be assumed shape array");
10413 return MATCH_ERROR
;
10419 /* Match the enum definition statement, here we are trying to match
10420 the first line of enum definition statement.
10421 Returns MATCH_YES if match is found. */
10424 gfc_match_enum (void)
10428 m
= gfc_match_eos ();
10429 if (m
!= MATCH_YES
)
10432 if (!gfc_notify_std (GFC_STD_F2003
, "ENUM and ENUMERATOR at %C"))
10433 return MATCH_ERROR
;
10439 /* Returns an initializer whose value is one higher than the value of the
10440 LAST_INITIALIZER argument. If the argument is NULL, the
10441 initializers value will be set to zero. The initializer's kind
10442 will be set to gfc_c_int_kind.
10444 If -fshort-enums is given, the appropriate kind will be selected
10445 later after all enumerators have been parsed. A warning is issued
10446 here if an initializer exceeds gfc_c_int_kind. */
10449 enum_initializer (gfc_expr
*last_initializer
, locus where
)
10452 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_c_int_kind
, &where
);
10454 mpz_init (result
->value
.integer
);
10456 if (last_initializer
!= NULL
)
10458 mpz_add_ui (result
->value
.integer
, last_initializer
->value
.integer
, 1);
10459 result
->where
= last_initializer
->where
;
10461 if (gfc_check_integer_range (result
->value
.integer
,
10462 gfc_c_int_kind
) != ARITH_OK
)
10464 gfc_error ("Enumerator exceeds the C integer type at %C");
10470 /* Control comes here, if it's the very first enumerator and no
10471 initializer has been given. It will be initialized to zero. */
10472 mpz_set_si (result
->value
.integer
, 0);
10479 /* Match a variable name with an optional initializer. When this
10480 subroutine is called, a variable is expected to be parsed next.
10481 Depending on what is happening at the moment, updates either the
10482 symbol table or the current interface. */
10485 enumerator_decl (void)
10487 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10488 gfc_expr
*initializer
;
10489 gfc_array_spec
*as
= NULL
;
10496 initializer
= NULL
;
10497 old_locus
= gfc_current_locus
;
10499 /* When we get here, we've just matched a list of attributes and
10500 maybe a type and a double colon. The next thing we expect to see
10501 is the name of the symbol. */
10502 m
= gfc_match_name (name
);
10503 if (m
!= MATCH_YES
)
10506 var_locus
= gfc_current_locus
;
10508 /* OK, we've successfully matched the declaration. Now put the
10509 symbol in the current namespace. If we fail to create the symbol,
10511 if (!build_sym (name
, NULL
, false, &as
, &var_locus
))
10517 /* The double colon must be present in order to have initializers.
10518 Otherwise the statement is ambiguous with an assignment statement. */
10521 if (gfc_match_char ('=') == MATCH_YES
)
10523 m
= gfc_match_init_expr (&initializer
);
10526 gfc_error ("Expected an initialization expression at %C");
10530 if (m
!= MATCH_YES
)
10535 /* If we do not have an initializer, the initialization value of the
10536 previous enumerator (stored in last_initializer) is incremented
10537 by 1 and is used to initialize the current enumerator. */
10538 if (initializer
== NULL
)
10539 initializer
= enum_initializer (last_initializer
, old_locus
);
10541 if (initializer
== NULL
|| initializer
->ts
.type
!= BT_INTEGER
)
10543 gfc_error ("ENUMERATOR %L not initialized with integer expression",
10549 /* Store this current initializer, for the next enumerator variable
10550 to be parsed. add_init_expr_to_sym() zeros initializer, so we
10551 use last_initializer below. */
10552 last_initializer
= initializer
;
10553 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
10555 /* Maintain enumerator history. */
10556 gfc_find_symbol (name
, NULL
, 0, &sym
);
10557 create_enum_history (sym
, last_initializer
);
10559 return (t
) ? MATCH_YES
: MATCH_ERROR
;
10562 /* Free stuff up and return. */
10563 gfc_free_expr (initializer
);
10569 /* Match the enumerator definition statement. */
10572 gfc_match_enumerator_def (void)
10577 gfc_clear_ts (¤t_ts
);
10579 m
= gfc_match (" enumerator");
10580 if (m
!= MATCH_YES
)
10583 m
= gfc_match (" :: ");
10584 if (m
== MATCH_ERROR
)
10587 colon_seen
= (m
== MATCH_YES
);
10589 if (gfc_current_state () != COMP_ENUM
)
10591 gfc_error ("ENUM definition statement expected before %C");
10592 gfc_free_enum_history ();
10593 return MATCH_ERROR
;
10596 (¤t_ts
)->type
= BT_INTEGER
;
10597 (¤t_ts
)->kind
= gfc_c_int_kind
;
10599 gfc_clear_attr (¤t_attr
);
10600 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, NULL
);
10609 m
= enumerator_decl ();
10610 if (m
== MATCH_ERROR
)
10612 gfc_free_enum_history ();
10618 if (gfc_match_eos () == MATCH_YES
)
10620 if (gfc_match_char (',') != MATCH_YES
)
10624 if (gfc_current_state () == COMP_ENUM
)
10626 gfc_free_enum_history ();
10627 gfc_error ("Syntax error in ENUMERATOR definition at %C");
10632 gfc_free_array_spec (current_as
);
10639 /* Match binding attributes. */
10642 match_binding_attributes (gfc_typebound_proc
* ba
, bool generic
, bool ppc
)
10644 bool found_passing
= false;
10645 bool seen_ptr
= false;
10646 match m
= MATCH_YES
;
10648 /* Initialize to defaults. Do so even before the MATCH_NO check so that in
10649 this case the defaults are in there. */
10650 ba
->access
= ACCESS_UNKNOWN
;
10651 ba
->pass_arg
= NULL
;
10652 ba
->pass_arg_num
= 0;
10654 ba
->non_overridable
= 0;
10658 /* If we find a comma, we believe there are binding attributes. */
10659 m
= gfc_match_char (',');
10665 /* Access specifier. */
10667 m
= gfc_match (" public");
10668 if (m
== MATCH_ERROR
)
10670 if (m
== MATCH_YES
)
10672 if (ba
->access
!= ACCESS_UNKNOWN
)
10674 gfc_error ("Duplicate access-specifier at %C");
10678 ba
->access
= ACCESS_PUBLIC
;
10682 m
= gfc_match (" private");
10683 if (m
== MATCH_ERROR
)
10685 if (m
== MATCH_YES
)
10687 if (ba
->access
!= ACCESS_UNKNOWN
)
10689 gfc_error ("Duplicate access-specifier at %C");
10693 ba
->access
= ACCESS_PRIVATE
;
10697 /* If inside GENERIC, the following is not allowed. */
10702 m
= gfc_match (" nopass");
10703 if (m
== MATCH_ERROR
)
10705 if (m
== MATCH_YES
)
10709 gfc_error ("Binding attributes already specify passing,"
10710 " illegal NOPASS at %C");
10714 found_passing
= true;
10719 /* PASS possibly including argument. */
10720 m
= gfc_match (" pass");
10721 if (m
== MATCH_ERROR
)
10723 if (m
== MATCH_YES
)
10725 char arg
[GFC_MAX_SYMBOL_LEN
+ 1];
10729 gfc_error ("Binding attributes already specify passing,"
10730 " illegal PASS at %C");
10734 m
= gfc_match (" ( %n )", arg
);
10735 if (m
== MATCH_ERROR
)
10737 if (m
== MATCH_YES
)
10738 ba
->pass_arg
= gfc_get_string ("%s", arg
);
10739 gcc_assert ((m
== MATCH_YES
) == (ba
->pass_arg
!= NULL
));
10741 found_passing
= true;
10748 /* POINTER flag. */
10749 m
= gfc_match (" pointer");
10750 if (m
== MATCH_ERROR
)
10752 if (m
== MATCH_YES
)
10756 gfc_error ("Duplicate POINTER attribute at %C");
10766 /* NON_OVERRIDABLE flag. */
10767 m
= gfc_match (" non_overridable");
10768 if (m
== MATCH_ERROR
)
10770 if (m
== MATCH_YES
)
10772 if (ba
->non_overridable
)
10774 gfc_error ("Duplicate NON_OVERRIDABLE at %C");
10778 ba
->non_overridable
= 1;
10782 /* DEFERRED flag. */
10783 m
= gfc_match (" deferred");
10784 if (m
== MATCH_ERROR
)
10786 if (m
== MATCH_YES
)
10790 gfc_error ("Duplicate DEFERRED at %C");
10801 /* Nothing matching found. */
10803 gfc_error ("Expected access-specifier at %C");
10805 gfc_error ("Expected binding attribute at %C");
10808 while (gfc_match_char (',') == MATCH_YES
);
10810 /* NON_OVERRIDABLE and DEFERRED exclude themselves. */
10811 if (ba
->non_overridable
&& ba
->deferred
)
10813 gfc_error ("NON_OVERRIDABLE and DEFERRED cannot both appear at %C");
10820 if (ba
->access
== ACCESS_UNKNOWN
)
10821 ba
->access
= ppc
? gfc_current_block()->component_access
10822 : gfc_typebound_default_access
;
10824 if (ppc
&& !seen_ptr
)
10826 gfc_error ("POINTER attribute is required for procedure pointer component"
10834 return MATCH_ERROR
;
10838 /* Match a PROCEDURE specific binding inside a derived type. */
10841 match_procedure_in_type (void)
10843 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10844 char target_buf
[GFC_MAX_SYMBOL_LEN
+ 1];
10845 char* target
= NULL
, *ifc
= NULL
;
10846 gfc_typebound_proc tb
;
10850 gfc_symtree
* stree
;
10855 /* Check current state. */
10856 gcc_assert (gfc_state_stack
->state
== COMP_DERIVED_CONTAINS
);
10857 block
= gfc_state_stack
->previous
->sym
;
10858 gcc_assert (block
);
10860 /* Try to match PROCEDURE(interface). */
10861 if (gfc_match (" (") == MATCH_YES
)
10863 m
= gfc_match_name (target_buf
);
10864 if (m
== MATCH_ERROR
)
10866 if (m
!= MATCH_YES
)
10868 gfc_error ("Interface-name expected after %<(%> at %C");
10869 return MATCH_ERROR
;
10872 if (gfc_match (" )") != MATCH_YES
)
10874 gfc_error ("%<)%> expected at %C");
10875 return MATCH_ERROR
;
10881 /* Construct the data structure. */
10882 memset (&tb
, 0, sizeof (tb
));
10883 tb
.where
= gfc_current_locus
;
10885 /* Match binding attributes. */
10886 m
= match_binding_attributes (&tb
, false, false);
10887 if (m
== MATCH_ERROR
)
10889 seen_attrs
= (m
== MATCH_YES
);
10891 /* Check that attribute DEFERRED is given if an interface is specified. */
10892 if (tb
.deferred
&& !ifc
)
10894 gfc_error ("Interface must be specified for DEFERRED binding at %C");
10895 return MATCH_ERROR
;
10897 if (ifc
&& !tb
.deferred
)
10899 gfc_error ("PROCEDURE(interface) at %C should be declared DEFERRED");
10900 return MATCH_ERROR
;
10903 /* Match the colons. */
10904 m
= gfc_match (" ::");
10905 if (m
== MATCH_ERROR
)
10907 seen_colons
= (m
== MATCH_YES
);
10908 if (seen_attrs
&& !seen_colons
)
10910 gfc_error ("Expected %<::%> after binding-attributes at %C");
10911 return MATCH_ERROR
;
10914 /* Match the binding names. */
10917 m
= gfc_match_name (name
);
10918 if (m
== MATCH_ERROR
)
10922 gfc_error ("Expected binding name at %C");
10923 return MATCH_ERROR
;
10926 if (num
>1 && !gfc_notify_std (GFC_STD_F2008
, "PROCEDURE list at %C"))
10927 return MATCH_ERROR
;
10929 /* Try to match the '=> target', if it's there. */
10931 m
= gfc_match (" =>");
10932 if (m
== MATCH_ERROR
)
10934 if (m
== MATCH_YES
)
10938 gfc_error ("%<=> target%> is invalid for DEFERRED binding at %C");
10939 return MATCH_ERROR
;
10944 gfc_error ("%<::%> needed in PROCEDURE binding with explicit target"
10946 return MATCH_ERROR
;
10949 m
= gfc_match_name (target_buf
);
10950 if (m
== MATCH_ERROR
)
10954 gfc_error ("Expected binding target after %<=>%> at %C");
10955 return MATCH_ERROR
;
10957 target
= target_buf
;
10960 /* If no target was found, it has the same name as the binding. */
10964 /* Get the namespace to insert the symbols into. */
10965 ns
= block
->f2k_derived
;
10968 /* If the binding is DEFERRED, check that the containing type is ABSTRACT. */
10969 if (tb
.deferred
&& !block
->attr
.abstract
)
10971 gfc_error ("Type %qs containing DEFERRED binding at %C "
10972 "is not ABSTRACT", block
->name
);
10973 return MATCH_ERROR
;
10976 /* See if we already have a binding with this name in the symtree which
10977 would be an error. If a GENERIC already targeted this binding, it may
10978 be already there but then typebound is still NULL. */
10979 stree
= gfc_find_symtree (ns
->tb_sym_root
, name
);
10980 if (stree
&& stree
->n
.tb
)
10982 gfc_error ("There is already a procedure with binding name %qs for "
10983 "the derived type %qs at %C", name
, block
->name
);
10984 return MATCH_ERROR
;
10987 /* Insert it and set attributes. */
10991 stree
= gfc_new_symtree (&ns
->tb_sym_root
, name
);
10992 gcc_assert (stree
);
10994 stree
->n
.tb
= gfc_get_typebound_proc (&tb
);
10996 if (gfc_get_sym_tree (target
, gfc_current_ns
, &stree
->n
.tb
->u
.specific
,
10998 return MATCH_ERROR
;
10999 gfc_set_sym_referenced (stree
->n
.tb
->u
.specific
->n
.sym
);
11000 gfc_add_flavor(&stree
->n
.tb
->u
.specific
->n
.sym
->attr
, FL_PROCEDURE
,
11001 target
, &stree
->n
.tb
->u
.specific
->n
.sym
->declared_at
);
11003 if (gfc_match_eos () == MATCH_YES
)
11005 if (gfc_match_char (',') != MATCH_YES
)
11010 gfc_error ("Syntax error in PROCEDURE statement at %C");
11011 return MATCH_ERROR
;
11015 /* Match a GENERIC procedure binding inside a derived type. */
11018 gfc_match_generic (void)
11020 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
11021 char bind_name
[GFC_MAX_SYMBOL_LEN
+ 16]; /* Allow space for OPERATOR(...). */
11023 gfc_typebound_proc tbattr
; /* Used for match_binding_attributes. */
11024 gfc_typebound_proc
* tb
;
11026 interface_type op_type
;
11027 gfc_intrinsic_op op
;
11030 /* Check current state. */
11031 if (gfc_current_state () == COMP_DERIVED
)
11033 gfc_error ("GENERIC at %C must be inside a derived-type CONTAINS");
11034 return MATCH_ERROR
;
11036 if (gfc_current_state () != COMP_DERIVED_CONTAINS
)
11038 block
= gfc_state_stack
->previous
->sym
;
11039 ns
= block
->f2k_derived
;
11040 gcc_assert (block
&& ns
);
11042 memset (&tbattr
, 0, sizeof (tbattr
));
11043 tbattr
.where
= gfc_current_locus
;
11045 /* See if we get an access-specifier. */
11046 m
= match_binding_attributes (&tbattr
, true, false);
11047 if (m
== MATCH_ERROR
)
11050 /* Now the colons, those are required. */
11051 if (gfc_match (" ::") != MATCH_YES
)
11053 gfc_error ("Expected %<::%> at %C");
11057 /* Match the binding name; depending on type (operator / generic) format
11058 it for future error messages into bind_name. */
11060 m
= gfc_match_generic_spec (&op_type
, name
, &op
);
11061 if (m
== MATCH_ERROR
)
11062 return MATCH_ERROR
;
11065 gfc_error ("Expected generic name or operator descriptor at %C");
11071 case INTERFACE_GENERIC
:
11072 case INTERFACE_DTIO
:
11073 snprintf (bind_name
, sizeof (bind_name
), "%s", name
);
11076 case INTERFACE_USER_OP
:
11077 snprintf (bind_name
, sizeof (bind_name
), "OPERATOR(.%s.)", name
);
11080 case INTERFACE_INTRINSIC_OP
:
11081 snprintf (bind_name
, sizeof (bind_name
), "OPERATOR(%s)",
11082 gfc_op2string (op
));
11085 case INTERFACE_NAMELESS
:
11086 gfc_error ("Malformed GENERIC statement at %C");
11091 gcc_unreachable ();
11094 /* Match the required =>. */
11095 if (gfc_match (" =>") != MATCH_YES
)
11097 gfc_error ("Expected %<=>%> at %C");
11101 /* Try to find existing GENERIC binding with this name / for this operator;
11102 if there is something, check that it is another GENERIC and then extend
11103 it rather than building a new node. Otherwise, create it and put it
11104 at the right position. */
11108 case INTERFACE_DTIO
:
11109 case INTERFACE_USER_OP
:
11110 case INTERFACE_GENERIC
:
11112 const bool is_op
= (op_type
== INTERFACE_USER_OP
);
11115 st
= gfc_find_symtree (is_op
? ns
->tb_uop_root
: ns
->tb_sym_root
, name
);
11116 tb
= st
? st
->n
.tb
: NULL
;
11120 case INTERFACE_INTRINSIC_OP
:
11121 tb
= ns
->tb_op
[op
];
11125 gcc_unreachable ();
11130 if (!tb
->is_generic
)
11132 gcc_assert (op_type
== INTERFACE_GENERIC
);
11133 gfc_error ("There's already a non-generic procedure with binding name"
11134 " %qs for the derived type %qs at %C",
11135 bind_name
, block
->name
);
11139 if (tb
->access
!= tbattr
.access
)
11141 gfc_error ("Binding at %C must have the same access as already"
11142 " defined binding %qs", bind_name
);
11148 tb
= gfc_get_typebound_proc (NULL
);
11149 tb
->where
= gfc_current_locus
;
11150 tb
->access
= tbattr
.access
;
11151 tb
->is_generic
= 1;
11152 tb
->u
.generic
= NULL
;
11156 case INTERFACE_DTIO
:
11157 case INTERFACE_GENERIC
:
11158 case INTERFACE_USER_OP
:
11160 const bool is_op
= (op_type
== INTERFACE_USER_OP
);
11161 gfc_symtree
* st
= gfc_get_tbp_symtree (is_op
? &ns
->tb_uop_root
:
11162 &ns
->tb_sym_root
, name
);
11169 case INTERFACE_INTRINSIC_OP
:
11170 ns
->tb_op
[op
] = tb
;
11174 gcc_unreachable ();
11178 /* Now, match all following names as specific targets. */
11181 gfc_symtree
* target_st
;
11182 gfc_tbp_generic
* target
;
11184 m
= gfc_match_name (name
);
11185 if (m
== MATCH_ERROR
)
11189 gfc_error ("Expected specific binding name at %C");
11193 target_st
= gfc_get_tbp_symtree (&ns
->tb_sym_root
, name
);
11195 /* See if this is a duplicate specification. */
11196 for (target
= tb
->u
.generic
; target
; target
= target
->next
)
11197 if (target_st
== target
->specific_st
)
11199 gfc_error ("%qs already defined as specific binding for the"
11200 " generic %qs at %C", name
, bind_name
);
11204 target
= gfc_get_tbp_generic ();
11205 target
->specific_st
= target_st
;
11206 target
->specific
= NULL
;
11207 target
->next
= tb
->u
.generic
;
11208 target
->is_operator
= ((op_type
== INTERFACE_USER_OP
)
11209 || (op_type
== INTERFACE_INTRINSIC_OP
));
11210 tb
->u
.generic
= target
;
11212 while (gfc_match (" ,") == MATCH_YES
);
11214 /* Here should be the end. */
11215 if (gfc_match_eos () != MATCH_YES
)
11217 gfc_error ("Junk after GENERIC binding at %C");
11224 return MATCH_ERROR
;
11228 /* Match a FINAL declaration inside a derived type. */
11231 gfc_match_final_decl (void)
11233 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
11236 gfc_namespace
* module_ns
;
11240 if (gfc_current_form
== FORM_FREE
)
11242 char c
= gfc_peek_ascii_char ();
11243 if (!gfc_is_whitespace (c
) && c
!= ':')
11247 if (gfc_state_stack
->state
!= COMP_DERIVED_CONTAINS
)
11249 if (gfc_current_form
== FORM_FIXED
)
11252 gfc_error ("FINAL declaration at %C must be inside a derived type "
11253 "CONTAINS section");
11254 return MATCH_ERROR
;
11257 block
= gfc_state_stack
->previous
->sym
;
11258 gcc_assert (block
);
11260 if (!gfc_state_stack
->previous
|| !gfc_state_stack
->previous
->previous
11261 || gfc_state_stack
->previous
->previous
->state
!= COMP_MODULE
)
11263 gfc_error ("Derived type declaration with FINAL at %C must be in the"
11264 " specification part of a MODULE");
11265 return MATCH_ERROR
;
11268 module_ns
= gfc_current_ns
;
11269 gcc_assert (module_ns
);
11270 gcc_assert (module_ns
->proc_name
->attr
.flavor
== FL_MODULE
);
11272 /* Match optional ::, don't care about MATCH_YES or MATCH_NO. */
11273 if (gfc_match (" ::") == MATCH_ERROR
)
11274 return MATCH_ERROR
;
11276 /* Match the sequence of procedure names. */
11283 if (first
&& gfc_match_eos () == MATCH_YES
)
11285 gfc_error ("Empty FINAL at %C");
11286 return MATCH_ERROR
;
11289 m
= gfc_match_name (name
);
11292 gfc_error ("Expected module procedure name at %C");
11293 return MATCH_ERROR
;
11295 else if (m
!= MATCH_YES
)
11296 return MATCH_ERROR
;
11298 if (gfc_match_eos () == MATCH_YES
)
11300 if (!last
&& gfc_match_char (',') != MATCH_YES
)
11302 gfc_error ("Expected %<,%> at %C");
11303 return MATCH_ERROR
;
11306 if (gfc_get_symbol (name
, module_ns
, &sym
))
11308 gfc_error ("Unknown procedure name %qs at %C", name
);
11309 return MATCH_ERROR
;
11312 /* Mark the symbol as module procedure. */
11313 if (sym
->attr
.proc
!= PROC_MODULE
11314 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
11315 return MATCH_ERROR
;
11317 /* Check if we already have this symbol in the list, this is an error. */
11318 for (f
= block
->f2k_derived
->finalizers
; f
; f
= f
->next
)
11319 if (f
->proc_sym
== sym
)
11321 gfc_error ("%qs at %C is already defined as FINAL procedure",
11323 return MATCH_ERROR
;
11326 /* Add this symbol to the list of finalizers. */
11327 gcc_assert (block
->f2k_derived
);
11329 f
= XCNEW (gfc_finalizer
);
11331 f
->proc_tree
= NULL
;
11332 f
->where
= gfc_current_locus
;
11333 f
->next
= block
->f2k_derived
->finalizers
;
11334 block
->f2k_derived
->finalizers
= f
;
11344 const ext_attr_t ext_attr_list
[] = {
11345 { "dllimport", EXT_ATTR_DLLIMPORT
, "dllimport" },
11346 { "dllexport", EXT_ATTR_DLLEXPORT
, "dllexport" },
11347 { "cdecl", EXT_ATTR_CDECL
, "cdecl" },
11348 { "stdcall", EXT_ATTR_STDCALL
, "stdcall" },
11349 { "fastcall", EXT_ATTR_FASTCALL
, "fastcall" },
11350 { "no_arg_check", EXT_ATTR_NO_ARG_CHECK
, NULL
},
11351 { NULL
, EXT_ATTR_LAST
, NULL
}
11354 /* Match a !GCC$ ATTRIBUTES statement of the form:
11355 !GCC$ ATTRIBUTES attribute-list :: var-name [, var-name] ...
11356 When we come here, we have already matched the !GCC$ ATTRIBUTES string.
11358 TODO: We should support all GCC attributes using the same syntax for
11359 the attribute list, i.e. the list in C
11360 __attributes(( attribute-list ))
11362 !GCC$ ATTRIBUTES attribute-list ::
11363 Cf. c-parser.c's c_parser_attributes; the data can then directly be
11366 As there is absolutely no risk of confusion, we should never return
11369 gfc_match_gcc_attributes (void)
11371 symbol_attribute attr
;
11372 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
11377 gfc_clear_attr (&attr
);
11382 if (gfc_match_name (name
) != MATCH_YES
)
11383 return MATCH_ERROR
;
11385 for (id
= 0; id
< EXT_ATTR_LAST
; id
++)
11386 if (strcmp (name
, ext_attr_list
[id
].name
) == 0)
11389 if (id
== EXT_ATTR_LAST
)
11391 gfc_error ("Unknown attribute in !GCC$ ATTRIBUTES statement at %C");
11392 return MATCH_ERROR
;
11395 if (!gfc_add_ext_attribute (&attr
, (ext_attr_id_t
)id
, &gfc_current_locus
))
11396 return MATCH_ERROR
;
11398 gfc_gobble_whitespace ();
11399 ch
= gfc_next_ascii_char ();
11402 /* This is the successful exit condition for the loop. */
11403 if (gfc_next_ascii_char () == ':')
11413 if (gfc_match_eos () == MATCH_YES
)
11418 m
= gfc_match_name (name
);
11419 if (m
!= MATCH_YES
)
11422 if (find_special (name
, &sym
, true))
11423 return MATCH_ERROR
;
11425 sym
->attr
.ext_attr
|= attr
.ext_attr
;
11427 if (gfc_match_eos () == MATCH_YES
)
11430 if (gfc_match_char (',') != MATCH_YES
)
11437 gfc_error ("Syntax error in !GCC$ ATTRIBUTES statement at %C");
11438 return MATCH_ERROR
;
11442 /* Match a !GCC$ UNROLL statement of the form:
11445 The parameter n is the number of times we are supposed to unroll.
11447 When we come here, we have already matched the !GCC$ UNROLL string. */
11449 gfc_match_gcc_unroll (void)
11453 if (gfc_match_small_int (&value
) == MATCH_YES
)
11455 if (value
< 0 || value
> USHRT_MAX
)
11457 gfc_error ("%<GCC unroll%> directive requires a"
11458 " non-negative integral constant"
11459 " less than or equal to %u at %C",
11462 return MATCH_ERROR
;
11464 if (gfc_match_eos () == MATCH_YES
)
11466 directive_unroll
= value
== 0 ? 1 : value
;
11471 gfc_error ("Syntax error in !GCC$ UNROLL directive at %C");
11472 return MATCH_ERROR
;
11475 /* Match a !GCC$ builtin (b) attributes simd flags if('target') form:
11477 The parameter b is name of a middle-end built-in.
11478 FLAGS is optional and must be one of:
11482 IF('target') is optional and TARGET is a name of a multilib ABI.
11484 When we come here, we have already matched the !GCC$ builtin string. */
11487 gfc_match_gcc_builtin (void)
11489 char builtin
[GFC_MAX_SYMBOL_LEN
+ 1];
11490 char target
[GFC_MAX_SYMBOL_LEN
+ 1];
11492 if (gfc_match (" ( %n ) attributes simd", builtin
) != MATCH_YES
)
11493 return MATCH_ERROR
;
11495 gfc_simd_clause clause
= SIMD_NONE
;
11496 if (gfc_match (" ( notinbranch ) ") == MATCH_YES
)
11497 clause
= SIMD_NOTINBRANCH
;
11498 else if (gfc_match (" ( inbranch ) ") == MATCH_YES
)
11499 clause
= SIMD_INBRANCH
;
11501 if (gfc_match (" if ( '%n' ) ", target
) == MATCH_YES
)
11503 const char *abi
= targetm
.get_multilib_abi_name ();
11504 if (abi
== NULL
|| strcmp (abi
, target
) != 0)
11508 if (gfc_vectorized_builtins
== NULL
)
11509 gfc_vectorized_builtins
= new hash_map
<nofree_string_hash
, int> ();
11511 char *r
= XNEWVEC (char, strlen (builtin
) + 32);
11512 sprintf (r
, "__builtin_%s", builtin
);
11515 int &value
= gfc_vectorized_builtins
->get_or_insert (r
, &existed
);