PR tree-optimization/86415 - strlen() not folded for substrings within constant arrays
[official-gcc.git] / gcc / fortran / decl.c
blob09541da2577909e9c46aec30fb14d308ed32ae46
1 /* Declaration statement matcher
2 Copyright (C) 2002-2018 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
10 version.
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
15 for more details.
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/>. */
21 #include "config.h"
22 #include "system.h"
23 #include "coretypes.h"
24 #include "options.h"
25 #include "tree.h"
26 #include "gfortran.h"
27 #include "stringpool.h"
28 #include "match.h"
29 #include "parse.h"
30 #include "constructor.h"
32 /* Macros to access allocate memory for gfc_data_variable,
33 gfc_data_value and gfc_data. */
34 #define gfc_get_data_variable() XCNEW (gfc_data_variable)
35 #define gfc_get_data_value() XCNEW (gfc_data_value)
36 #define gfc_get_data() XCNEW (gfc_data)
39 static bool set_binding_label (const char **, const char *, int);
42 /* This flag is set if an old-style length selector is matched
43 during a type-declaration statement. */
45 static int old_char_selector;
47 /* When variables acquire types and attributes from a declaration
48 statement, they get them from the following static variables. The
49 first part of a declaration sets these variables and the second
50 part copies these into symbol structures. */
52 static gfc_typespec current_ts;
54 static symbol_attribute current_attr;
55 static gfc_array_spec *current_as;
56 static int colon_seen;
57 static int attr_seen;
59 /* The current binding label (if any). */
60 static const char* curr_binding_label;
61 /* Need to know how many identifiers are on the current data declaration
62 line in case we're given the BIND(C) attribute with a NAME= specifier. */
63 static int num_idents_on_line;
64 /* Need to know if a NAME= specifier was found during gfc_match_bind_c so we
65 can supply a name if the curr_binding_label is nil and NAME= was not. */
66 static int has_name_equals = 0;
68 /* Initializer of the previous enumerator. */
70 static gfc_expr *last_initializer;
72 /* History of all the enumerators is maintained, so that
73 kind values of all the enumerators could be updated depending
74 upon the maximum initialized value. */
76 typedef struct enumerator_history
78 gfc_symbol *sym;
79 gfc_expr *initializer;
80 struct enumerator_history *next;
82 enumerator_history;
84 /* Header of enum history chain. */
86 static enumerator_history *enum_history = NULL;
88 /* Pointer of enum history node containing largest initializer. */
90 static enumerator_history *max_enum = NULL;
92 /* gfc_new_block points to the symbol of a newly matched block. */
94 gfc_symbol *gfc_new_block;
96 bool gfc_matching_function;
98 /* Set upon parsing a !GCC$ unroll n directive for use in the next loop. */
99 int directive_unroll = -1;
101 /* If a kind expression of a component of a parameterized derived type is
102 parameterized, temporarily store the expression here. */
103 static gfc_expr *saved_kind_expr = NULL;
105 /* Used to store the parameter list arising in a PDT declaration and
106 in the typespec of a PDT variable or component. */
107 static gfc_actual_arglist *decl_type_param_list;
108 static gfc_actual_arglist *type_param_spec_list;
110 /********************* DATA statement subroutines *********************/
112 static bool in_match_data = false;
114 bool
115 gfc_in_match_data (void)
117 return in_match_data;
120 static void
121 set_in_match_data (bool set_value)
123 in_match_data = set_value;
126 /* Free a gfc_data_variable structure and everything beneath it. */
128 static void
129 free_variable (gfc_data_variable *p)
131 gfc_data_variable *q;
133 for (; p; p = q)
135 q = p->next;
136 gfc_free_expr (p->expr);
137 gfc_free_iterator (&p->iter, 0);
138 free_variable (p->list);
139 free (p);
144 /* Free a gfc_data_value structure and everything beneath it. */
146 static void
147 free_value (gfc_data_value *p)
149 gfc_data_value *q;
151 for (; p; p = q)
153 q = p->next;
154 mpz_clear (p->repeat);
155 gfc_free_expr (p->expr);
156 free (p);
161 /* Free a list of gfc_data structures. */
163 void
164 gfc_free_data (gfc_data *p)
166 gfc_data *q;
168 for (; p; p = q)
170 q = p->next;
171 free_variable (p->var);
172 free_value (p->value);
173 free (p);
178 /* Free all data in a namespace. */
180 static void
181 gfc_free_data_all (gfc_namespace *ns)
183 gfc_data *d;
185 for (;ns->data;)
187 d = ns->data->next;
188 free (ns->data);
189 ns->data = d;
193 /* Reject data parsed since the last restore point was marked. */
195 void
196 gfc_reject_data (gfc_namespace *ns)
198 gfc_data *d;
200 while (ns->data && ns->data != ns->old_data)
202 d = ns->data->next;
203 free (ns->data);
204 ns->data = d;
208 static match var_element (gfc_data_variable *);
210 /* Match a list of variables terminated by an iterator and a right
211 parenthesis. */
213 static match
214 var_list (gfc_data_variable *parent)
216 gfc_data_variable *tail, var;
217 match m;
219 m = var_element (&var);
220 if (m == MATCH_ERROR)
221 return MATCH_ERROR;
222 if (m == MATCH_NO)
223 goto syntax;
225 tail = gfc_get_data_variable ();
226 *tail = var;
228 parent->list = tail;
230 for (;;)
232 if (gfc_match_char (',') != MATCH_YES)
233 goto syntax;
235 m = gfc_match_iterator (&parent->iter, 1);
236 if (m == MATCH_YES)
237 break;
238 if (m == MATCH_ERROR)
239 return MATCH_ERROR;
241 m = var_element (&var);
242 if (m == MATCH_ERROR)
243 return MATCH_ERROR;
244 if (m == MATCH_NO)
245 goto syntax;
247 tail->next = gfc_get_data_variable ();
248 tail = tail->next;
250 *tail = var;
253 if (gfc_match_char (')') != MATCH_YES)
254 goto syntax;
255 return MATCH_YES;
257 syntax:
258 gfc_syntax_error (ST_DATA);
259 return MATCH_ERROR;
263 /* Match a single element in a data variable list, which can be a
264 variable-iterator list. */
266 static match
267 var_element (gfc_data_variable *new_var)
269 match m;
270 gfc_symbol *sym;
272 memset (new_var, 0, sizeof (gfc_data_variable));
274 if (gfc_match_char ('(') == MATCH_YES)
275 return var_list (new_var);
277 m = gfc_match_variable (&new_var->expr, 0);
278 if (m != MATCH_YES)
279 return m;
281 sym = new_var->expr->symtree->n.sym;
283 /* Symbol should already have an associated type. */
284 if (!gfc_check_symbol_typed (sym, gfc_current_ns, false, gfc_current_locus))
285 return MATCH_ERROR;
287 if (!sym->attr.function && gfc_current_ns->parent
288 && gfc_current_ns->parent == sym->ns)
290 gfc_error ("Host associated variable %qs may not be in the DATA "
291 "statement at %C", sym->name);
292 return MATCH_ERROR;
295 if (gfc_current_state () != COMP_BLOCK_DATA
296 && sym->attr.in_common
297 && !gfc_notify_std (GFC_STD_GNU, "initialization of "
298 "common block variable %qs in DATA statement at %C",
299 sym->name))
300 return MATCH_ERROR;
302 if (!gfc_add_data (&sym->attr, sym->name, &new_var->expr->where))
303 return MATCH_ERROR;
305 return MATCH_YES;
309 /* Match the top-level list of data variables. */
311 static match
312 top_var_list (gfc_data *d)
314 gfc_data_variable var, *tail, *new_var;
315 match m;
317 tail = NULL;
319 for (;;)
321 m = var_element (&var);
322 if (m == MATCH_NO)
323 goto syntax;
324 if (m == MATCH_ERROR)
325 return MATCH_ERROR;
327 new_var = gfc_get_data_variable ();
328 *new_var = var;
330 if (tail == NULL)
331 d->var = new_var;
332 else
333 tail->next = new_var;
335 tail = new_var;
337 if (gfc_match_char ('/') == MATCH_YES)
338 break;
339 if (gfc_match_char (',') != MATCH_YES)
340 goto syntax;
343 return MATCH_YES;
345 syntax:
346 gfc_syntax_error (ST_DATA);
347 gfc_free_data_all (gfc_current_ns);
348 return MATCH_ERROR;
352 static match
353 match_data_constant (gfc_expr **result)
355 char name[GFC_MAX_SYMBOL_LEN + 1];
356 gfc_symbol *sym, *dt_sym = NULL;
357 gfc_expr *expr;
358 match m;
359 locus old_loc;
361 m = gfc_match_literal_constant (&expr, 1);
362 if (m == MATCH_YES)
364 *result = expr;
365 return MATCH_YES;
368 if (m == MATCH_ERROR)
369 return MATCH_ERROR;
371 m = gfc_match_null (result);
372 if (m != MATCH_NO)
373 return m;
375 old_loc = gfc_current_locus;
377 /* Should this be a structure component, try to match it
378 before matching a name. */
379 m = gfc_match_rvalue (result);
380 if (m == MATCH_ERROR)
381 return m;
383 if (m == MATCH_YES && (*result)->expr_type == EXPR_STRUCTURE)
385 if (!gfc_simplify_expr (*result, 0))
386 m = MATCH_ERROR;
387 return m;
389 else if (m == MATCH_YES)
391 /* F2018:R845 data-stmt-constant is initial-data-target.
392 A data-stmt-constant shall be ... initial-data-target if and
393 only if the corresponding data-stmt-object has the POINTER
394 attribute. ... If data-stmt-constant is initial-data-target
395 the corresponding data statement object shall be
396 data-pointer-initialization compatible (7.5.4.6) with the initial
397 data target; the data statement object is initially associated
398 with the target. */
399 if ((*result)->symtree->n.sym->attr.save
400 && (*result)->symtree->n.sym->attr.target)
401 return m;
402 gfc_free_expr (*result);
405 gfc_current_locus = old_loc;
407 m = gfc_match_name (name);
408 if (m != MATCH_YES)
409 return m;
411 if (gfc_find_symbol (name, NULL, 1, &sym))
412 return MATCH_ERROR;
414 if (sym && sym->attr.generic)
415 dt_sym = gfc_find_dt_in_generic (sym);
417 if (sym == NULL
418 || (sym->attr.flavor != FL_PARAMETER
419 && (!dt_sym || !gfc_fl_struct (dt_sym->attr.flavor))))
421 gfc_error ("Symbol %qs must be a PARAMETER in DATA statement at %C",
422 name);
423 *result = NULL;
424 return MATCH_ERROR;
426 else if (dt_sym && gfc_fl_struct (dt_sym->attr.flavor))
427 return gfc_match_structure_constructor (dt_sym, result);
429 /* Check to see if the value is an initialization array expression. */
430 if (sym->value->expr_type == EXPR_ARRAY)
432 gfc_current_locus = old_loc;
434 m = gfc_match_init_expr (result);
435 if (m == MATCH_ERROR)
436 return m;
438 if (m == MATCH_YES)
440 if (!gfc_simplify_expr (*result, 0))
441 m = MATCH_ERROR;
443 if ((*result)->expr_type == EXPR_CONSTANT)
444 return m;
445 else
447 gfc_error ("Invalid initializer %s in Data statement at %C", name);
448 return MATCH_ERROR;
453 *result = gfc_copy_expr (sym->value);
454 return MATCH_YES;
458 /* Match a list of values in a DATA statement. The leading '/' has
459 already been seen at this point. */
461 static match
462 top_val_list (gfc_data *data)
464 gfc_data_value *new_val, *tail;
465 gfc_expr *expr;
466 match m;
468 tail = NULL;
470 for (;;)
472 m = match_data_constant (&expr);
473 if (m == MATCH_NO)
474 goto syntax;
475 if (m == MATCH_ERROR)
476 return MATCH_ERROR;
478 new_val = gfc_get_data_value ();
479 mpz_init (new_val->repeat);
481 if (tail == NULL)
482 data->value = new_val;
483 else
484 tail->next = new_val;
486 tail = new_val;
488 if (expr->ts.type != BT_INTEGER || gfc_match_char ('*') != MATCH_YES)
490 tail->expr = expr;
491 mpz_set_ui (tail->repeat, 1);
493 else
495 mpz_set (tail->repeat, expr->value.integer);
496 gfc_free_expr (expr);
498 m = match_data_constant (&tail->expr);
499 if (m == MATCH_NO)
500 goto syntax;
501 if (m == MATCH_ERROR)
502 return MATCH_ERROR;
505 if (gfc_match_char ('/') == MATCH_YES)
506 break;
507 if (gfc_match_char (',') == MATCH_NO)
508 goto syntax;
511 return MATCH_YES;
513 syntax:
514 gfc_syntax_error (ST_DATA);
515 gfc_free_data_all (gfc_current_ns);
516 return MATCH_ERROR;
520 /* Matches an old style initialization. */
522 static match
523 match_old_style_init (const char *name)
525 match m;
526 gfc_symtree *st;
527 gfc_symbol *sym;
528 gfc_data *newdata;
530 /* Set up data structure to hold initializers. */
531 gfc_find_sym_tree (name, NULL, 0, &st);
532 sym = st->n.sym;
534 newdata = gfc_get_data ();
535 newdata->var = gfc_get_data_variable ();
536 newdata->var->expr = gfc_get_variable_expr (st);
537 newdata->where = gfc_current_locus;
539 /* Match initial value list. This also eats the terminal '/'. */
540 m = top_val_list (newdata);
541 if (m != MATCH_YES)
543 free (newdata);
544 return m;
547 if (gfc_pure (NULL))
549 gfc_error ("Initialization at %C is not allowed in a PURE procedure");
550 free (newdata);
551 return MATCH_ERROR;
553 gfc_unset_implicit_pure (gfc_current_ns->proc_name);
555 /* Mark the variable as having appeared in a data statement. */
556 if (!gfc_add_data (&sym->attr, sym->name, &sym->declared_at))
558 free (newdata);
559 return MATCH_ERROR;
562 /* Chain in namespace list of DATA initializers. */
563 newdata->next = gfc_current_ns->data;
564 gfc_current_ns->data = newdata;
566 return m;
570 /* Match the stuff following a DATA statement. If ERROR_FLAG is set,
571 we are matching a DATA statement and are therefore issuing an error
572 if we encounter something unexpected, if not, we're trying to match
573 an old-style initialization expression of the form INTEGER I /2/. */
575 match
576 gfc_match_data (void)
578 gfc_data *new_data;
579 match m;
581 /* Before parsing the rest of a DATA statement, check F2008:c1206. */
582 if ((gfc_current_state () == COMP_FUNCTION
583 || gfc_current_state () == COMP_SUBROUTINE)
584 && gfc_state_stack->previous->state == COMP_INTERFACE)
586 gfc_error ("DATA statement at %C cannot appear within an INTERFACE");
587 return MATCH_ERROR;
590 set_in_match_data (true);
592 for (;;)
594 new_data = gfc_get_data ();
595 new_data->where = gfc_current_locus;
597 m = top_var_list (new_data);
598 if (m != MATCH_YES)
599 goto cleanup;
601 if (new_data->var->iter.var
602 && new_data->var->iter.var->ts.type == BT_INTEGER
603 && new_data->var->iter.var->symtree->n.sym->attr.implied_index == 1
604 && new_data->var->list
605 && new_data->var->list->expr
606 && new_data->var->list->expr->ts.type == BT_CHARACTER
607 && new_data->var->list->expr->ref
608 && new_data->var->list->expr->ref->type == REF_SUBSTRING)
610 gfc_error ("Invalid substring in data-implied-do at %L in DATA "
611 "statement", &new_data->var->list->expr->where);
612 goto cleanup;
615 m = top_val_list (new_data);
616 if (m != MATCH_YES)
617 goto cleanup;
619 new_data->next = gfc_current_ns->data;
620 gfc_current_ns->data = new_data;
622 if (gfc_match_eos () == MATCH_YES)
623 break;
625 gfc_match_char (','); /* Optional comma */
628 set_in_match_data (false);
630 if (gfc_pure (NULL))
632 gfc_error ("DATA statement at %C is not allowed in a PURE procedure");
633 return MATCH_ERROR;
635 gfc_unset_implicit_pure (gfc_current_ns->proc_name);
637 return MATCH_YES;
639 cleanup:
640 set_in_match_data (false);
641 gfc_free_data (new_data);
642 return MATCH_ERROR;
646 /************************ Declaration statements *********************/
649 /* Like gfc_match_init_expr, but matches a 'clist' (old-style initialization
650 list). The difference here is the expression is a list of constants
651 and is surrounded by '/'.
652 The typespec ts must match the typespec of the variable which the
653 clist is initializing.
654 The arrayspec tells whether this should match a list of constants
655 corresponding to array elements or a scalar (as == NULL). */
657 static match
658 match_clist_expr (gfc_expr **result, gfc_typespec *ts, gfc_array_spec *as)
660 gfc_constructor_base array_head = NULL;
661 gfc_expr *expr = NULL;
662 match m;
663 locus where;
664 mpz_t repeat, cons_size, as_size;
665 bool scalar;
666 int cmp;
668 gcc_assert (ts);
670 mpz_init_set_ui (repeat, 0);
671 scalar = !as || !as->rank;
673 /* We have already matched '/' - now look for a constant list, as with
674 top_val_list from decl.c, but append the result to an array. */
675 if (gfc_match ("/") == MATCH_YES)
677 gfc_error ("Empty old style initializer list at %C");
678 goto cleanup;
681 where = gfc_current_locus;
682 for (;;)
684 m = match_data_constant (&expr);
685 if (m != MATCH_YES)
686 expr = NULL; /* match_data_constant may set expr to garbage */
687 if (m == MATCH_NO)
688 goto syntax;
689 if (m == MATCH_ERROR)
690 goto cleanup;
692 /* Found r in repeat spec r*c; look for the constant to repeat. */
693 if ( gfc_match_char ('*') == MATCH_YES)
695 if (scalar)
697 gfc_error ("Repeat spec invalid in scalar initializer at %C");
698 goto cleanup;
700 if (expr->ts.type != BT_INTEGER)
702 gfc_error ("Repeat spec must be an integer at %C");
703 goto cleanup;
705 mpz_set (repeat, expr->value.integer);
706 gfc_free_expr (expr);
707 expr = NULL;
709 m = match_data_constant (&expr);
710 if (m == MATCH_NO)
711 gfc_error ("Expected data constant after repeat spec at %C");
712 if (m != MATCH_YES)
713 goto cleanup;
715 /* No repeat spec, we matched the data constant itself. */
716 else
717 mpz_set_ui (repeat, 1);
719 if (!scalar)
721 /* Add the constant initializer as many times as repeated. */
722 for (; mpz_cmp_ui (repeat, 0) > 0; mpz_sub_ui (repeat, repeat, 1))
724 /* Make sure types of elements match */
725 if(ts && !gfc_compare_types (&expr->ts, ts)
726 && !gfc_convert_type (expr, ts, 1))
727 goto cleanup;
729 gfc_constructor_append_expr (&array_head,
730 gfc_copy_expr (expr), &gfc_current_locus);
733 gfc_free_expr (expr);
734 expr = NULL;
737 /* For scalar initializers quit after one element. */
738 else
740 if(gfc_match_char ('/') != MATCH_YES)
742 gfc_error ("End of scalar initializer expected at %C");
743 goto cleanup;
745 break;
748 if (gfc_match_char ('/') == MATCH_YES)
749 break;
750 if (gfc_match_char (',') == MATCH_NO)
751 goto syntax;
754 /* Set up expr as an array constructor. */
755 if (!scalar)
757 expr = gfc_get_array_expr (ts->type, ts->kind, &where);
758 expr->ts = *ts;
759 expr->value.constructor = array_head;
761 expr->rank = as->rank;
762 expr->shape = gfc_get_shape (expr->rank);
764 /* Validate sizes. We built expr ourselves, so cons_size will be
765 constant (we fail above for non-constant expressions).
766 We still need to verify that the array-spec has constant size. */
767 cmp = 0;
768 gcc_assert (gfc_array_size (expr, &cons_size));
769 if (!spec_size (as, &as_size))
771 gfc_error ("Expected constant array-spec in initializer list at %L",
772 as->type == AS_EXPLICIT ? &as->upper[0]->where : &where);
773 cmp = -1;
775 else
777 /* Make sure the specs are of the same size. */
778 cmp = mpz_cmp (cons_size, as_size);
779 if (cmp < 0)
780 gfc_error ("Not enough elements in array initializer at %C");
781 else if (cmp > 0)
782 gfc_error ("Too many elements in array initializer at %C");
783 mpz_clear (as_size);
785 mpz_clear (cons_size);
786 if (cmp)
787 goto cleanup;
790 /* Make sure scalar types match. */
791 else if (!gfc_compare_types (&expr->ts, ts)
792 && !gfc_convert_type (expr, ts, 1))
793 goto cleanup;
795 if (expr->ts.u.cl)
796 expr->ts.u.cl->length_from_typespec = 1;
798 *result = expr;
799 mpz_clear (repeat);
800 return MATCH_YES;
802 syntax:
803 gfc_error ("Syntax error in old style initializer list at %C");
805 cleanup:
806 if (expr)
807 expr->value.constructor = NULL;
808 gfc_free_expr (expr);
809 gfc_constructor_free (array_head);
810 mpz_clear (repeat);
811 return MATCH_ERROR;
815 /* Auxiliary function to merge DIMENSION and CODIMENSION array specs. */
817 static bool
818 merge_array_spec (gfc_array_spec *from, gfc_array_spec *to, bool copy)
820 int i, j;
822 if ((from->type == AS_ASSUMED_RANK && to->corank)
823 || (to->type == AS_ASSUMED_RANK && from->corank))
825 gfc_error ("The assumed-rank array at %C shall not have a codimension");
826 return false;
829 if (to->rank == 0 && from->rank > 0)
831 to->rank = from->rank;
832 to->type = from->type;
833 to->cray_pointee = from->cray_pointee;
834 to->cp_was_assumed = from->cp_was_assumed;
836 for (i = 0; i < to->corank; i++)
838 /* Do not exceed the limits on lower[] and upper[]. gfortran
839 cleans up elsewhere. */
840 j = from->rank + i;
841 if (j >= GFC_MAX_DIMENSIONS)
842 break;
844 to->lower[j] = to->lower[i];
845 to->upper[j] = to->upper[i];
847 for (i = 0; i < from->rank; i++)
849 if (copy)
851 to->lower[i] = gfc_copy_expr (from->lower[i]);
852 to->upper[i] = gfc_copy_expr (from->upper[i]);
854 else
856 to->lower[i] = from->lower[i];
857 to->upper[i] = from->upper[i];
861 else if (to->corank == 0 && from->corank > 0)
863 to->corank = from->corank;
864 to->cotype = from->cotype;
866 for (i = 0; i < from->corank; i++)
868 /* Do not exceed the limits on lower[] and upper[]. gfortran
869 cleans up elsewhere. */
870 j = to->rank + i;
871 if (j >= GFC_MAX_DIMENSIONS)
872 break;
874 if (copy)
876 to->lower[j] = gfc_copy_expr (from->lower[i]);
877 to->upper[j] = gfc_copy_expr (from->upper[i]);
879 else
881 to->lower[j] = from->lower[i];
882 to->upper[j] = from->upper[i];
887 if (to->rank + to->corank > GFC_MAX_DIMENSIONS)
889 gfc_error ("Sum of array rank %d and corank %d at %C exceeds maximum "
890 "allowed dimensions of %d",
891 to->rank, to->corank, GFC_MAX_DIMENSIONS);
892 to->corank = GFC_MAX_DIMENSIONS - to->rank;
893 return false;
895 return true;
899 /* Match an intent specification. Since this can only happen after an
900 INTENT word, a legal intent-spec must follow. */
902 static sym_intent
903 match_intent_spec (void)
906 if (gfc_match (" ( in out )") == MATCH_YES)
907 return INTENT_INOUT;
908 if (gfc_match (" ( in )") == MATCH_YES)
909 return INTENT_IN;
910 if (gfc_match (" ( out )") == MATCH_YES)
911 return INTENT_OUT;
913 gfc_error ("Bad INTENT specification at %C");
914 return INTENT_UNKNOWN;
918 /* Matches a character length specification, which is either a
919 specification expression, '*', or ':'. */
921 static match
922 char_len_param_value (gfc_expr **expr, bool *deferred)
924 match m;
926 *expr = NULL;
927 *deferred = false;
929 if (gfc_match_char ('*') == MATCH_YES)
930 return MATCH_YES;
932 if (gfc_match_char (':') == MATCH_YES)
934 if (!gfc_notify_std (GFC_STD_F2003, "deferred type parameter at %C"))
935 return MATCH_ERROR;
937 *deferred = true;
939 return MATCH_YES;
942 m = gfc_match_expr (expr);
944 if (m == MATCH_NO || m == MATCH_ERROR)
945 return m;
947 if (!gfc_expr_check_typed (*expr, gfc_current_ns, false))
948 return MATCH_ERROR;
950 if ((*expr)->expr_type == EXPR_FUNCTION)
952 if ((*expr)->ts.type == BT_INTEGER
953 || ((*expr)->ts.type == BT_UNKNOWN
954 && strcmp((*expr)->symtree->name, "null") != 0))
955 return MATCH_YES;
957 goto syntax;
959 else if ((*expr)->expr_type == EXPR_CONSTANT)
961 /* F2008, 4.4.3.1: The length is a type parameter; its kind is
962 processor dependent and its value is greater than or equal to zero.
963 F2008, 4.4.3.2: If the character length parameter value evaluates
964 to a negative value, the length of character entities declared
965 is zero. */
967 if ((*expr)->ts.type == BT_INTEGER)
969 if (mpz_cmp_si ((*expr)->value.integer, 0) < 0)
970 mpz_set_si ((*expr)->value.integer, 0);
972 else
973 goto syntax;
975 else if ((*expr)->expr_type == EXPR_ARRAY)
976 goto syntax;
977 else if ((*expr)->expr_type == EXPR_VARIABLE)
979 bool t;
980 gfc_expr *e;
982 e = gfc_copy_expr (*expr);
984 /* This catches the invalid code "[character(m(2:3)) :: 'x', 'y']",
985 which causes an ICE if gfc_reduce_init_expr() is called. */
986 if (e->ref && e->ref->type == REF_ARRAY
987 && e->ref->u.ar.type == AR_UNKNOWN
988 && e->ref->u.ar.dimen_type[0] == DIMEN_RANGE)
989 goto syntax;
991 t = gfc_reduce_init_expr (e);
993 if (!t && e->ts.type == BT_UNKNOWN
994 && e->symtree->n.sym->attr.untyped == 1
995 && (flag_implicit_none
996 || e->symtree->n.sym->ns->seen_implicit_none == 1
997 || e->symtree->n.sym->ns->parent->seen_implicit_none == 1))
999 gfc_free_expr (e);
1000 goto syntax;
1003 if ((e->ref && e->ref->type == REF_ARRAY
1004 && e->ref->u.ar.type != AR_ELEMENT)
1005 || (!e->ref && e->expr_type == EXPR_ARRAY))
1007 gfc_free_expr (e);
1008 goto syntax;
1011 gfc_free_expr (e);
1014 return m;
1016 syntax:
1017 gfc_error ("Scalar INTEGER expression expected at %L", &(*expr)->where);
1018 return MATCH_ERROR;
1022 /* A character length is a '*' followed by a literal integer or a
1023 char_len_param_value in parenthesis. */
1025 static match
1026 match_char_length (gfc_expr **expr, bool *deferred, bool obsolescent_check)
1028 int length;
1029 match m;
1031 *deferred = false;
1032 m = gfc_match_char ('*');
1033 if (m != MATCH_YES)
1034 return m;
1036 m = gfc_match_small_literal_int (&length, NULL);
1037 if (m == MATCH_ERROR)
1038 return m;
1040 if (m == MATCH_YES)
1042 if (obsolescent_check
1043 && !gfc_notify_std (GFC_STD_F95_OBS, "Old-style character length at %C"))
1044 return MATCH_ERROR;
1045 *expr = gfc_get_int_expr (gfc_charlen_int_kind, NULL, length);
1046 return m;
1049 if (gfc_match_char ('(') == MATCH_NO)
1050 goto syntax;
1052 m = char_len_param_value (expr, deferred);
1053 if (m != MATCH_YES && gfc_matching_function)
1055 gfc_undo_symbols ();
1056 m = MATCH_YES;
1059 if (m == MATCH_ERROR)
1060 return m;
1061 if (m == MATCH_NO)
1062 goto syntax;
1064 if (gfc_match_char (')') == MATCH_NO)
1066 gfc_free_expr (*expr);
1067 *expr = NULL;
1068 goto syntax;
1071 return MATCH_YES;
1073 syntax:
1074 gfc_error ("Syntax error in character length specification at %C");
1075 return MATCH_ERROR;
1079 /* Special subroutine for finding a symbol. Check if the name is found
1080 in the current name space. If not, and we're compiling a function or
1081 subroutine and the parent compilation unit is an interface, then check
1082 to see if the name we've been given is the name of the interface
1083 (located in another namespace). */
1085 static int
1086 find_special (const char *name, gfc_symbol **result, bool allow_subroutine)
1088 gfc_state_data *s;
1089 gfc_symtree *st;
1090 int i;
1092 i = gfc_get_sym_tree (name, NULL, &st, allow_subroutine);
1093 if (i == 0)
1095 *result = st ? st->n.sym : NULL;
1096 goto end;
1099 if (gfc_current_state () != COMP_SUBROUTINE
1100 && gfc_current_state () != COMP_FUNCTION)
1101 goto end;
1103 s = gfc_state_stack->previous;
1104 if (s == NULL)
1105 goto end;
1107 if (s->state != COMP_INTERFACE)
1108 goto end;
1109 if (s->sym == NULL)
1110 goto end; /* Nameless interface. */
1112 if (strcmp (name, s->sym->name) == 0)
1114 *result = s->sym;
1115 return 0;
1118 end:
1119 return i;
1123 /* Special subroutine for getting a symbol node associated with a
1124 procedure name, used in SUBROUTINE and FUNCTION statements. The
1125 symbol is created in the parent using with symtree node in the
1126 child unit pointing to the symbol. If the current namespace has no
1127 parent, then the symbol is just created in the current unit. */
1129 static int
1130 get_proc_name (const char *name, gfc_symbol **result, bool module_fcn_entry)
1132 gfc_symtree *st;
1133 gfc_symbol *sym;
1134 int rc = 0;
1136 /* Module functions have to be left in their own namespace because
1137 they have potentially (almost certainly!) already been referenced.
1138 In this sense, they are rather like external functions. This is
1139 fixed up in resolve.c(resolve_entries), where the symbol name-
1140 space is set to point to the master function, so that the fake
1141 result mechanism can work. */
1142 if (module_fcn_entry)
1144 /* Present if entry is declared to be a module procedure. */
1145 rc = gfc_find_symbol (name, gfc_current_ns->parent, 0, result);
1147 if (*result == NULL)
1148 rc = gfc_get_symbol (name, NULL, result);
1149 else if (!gfc_get_symbol (name, NULL, &sym) && sym
1150 && (*result)->ts.type == BT_UNKNOWN
1151 && sym->attr.flavor == FL_UNKNOWN)
1152 /* Pick up the typespec for the entry, if declared in the function
1153 body. Note that this symbol is FL_UNKNOWN because it will
1154 only have appeared in a type declaration. The local symtree
1155 is set to point to the module symbol and a unique symtree
1156 to the local version. This latter ensures a correct clearing
1157 of the symbols. */
1159 /* If the ENTRY proceeds its specification, we need to ensure
1160 that this does not raise a "has no IMPLICIT type" error. */
1161 if (sym->ts.type == BT_UNKNOWN)
1162 sym->attr.untyped = 1;
1164 (*result)->ts = sym->ts;
1166 /* Put the symbol in the procedure namespace so that, should
1167 the ENTRY precede its specification, the specification
1168 can be applied. */
1169 (*result)->ns = gfc_current_ns;
1171 gfc_find_sym_tree (name, gfc_current_ns, 0, &st);
1172 st->n.sym = *result;
1173 st = gfc_get_unique_symtree (gfc_current_ns);
1174 sym->refs++;
1175 st->n.sym = sym;
1178 else
1179 rc = gfc_get_symbol (name, gfc_current_ns->parent, result);
1181 if (rc)
1182 return rc;
1184 sym = *result;
1185 if (sym->attr.proc == PROC_ST_FUNCTION)
1186 return rc;
1188 if (sym->attr.module_procedure && sym->attr.if_source == IFSRC_IFBODY)
1190 /* Create a partially populated interface symbol to carry the
1191 characteristics of the procedure and the result. */
1192 sym->tlink = gfc_new_symbol (name, sym->ns);
1193 gfc_add_type (sym->tlink, &(sym->ts), &gfc_current_locus);
1194 gfc_copy_attr (&sym->tlink->attr, &sym->attr, NULL);
1195 if (sym->attr.dimension)
1196 sym->tlink->as = gfc_copy_array_spec (sym->as);
1198 /* Ideally, at this point, a copy would be made of the formal
1199 arguments and their namespace. However, this does not appear
1200 to be necessary, albeit at the expense of not being able to
1201 use gfc_compare_interfaces directly. */
1203 if (sym->result && sym->result != sym)
1205 sym->tlink->result = sym->result;
1206 sym->result = NULL;
1208 else if (sym->result)
1210 sym->tlink->result = sym->tlink;
1213 else if (sym && !sym->gfc_new
1214 && gfc_current_state () != COMP_INTERFACE)
1216 /* Trap another encompassed procedure with the same name. All
1217 these conditions are necessary to avoid picking up an entry
1218 whose name clashes with that of the encompassing procedure;
1219 this is handled using gsymbols to register unique, globally
1220 accessible names. */
1221 if (sym->attr.flavor != 0
1222 && sym->attr.proc != 0
1223 && (sym->attr.subroutine || sym->attr.function || sym->attr.entry)
1224 && sym->attr.if_source != IFSRC_UNKNOWN)
1225 gfc_error_now ("Procedure %qs at %C is already defined at %L",
1226 name, &sym->declared_at);
1228 if (sym->attr.flavor != 0
1229 && sym->attr.entry && sym->attr.if_source != IFSRC_UNKNOWN)
1230 gfc_error_now ("Procedure %qs at %C is already defined at %L",
1231 name, &sym->declared_at);
1233 if (sym->attr.external && sym->attr.procedure
1234 && gfc_current_state () == COMP_CONTAINS)
1235 gfc_error_now ("Contained procedure %qs at %C clashes with "
1236 "procedure defined at %L",
1237 name, &sym->declared_at);
1239 /* Trap a procedure with a name the same as interface in the
1240 encompassing scope. */
1241 if (sym->attr.generic != 0
1242 && (sym->attr.subroutine || sym->attr.function)
1243 && !sym->attr.mod_proc)
1244 gfc_error_now ("Name %qs at %C is already defined"
1245 " as a generic interface at %L",
1246 name, &sym->declared_at);
1248 /* Trap declarations of attributes in encompassing scope. The
1249 signature for this is that ts.kind is set. Legitimate
1250 references only set ts.type. */
1251 if (sym->ts.kind != 0
1252 && !sym->attr.implicit_type
1253 && sym->attr.proc == 0
1254 && gfc_current_ns->parent != NULL
1255 && sym->attr.access == 0
1256 && !module_fcn_entry)
1257 gfc_error_now ("Procedure %qs at %C has an explicit interface "
1258 "from a previous declaration", name);
1261 /* C1246 (R1225) MODULE shall appear only in the function-stmt or
1262 subroutine-stmt of a module subprogram or of a nonabstract interface
1263 body that is declared in the scoping unit of a module or submodule. */
1264 if (sym->attr.external
1265 && (sym->attr.subroutine || sym->attr.function)
1266 && sym->attr.if_source == IFSRC_IFBODY
1267 && !current_attr.module_procedure
1268 && sym->attr.proc == PROC_MODULE
1269 && gfc_state_stack->state == COMP_CONTAINS)
1270 gfc_error_now ("Procedure %qs defined in interface body at %L "
1271 "clashes with internal procedure defined at %C",
1272 name, &sym->declared_at);
1274 if (sym && !sym->gfc_new
1275 && sym->attr.flavor != FL_UNKNOWN
1276 && sym->attr.referenced == 0 && sym->attr.subroutine == 1
1277 && gfc_state_stack->state == COMP_CONTAINS
1278 && gfc_state_stack->previous->state == COMP_SUBROUTINE)
1279 gfc_error_now ("Procedure %qs at %C is already defined at %L",
1280 name, &sym->declared_at);
1282 if (gfc_current_ns->parent == NULL || *result == NULL)
1283 return rc;
1285 /* Module function entries will already have a symtree in
1286 the current namespace but will need one at module level. */
1287 if (module_fcn_entry)
1289 /* Present if entry is declared to be a module procedure. */
1290 rc = gfc_find_sym_tree (name, gfc_current_ns->parent, 0, &st);
1291 if (st == NULL)
1292 st = gfc_new_symtree (&gfc_current_ns->parent->sym_root, name);
1294 else
1295 st = gfc_new_symtree (&gfc_current_ns->sym_root, name);
1297 st->n.sym = sym;
1298 sym->refs++;
1300 /* See if the procedure should be a module procedure. */
1302 if (((sym->ns->proc_name != NULL
1303 && sym->ns->proc_name->attr.flavor == FL_MODULE
1304 && sym->attr.proc != PROC_MODULE)
1305 || (module_fcn_entry && sym->attr.proc != PROC_MODULE))
1306 && !gfc_add_procedure (&sym->attr, PROC_MODULE, sym->name, NULL))
1307 rc = 2;
1309 return rc;
1313 /* Verify that the given symbol representing a parameter is C
1314 interoperable, by checking to see if it was marked as such after
1315 its declaration. If the given symbol is not interoperable, a
1316 warning is reported, thus removing the need to return the status to
1317 the calling function. The standard does not require the user use
1318 one of the iso_c_binding named constants to declare an
1319 interoperable parameter, but we can't be sure if the param is C
1320 interop or not if the user doesn't. For example, integer(4) may be
1321 legal Fortran, but doesn't have meaning in C. It may interop with
1322 a number of the C types, which causes a problem because the
1323 compiler can't know which one. This code is almost certainly not
1324 portable, and the user will get what they deserve if the C type
1325 across platforms isn't always interoperable with integer(4). If
1326 the user had used something like integer(c_int) or integer(c_long),
1327 the compiler could have automatically handled the varying sizes
1328 across platforms. */
1330 bool
1331 gfc_verify_c_interop_param (gfc_symbol *sym)
1333 int is_c_interop = 0;
1334 bool retval = true;
1336 /* We check implicitly typed variables in symbol.c:gfc_set_default_type().
1337 Don't repeat the checks here. */
1338 if (sym->attr.implicit_type)
1339 return true;
1341 /* For subroutines or functions that are passed to a BIND(C) procedure,
1342 they're interoperable if they're BIND(C) and their params are all
1343 interoperable. */
1344 if (sym->attr.flavor == FL_PROCEDURE)
1346 if (sym->attr.is_bind_c == 0)
1348 gfc_error_now ("Procedure %qs at %L must have the BIND(C) "
1349 "attribute to be C interoperable", sym->name,
1350 &(sym->declared_at));
1351 return false;
1353 else
1355 if (sym->attr.is_c_interop == 1)
1356 /* We've already checked this procedure; don't check it again. */
1357 return true;
1358 else
1359 return verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
1360 sym->common_block);
1364 /* See if we've stored a reference to a procedure that owns sym. */
1365 if (sym->ns != NULL && sym->ns->proc_name != NULL)
1367 if (sym->ns->proc_name->attr.is_bind_c == 1)
1369 is_c_interop = (gfc_verify_c_interop(&(sym->ts)) ? 1 : 0);
1371 if (is_c_interop != 1)
1373 /* Make personalized messages to give better feedback. */
1374 if (sym->ts.type == BT_DERIVED)
1375 gfc_error ("Variable %qs at %L is a dummy argument to the "
1376 "BIND(C) procedure %qs but is not C interoperable "
1377 "because derived type %qs is not C interoperable",
1378 sym->name, &(sym->declared_at),
1379 sym->ns->proc_name->name,
1380 sym->ts.u.derived->name);
1381 else if (sym->ts.type == BT_CLASS)
1382 gfc_error ("Variable %qs at %L is a dummy argument to the "
1383 "BIND(C) procedure %qs but is not C interoperable "
1384 "because it is polymorphic",
1385 sym->name, &(sym->declared_at),
1386 sym->ns->proc_name->name);
1387 else if (warn_c_binding_type)
1388 gfc_warning (OPT_Wc_binding_type,
1389 "Variable %qs at %L is a dummy argument of the "
1390 "BIND(C) procedure %qs but may not be C "
1391 "interoperable",
1392 sym->name, &(sym->declared_at),
1393 sym->ns->proc_name->name);
1396 /* Character strings are only C interoperable if they have a
1397 length of 1. */
1398 if (sym->ts.type == BT_CHARACTER)
1400 gfc_charlen *cl = sym->ts.u.cl;
1401 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT
1402 || mpz_cmp_si (cl->length->value.integer, 1) != 0)
1404 gfc_error ("Character argument %qs at %L "
1405 "must be length 1 because "
1406 "procedure %qs is BIND(C)",
1407 sym->name, &sym->declared_at,
1408 sym->ns->proc_name->name);
1409 retval = false;
1413 /* We have to make sure that any param to a bind(c) routine does
1414 not have the allocatable, pointer, or optional attributes,
1415 according to J3/04-007, section 5.1. */
1416 if (sym->attr.allocatable == 1
1417 && !gfc_notify_std (GFC_STD_F2018, "Variable %qs at %L with "
1418 "ALLOCATABLE attribute in procedure %qs "
1419 "with BIND(C)", sym->name,
1420 &(sym->declared_at),
1421 sym->ns->proc_name->name))
1422 retval = false;
1424 if (sym->attr.pointer == 1
1425 && !gfc_notify_std (GFC_STD_F2018, "Variable %qs at %L with "
1426 "POINTER attribute in procedure %qs "
1427 "with BIND(C)", sym->name,
1428 &(sym->declared_at),
1429 sym->ns->proc_name->name))
1430 retval = false;
1432 if ((sym->attr.allocatable || sym->attr.pointer) && !sym->as)
1434 gfc_error ("Scalar variable %qs at %L with POINTER or "
1435 "ALLOCATABLE in procedure %qs with BIND(C) is not yet"
1436 " supported", sym->name, &(sym->declared_at),
1437 sym->ns->proc_name->name);
1438 retval = false;
1441 if (sym->attr.optional == 1 && sym->attr.value)
1443 gfc_error ("Variable %qs at %L cannot have both the OPTIONAL "
1444 "and the VALUE attribute because procedure %qs "
1445 "is BIND(C)", sym->name, &(sym->declared_at),
1446 sym->ns->proc_name->name);
1447 retval = false;
1449 else if (sym->attr.optional == 1
1450 && !gfc_notify_std (GFC_STD_F2018, "Variable %qs "
1451 "at %L with OPTIONAL attribute in "
1452 "procedure %qs which is BIND(C)",
1453 sym->name, &(sym->declared_at),
1454 sym->ns->proc_name->name))
1455 retval = false;
1457 /* Make sure that if it has the dimension attribute, that it is
1458 either assumed size or explicit shape. Deferred shape is already
1459 covered by the pointer/allocatable attribute. */
1460 if (sym->as != NULL && sym->as->type == AS_ASSUMED_SHAPE
1461 && !gfc_notify_std (GFC_STD_F2018, "Assumed-shape array %qs "
1462 "at %L as dummy argument to the BIND(C) "
1463 "procedure %qs at %L", sym->name,
1464 &(sym->declared_at),
1465 sym->ns->proc_name->name,
1466 &(sym->ns->proc_name->declared_at)))
1467 retval = false;
1471 return retval;
1476 /* Function called by variable_decl() that adds a name to the symbol table. */
1478 static bool
1479 build_sym (const char *name, gfc_charlen *cl, bool cl_deferred,
1480 gfc_array_spec **as, locus *var_locus)
1482 symbol_attribute attr;
1483 gfc_symbol *sym;
1484 int upper;
1485 gfc_symtree *st;
1487 /* Symbols in a submodule are host associated from the parent module or
1488 submodules. Therefore, they can be overridden by declarations in the
1489 submodule scope. Deal with this by attaching the existing symbol to
1490 a new symtree and recycling the old symtree with a new symbol... */
1491 st = gfc_find_symtree (gfc_current_ns->sym_root, name);
1492 if (st != NULL && gfc_state_stack->state == COMP_SUBMODULE
1493 && st->n.sym != NULL
1494 && st->n.sym->attr.host_assoc && st->n.sym->attr.used_in_submodule)
1496 gfc_symtree *s = gfc_get_unique_symtree (gfc_current_ns);
1497 s->n.sym = st->n.sym;
1498 sym = gfc_new_symbol (name, gfc_current_ns);
1501 st->n.sym = sym;
1502 sym->refs++;
1503 gfc_set_sym_referenced (sym);
1505 /* ...Otherwise generate a new symtree and new symbol. */
1506 else if (gfc_get_symbol (name, NULL, &sym))
1507 return false;
1509 /* Check if the name has already been defined as a type. The
1510 first letter of the symtree will be in upper case then. Of
1511 course, this is only necessary if the upper case letter is
1512 actually different. */
1514 upper = TOUPPER(name[0]);
1515 if (upper != name[0])
1517 char u_name[GFC_MAX_SYMBOL_LEN + 1];
1518 gfc_symtree *st;
1520 gcc_assert (strlen(name) <= GFC_MAX_SYMBOL_LEN);
1521 strcpy (u_name, name);
1522 u_name[0] = upper;
1524 st = gfc_find_symtree (gfc_current_ns->sym_root, u_name);
1526 /* STRUCTURE types can alias symbol names */
1527 if (st != 0 && st->n.sym->attr.flavor != FL_STRUCT)
1529 gfc_error ("Symbol %qs at %C also declared as a type at %L", name,
1530 &st->n.sym->declared_at);
1531 return false;
1535 /* Start updating the symbol table. Add basic type attribute if present. */
1536 if (current_ts.type != BT_UNKNOWN
1537 && (sym->attr.implicit_type == 0
1538 || !gfc_compare_types (&sym->ts, &current_ts))
1539 && !gfc_add_type (sym, &current_ts, var_locus))
1540 return false;
1542 if (sym->ts.type == BT_CHARACTER)
1544 sym->ts.u.cl = cl;
1545 sym->ts.deferred = cl_deferred;
1548 /* Add dimension attribute if present. */
1549 if (!gfc_set_array_spec (sym, *as, var_locus))
1550 return false;
1551 *as = NULL;
1553 /* Add attribute to symbol. The copy is so that we can reset the
1554 dimension attribute. */
1555 attr = current_attr;
1556 attr.dimension = 0;
1557 attr.codimension = 0;
1559 if (!gfc_copy_attr (&sym->attr, &attr, var_locus))
1560 return false;
1562 /* Finish any work that may need to be done for the binding label,
1563 if it's a bind(c). The bind(c) attr is found before the symbol
1564 is made, and before the symbol name (for data decls), so the
1565 current_ts is holding the binding label, or nothing if the
1566 name= attr wasn't given. Therefore, test here if we're dealing
1567 with a bind(c) and make sure the binding label is set correctly. */
1568 if (sym->attr.is_bind_c == 1)
1570 if (!sym->binding_label)
1572 /* Set the binding label and verify that if a NAME= was specified
1573 then only one identifier was in the entity-decl-list. */
1574 if (!set_binding_label (&sym->binding_label, sym->name,
1575 num_idents_on_line))
1576 return false;
1580 /* See if we know we're in a common block, and if it's a bind(c)
1581 common then we need to make sure we're an interoperable type. */
1582 if (sym->attr.in_common == 1)
1584 /* Test the common block object. */
1585 if (sym->common_block != NULL && sym->common_block->is_bind_c == 1
1586 && sym->ts.is_c_interop != 1)
1588 gfc_error_now ("Variable %qs in common block %qs at %C "
1589 "must be declared with a C interoperable "
1590 "kind since common block %qs is BIND(C)",
1591 sym->name, sym->common_block->name,
1592 sym->common_block->name);
1593 gfc_clear_error ();
1597 sym->attr.implied_index = 0;
1599 /* Use the parameter expressions for a parameterized derived type. */
1600 if ((sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
1601 && sym->ts.u.derived->attr.pdt_type && type_param_spec_list)
1602 sym->param_list = gfc_copy_actual_arglist (type_param_spec_list);
1604 if (sym->ts.type == BT_CLASS)
1605 return gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as);
1607 return true;
1611 /* Set character constant to the given length. The constant will be padded or
1612 truncated. If we're inside an array constructor without a typespec, we
1613 additionally check that all elements have the same length; check_len -1
1614 means no checking. */
1616 void
1617 gfc_set_constant_character_len (gfc_charlen_t len, gfc_expr *expr,
1618 gfc_charlen_t check_len)
1620 gfc_char_t *s;
1621 gfc_charlen_t slen;
1623 if (expr->ts.type != BT_CHARACTER)
1624 return;
1626 if (expr->expr_type != EXPR_CONSTANT)
1628 gfc_error_now ("CHARACTER length must be a constant at %L", &expr->where);
1629 return;
1632 slen = expr->value.character.length;
1633 if (len != slen)
1635 s = gfc_get_wide_string (len + 1);
1636 memcpy (s, expr->value.character.string,
1637 MIN (len, slen) * sizeof (gfc_char_t));
1638 if (len > slen)
1639 gfc_wide_memset (&s[slen], ' ', len - slen);
1641 if (warn_character_truncation && slen > len)
1642 gfc_warning_now (OPT_Wcharacter_truncation,
1643 "CHARACTER expression at %L is being truncated "
1644 "(%ld/%ld)", &expr->where,
1645 (long) slen, (long) len);
1647 /* Apply the standard by 'hand' otherwise it gets cleared for
1648 initializers. */
1649 if (check_len != -1 && slen != check_len
1650 && !(gfc_option.allow_std & GFC_STD_GNU))
1651 gfc_error_now ("The CHARACTER elements of the array constructor "
1652 "at %L must have the same length (%ld/%ld)",
1653 &expr->where, (long) slen,
1654 (long) check_len);
1656 s[len] = '\0';
1657 free (expr->value.character.string);
1658 expr->value.character.string = s;
1659 expr->value.character.length = len;
1664 /* Function to create and update the enumerator history
1665 using the information passed as arguments.
1666 Pointer "max_enum" is also updated, to point to
1667 enum history node containing largest initializer.
1669 SYM points to the symbol node of enumerator.
1670 INIT points to its enumerator value. */
1672 static void
1673 create_enum_history (gfc_symbol *sym, gfc_expr *init)
1675 enumerator_history *new_enum_history;
1676 gcc_assert (sym != NULL && init != NULL);
1678 new_enum_history = XCNEW (enumerator_history);
1680 new_enum_history->sym = sym;
1681 new_enum_history->initializer = init;
1682 new_enum_history->next = NULL;
1684 if (enum_history == NULL)
1686 enum_history = new_enum_history;
1687 max_enum = enum_history;
1689 else
1691 new_enum_history->next = enum_history;
1692 enum_history = new_enum_history;
1694 if (mpz_cmp (max_enum->initializer->value.integer,
1695 new_enum_history->initializer->value.integer) < 0)
1696 max_enum = new_enum_history;
1701 /* Function to free enum kind history. */
1703 void
1704 gfc_free_enum_history (void)
1706 enumerator_history *current = enum_history;
1707 enumerator_history *next;
1709 while (current != NULL)
1711 next = current->next;
1712 free (current);
1713 current = next;
1715 max_enum = NULL;
1716 enum_history = NULL;
1720 /* Function called by variable_decl() that adds an initialization
1721 expression to a symbol. */
1723 static bool
1724 add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus)
1726 symbol_attribute attr;
1727 gfc_symbol *sym;
1728 gfc_expr *init;
1730 init = *initp;
1731 if (find_special (name, &sym, false))
1732 return false;
1734 attr = sym->attr;
1736 /* If this symbol is confirming an implicit parameter type,
1737 then an initialization expression is not allowed. */
1738 if (attr.flavor == FL_PARAMETER
1739 && sym->value != NULL
1740 && *initp != NULL)
1742 gfc_error ("Initializer not allowed for PARAMETER %qs at %C",
1743 sym->name);
1744 return false;
1747 if (init == NULL)
1749 /* An initializer is required for PARAMETER declarations. */
1750 if (attr.flavor == FL_PARAMETER)
1752 gfc_error ("PARAMETER at %L is missing an initializer", var_locus);
1753 return false;
1756 else
1758 /* If a variable appears in a DATA block, it cannot have an
1759 initializer. */
1760 if (sym->attr.data)
1762 gfc_error ("Variable %qs at %C with an initializer already "
1763 "appears in a DATA statement", sym->name);
1764 return false;
1767 /* Check if the assignment can happen. This has to be put off
1768 until later for derived type variables and procedure pointers. */
1769 if (!gfc_bt_struct (sym->ts.type) && !gfc_bt_struct (init->ts.type)
1770 && sym->ts.type != BT_CLASS && init->ts.type != BT_CLASS
1771 && !sym->attr.proc_pointer
1772 && !gfc_check_assign_symbol (sym, NULL, init))
1773 return false;
1775 if (sym->ts.type == BT_CHARACTER && sym->ts.u.cl
1776 && init->ts.type == BT_CHARACTER)
1778 /* Update symbol character length according initializer. */
1779 if (!gfc_check_assign_symbol (sym, NULL, init))
1780 return false;
1782 if (sym->ts.u.cl->length == NULL)
1784 gfc_charlen_t clen;
1785 /* If there are multiple CHARACTER variables declared on the
1786 same line, we don't want them to share the same length. */
1787 sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
1789 if (sym->attr.flavor == FL_PARAMETER)
1791 if (init->expr_type == EXPR_CONSTANT)
1793 clen = init->value.character.length;
1794 sym->ts.u.cl->length
1795 = gfc_get_int_expr (gfc_charlen_int_kind,
1796 NULL, clen);
1798 else if (init->expr_type == EXPR_ARRAY)
1800 if (init->ts.u.cl && init->ts.u.cl->length)
1802 const gfc_expr *length = init->ts.u.cl->length;
1803 if (length->expr_type != EXPR_CONSTANT)
1805 gfc_error ("Cannot initialize parameter array "
1806 "at %L "
1807 "with variable length elements",
1808 &sym->declared_at);
1809 return false;
1811 clen = mpz_get_si (length->value.integer);
1813 else if (init->value.constructor)
1815 gfc_constructor *c;
1816 c = gfc_constructor_first (init->value.constructor);
1817 clen = c->expr->value.character.length;
1819 else
1820 gcc_unreachable ();
1821 sym->ts.u.cl->length
1822 = gfc_get_int_expr (gfc_charlen_int_kind,
1823 NULL, clen);
1825 else if (init->ts.u.cl && init->ts.u.cl->length)
1826 sym->ts.u.cl->length =
1827 gfc_copy_expr (sym->value->ts.u.cl->length);
1830 /* Update initializer character length according symbol. */
1831 else if (sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
1833 if (!gfc_specification_expr (sym->ts.u.cl->length))
1834 return false;
1836 int k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind,
1837 false);
1838 /* resolve_charlen will complain later on if the length
1839 is too large. Just skeep the initialization in that case. */
1840 if (mpz_cmp (sym->ts.u.cl->length->value.integer,
1841 gfc_integer_kinds[k].huge) <= 0)
1843 HOST_WIDE_INT len
1844 = gfc_mpz_get_hwi (sym->ts.u.cl->length->value.integer);
1846 if (init->expr_type == EXPR_CONSTANT)
1847 gfc_set_constant_character_len (len, init, -1);
1848 else if (init->expr_type == EXPR_ARRAY)
1850 gfc_constructor *c;
1852 /* Build a new charlen to prevent simplification from
1853 deleting the length before it is resolved. */
1854 init->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
1855 init->ts.u.cl->length
1856 = gfc_copy_expr (sym->ts.u.cl->length);
1858 for (c = gfc_constructor_first (init->value.constructor);
1859 c; c = gfc_constructor_next (c))
1860 gfc_set_constant_character_len (len, c->expr, -1);
1866 /* If sym is implied-shape, set its upper bounds from init. */
1867 if (sym->attr.flavor == FL_PARAMETER && sym->attr.dimension
1868 && sym->as->type == AS_IMPLIED_SHAPE)
1870 int dim;
1872 if (init->rank == 0)
1874 gfc_error ("Can't initialize implied-shape array at %L"
1875 " with scalar", &sym->declared_at);
1876 return false;
1879 /* Shape should be present, we get an initialization expression. */
1880 gcc_assert (init->shape);
1882 for (dim = 0; dim < sym->as->rank; ++dim)
1884 int k;
1885 gfc_expr *e, *lower;
1887 lower = sym->as->lower[dim];
1889 /* If the lower bound is an array element from another
1890 parameterized array, then it is marked with EXPR_VARIABLE and
1891 is an initialization expression. Try to reduce it. */
1892 if (lower->expr_type == EXPR_VARIABLE)
1893 gfc_reduce_init_expr (lower);
1895 if (lower->expr_type == EXPR_CONSTANT)
1897 /* All dimensions must be without upper bound. */
1898 gcc_assert (!sym->as->upper[dim]);
1900 k = lower->ts.kind;
1901 e = gfc_get_constant_expr (BT_INTEGER, k, &sym->declared_at);
1902 mpz_add (e->value.integer, lower->value.integer,
1903 init->shape[dim]);
1904 mpz_sub_ui (e->value.integer, e->value.integer, 1);
1905 sym->as->upper[dim] = e;
1907 else
1909 gfc_error ("Non-constant lower bound in implied-shape"
1910 " declaration at %L", &lower->where);
1911 return false;
1915 sym->as->type = AS_EXPLICIT;
1918 /* Need to check if the expression we initialized this
1919 to was one of the iso_c_binding named constants. If so,
1920 and we're a parameter (constant), let it be iso_c.
1921 For example:
1922 integer(c_int), parameter :: my_int = c_int
1923 integer(my_int) :: my_int_2
1924 If we mark my_int as iso_c (since we can see it's value
1925 is equal to one of the named constants), then my_int_2
1926 will be considered C interoperable. */
1927 if (sym->ts.type != BT_CHARACTER && !gfc_bt_struct (sym->ts.type))
1929 sym->ts.is_iso_c |= init->ts.is_iso_c;
1930 sym->ts.is_c_interop |= init->ts.is_c_interop;
1931 /* attr bits needed for module files. */
1932 sym->attr.is_iso_c |= init->ts.is_iso_c;
1933 sym->attr.is_c_interop |= init->ts.is_c_interop;
1934 if (init->ts.is_iso_c)
1935 sym->ts.f90_type = init->ts.f90_type;
1938 /* Add initializer. Make sure we keep the ranks sane. */
1939 if (sym->attr.dimension && init->rank == 0)
1941 mpz_t size;
1942 gfc_expr *array;
1943 int n;
1944 if (sym->attr.flavor == FL_PARAMETER
1945 && init->expr_type == EXPR_CONSTANT
1946 && spec_size (sym->as, &size)
1947 && mpz_cmp_si (size, 0) > 0)
1949 array = gfc_get_array_expr (init->ts.type, init->ts.kind,
1950 &init->where);
1951 for (n = 0; n < (int)mpz_get_si (size); n++)
1952 gfc_constructor_append_expr (&array->value.constructor,
1953 n == 0
1954 ? init
1955 : gfc_copy_expr (init),
1956 &init->where);
1958 array->shape = gfc_get_shape (sym->as->rank);
1959 for (n = 0; n < sym->as->rank; n++)
1960 spec_dimen_size (sym->as, n, &array->shape[n]);
1962 init = array;
1963 mpz_clear (size);
1965 init->rank = sym->as->rank;
1968 sym->value = init;
1969 if (sym->attr.save == SAVE_NONE)
1970 sym->attr.save = SAVE_IMPLICIT;
1971 *initp = NULL;
1974 return true;
1978 /* Function called by variable_decl() that adds a name to a structure
1979 being built. */
1981 static bool
1982 build_struct (const char *name, gfc_charlen *cl, gfc_expr **init,
1983 gfc_array_spec **as)
1985 gfc_state_data *s;
1986 gfc_component *c;
1988 /* F03:C438/C439. If the current symbol is of the same derived type that we're
1989 constructing, it must have the pointer attribute. */
1990 if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS)
1991 && current_ts.u.derived == gfc_current_block ()
1992 && current_attr.pointer == 0)
1994 if (current_attr.allocatable
1995 && !gfc_notify_std(GFC_STD_F2008, "Component at %C "
1996 "must have the POINTER attribute"))
1998 return false;
2000 else if (current_attr.allocatable == 0)
2002 gfc_error ("Component at %C must have the POINTER attribute");
2003 return false;
2007 /* F03:C437. */
2008 if (current_ts.type == BT_CLASS
2009 && !(current_attr.pointer || current_attr.allocatable))
2011 gfc_error ("Component %qs with CLASS at %C must be allocatable "
2012 "or pointer", name);
2013 return false;
2016 if (gfc_current_block ()->attr.pointer && (*as)->rank != 0)
2018 if ((*as)->type != AS_DEFERRED && (*as)->type != AS_EXPLICIT)
2020 gfc_error ("Array component of structure at %C must have explicit "
2021 "or deferred shape");
2022 return false;
2026 /* If we are in a nested union/map definition, gfc_add_component will not
2027 properly find repeated components because:
2028 (i) gfc_add_component does a flat search, where components of unions
2029 and maps are implicity chained so nested components may conflict.
2030 (ii) Unions and maps are not linked as components of their parent
2031 structures until after they are parsed.
2032 For (i) we use gfc_find_component which searches recursively, and for (ii)
2033 we search each block directly from the parse stack until we find the top
2034 level structure. */
2036 s = gfc_state_stack;
2037 if (s->state == COMP_UNION || s->state == COMP_MAP)
2039 while (s->state == COMP_UNION || gfc_comp_struct (s->state))
2041 c = gfc_find_component (s->sym, name, true, true, NULL);
2042 if (c != NULL)
2044 gfc_error_now ("Component %qs at %C already declared at %L",
2045 name, &c->loc);
2046 return false;
2048 /* Break after we've searched the entire chain. */
2049 if (s->state == COMP_DERIVED || s->state == COMP_STRUCTURE)
2050 break;
2051 s = s->previous;
2055 if (!gfc_add_component (gfc_current_block(), name, &c))
2056 return false;
2058 c->ts = current_ts;
2059 if (c->ts.type == BT_CHARACTER)
2060 c->ts.u.cl = cl;
2062 if (c->ts.type != BT_CLASS && c->ts.type != BT_DERIVED
2063 && (c->ts.kind == 0 || c->ts.type == BT_CHARACTER)
2064 && saved_kind_expr != NULL)
2065 c->kind_expr = gfc_copy_expr (saved_kind_expr);
2067 c->attr = current_attr;
2069 c->initializer = *init;
2070 *init = NULL;
2072 c->as = *as;
2073 if (c->as != NULL)
2075 if (c->as->corank)
2076 c->attr.codimension = 1;
2077 if (c->as->rank)
2078 c->attr.dimension = 1;
2080 *as = NULL;
2082 gfc_apply_init (&c->ts, &c->attr, c->initializer);
2084 /* Check array components. */
2085 if (!c->attr.dimension)
2086 goto scalar;
2088 if (c->attr.pointer)
2090 if (c->as->type != AS_DEFERRED)
2092 gfc_error ("Pointer array component of structure at %C must have a "
2093 "deferred shape");
2094 return false;
2097 else if (c->attr.allocatable)
2099 if (c->as->type != AS_DEFERRED)
2101 gfc_error ("Allocatable component of structure at %C must have a "
2102 "deferred shape");
2103 return false;
2106 else
2108 if (c->as->type != AS_EXPLICIT)
2110 gfc_error ("Array component of structure at %C must have an "
2111 "explicit shape");
2112 return false;
2116 scalar:
2117 if (c->ts.type == BT_CLASS)
2118 return gfc_build_class_symbol (&c->ts, &c->attr, &c->as);
2120 if (c->attr.pdt_kind || c->attr.pdt_len)
2122 gfc_symbol *sym;
2123 gfc_find_symbol (c->name, gfc_current_block ()->f2k_derived,
2124 0, &sym);
2125 if (sym == NULL)
2127 gfc_error ("Type parameter %qs at %C has no corresponding entry "
2128 "in the type parameter name list at %L",
2129 c->name, &gfc_current_block ()->declared_at);
2130 return false;
2132 sym->ts = c->ts;
2133 sym->attr.pdt_kind = c->attr.pdt_kind;
2134 sym->attr.pdt_len = c->attr.pdt_len;
2135 if (c->initializer)
2136 sym->value = gfc_copy_expr (c->initializer);
2137 sym->attr.flavor = FL_VARIABLE;
2140 if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
2141 && c->ts.u.derived && c->ts.u.derived->attr.pdt_template
2142 && decl_type_param_list)
2143 c->param_list = gfc_copy_actual_arglist (decl_type_param_list);
2145 return true;
2149 /* Match a 'NULL()', and possibly take care of some side effects. */
2151 match
2152 gfc_match_null (gfc_expr **result)
2154 gfc_symbol *sym;
2155 match m, m2 = MATCH_NO;
2157 if ((m = gfc_match (" null ( )")) == MATCH_ERROR)
2158 return MATCH_ERROR;
2160 if (m == MATCH_NO)
2162 locus old_loc;
2163 char name[GFC_MAX_SYMBOL_LEN + 1];
2165 if ((m2 = gfc_match (" null (")) != MATCH_YES)
2166 return m2;
2168 old_loc = gfc_current_locus;
2169 if ((m2 = gfc_match (" %n ) ", name)) == MATCH_ERROR)
2170 return MATCH_ERROR;
2171 if (m2 != MATCH_YES
2172 && ((m2 = gfc_match (" mold = %n )", name)) == MATCH_ERROR))
2173 return MATCH_ERROR;
2174 if (m2 == MATCH_NO)
2176 gfc_current_locus = old_loc;
2177 return MATCH_NO;
2181 /* The NULL symbol now has to be/become an intrinsic function. */
2182 if (gfc_get_symbol ("null", NULL, &sym))
2184 gfc_error ("NULL() initialization at %C is ambiguous");
2185 return MATCH_ERROR;
2188 gfc_intrinsic_symbol (sym);
2190 if (sym->attr.proc != PROC_INTRINSIC
2191 && !(sym->attr.use_assoc && sym->attr.intrinsic)
2192 && (!gfc_add_procedure(&sym->attr, PROC_INTRINSIC, sym->name, NULL)
2193 || !gfc_add_function (&sym->attr, sym->name, NULL)))
2194 return MATCH_ERROR;
2196 *result = gfc_get_null_expr (&gfc_current_locus);
2198 /* Invalid per F2008, C512. */
2199 if (m2 == MATCH_YES)
2201 gfc_error ("NULL() initialization at %C may not have MOLD");
2202 return MATCH_ERROR;
2205 return MATCH_YES;
2209 /* Match the initialization expr for a data pointer or procedure pointer. */
2211 static match
2212 match_pointer_init (gfc_expr **init, int procptr)
2214 match m;
2216 if (gfc_pure (NULL) && !gfc_comp_struct (gfc_state_stack->state))
2218 gfc_error ("Initialization of pointer at %C is not allowed in "
2219 "a PURE procedure");
2220 return MATCH_ERROR;
2222 gfc_unset_implicit_pure (gfc_current_ns->proc_name);
2224 /* Match NULL() initialization. */
2225 m = gfc_match_null (init);
2226 if (m != MATCH_NO)
2227 return m;
2229 /* Match non-NULL initialization. */
2230 gfc_matching_ptr_assignment = !procptr;
2231 gfc_matching_procptr_assignment = procptr;
2232 m = gfc_match_rvalue (init);
2233 gfc_matching_ptr_assignment = 0;
2234 gfc_matching_procptr_assignment = 0;
2235 if (m == MATCH_ERROR)
2236 return MATCH_ERROR;
2237 else if (m == MATCH_NO)
2239 gfc_error ("Error in pointer initialization at %C");
2240 return MATCH_ERROR;
2243 if (!procptr && !gfc_resolve_expr (*init))
2244 return MATCH_ERROR;
2246 if (!gfc_notify_std (GFC_STD_F2008, "non-NULL pointer "
2247 "initialization at %C"))
2248 return MATCH_ERROR;
2250 return MATCH_YES;
2254 static bool
2255 check_function_name (char *name)
2257 /* In functions that have a RESULT variable defined, the function name always
2258 refers to function calls. Therefore, the name is not allowed to appear in
2259 specification statements. When checking this, be careful about
2260 'hidden' procedure pointer results ('ppr@'). */
2262 if (gfc_current_state () == COMP_FUNCTION)
2264 gfc_symbol *block = gfc_current_block ();
2265 if (block && block->result && block->result != block
2266 && strcmp (block->result->name, "ppr@") != 0
2267 && strcmp (block->name, name) == 0)
2269 gfc_error ("RESULT variable %qs at %L prohibits FUNCTION name %qs at %C "
2270 "from appearing in a specification statement",
2271 block->result->name, &block->result->declared_at, name);
2272 return false;
2276 return true;
2280 /* Match a variable name with an optional initializer. When this
2281 subroutine is called, a variable is expected to be parsed next.
2282 Depending on what is happening at the moment, updates either the
2283 symbol table or the current interface. */
2285 static match
2286 variable_decl (int elem)
2288 char name[GFC_MAX_SYMBOL_LEN + 1];
2289 static unsigned int fill_id = 0;
2290 gfc_expr *initializer, *char_len;
2291 gfc_array_spec *as;
2292 gfc_array_spec *cp_as; /* Extra copy for Cray Pointees. */
2293 gfc_charlen *cl;
2294 bool cl_deferred;
2295 locus var_locus;
2296 match m;
2297 bool t;
2298 gfc_symbol *sym;
2300 initializer = NULL;
2301 as = NULL;
2302 cp_as = NULL;
2304 /* When we get here, we've just matched a list of attributes and
2305 maybe a type and a double colon. The next thing we expect to see
2306 is the name of the symbol. */
2308 /* If we are parsing a structure with legacy support, we allow the symbol
2309 name to be '%FILL' which gives it an anonymous (inaccessible) name. */
2310 m = MATCH_NO;
2311 gfc_gobble_whitespace ();
2312 if (gfc_peek_ascii_char () == '%')
2314 gfc_next_ascii_char ();
2315 m = gfc_match ("fill");
2318 if (m != MATCH_YES)
2320 m = gfc_match_name (name);
2321 if (m != MATCH_YES)
2322 goto cleanup;
2325 else
2327 m = MATCH_ERROR;
2328 if (gfc_current_state () != COMP_STRUCTURE)
2330 if (flag_dec_structure)
2331 gfc_error ("%qs not allowed outside STRUCTURE at %C", "%FILL");
2332 else
2333 gfc_error ("%qs at %C is a DEC extension, enable with "
2334 "%<-fdec-structure%>", "%FILL");
2335 goto cleanup;
2338 if (attr_seen)
2340 gfc_error ("%qs entity cannot have attributes at %C", "%FILL");
2341 goto cleanup;
2344 /* %FILL components are given invalid fortran names. */
2345 snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "%%FILL%u", fill_id++);
2346 m = MATCH_YES;
2349 var_locus = gfc_current_locus;
2351 /* Now we could see the optional array spec. or character length. */
2352 m = gfc_match_array_spec (&as, true, true);
2353 if (m == MATCH_ERROR)
2354 goto cleanup;
2356 if (m == MATCH_NO)
2357 as = gfc_copy_array_spec (current_as);
2358 else if (current_as
2359 && !merge_array_spec (current_as, as, true))
2361 m = MATCH_ERROR;
2362 goto cleanup;
2365 if (flag_cray_pointer)
2366 cp_as = gfc_copy_array_spec (as);
2368 /* At this point, we know for sure if the symbol is PARAMETER and can thus
2369 determine (and check) whether it can be implied-shape. If it
2370 was parsed as assumed-size, change it because PARAMETERs can not
2371 be assumed-size.
2373 An explicit-shape-array cannot appear under several conditions.
2374 That check is done here as well. */
2375 if (as)
2377 if (as->type == AS_IMPLIED_SHAPE && current_attr.flavor != FL_PARAMETER)
2379 m = MATCH_ERROR;
2380 gfc_error ("Non-PARAMETER symbol %qs at %L can't be implied-shape",
2381 name, &var_locus);
2382 goto cleanup;
2385 if (as->type == AS_ASSUMED_SIZE && as->rank == 1
2386 && current_attr.flavor == FL_PARAMETER)
2387 as->type = AS_IMPLIED_SHAPE;
2389 if (as->type == AS_IMPLIED_SHAPE
2390 && !gfc_notify_std (GFC_STD_F2008, "Implied-shape array at %L",
2391 &var_locus))
2393 m = MATCH_ERROR;
2394 goto cleanup;
2397 /* F2018:C830 (R816) An explicit-shape-spec whose bounds are not
2398 constant expressions shall appear only in a subprogram, derived
2399 type definition, BLOCK construct, or interface body. */
2400 if (as->type == AS_EXPLICIT
2401 && gfc_current_state () != COMP_BLOCK
2402 && gfc_current_state () != COMP_DERIVED
2403 && gfc_current_state () != COMP_FUNCTION
2404 && gfc_current_state () != COMP_INTERFACE
2405 && gfc_current_state () != COMP_SUBROUTINE)
2407 gfc_expr *e;
2408 bool not_constant = false;
2410 for (int i = 0; i < as->rank; i++)
2412 e = gfc_copy_expr (as->lower[i]);
2413 gfc_resolve_expr (e);
2414 gfc_simplify_expr (e, 0);
2415 if (e && (e->expr_type != EXPR_CONSTANT))
2417 not_constant = true;
2418 break;
2420 gfc_free_expr (e);
2422 e = gfc_copy_expr (as->upper[i]);
2423 gfc_resolve_expr (e);
2424 gfc_simplify_expr (e, 0);
2425 if (e && (e->expr_type != EXPR_CONSTANT))
2427 not_constant = true;
2428 break;
2430 gfc_free_expr (e);
2433 if (not_constant)
2435 gfc_error ("Explicit shaped array with nonconstant bounds at %C");
2436 m = MATCH_ERROR;
2437 goto cleanup;
2440 if (as->type == AS_EXPLICIT)
2442 for (int i = 0; i < as->rank; i++)
2444 gfc_expr *e, *n;
2445 e = as->lower[i];
2446 if (e->expr_type != EXPR_CONSTANT)
2448 n = gfc_copy_expr (e);
2449 gfc_simplify_expr (n, 1);
2450 if (n->expr_type == EXPR_CONSTANT)
2451 gfc_replace_expr (e, n);
2452 else
2453 gfc_free_expr (n);
2455 e = as->upper[i];
2456 if (e->expr_type != EXPR_CONSTANT)
2458 n = gfc_copy_expr (e);
2459 gfc_simplify_expr (n, 1);
2460 if (n->expr_type == EXPR_CONSTANT)
2461 gfc_replace_expr (e, n);
2462 else
2463 gfc_free_expr (n);
2469 char_len = NULL;
2470 cl = NULL;
2471 cl_deferred = false;
2473 if (current_ts.type == BT_CHARACTER)
2475 switch (match_char_length (&char_len, &cl_deferred, false))
2477 case MATCH_YES:
2478 cl = gfc_new_charlen (gfc_current_ns, NULL);
2480 cl->length = char_len;
2481 break;
2483 /* Non-constant lengths need to be copied after the first
2484 element. Also copy assumed lengths. */
2485 case MATCH_NO:
2486 if (elem > 1
2487 && (current_ts.u.cl->length == NULL
2488 || current_ts.u.cl->length->expr_type != EXPR_CONSTANT))
2490 cl = gfc_new_charlen (gfc_current_ns, NULL);
2491 cl->length = gfc_copy_expr (current_ts.u.cl->length);
2493 else
2494 cl = current_ts.u.cl;
2496 cl_deferred = current_ts.deferred;
2498 break;
2500 case MATCH_ERROR:
2501 goto cleanup;
2505 /* The dummy arguments and result of the abreviated form of MODULE
2506 PROCEDUREs, used in SUBMODULES should not be redefined. */
2507 if (gfc_current_ns->proc_name
2508 && gfc_current_ns->proc_name->abr_modproc_decl)
2510 gfc_find_symbol (name, gfc_current_ns, 1, &sym);
2511 if (sym != NULL && (sym->attr.dummy || sym->attr.result))
2513 m = MATCH_ERROR;
2514 gfc_error ("%qs at %C is a redefinition of the declaration "
2515 "in the corresponding interface for MODULE "
2516 "PROCEDURE %qs", sym->name,
2517 gfc_current_ns->proc_name->name);
2518 goto cleanup;
2522 /* %FILL components may not have initializers. */
2523 if (strncmp (name, "%FILL", 5) == 0 && gfc_match_eos () != MATCH_YES)
2525 gfc_error ("%qs entity cannot have an initializer at %C", "%FILL");
2526 m = MATCH_ERROR;
2527 goto cleanup;
2530 /* If this symbol has already shown up in a Cray Pointer declaration,
2531 and this is not a component declaration,
2532 then we want to set the type & bail out. */
2533 if (flag_cray_pointer && !gfc_comp_struct (gfc_current_state ()))
2535 gfc_find_symbol (name, gfc_current_ns, 1, &sym);
2536 if (sym != NULL && sym->attr.cray_pointee)
2538 m = MATCH_YES;
2539 if (!gfc_add_type (sym, &current_ts, &gfc_current_locus))
2541 m = MATCH_ERROR;
2542 goto cleanup;
2545 /* Check to see if we have an array specification. */
2546 if (cp_as != NULL)
2548 if (sym->as != NULL)
2550 gfc_error ("Duplicate array spec for Cray pointee at %C");
2551 gfc_free_array_spec (cp_as);
2552 m = MATCH_ERROR;
2553 goto cleanup;
2555 else
2557 if (!gfc_set_array_spec (sym, cp_as, &var_locus))
2558 gfc_internal_error ("Couldn't set pointee array spec.");
2560 /* Fix the array spec. */
2561 m = gfc_mod_pointee_as (sym->as);
2562 if (m == MATCH_ERROR)
2563 goto cleanup;
2566 goto cleanup;
2568 else
2570 gfc_free_array_spec (cp_as);
2574 /* Procedure pointer as function result. */
2575 if (gfc_current_state () == COMP_FUNCTION
2576 && strcmp ("ppr@", gfc_current_block ()->name) == 0
2577 && strcmp (name, gfc_current_block ()->ns->proc_name->name) == 0)
2578 strcpy (name, "ppr@");
2580 if (gfc_current_state () == COMP_FUNCTION
2581 && strcmp (name, gfc_current_block ()->name) == 0
2582 && gfc_current_block ()->result
2583 && strcmp ("ppr@", gfc_current_block ()->result->name) == 0)
2584 strcpy (name, "ppr@");
2586 /* OK, we've successfully matched the declaration. Now put the
2587 symbol in the current namespace, because it might be used in the
2588 optional initialization expression for this symbol, e.g. this is
2589 perfectly legal:
2591 integer, parameter :: i = huge(i)
2593 This is only true for parameters or variables of a basic type.
2594 For components of derived types, it is not true, so we don't
2595 create a symbol for those yet. If we fail to create the symbol,
2596 bail out. */
2597 if (!gfc_comp_struct (gfc_current_state ())
2598 && !build_sym (name, cl, cl_deferred, &as, &var_locus))
2600 m = MATCH_ERROR;
2601 goto cleanup;
2604 if (!check_function_name (name))
2606 m = MATCH_ERROR;
2607 goto cleanup;
2610 /* We allow old-style initializations of the form
2611 integer i /2/, j(4) /3*3, 1/
2612 (if no colon has been seen). These are different from data
2613 statements in that initializers are only allowed to apply to the
2614 variable immediately preceding, i.e.
2615 integer i, j /1, 2/
2616 is not allowed. Therefore we have to do some work manually, that
2617 could otherwise be left to the matchers for DATA statements. */
2619 if (!colon_seen && gfc_match (" /") == MATCH_YES)
2621 if (!gfc_notify_std (GFC_STD_GNU, "Old-style "
2622 "initialization at %C"))
2623 return MATCH_ERROR;
2625 /* Allow old style initializations for components of STRUCTUREs and MAPs
2626 but not components of derived types. */
2627 else if (gfc_current_state () == COMP_DERIVED)
2629 gfc_error ("Invalid old style initialization for derived type "
2630 "component at %C");
2631 m = MATCH_ERROR;
2632 goto cleanup;
2635 /* For structure components, read the initializer as a special
2636 expression and let the rest of this function apply the initializer
2637 as usual. */
2638 else if (gfc_comp_struct (gfc_current_state ()))
2640 m = match_clist_expr (&initializer, &current_ts, as);
2641 if (m == MATCH_NO)
2642 gfc_error ("Syntax error in old style initialization of %s at %C",
2643 name);
2644 if (m != MATCH_YES)
2645 goto cleanup;
2648 /* Otherwise we treat the old style initialization just like a
2649 DATA declaration for the current variable. */
2650 else
2651 return match_old_style_init (name);
2654 /* The double colon must be present in order to have initializers.
2655 Otherwise the statement is ambiguous with an assignment statement. */
2656 if (colon_seen)
2658 if (gfc_match (" =>") == MATCH_YES)
2660 if (!current_attr.pointer)
2662 gfc_error ("Initialization at %C isn't for a pointer variable");
2663 m = MATCH_ERROR;
2664 goto cleanup;
2667 m = match_pointer_init (&initializer, 0);
2668 if (m != MATCH_YES)
2669 goto cleanup;
2671 else if (gfc_match_char ('=') == MATCH_YES)
2673 if (current_attr.pointer)
2675 gfc_error ("Pointer initialization at %C requires %<=>%>, "
2676 "not %<=%>");
2677 m = MATCH_ERROR;
2678 goto cleanup;
2681 m = gfc_match_init_expr (&initializer);
2682 if (m == MATCH_NO)
2684 gfc_error ("Expected an initialization expression at %C");
2685 m = MATCH_ERROR;
2688 if (current_attr.flavor != FL_PARAMETER && gfc_pure (NULL)
2689 && !gfc_comp_struct (gfc_state_stack->state))
2691 gfc_error ("Initialization of variable at %C is not allowed in "
2692 "a PURE procedure");
2693 m = MATCH_ERROR;
2696 if (current_attr.flavor != FL_PARAMETER
2697 && !gfc_comp_struct (gfc_state_stack->state))
2698 gfc_unset_implicit_pure (gfc_current_ns->proc_name);
2700 if (m != MATCH_YES)
2701 goto cleanup;
2705 if (initializer != NULL && current_attr.allocatable
2706 && gfc_comp_struct (gfc_current_state ()))
2708 gfc_error ("Initialization of allocatable component at %C is not "
2709 "allowed");
2710 m = MATCH_ERROR;
2711 goto cleanup;
2714 if (gfc_current_state () == COMP_DERIVED
2715 && gfc_current_block ()->attr.pdt_template)
2717 gfc_symbol *param;
2718 gfc_find_symbol (name, gfc_current_block ()->f2k_derived,
2719 0, &param);
2720 if (!param && (current_attr.pdt_kind || current_attr.pdt_len))
2722 gfc_error ("The component with KIND or LEN attribute at %C does not "
2723 "not appear in the type parameter list at %L",
2724 &gfc_current_block ()->declared_at);
2725 m = MATCH_ERROR;
2726 goto cleanup;
2728 else if (param && !(current_attr.pdt_kind || current_attr.pdt_len))
2730 gfc_error ("The component at %C that appears in the type parameter "
2731 "list at %L has neither the KIND nor LEN attribute",
2732 &gfc_current_block ()->declared_at);
2733 m = MATCH_ERROR;
2734 goto cleanup;
2736 else if (as && (current_attr.pdt_kind || current_attr.pdt_len))
2738 gfc_error ("The component at %C which is a type parameter must be "
2739 "a scalar");
2740 m = MATCH_ERROR;
2741 goto cleanup;
2743 else if (param && initializer)
2744 param->value = gfc_copy_expr (initializer);
2747 /* Add the initializer. Note that it is fine if initializer is
2748 NULL here, because we sometimes also need to check if a
2749 declaration *must* have an initialization expression. */
2750 if (!gfc_comp_struct (gfc_current_state ()))
2751 t = add_init_expr_to_sym (name, &initializer, &var_locus);
2752 else
2754 if (current_ts.type == BT_DERIVED
2755 && !current_attr.pointer && !initializer)
2756 initializer = gfc_default_initializer (&current_ts);
2757 t = build_struct (name, cl, &initializer, &as);
2759 /* If we match a nested structure definition we expect to see the
2760 * body even if the variable declarations blow up, so we need to keep
2761 * the structure declaration around. */
2762 if (gfc_new_block && gfc_new_block->attr.flavor == FL_STRUCT)
2763 gfc_commit_symbol (gfc_new_block);
2766 m = (t) ? MATCH_YES : MATCH_ERROR;
2768 cleanup:
2769 /* Free stuff up and return. */
2770 gfc_free_expr (initializer);
2771 gfc_free_array_spec (as);
2773 return m;
2777 /* Match an extended-f77 "TYPESPEC*bytesize"-style kind specification.
2778 This assumes that the byte size is equal to the kind number for
2779 non-COMPLEX types, and equal to twice the kind number for COMPLEX. */
2781 match
2782 gfc_match_old_kind_spec (gfc_typespec *ts)
2784 match m;
2785 int original_kind;
2787 if (gfc_match_char ('*') != MATCH_YES)
2788 return MATCH_NO;
2790 m = gfc_match_small_literal_int (&ts->kind, NULL);
2791 if (m != MATCH_YES)
2792 return MATCH_ERROR;
2794 original_kind = ts->kind;
2796 /* Massage the kind numbers for complex types. */
2797 if (ts->type == BT_COMPLEX)
2799 if (ts->kind % 2)
2801 gfc_error ("Old-style type declaration %s*%d not supported at %C",
2802 gfc_basic_typename (ts->type), original_kind);
2803 return MATCH_ERROR;
2805 ts->kind /= 2;
2809 if (ts->type == BT_INTEGER && ts->kind == 4 && flag_integer4_kind == 8)
2810 ts->kind = 8;
2812 if (ts->type == BT_REAL || ts->type == BT_COMPLEX)
2814 if (ts->kind == 4)
2816 if (flag_real4_kind == 8)
2817 ts->kind = 8;
2818 if (flag_real4_kind == 10)
2819 ts->kind = 10;
2820 if (flag_real4_kind == 16)
2821 ts->kind = 16;
2824 if (ts->kind == 8)
2826 if (flag_real8_kind == 4)
2827 ts->kind = 4;
2828 if (flag_real8_kind == 10)
2829 ts->kind = 10;
2830 if (flag_real8_kind == 16)
2831 ts->kind = 16;
2835 if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
2837 gfc_error ("Old-style type declaration %s*%d not supported at %C",
2838 gfc_basic_typename (ts->type), original_kind);
2839 return MATCH_ERROR;
2842 if (!gfc_notify_std (GFC_STD_GNU,
2843 "Nonstandard type declaration %s*%d at %C",
2844 gfc_basic_typename(ts->type), original_kind))
2845 return MATCH_ERROR;
2847 return MATCH_YES;
2851 /* Match a kind specification. Since kinds are generally optional, we
2852 usually return MATCH_NO if something goes wrong. If a "kind="
2853 string is found, then we know we have an error. */
2855 match
2856 gfc_match_kind_spec (gfc_typespec *ts, bool kind_expr_only)
2858 locus where, loc;
2859 gfc_expr *e;
2860 match m, n;
2861 char c;
2863 m = MATCH_NO;
2864 n = MATCH_YES;
2865 e = NULL;
2866 saved_kind_expr = NULL;
2868 where = loc = gfc_current_locus;
2870 if (kind_expr_only)
2871 goto kind_expr;
2873 if (gfc_match_char ('(') == MATCH_NO)
2874 return MATCH_NO;
2876 /* Also gobbles optional text. */
2877 if (gfc_match (" kind = ") == MATCH_YES)
2878 m = MATCH_ERROR;
2880 loc = gfc_current_locus;
2882 kind_expr:
2884 n = gfc_match_init_expr (&e);
2886 if (gfc_derived_parameter_expr (e))
2888 ts->kind = 0;
2889 saved_kind_expr = gfc_copy_expr (e);
2890 goto close_brackets;
2893 if (n != MATCH_YES)
2895 if (gfc_matching_function)
2897 /* The function kind expression might include use associated or
2898 imported parameters and try again after the specification
2899 expressions..... */
2900 if (gfc_match_char (')') != MATCH_YES)
2902 gfc_error ("Missing right parenthesis at %C");
2903 m = MATCH_ERROR;
2904 goto no_match;
2907 gfc_free_expr (e);
2908 gfc_undo_symbols ();
2909 return MATCH_YES;
2911 else
2913 /* ....or else, the match is real. */
2914 if (n == MATCH_NO)
2915 gfc_error ("Expected initialization expression at %C");
2916 if (n != MATCH_YES)
2917 return MATCH_ERROR;
2921 if (e->rank != 0)
2923 gfc_error ("Expected scalar initialization expression at %C");
2924 m = MATCH_ERROR;
2925 goto no_match;
2928 if (gfc_extract_int (e, &ts->kind, 1))
2930 m = MATCH_ERROR;
2931 goto no_match;
2934 /* Before throwing away the expression, let's see if we had a
2935 C interoperable kind (and store the fact). */
2936 if (e->ts.is_c_interop == 1)
2938 /* Mark this as C interoperable if being declared with one
2939 of the named constants from iso_c_binding. */
2940 ts->is_c_interop = e->ts.is_iso_c;
2941 ts->f90_type = e->ts.f90_type;
2942 if (e->symtree)
2943 ts->interop_kind = e->symtree->n.sym;
2946 gfc_free_expr (e);
2947 e = NULL;
2949 /* Ignore errors to this point, if we've gotten here. This means
2950 we ignore the m=MATCH_ERROR from above. */
2951 if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
2953 gfc_error ("Kind %d not supported for type %s at %C", ts->kind,
2954 gfc_basic_typename (ts->type));
2955 gfc_current_locus = where;
2956 return MATCH_ERROR;
2959 /* Warn if, e.g., c_int is used for a REAL variable, but not
2960 if, e.g., c_double is used for COMPLEX as the standard
2961 explicitly says that the kind type parameter for complex and real
2962 variable is the same, i.e. c_float == c_float_complex. */
2963 if (ts->f90_type != BT_UNKNOWN && ts->f90_type != ts->type
2964 && !((ts->f90_type == BT_REAL && ts->type == BT_COMPLEX)
2965 || (ts->f90_type == BT_COMPLEX && ts->type == BT_REAL)))
2966 gfc_warning_now (0, "C kind type parameter is for type %s but type at %L "
2967 "is %s", gfc_basic_typename (ts->f90_type), &where,
2968 gfc_basic_typename (ts->type));
2970 close_brackets:
2972 gfc_gobble_whitespace ();
2973 if ((c = gfc_next_ascii_char ()) != ')'
2974 && (ts->type != BT_CHARACTER || c != ','))
2976 if (ts->type == BT_CHARACTER)
2977 gfc_error ("Missing right parenthesis or comma at %C");
2978 else
2979 gfc_error ("Missing right parenthesis at %C");
2980 m = MATCH_ERROR;
2982 else
2983 /* All tests passed. */
2984 m = MATCH_YES;
2986 if(m == MATCH_ERROR)
2987 gfc_current_locus = where;
2989 if (ts->type == BT_INTEGER && ts->kind == 4 && flag_integer4_kind == 8)
2990 ts->kind = 8;
2992 if (ts->type == BT_REAL || ts->type == BT_COMPLEX)
2994 if (ts->kind == 4)
2996 if (flag_real4_kind == 8)
2997 ts->kind = 8;
2998 if (flag_real4_kind == 10)
2999 ts->kind = 10;
3000 if (flag_real4_kind == 16)
3001 ts->kind = 16;
3004 if (ts->kind == 8)
3006 if (flag_real8_kind == 4)
3007 ts->kind = 4;
3008 if (flag_real8_kind == 10)
3009 ts->kind = 10;
3010 if (flag_real8_kind == 16)
3011 ts->kind = 16;
3015 /* Return what we know from the test(s). */
3016 return m;
3018 no_match:
3019 gfc_free_expr (e);
3020 gfc_current_locus = where;
3021 return m;
3025 static match
3026 match_char_kind (int * kind, int * is_iso_c)
3028 locus where;
3029 gfc_expr *e;
3030 match m, n;
3031 bool fail;
3033 m = MATCH_NO;
3034 e = NULL;
3035 where = gfc_current_locus;
3037 n = gfc_match_init_expr (&e);
3039 if (n != MATCH_YES && gfc_matching_function)
3041 /* The expression might include use-associated or imported
3042 parameters and try again after the specification
3043 expressions. */
3044 gfc_free_expr (e);
3045 gfc_undo_symbols ();
3046 return MATCH_YES;
3049 if (n == MATCH_NO)
3050 gfc_error ("Expected initialization expression at %C");
3051 if (n != MATCH_YES)
3052 return MATCH_ERROR;
3054 if (e->rank != 0)
3056 gfc_error ("Expected scalar initialization expression at %C");
3057 m = MATCH_ERROR;
3058 goto no_match;
3061 if (gfc_derived_parameter_expr (e))
3063 saved_kind_expr = e;
3064 *kind = 0;
3065 return MATCH_YES;
3068 fail = gfc_extract_int (e, kind, 1);
3069 *is_iso_c = e->ts.is_iso_c;
3070 if (fail)
3072 m = MATCH_ERROR;
3073 goto no_match;
3076 gfc_free_expr (e);
3078 /* Ignore errors to this point, if we've gotten here. This means
3079 we ignore the m=MATCH_ERROR from above. */
3080 if (gfc_validate_kind (BT_CHARACTER, *kind, true) < 0)
3082 gfc_error ("Kind %d is not supported for CHARACTER at %C", *kind);
3083 m = MATCH_ERROR;
3085 else
3086 /* All tests passed. */
3087 m = MATCH_YES;
3089 if (m == MATCH_ERROR)
3090 gfc_current_locus = where;
3092 /* Return what we know from the test(s). */
3093 return m;
3095 no_match:
3096 gfc_free_expr (e);
3097 gfc_current_locus = where;
3098 return m;
3102 /* Match the various kind/length specifications in a CHARACTER
3103 declaration. We don't return MATCH_NO. */
3105 match
3106 gfc_match_char_spec (gfc_typespec *ts)
3108 int kind, seen_length, is_iso_c;
3109 gfc_charlen *cl;
3110 gfc_expr *len;
3111 match m;
3112 bool deferred;
3114 len = NULL;
3115 seen_length = 0;
3116 kind = 0;
3117 is_iso_c = 0;
3118 deferred = false;
3120 /* Try the old-style specification first. */
3121 old_char_selector = 0;
3123 m = match_char_length (&len, &deferred, true);
3124 if (m != MATCH_NO)
3126 if (m == MATCH_YES)
3127 old_char_selector = 1;
3128 seen_length = 1;
3129 goto done;
3132 m = gfc_match_char ('(');
3133 if (m != MATCH_YES)
3135 m = MATCH_YES; /* Character without length is a single char. */
3136 goto done;
3139 /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ). */
3140 if (gfc_match (" kind =") == MATCH_YES)
3142 m = match_char_kind (&kind, &is_iso_c);
3144 if (m == MATCH_ERROR)
3145 goto done;
3146 if (m == MATCH_NO)
3147 goto syntax;
3149 if (gfc_match (" , len =") == MATCH_NO)
3150 goto rparen;
3152 m = char_len_param_value (&len, &deferred);
3153 if (m == MATCH_NO)
3154 goto syntax;
3155 if (m == MATCH_ERROR)
3156 goto done;
3157 seen_length = 1;
3159 goto rparen;
3162 /* Try to match "LEN = <len-param>" or "LEN = <len-param>, KIND = <int>". */
3163 if (gfc_match (" len =") == MATCH_YES)
3165 m = char_len_param_value (&len, &deferred);
3166 if (m == MATCH_NO)
3167 goto syntax;
3168 if (m == MATCH_ERROR)
3169 goto done;
3170 seen_length = 1;
3172 if (gfc_match_char (')') == MATCH_YES)
3173 goto done;
3175 if (gfc_match (" , kind =") != MATCH_YES)
3176 goto syntax;
3178 if (match_char_kind (&kind, &is_iso_c) == MATCH_ERROR)
3179 goto done;
3181 goto rparen;
3184 /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ). */
3185 m = char_len_param_value (&len, &deferred);
3186 if (m == MATCH_NO)
3187 goto syntax;
3188 if (m == MATCH_ERROR)
3189 goto done;
3190 seen_length = 1;
3192 m = gfc_match_char (')');
3193 if (m == MATCH_YES)
3194 goto done;
3196 if (gfc_match_char (',') != MATCH_YES)
3197 goto syntax;
3199 gfc_match (" kind ="); /* Gobble optional text. */
3201 m = match_char_kind (&kind, &is_iso_c);
3202 if (m == MATCH_ERROR)
3203 goto done;
3204 if (m == MATCH_NO)
3205 goto syntax;
3207 rparen:
3208 /* Require a right-paren at this point. */
3209 m = gfc_match_char (')');
3210 if (m == MATCH_YES)
3211 goto done;
3213 syntax:
3214 gfc_error ("Syntax error in CHARACTER declaration at %C");
3215 m = MATCH_ERROR;
3216 gfc_free_expr (len);
3217 return m;
3219 done:
3220 /* Deal with character functions after USE and IMPORT statements. */
3221 if (gfc_matching_function)
3223 gfc_free_expr (len);
3224 gfc_undo_symbols ();
3225 return MATCH_YES;
3228 if (m != MATCH_YES)
3230 gfc_free_expr (len);
3231 return m;
3234 /* Do some final massaging of the length values. */
3235 cl = gfc_new_charlen (gfc_current_ns, NULL);
3237 if (seen_length == 0)
3238 cl->length = gfc_get_int_expr (gfc_charlen_int_kind, NULL, 1);
3239 else
3241 /* If gfortran ends up here, then len may be reducible to a constant.
3242 Try to do that here. If it does not reduce, simply assign len to
3243 charlen. A complication occurs with user-defined generic functions,
3244 which are not resolved. Use a private namespace to deal with
3245 generic functions. */
3247 if (len && len->expr_type != EXPR_CONSTANT)
3249 gfc_namespace *old_ns;
3250 gfc_expr *e;
3252 old_ns = gfc_current_ns;
3253 gfc_current_ns = gfc_get_namespace (NULL, 0);
3255 e = gfc_copy_expr (len);
3256 gfc_reduce_init_expr (e);
3257 if (e->expr_type == EXPR_CONSTANT)
3259 gfc_replace_expr (len, e);
3260 if (mpz_cmp_si (len->value.integer, 0) < 0)
3261 mpz_set_ui (len->value.integer, 0);
3263 else
3264 gfc_free_expr (e);
3266 gfc_free_namespace (gfc_current_ns);
3267 gfc_current_ns = old_ns;
3270 cl->length = len;
3273 ts->u.cl = cl;
3274 ts->kind = kind == 0 ? gfc_default_character_kind : kind;
3275 ts->deferred = deferred;
3277 /* We have to know if it was a C interoperable kind so we can
3278 do accurate type checking of bind(c) procs, etc. */
3279 if (kind != 0)
3280 /* Mark this as C interoperable if being declared with one
3281 of the named constants from iso_c_binding. */
3282 ts->is_c_interop = is_iso_c;
3283 else if (len != NULL)
3284 /* Here, we might have parsed something such as: character(c_char)
3285 In this case, the parsing code above grabs the c_char when
3286 looking for the length (line 1690, roughly). it's the last
3287 testcase for parsing the kind params of a character variable.
3288 However, it's not actually the length. this seems like it
3289 could be an error.
3290 To see if the user used a C interop kind, test the expr
3291 of the so called length, and see if it's C interoperable. */
3292 ts->is_c_interop = len->ts.is_iso_c;
3294 return MATCH_YES;
3298 /* Matches a RECORD declaration. */
3300 static match
3301 match_record_decl (char *name)
3303 locus old_loc;
3304 old_loc = gfc_current_locus;
3305 match m;
3307 m = gfc_match (" record /");
3308 if (m == MATCH_YES)
3310 if (!flag_dec_structure)
3312 gfc_current_locus = old_loc;
3313 gfc_error ("RECORD at %C is an extension, enable it with "
3314 "-fdec-structure");
3315 return MATCH_ERROR;
3317 m = gfc_match (" %n/", name);
3318 if (m == MATCH_YES)
3319 return MATCH_YES;
3322 gfc_current_locus = old_loc;
3323 if (flag_dec_structure
3324 && (gfc_match (" record% ") == MATCH_YES
3325 || gfc_match (" record%t") == MATCH_YES))
3326 gfc_error ("Structure name expected after RECORD at %C");
3327 if (m == MATCH_NO)
3328 return MATCH_NO;
3330 return MATCH_ERROR;
3334 /* This function uses the gfc_actual_arglist 'type_param_spec_list' as a source
3335 of expressions to substitute into the possibly parameterized expression
3336 'e'. Using a list is inefficient but should not be too bad since the
3337 number of type parameters is not likely to be large. */
3338 static bool
3339 insert_parameter_exprs (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED,
3340 int* f)
3342 gfc_actual_arglist *param;
3343 gfc_expr *copy;
3345 if (e->expr_type != EXPR_VARIABLE)
3346 return false;
3348 gcc_assert (e->symtree);
3349 if (e->symtree->n.sym->attr.pdt_kind
3350 || (*f != 0 && e->symtree->n.sym->attr.pdt_len))
3352 for (param = type_param_spec_list; param; param = param->next)
3353 if (strcmp (e->symtree->n.sym->name, param->name) == 0)
3354 break;
3356 if (param)
3358 copy = gfc_copy_expr (param->expr);
3359 *e = *copy;
3360 free (copy);
3364 return false;
3368 bool
3369 gfc_insert_kind_parameter_exprs (gfc_expr *e)
3371 return gfc_traverse_expr (e, NULL, &insert_parameter_exprs, 0);
3375 bool
3376 gfc_insert_parameter_exprs (gfc_expr *e, gfc_actual_arglist *param_list)
3378 gfc_actual_arglist *old_param_spec_list = type_param_spec_list;
3379 type_param_spec_list = param_list;
3380 return gfc_traverse_expr (e, NULL, &insert_parameter_exprs, 1);
3381 type_param_spec_list = NULL;
3382 type_param_spec_list = old_param_spec_list;
3385 /* Determines the instance of a parameterized derived type to be used by
3386 matching determining the values of the kind parameters and using them
3387 in the name of the instance. If the instance exists, it is used, otherwise
3388 a new derived type is created. */
3389 match
3390 gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym,
3391 gfc_actual_arglist **ext_param_list)
3393 /* The PDT template symbol. */
3394 gfc_symbol *pdt = *sym;
3395 /* The symbol for the parameter in the template f2k_namespace. */
3396 gfc_symbol *param;
3397 /* The hoped for instance of the PDT. */
3398 gfc_symbol *instance;
3399 /* The list of parameters appearing in the PDT declaration. */
3400 gfc_formal_arglist *type_param_name_list;
3401 /* Used to store the parameter specification list during recursive calls. */
3402 gfc_actual_arglist *old_param_spec_list;
3403 /* Pointers to the parameter specification being used. */
3404 gfc_actual_arglist *actual_param;
3405 gfc_actual_arglist *tail = NULL;
3406 /* Used to build up the name of the PDT instance. The prefix uses 4
3407 characters and each KIND parameter 2 more. Allow 8 of the latter. */
3408 char name[GFC_MAX_SYMBOL_LEN + 21];
3410 bool name_seen = (param_list == NULL);
3411 bool assumed_seen = false;
3412 bool deferred_seen = false;
3413 bool spec_error = false;
3414 int kind_value, i;
3415 gfc_expr *kind_expr;
3416 gfc_component *c1, *c2;
3417 match m;
3419 type_param_spec_list = NULL;
3421 type_param_name_list = pdt->formal;
3422 actual_param = param_list;
3423 sprintf (name, "Pdt%s", pdt->name);
3425 /* Run through the parameter name list and pick up the actual
3426 parameter values or use the default values in the PDT declaration. */
3427 for (; type_param_name_list;
3428 type_param_name_list = type_param_name_list->next)
3430 if (actual_param && actual_param->spec_type != SPEC_EXPLICIT)
3432 if (actual_param->spec_type == SPEC_ASSUMED)
3433 spec_error = deferred_seen;
3434 else
3435 spec_error = assumed_seen;
3437 if (spec_error)
3439 gfc_error ("The type parameter spec list at %C cannot contain "
3440 "both ASSUMED and DEFERRED parameters");
3441 goto error_return;
3445 if (actual_param && actual_param->name)
3446 name_seen = true;
3447 param = type_param_name_list->sym;
3449 if (!param || !param->name)
3450 continue;
3452 c1 = gfc_find_component (pdt, param->name, false, true, NULL);
3453 /* An error should already have been thrown in resolve.c
3454 (resolve_fl_derived0). */
3455 if (!pdt->attr.use_assoc && !c1)
3456 goto error_return;
3458 kind_expr = NULL;
3459 if (!name_seen)
3461 if (!actual_param && !(c1 && c1->initializer))
3463 gfc_error ("The type parameter spec list at %C does not contain "
3464 "enough parameter expressions");
3465 goto error_return;
3467 else if (!actual_param && c1 && c1->initializer)
3468 kind_expr = gfc_copy_expr (c1->initializer);
3469 else if (actual_param && actual_param->spec_type == SPEC_EXPLICIT)
3470 kind_expr = gfc_copy_expr (actual_param->expr);
3472 else
3474 actual_param = param_list;
3475 for (;actual_param; actual_param = actual_param->next)
3476 if (actual_param->name
3477 && strcmp (actual_param->name, param->name) == 0)
3478 break;
3479 if (actual_param && actual_param->spec_type == SPEC_EXPLICIT)
3480 kind_expr = gfc_copy_expr (actual_param->expr);
3481 else
3483 if (c1->initializer)
3484 kind_expr = gfc_copy_expr (c1->initializer);
3485 else if (!(actual_param && param->attr.pdt_len))
3487 gfc_error ("The derived parameter %qs at %C does not "
3488 "have a default value", param->name);
3489 goto error_return;
3494 /* Store the current parameter expressions in a temporary actual
3495 arglist 'list' so that they can be substituted in the corresponding
3496 expressions in the PDT instance. */
3497 if (type_param_spec_list == NULL)
3499 type_param_spec_list = gfc_get_actual_arglist ();
3500 tail = type_param_spec_list;
3502 else
3504 tail->next = gfc_get_actual_arglist ();
3505 tail = tail->next;
3507 tail->name = param->name;
3509 if (kind_expr)
3511 /* Try simplification even for LEN expressions. */
3512 gfc_resolve_expr (kind_expr);
3513 gfc_simplify_expr (kind_expr, 1);
3514 /* Variable expressions seem to default to BT_PROCEDURE.
3515 TODO find out why this is and fix it. */
3516 if (kind_expr->ts.type != BT_INTEGER
3517 && kind_expr->ts.type != BT_PROCEDURE)
3519 gfc_error ("The parameter expression at %C must be of "
3520 "INTEGER type and not %s type",
3521 gfc_basic_typename (kind_expr->ts.type));
3522 goto error_return;
3525 tail->expr = gfc_copy_expr (kind_expr);
3528 if (actual_param)
3529 tail->spec_type = actual_param->spec_type;
3531 if (!param->attr.pdt_kind)
3533 if (!name_seen && actual_param)
3534 actual_param = actual_param->next;
3535 if (kind_expr)
3537 gfc_free_expr (kind_expr);
3538 kind_expr = NULL;
3540 continue;
3543 if (actual_param
3544 && (actual_param->spec_type == SPEC_ASSUMED
3545 || actual_param->spec_type == SPEC_DEFERRED))
3547 gfc_error ("The KIND parameter %qs at %C cannot either be "
3548 "ASSUMED or DEFERRED", param->name);
3549 goto error_return;
3552 if (!kind_expr || !gfc_is_constant_expr (kind_expr))
3554 gfc_error ("The value for the KIND parameter %qs at %C does not "
3555 "reduce to a constant expression", param->name);
3556 goto error_return;
3559 gfc_extract_int (kind_expr, &kind_value);
3560 sprintf (name + strlen (name), "_%d", kind_value);
3562 if (!name_seen && actual_param)
3563 actual_param = actual_param->next;
3564 gfc_free_expr (kind_expr);
3567 if (!name_seen && actual_param)
3569 gfc_error ("The type parameter spec list at %C contains too many "
3570 "parameter expressions");
3571 goto error_return;
3574 /* Now we search for the PDT instance 'name'. If it doesn't exist, we
3575 build it, using 'pdt' as a template. */
3576 if (gfc_get_symbol (name, pdt->ns, &instance))
3578 gfc_error ("Parameterized derived type at %C is ambiguous");
3579 goto error_return;
3582 m = MATCH_YES;
3584 if (instance->attr.flavor == FL_DERIVED
3585 && instance->attr.pdt_type)
3587 instance->refs++;
3588 if (ext_param_list)
3589 *ext_param_list = type_param_spec_list;
3590 *sym = instance;
3591 gfc_commit_symbols ();
3592 return m;
3595 /* Start building the new instance of the parameterized type. */
3596 gfc_copy_attr (&instance->attr, &pdt->attr, &pdt->declared_at);
3597 instance->attr.pdt_template = 0;
3598 instance->attr.pdt_type = 1;
3599 instance->declared_at = gfc_current_locus;
3601 /* Add the components, replacing the parameters in all expressions
3602 with the expressions for their values in 'type_param_spec_list'. */
3603 c1 = pdt->components;
3604 tail = type_param_spec_list;
3605 for (; c1; c1 = c1->next)
3607 gfc_add_component (instance, c1->name, &c2);
3609 c2->ts = c1->ts;
3610 c2->attr = c1->attr;
3612 /* The order of declaration of the type_specs might not be the
3613 same as that of the components. */
3614 if (c1->attr.pdt_kind || c1->attr.pdt_len)
3616 for (tail = type_param_spec_list; tail; tail = tail->next)
3617 if (strcmp (c1->name, tail->name) == 0)
3618 break;
3621 /* Deal with type extension by recursively calling this function
3622 to obtain the instance of the extended type. */
3623 if (gfc_current_state () != COMP_DERIVED
3624 && c1 == pdt->components
3625 && (c1->ts.type == BT_DERIVED || c1->ts.type == BT_CLASS)
3626 && c1->ts.u.derived && c1->ts.u.derived->attr.pdt_template
3627 && gfc_get_derived_super_type (*sym) == c2->ts.u.derived)
3629 gfc_formal_arglist *f;
3631 old_param_spec_list = type_param_spec_list;
3633 /* Obtain a spec list appropriate to the extended type..*/
3634 actual_param = gfc_copy_actual_arglist (type_param_spec_list);
3635 type_param_spec_list = actual_param;
3636 for (f = c1->ts.u.derived->formal; f && f->next; f = f->next)
3637 actual_param = actual_param->next;
3638 if (actual_param)
3640 gfc_free_actual_arglist (actual_param->next);
3641 actual_param->next = NULL;
3644 /* Now obtain the PDT instance for the extended type. */
3645 c2->param_list = type_param_spec_list;
3646 m = gfc_get_pdt_instance (type_param_spec_list, &c2->ts.u.derived,
3647 NULL);
3648 type_param_spec_list = old_param_spec_list;
3650 c2->ts.u.derived->refs++;
3651 gfc_set_sym_referenced (c2->ts.u.derived);
3653 /* Set extension level. */
3654 if (c2->ts.u.derived->attr.extension == 255)
3656 /* Since the extension field is 8 bit wide, we can only have
3657 up to 255 extension levels. */
3658 gfc_error ("Maximum extension level reached with type %qs at %L",
3659 c2->ts.u.derived->name,
3660 &c2->ts.u.derived->declared_at);
3661 goto error_return;
3663 instance->attr.extension = c2->ts.u.derived->attr.extension + 1;
3665 continue;
3668 /* Set the component kind using the parameterized expression. */
3669 if ((c1->ts.kind == 0 || c1->ts.type == BT_CHARACTER)
3670 && c1->kind_expr != NULL)
3672 gfc_expr *e = gfc_copy_expr (c1->kind_expr);
3673 gfc_insert_kind_parameter_exprs (e);
3674 gfc_simplify_expr (e, 1);
3675 gfc_extract_int (e, &c2->ts.kind);
3676 gfc_free_expr (e);
3677 if (gfc_validate_kind (c2->ts.type, c2->ts.kind, true) < 0)
3679 gfc_error ("Kind %d not supported for type %s at %C",
3680 c2->ts.kind, gfc_basic_typename (c2->ts.type));
3681 goto error_return;
3685 /* Similarly, set the string length if parameterized. */
3686 if (c1->ts.type == BT_CHARACTER
3687 && c1->ts.u.cl->length
3688 && gfc_derived_parameter_expr (c1->ts.u.cl->length))
3690 gfc_expr *e;
3691 e = gfc_copy_expr (c1->ts.u.cl->length);
3692 gfc_insert_kind_parameter_exprs (e);
3693 gfc_simplify_expr (e, 1);
3694 c2->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
3695 c2->ts.u.cl->length = e;
3696 c2->attr.pdt_string = 1;
3699 /* Set up either the KIND/LEN initializer, if constant,
3700 or the parameterized expression. Use the template
3701 initializer if one is not already set in this instance. */
3702 if (c2->attr.pdt_kind || c2->attr.pdt_len)
3704 if (tail && tail->expr && gfc_is_constant_expr (tail->expr))
3705 c2->initializer = gfc_copy_expr (tail->expr);
3706 else if (tail && tail->expr)
3708 c2->param_list = gfc_get_actual_arglist ();
3709 c2->param_list->name = tail->name;
3710 c2->param_list->expr = gfc_copy_expr (tail->expr);
3711 c2->param_list->next = NULL;
3714 if (!c2->initializer && c1->initializer)
3715 c2->initializer = gfc_copy_expr (c1->initializer);
3718 /* Copy the array spec. */
3719 c2->as = gfc_copy_array_spec (c1->as);
3720 if (c1->ts.type == BT_CLASS)
3721 CLASS_DATA (c2)->as = gfc_copy_array_spec (CLASS_DATA (c1)->as);
3723 /* Determine if an array spec is parameterized. If so, substitute
3724 in the parameter expressions for the bounds and set the pdt_array
3725 attribute. Notice that this attribute must be unconditionally set
3726 if this is an array of parameterized character length. */
3727 if (c1->as && c1->as->type == AS_EXPLICIT)
3729 bool pdt_array = false;
3731 /* Are the bounds of the array parameterized? */
3732 for (i = 0; i < c1->as->rank; i++)
3734 if (gfc_derived_parameter_expr (c1->as->lower[i]))
3735 pdt_array = true;
3736 if (gfc_derived_parameter_expr (c1->as->upper[i]))
3737 pdt_array = true;
3740 /* If they are, free the expressions for the bounds and
3741 replace them with the template expressions with substitute
3742 values. */
3743 for (i = 0; pdt_array && i < c1->as->rank; i++)
3745 gfc_expr *e;
3746 e = gfc_copy_expr (c1->as->lower[i]);
3747 gfc_insert_kind_parameter_exprs (e);
3748 gfc_simplify_expr (e, 1);
3749 gfc_free_expr (c2->as->lower[i]);
3750 c2->as->lower[i] = e;
3751 e = gfc_copy_expr (c1->as->upper[i]);
3752 gfc_insert_kind_parameter_exprs (e);
3753 gfc_simplify_expr (e, 1);
3754 gfc_free_expr (c2->as->upper[i]);
3755 c2->as->upper[i] = e;
3757 c2->attr.pdt_array = pdt_array ? 1 : c2->attr.pdt_string;
3758 if (c1->initializer)
3760 c2->initializer = gfc_copy_expr (c1->initializer);
3761 gfc_insert_kind_parameter_exprs (c2->initializer);
3762 gfc_simplify_expr (c2->initializer, 1);
3766 /* Recurse into this function for PDT components. */
3767 if ((c1->ts.type == BT_DERIVED || c1->ts.type == BT_CLASS)
3768 && c1->ts.u.derived && c1->ts.u.derived->attr.pdt_template)
3770 gfc_actual_arglist *params;
3771 /* The component in the template has a list of specification
3772 expressions derived from its declaration. */
3773 params = gfc_copy_actual_arglist (c1->param_list);
3774 actual_param = params;
3775 /* Substitute the template parameters with the expressions
3776 from the specification list. */
3777 for (;actual_param; actual_param = actual_param->next)
3778 gfc_insert_parameter_exprs (actual_param->expr,
3779 type_param_spec_list);
3781 /* Now obtain the PDT instance for the component. */
3782 old_param_spec_list = type_param_spec_list;
3783 m = gfc_get_pdt_instance (params, &c2->ts.u.derived, NULL);
3784 type_param_spec_list = old_param_spec_list;
3786 c2->param_list = params;
3787 if (!(c2->attr.pointer || c2->attr.allocatable))
3788 c2->initializer = gfc_default_initializer (&c2->ts);
3790 if (c2->attr.allocatable)
3791 instance->attr.alloc_comp = 1;
3795 gfc_commit_symbol (instance);
3796 if (ext_param_list)
3797 *ext_param_list = type_param_spec_list;
3798 *sym = instance;
3799 return m;
3801 error_return:
3802 gfc_free_actual_arglist (type_param_spec_list);
3803 return MATCH_ERROR;
3807 /* Matches a declaration-type-spec (F03:R502). If successful, sets the ts
3808 structure to the matched specification. This is necessary for FUNCTION and
3809 IMPLICIT statements.
3811 If implicit_flag is nonzero, then we don't check for the optional
3812 kind specification. Not doing so is needed for matching an IMPLICIT
3813 statement correctly. */
3815 match
3816 gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
3818 char name[GFC_MAX_SYMBOL_LEN + 1];
3819 gfc_symbol *sym, *dt_sym;
3820 match m;
3821 char c;
3822 bool seen_deferred_kind, matched_type;
3823 const char *dt_name;
3825 decl_type_param_list = NULL;
3827 /* A belt and braces check that the typespec is correctly being treated
3828 as a deferred characteristic association. */
3829 seen_deferred_kind = (gfc_current_state () == COMP_FUNCTION)
3830 && (gfc_current_block ()->result->ts.kind == -1)
3831 && (ts->kind == -1);
3832 gfc_clear_ts (ts);
3833 if (seen_deferred_kind)
3834 ts->kind = -1;
3836 /* Clear the current binding label, in case one is given. */
3837 curr_binding_label = NULL;
3839 if (gfc_match (" byte") == MATCH_YES)
3841 if (!gfc_notify_std (GFC_STD_GNU, "BYTE type at %C"))
3842 return MATCH_ERROR;
3844 if (gfc_validate_kind (BT_INTEGER, 1, true) < 0)
3846 gfc_error ("BYTE type used at %C "
3847 "is not available on the target machine");
3848 return MATCH_ERROR;
3851 ts->type = BT_INTEGER;
3852 ts->kind = 1;
3853 return MATCH_YES;
3857 m = gfc_match (" type (");
3858 matched_type = (m == MATCH_YES);
3859 if (matched_type)
3861 gfc_gobble_whitespace ();
3862 if (gfc_peek_ascii_char () == '*')
3864 if ((m = gfc_match ("*)")) != MATCH_YES)
3865 return m;
3866 if (gfc_comp_struct (gfc_current_state ()))
3868 gfc_error ("Assumed type at %C is not allowed for components");
3869 return MATCH_ERROR;
3871 if (!gfc_notify_std (GFC_STD_F2018, "Assumed type at %C"))
3872 return MATCH_ERROR;
3873 ts->type = BT_ASSUMED;
3874 return MATCH_YES;
3877 m = gfc_match ("%n", name);
3878 matched_type = (m == MATCH_YES);
3881 if ((matched_type && strcmp ("integer", name) == 0)
3882 || (!matched_type && gfc_match (" integer") == MATCH_YES))
3884 ts->type = BT_INTEGER;
3885 ts->kind = gfc_default_integer_kind;
3886 goto get_kind;
3889 if ((matched_type && strcmp ("character", name) == 0)
3890 || (!matched_type && gfc_match (" character") == MATCH_YES))
3892 if (matched_type
3893 && !gfc_notify_std (GFC_STD_F2008, "TYPE with "
3894 "intrinsic-type-spec at %C"))
3895 return MATCH_ERROR;
3897 ts->type = BT_CHARACTER;
3898 if (implicit_flag == 0)
3899 m = gfc_match_char_spec (ts);
3900 else
3901 m = MATCH_YES;
3903 if (matched_type && m == MATCH_YES && gfc_match_char (')') != MATCH_YES)
3904 m = MATCH_ERROR;
3906 return m;
3909 if ((matched_type && strcmp ("real", name) == 0)
3910 || (!matched_type && gfc_match (" real") == MATCH_YES))
3912 ts->type = BT_REAL;
3913 ts->kind = gfc_default_real_kind;
3914 goto get_kind;
3917 if ((matched_type
3918 && (strcmp ("doubleprecision", name) == 0
3919 || (strcmp ("double", name) == 0
3920 && gfc_match (" precision") == MATCH_YES)))
3921 || (!matched_type && gfc_match (" double precision") == MATCH_YES))
3923 if (matched_type
3924 && !gfc_notify_std (GFC_STD_F2008, "TYPE with "
3925 "intrinsic-type-spec at %C"))
3926 return MATCH_ERROR;
3927 if (matched_type && gfc_match_char (')') != MATCH_YES)
3928 return MATCH_ERROR;
3930 ts->type = BT_REAL;
3931 ts->kind = gfc_default_double_kind;
3932 return MATCH_YES;
3935 if ((matched_type && strcmp ("complex", name) == 0)
3936 || (!matched_type && gfc_match (" complex") == MATCH_YES))
3938 ts->type = BT_COMPLEX;
3939 ts->kind = gfc_default_complex_kind;
3940 goto get_kind;
3943 if ((matched_type
3944 && (strcmp ("doublecomplex", name) == 0
3945 || (strcmp ("double", name) == 0
3946 && gfc_match (" complex") == MATCH_YES)))
3947 || (!matched_type && gfc_match (" double complex") == MATCH_YES))
3949 if (!gfc_notify_std (GFC_STD_GNU, "DOUBLE COMPLEX at %C"))
3950 return MATCH_ERROR;
3952 if (matched_type
3953 && !gfc_notify_std (GFC_STD_F2008, "TYPE with "
3954 "intrinsic-type-spec at %C"))
3955 return MATCH_ERROR;
3957 if (matched_type && gfc_match_char (')') != MATCH_YES)
3958 return MATCH_ERROR;
3960 ts->type = BT_COMPLEX;
3961 ts->kind = gfc_default_double_kind;
3962 return MATCH_YES;
3965 if ((matched_type && strcmp ("logical", name) == 0)
3966 || (!matched_type && gfc_match (" logical") == MATCH_YES))
3968 ts->type = BT_LOGICAL;
3969 ts->kind = gfc_default_logical_kind;
3970 goto get_kind;
3973 if (matched_type)
3975 m = gfc_match_actual_arglist (1, &decl_type_param_list, true);
3976 if (m == MATCH_ERROR)
3977 return m;
3979 m = gfc_match_char (')');
3982 if (m != MATCH_YES)
3983 m = match_record_decl (name);
3985 if (matched_type || m == MATCH_YES)
3987 ts->type = BT_DERIVED;
3988 /* We accept record/s/ or type(s) where s is a structure, but we
3989 * don't need all the extra derived-type stuff for structures. */
3990 if (gfc_find_symbol (gfc_dt_upper_string (name), NULL, 1, &sym))
3992 gfc_error ("Type name %qs at %C is ambiguous", name);
3993 return MATCH_ERROR;
3996 if (sym && sym->attr.flavor == FL_DERIVED
3997 && sym->attr.pdt_template
3998 && gfc_current_state () != COMP_DERIVED)
4000 m = gfc_get_pdt_instance (decl_type_param_list, &sym, NULL);
4001 if (m != MATCH_YES)
4002 return m;
4003 gcc_assert (!sym->attr.pdt_template && sym->attr.pdt_type);
4004 ts->u.derived = sym;
4005 strcpy (name, gfc_dt_lower_string (sym->name));
4008 if (sym && sym->attr.flavor == FL_STRUCT)
4010 ts->u.derived = sym;
4011 return MATCH_YES;
4013 /* Actually a derived type. */
4016 else
4018 /* Match nested STRUCTURE declarations; only valid within another
4019 structure declaration. */
4020 if (flag_dec_structure
4021 && (gfc_current_state () == COMP_STRUCTURE
4022 || gfc_current_state () == COMP_MAP))
4024 m = gfc_match (" structure");
4025 if (m == MATCH_YES)
4027 m = gfc_match_structure_decl ();
4028 if (m == MATCH_YES)
4030 /* gfc_new_block is updated by match_structure_decl. */
4031 ts->type = BT_DERIVED;
4032 ts->u.derived = gfc_new_block;
4033 return MATCH_YES;
4036 if (m == MATCH_ERROR)
4037 return MATCH_ERROR;
4040 /* Match CLASS declarations. */
4041 m = gfc_match (" class ( * )");
4042 if (m == MATCH_ERROR)
4043 return MATCH_ERROR;
4044 else if (m == MATCH_YES)
4046 gfc_symbol *upe;
4047 gfc_symtree *st;
4048 ts->type = BT_CLASS;
4049 gfc_find_symbol ("STAR", gfc_current_ns, 1, &upe);
4050 if (upe == NULL)
4052 upe = gfc_new_symbol ("STAR", gfc_current_ns);
4053 st = gfc_new_symtree (&gfc_current_ns->sym_root, "STAR");
4054 st->n.sym = upe;
4055 gfc_set_sym_referenced (upe);
4056 upe->refs++;
4057 upe->ts.type = BT_VOID;
4058 upe->attr.unlimited_polymorphic = 1;
4059 /* This is essential to force the construction of
4060 unlimited polymorphic component class containers. */
4061 upe->attr.zero_comp = 1;
4062 if (!gfc_add_flavor (&upe->attr, FL_DERIVED, NULL,
4063 &gfc_current_locus))
4064 return MATCH_ERROR;
4066 else
4068 st = gfc_get_tbp_symtree (&gfc_current_ns->sym_root, "STAR");
4069 st->n.sym = upe;
4070 upe->refs++;
4072 ts->u.derived = upe;
4073 return m;
4076 m = gfc_match (" class (");
4078 if (m == MATCH_YES)
4079 m = gfc_match ("%n", name);
4080 else
4081 return m;
4083 if (m != MATCH_YES)
4084 return m;
4085 ts->type = BT_CLASS;
4087 if (!gfc_notify_std (GFC_STD_F2003, "CLASS statement at %C"))
4088 return MATCH_ERROR;
4090 m = gfc_match_actual_arglist (1, &decl_type_param_list, true);
4091 if (m == MATCH_ERROR)
4092 return m;
4094 m = gfc_match_char (')');
4095 if (m != MATCH_YES)
4096 return m;
4099 /* Defer association of the derived type until the end of the
4100 specification block. However, if the derived type can be
4101 found, add it to the typespec. */
4102 if (gfc_matching_function)
4104 ts->u.derived = NULL;
4105 if (gfc_current_state () != COMP_INTERFACE
4106 && !gfc_find_symbol (name, NULL, 1, &sym) && sym)
4108 sym = gfc_find_dt_in_generic (sym);
4109 ts->u.derived = sym;
4111 return MATCH_YES;
4114 /* Search for the name but allow the components to be defined later. If
4115 type = -1, this typespec has been seen in a function declaration but
4116 the type could not be accessed at that point. The actual derived type is
4117 stored in a symtree with the first letter of the name capitalized; the
4118 symtree with the all lower-case name contains the associated
4119 generic function. */
4120 dt_name = gfc_dt_upper_string (name);
4121 sym = NULL;
4122 dt_sym = NULL;
4123 if (ts->kind != -1)
4125 gfc_get_ha_symbol (name, &sym);
4126 if (sym->generic && gfc_find_symbol (dt_name, NULL, 0, &dt_sym))
4128 gfc_error ("Type name %qs at %C is ambiguous", name);
4129 return MATCH_ERROR;
4131 if (sym->generic && !dt_sym)
4132 dt_sym = gfc_find_dt_in_generic (sym);
4134 /* Host associated PDTs can get confused with their constructors
4135 because they ar instantiated in the template's namespace. */
4136 if (!dt_sym)
4138 if (gfc_find_symbol (dt_name, NULL, 1, &dt_sym))
4140 gfc_error ("Type name %qs at %C is ambiguous", name);
4141 return MATCH_ERROR;
4143 if (dt_sym && !dt_sym->attr.pdt_type)
4144 dt_sym = NULL;
4147 else if (ts->kind == -1)
4149 int iface = gfc_state_stack->previous->state != COMP_INTERFACE
4150 || gfc_current_ns->has_import_set;
4151 gfc_find_symbol (name, NULL, iface, &sym);
4152 if (sym && sym->generic && gfc_find_symbol (dt_name, NULL, 1, &dt_sym))
4154 gfc_error ("Type name %qs at %C is ambiguous", name);
4155 return MATCH_ERROR;
4157 if (sym && sym->generic && !dt_sym)
4158 dt_sym = gfc_find_dt_in_generic (sym);
4160 ts->kind = 0;
4161 if (sym == NULL)
4162 return MATCH_NO;
4165 if ((sym->attr.flavor != FL_UNKNOWN && sym->attr.flavor != FL_STRUCT
4166 && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.generic))
4167 || sym->attr.subroutine)
4169 gfc_error ("Type name %qs at %C conflicts with previously declared "
4170 "entity at %L, which has the same name", name,
4171 &sym->declared_at);
4172 return MATCH_ERROR;
4175 if (sym && sym->attr.flavor == FL_DERIVED
4176 && sym->attr.pdt_template
4177 && gfc_current_state () != COMP_DERIVED)
4179 m = gfc_get_pdt_instance (decl_type_param_list, &sym, NULL);
4180 if (m != MATCH_YES)
4181 return m;
4182 gcc_assert (!sym->attr.pdt_template && sym->attr.pdt_type);
4183 ts->u.derived = sym;
4184 strcpy (name, gfc_dt_lower_string (sym->name));
4187 gfc_save_symbol_data (sym);
4188 gfc_set_sym_referenced (sym);
4189 if (!sym->attr.generic
4190 && !gfc_add_generic (&sym->attr, sym->name, NULL))
4191 return MATCH_ERROR;
4193 if (!sym->attr.function
4194 && !gfc_add_function (&sym->attr, sym->name, NULL))
4195 return MATCH_ERROR;
4197 if (dt_sym && dt_sym->attr.flavor == FL_DERIVED
4198 && dt_sym->attr.pdt_template
4199 && gfc_current_state () != COMP_DERIVED)
4201 m = gfc_get_pdt_instance (decl_type_param_list, &dt_sym, NULL);
4202 if (m != MATCH_YES)
4203 return m;
4204 gcc_assert (!dt_sym->attr.pdt_template && dt_sym->attr.pdt_type);
4207 if (!dt_sym)
4209 gfc_interface *intr, *head;
4211 /* Use upper case to save the actual derived-type symbol. */
4212 gfc_get_symbol (dt_name, NULL, &dt_sym);
4213 dt_sym->name = gfc_get_string ("%s", sym->name);
4214 head = sym->generic;
4215 intr = gfc_get_interface ();
4216 intr->sym = dt_sym;
4217 intr->where = gfc_current_locus;
4218 intr->next = head;
4219 sym->generic = intr;
4220 sym->attr.if_source = IFSRC_DECL;
4222 else
4223 gfc_save_symbol_data (dt_sym);
4225 gfc_set_sym_referenced (dt_sym);
4227 if (dt_sym->attr.flavor != FL_DERIVED && dt_sym->attr.flavor != FL_STRUCT
4228 && !gfc_add_flavor (&dt_sym->attr, FL_DERIVED, sym->name, NULL))
4229 return MATCH_ERROR;
4231 ts->u.derived = dt_sym;
4233 return MATCH_YES;
4235 get_kind:
4236 if (matched_type
4237 && !gfc_notify_std (GFC_STD_F2008, "TYPE with "
4238 "intrinsic-type-spec at %C"))
4239 return MATCH_ERROR;
4241 /* For all types except double, derived and character, look for an
4242 optional kind specifier. MATCH_NO is actually OK at this point. */
4243 if (implicit_flag == 1)
4245 if (matched_type && gfc_match_char (')') != MATCH_YES)
4246 return MATCH_ERROR;
4248 return MATCH_YES;
4251 if (gfc_current_form == FORM_FREE)
4253 c = gfc_peek_ascii_char ();
4254 if (!gfc_is_whitespace (c) && c != '*' && c != '('
4255 && c != ':' && c != ',')
4257 if (matched_type && c == ')')
4259 gfc_next_ascii_char ();
4260 return MATCH_YES;
4262 return MATCH_NO;
4266 m = gfc_match_kind_spec (ts, false);
4267 if (m == MATCH_NO && ts->type != BT_CHARACTER)
4269 m = gfc_match_old_kind_spec (ts);
4270 if (gfc_validate_kind (ts->type, ts->kind, true) == -1)
4271 return MATCH_ERROR;
4274 if (matched_type && gfc_match_char (')') != MATCH_YES)
4275 return MATCH_ERROR;
4277 /* Defer association of the KIND expression of function results
4278 until after USE and IMPORT statements. */
4279 if ((gfc_current_state () == COMP_NONE && gfc_error_flag_test ())
4280 || gfc_matching_function)
4281 return MATCH_YES;
4283 if (m == MATCH_NO)
4284 m = MATCH_YES; /* No kind specifier found. */
4286 return m;
4290 /* Match an IMPLICIT NONE statement. Actually, this statement is
4291 already matched in parse.c, or we would not end up here in the
4292 first place. So the only thing we need to check, is if there is
4293 trailing garbage. If not, the match is successful. */
4295 match
4296 gfc_match_implicit_none (void)
4298 char c;
4299 match m;
4300 char name[GFC_MAX_SYMBOL_LEN + 1];
4301 bool type = false;
4302 bool external = false;
4303 locus cur_loc = gfc_current_locus;
4305 if (gfc_current_ns->seen_implicit_none
4306 || gfc_current_ns->has_implicit_none_export)
4308 gfc_error ("Duplicate IMPLICIT NONE statement at %C");
4309 return MATCH_ERROR;
4312 gfc_gobble_whitespace ();
4313 c = gfc_peek_ascii_char ();
4314 if (c == '(')
4316 (void) gfc_next_ascii_char ();
4317 if (!gfc_notify_std (GFC_STD_F2018, "IMPORT NONE with spec list at %C"))
4318 return MATCH_ERROR;
4320 gfc_gobble_whitespace ();
4321 if (gfc_peek_ascii_char () == ')')
4323 (void) gfc_next_ascii_char ();
4324 type = true;
4326 else
4327 for(;;)
4329 m = gfc_match (" %n", name);
4330 if (m != MATCH_YES)
4331 return MATCH_ERROR;
4333 if (strcmp (name, "type") == 0)
4334 type = true;
4335 else if (strcmp (name, "external") == 0)
4336 external = true;
4337 else
4338 return MATCH_ERROR;
4340 gfc_gobble_whitespace ();
4341 c = gfc_next_ascii_char ();
4342 if (c == ',')
4343 continue;
4344 if (c == ')')
4345 break;
4346 return MATCH_ERROR;
4349 else
4350 type = true;
4352 if (gfc_match_eos () != MATCH_YES)
4353 return MATCH_ERROR;
4355 gfc_set_implicit_none (type, external, &cur_loc);
4357 return MATCH_YES;
4361 /* Match the letter range(s) of an IMPLICIT statement. */
4363 static match
4364 match_implicit_range (void)
4366 char c, c1, c2;
4367 int inner;
4368 locus cur_loc;
4370 cur_loc = gfc_current_locus;
4372 gfc_gobble_whitespace ();
4373 c = gfc_next_ascii_char ();
4374 if (c != '(')
4376 gfc_error ("Missing character range in IMPLICIT at %C");
4377 goto bad;
4380 inner = 1;
4381 while (inner)
4383 gfc_gobble_whitespace ();
4384 c1 = gfc_next_ascii_char ();
4385 if (!ISALPHA (c1))
4386 goto bad;
4388 gfc_gobble_whitespace ();
4389 c = gfc_next_ascii_char ();
4391 switch (c)
4393 case ')':
4394 inner = 0; /* Fall through. */
4396 case ',':
4397 c2 = c1;
4398 break;
4400 case '-':
4401 gfc_gobble_whitespace ();
4402 c2 = gfc_next_ascii_char ();
4403 if (!ISALPHA (c2))
4404 goto bad;
4406 gfc_gobble_whitespace ();
4407 c = gfc_next_ascii_char ();
4409 if ((c != ',') && (c != ')'))
4410 goto bad;
4411 if (c == ')')
4412 inner = 0;
4414 break;
4416 default:
4417 goto bad;
4420 if (c1 > c2)
4422 gfc_error ("Letters must be in alphabetic order in "
4423 "IMPLICIT statement at %C");
4424 goto bad;
4427 /* See if we can add the newly matched range to the pending
4428 implicits from this IMPLICIT statement. We do not check for
4429 conflicts with whatever earlier IMPLICIT statements may have
4430 set. This is done when we've successfully finished matching
4431 the current one. */
4432 if (!gfc_add_new_implicit_range (c1, c2))
4433 goto bad;
4436 return MATCH_YES;
4438 bad:
4439 gfc_syntax_error (ST_IMPLICIT);
4441 gfc_current_locus = cur_loc;
4442 return MATCH_ERROR;
4446 /* Match an IMPLICIT statement, storing the types for
4447 gfc_set_implicit() if the statement is accepted by the parser.
4448 There is a strange looking, but legal syntactic construction
4449 possible. It looks like:
4451 IMPLICIT INTEGER (a-b) (c-d)
4453 This is legal if "a-b" is a constant expression that happens to
4454 equal one of the legal kinds for integers. The real problem
4455 happens with an implicit specification that looks like:
4457 IMPLICIT INTEGER (a-b)
4459 In this case, a typespec matcher that is "greedy" (as most of the
4460 matchers are) gobbles the character range as a kindspec, leaving
4461 nothing left. We therefore have to go a bit more slowly in the
4462 matching process by inhibiting the kindspec checking during
4463 typespec matching and checking for a kind later. */
4465 match
4466 gfc_match_implicit (void)
4468 gfc_typespec ts;
4469 locus cur_loc;
4470 char c;
4471 match m;
4473 if (gfc_current_ns->seen_implicit_none)
4475 gfc_error ("IMPLICIT statement at %C following an IMPLICIT NONE (type) "
4476 "statement");
4477 return MATCH_ERROR;
4480 gfc_clear_ts (&ts);
4482 /* We don't allow empty implicit statements. */
4483 if (gfc_match_eos () == MATCH_YES)
4485 gfc_error ("Empty IMPLICIT statement at %C");
4486 return MATCH_ERROR;
4491 /* First cleanup. */
4492 gfc_clear_new_implicit ();
4494 /* A basic type is mandatory here. */
4495 m = gfc_match_decl_type_spec (&ts, 1);
4496 if (m == MATCH_ERROR)
4497 goto error;
4498 if (m == MATCH_NO)
4499 goto syntax;
4501 cur_loc = gfc_current_locus;
4502 m = match_implicit_range ();
4504 if (m == MATCH_YES)
4506 /* We may have <TYPE> (<RANGE>). */
4507 gfc_gobble_whitespace ();
4508 c = gfc_peek_ascii_char ();
4509 if (c == ',' || c == '\n' || c == ';' || c == '!')
4511 /* Check for CHARACTER with no length parameter. */
4512 if (ts.type == BT_CHARACTER && !ts.u.cl)
4514 ts.kind = gfc_default_character_kind;
4515 ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
4516 ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind,
4517 NULL, 1);
4520 /* Record the Successful match. */
4521 if (!gfc_merge_new_implicit (&ts))
4522 return MATCH_ERROR;
4523 if (c == ',')
4524 c = gfc_next_ascii_char ();
4525 else if (gfc_match_eos () == MATCH_ERROR)
4526 goto error;
4527 continue;
4530 gfc_current_locus = cur_loc;
4533 /* Discard the (incorrectly) matched range. */
4534 gfc_clear_new_implicit ();
4536 /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
4537 if (ts.type == BT_CHARACTER)
4538 m = gfc_match_char_spec (&ts);
4539 else
4541 m = gfc_match_kind_spec (&ts, false);
4542 if (m == MATCH_NO)
4544 m = gfc_match_old_kind_spec (&ts);
4545 if (m == MATCH_ERROR)
4546 goto error;
4547 if (m == MATCH_NO)
4548 goto syntax;
4551 if (m == MATCH_ERROR)
4552 goto error;
4554 m = match_implicit_range ();
4555 if (m == MATCH_ERROR)
4556 goto error;
4557 if (m == MATCH_NO)
4558 goto syntax;
4560 gfc_gobble_whitespace ();
4561 c = gfc_next_ascii_char ();
4562 if (c != ',' && gfc_match_eos () != MATCH_YES)
4563 goto syntax;
4565 if (!gfc_merge_new_implicit (&ts))
4566 return MATCH_ERROR;
4568 while (c == ',');
4570 return MATCH_YES;
4572 syntax:
4573 gfc_syntax_error (ST_IMPLICIT);
4575 error:
4576 return MATCH_ERROR;
4580 match
4581 gfc_match_import (void)
4583 char name[GFC_MAX_SYMBOL_LEN + 1];
4584 match m;
4585 gfc_symbol *sym;
4586 gfc_symtree *st;
4588 if (gfc_current_ns->proc_name == NULL
4589 || gfc_current_ns->proc_name->attr.if_source != IFSRC_IFBODY)
4591 gfc_error ("IMPORT statement at %C only permitted in "
4592 "an INTERFACE body");
4593 return MATCH_ERROR;
4596 if (gfc_current_ns->proc_name->attr.module_procedure)
4598 gfc_error ("F2008: C1210 IMPORT statement at %C is not permitted "
4599 "in a module procedure interface body");
4600 return MATCH_ERROR;
4603 if (!gfc_notify_std (GFC_STD_F2003, "IMPORT statement at %C"))
4604 return MATCH_ERROR;
4606 if (gfc_match_eos () == MATCH_YES)
4608 /* All host variables should be imported. */
4609 gfc_current_ns->has_import_set = 1;
4610 return MATCH_YES;
4613 if (gfc_match (" ::") == MATCH_YES)
4615 if (gfc_match_eos () == MATCH_YES)
4617 gfc_error ("Expecting list of named entities at %C");
4618 return MATCH_ERROR;
4622 for(;;)
4624 sym = NULL;
4625 m = gfc_match (" %n", name);
4626 switch (m)
4628 case MATCH_YES:
4629 if (gfc_current_ns->parent != NULL
4630 && gfc_find_symbol (name, gfc_current_ns->parent, 1, &sym))
4632 gfc_error ("Type name %qs at %C is ambiguous", name);
4633 return MATCH_ERROR;
4635 else if (!sym && gfc_current_ns->proc_name->ns->parent != NULL
4636 && gfc_find_symbol (name,
4637 gfc_current_ns->proc_name->ns->parent,
4638 1, &sym))
4640 gfc_error ("Type name %qs at %C is ambiguous", name);
4641 return MATCH_ERROR;
4644 if (sym == NULL)
4646 gfc_error ("Cannot IMPORT %qs from host scoping unit "
4647 "at %C - does not exist.", name);
4648 return MATCH_ERROR;
4651 if (gfc_find_symtree (gfc_current_ns->sym_root, name))
4653 gfc_warning (0, "%qs is already IMPORTed from host scoping unit "
4654 "at %C", name);
4655 goto next_item;
4658 st = gfc_new_symtree (&gfc_current_ns->sym_root, name);
4659 st->n.sym = sym;
4660 sym->refs++;
4661 sym->attr.imported = 1;
4663 if (sym->attr.generic && (sym = gfc_find_dt_in_generic (sym)))
4665 /* The actual derived type is stored in a symtree with the first
4666 letter of the name capitalized; the symtree with the all
4667 lower-case name contains the associated generic function. */
4668 st = gfc_new_symtree (&gfc_current_ns->sym_root,
4669 gfc_dt_upper_string (name));
4670 st->n.sym = sym;
4671 sym->refs++;
4672 sym->attr.imported = 1;
4675 goto next_item;
4677 case MATCH_NO:
4678 break;
4680 case MATCH_ERROR:
4681 return MATCH_ERROR;
4684 next_item:
4685 if (gfc_match_eos () == MATCH_YES)
4686 break;
4687 if (gfc_match_char (',') != MATCH_YES)
4688 goto syntax;
4691 return MATCH_YES;
4693 syntax:
4694 gfc_error ("Syntax error in IMPORT statement at %C");
4695 return MATCH_ERROR;
4699 /* A minimal implementation of gfc_match without whitespace, escape
4700 characters or variable arguments. Returns true if the next
4701 characters match the TARGET template exactly. */
4703 static bool
4704 match_string_p (const char *target)
4706 const char *p;
4708 for (p = target; *p; p++)
4709 if ((char) gfc_next_ascii_char () != *p)
4710 return false;
4711 return true;
4714 /* Matches an attribute specification including array specs. If
4715 successful, leaves the variables current_attr and current_as
4716 holding the specification. Also sets the colon_seen variable for
4717 later use by matchers associated with initializations.
4719 This subroutine is a little tricky in the sense that we don't know
4720 if we really have an attr-spec until we hit the double colon.
4721 Until that time, we can only return MATCH_NO. This forces us to
4722 check for duplicate specification at this level. */
4724 static match
4725 match_attr_spec (void)
4727 /* Modifiers that can exist in a type statement. */
4728 enum
4729 { GFC_DECL_BEGIN = 0, DECL_ALLOCATABLE = GFC_DECL_BEGIN,
4730 DECL_IN = INTENT_IN, DECL_OUT = INTENT_OUT, DECL_INOUT = INTENT_INOUT,
4731 DECL_DIMENSION, DECL_EXTERNAL,
4732 DECL_INTRINSIC, DECL_OPTIONAL,
4733 DECL_PARAMETER, DECL_POINTER, DECL_PROTECTED, DECL_PRIVATE,
4734 DECL_STATIC, DECL_AUTOMATIC,
4735 DECL_PUBLIC, DECL_SAVE, DECL_TARGET, DECL_VALUE, DECL_VOLATILE,
4736 DECL_IS_BIND_C, DECL_CODIMENSION, DECL_ASYNCHRONOUS, DECL_CONTIGUOUS,
4737 DECL_LEN, DECL_KIND, DECL_NONE, GFC_DECL_END /* Sentinel */
4740 /* GFC_DECL_END is the sentinel, index starts at 0. */
4741 #define NUM_DECL GFC_DECL_END
4743 /* Make sure that values from sym_intent are safe to be used here. */
4744 gcc_assert (INTENT_IN > 0);
4746 locus start, seen_at[NUM_DECL];
4747 int seen[NUM_DECL];
4748 unsigned int d;
4749 const char *attr;
4750 match m;
4751 bool t;
4753 gfc_clear_attr (&current_attr);
4754 start = gfc_current_locus;
4756 current_as = NULL;
4757 colon_seen = 0;
4758 attr_seen = 0;
4760 /* See if we get all of the keywords up to the final double colon. */
4761 for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
4762 seen[d] = 0;
4764 for (;;)
4766 char ch;
4768 d = DECL_NONE;
4769 gfc_gobble_whitespace ();
4771 ch = gfc_next_ascii_char ();
4772 if (ch == ':')
4774 /* This is the successful exit condition for the loop. */
4775 if (gfc_next_ascii_char () == ':')
4776 break;
4778 else if (ch == ',')
4780 gfc_gobble_whitespace ();
4781 switch (gfc_peek_ascii_char ())
4783 case 'a':
4784 gfc_next_ascii_char ();
4785 switch (gfc_next_ascii_char ())
4787 case 'l':
4788 if (match_string_p ("locatable"))
4790 /* Matched "allocatable". */
4791 d = DECL_ALLOCATABLE;
4793 break;
4795 case 's':
4796 if (match_string_p ("ynchronous"))
4798 /* Matched "asynchronous". */
4799 d = DECL_ASYNCHRONOUS;
4801 break;
4803 case 'u':
4804 if (match_string_p ("tomatic"))
4806 /* Matched "automatic". */
4807 d = DECL_AUTOMATIC;
4809 break;
4811 break;
4813 case 'b':
4814 /* Try and match the bind(c). */
4815 m = gfc_match_bind_c (NULL, true);
4816 if (m == MATCH_YES)
4817 d = DECL_IS_BIND_C;
4818 else if (m == MATCH_ERROR)
4819 goto cleanup;
4820 break;
4822 case 'c':
4823 gfc_next_ascii_char ();
4824 if ('o' != gfc_next_ascii_char ())
4825 break;
4826 switch (gfc_next_ascii_char ())
4828 case 'd':
4829 if (match_string_p ("imension"))
4831 d = DECL_CODIMENSION;
4832 break;
4834 /* FALLTHRU */
4835 case 'n':
4836 if (match_string_p ("tiguous"))
4838 d = DECL_CONTIGUOUS;
4839 break;
4842 break;
4844 case 'd':
4845 if (match_string_p ("dimension"))
4846 d = DECL_DIMENSION;
4847 break;
4849 case 'e':
4850 if (match_string_p ("external"))
4851 d = DECL_EXTERNAL;
4852 break;
4854 case 'i':
4855 if (match_string_p ("int"))
4857 ch = gfc_next_ascii_char ();
4858 if (ch == 'e')
4860 if (match_string_p ("nt"))
4862 /* Matched "intent". */
4863 d = match_intent_spec ();
4864 if (d == INTENT_UNKNOWN)
4866 m = MATCH_ERROR;
4867 goto cleanup;
4871 else if (ch == 'r')
4873 if (match_string_p ("insic"))
4875 /* Matched "intrinsic". */
4876 d = DECL_INTRINSIC;
4880 break;
4882 case 'k':
4883 if (match_string_p ("kind"))
4884 d = DECL_KIND;
4885 break;
4887 case 'l':
4888 if (match_string_p ("len"))
4889 d = DECL_LEN;
4890 break;
4892 case 'o':
4893 if (match_string_p ("optional"))
4894 d = DECL_OPTIONAL;
4895 break;
4897 case 'p':
4898 gfc_next_ascii_char ();
4899 switch (gfc_next_ascii_char ())
4901 case 'a':
4902 if (match_string_p ("rameter"))
4904 /* Matched "parameter". */
4905 d = DECL_PARAMETER;
4907 break;
4909 case 'o':
4910 if (match_string_p ("inter"))
4912 /* Matched "pointer". */
4913 d = DECL_POINTER;
4915 break;
4917 case 'r':
4918 ch = gfc_next_ascii_char ();
4919 if (ch == 'i')
4921 if (match_string_p ("vate"))
4923 /* Matched "private". */
4924 d = DECL_PRIVATE;
4927 else if (ch == 'o')
4929 if (match_string_p ("tected"))
4931 /* Matched "protected". */
4932 d = DECL_PROTECTED;
4935 break;
4937 case 'u':
4938 if (match_string_p ("blic"))
4940 /* Matched "public". */
4941 d = DECL_PUBLIC;
4943 break;
4945 break;
4947 case 's':
4948 gfc_next_ascii_char ();
4949 switch (gfc_next_ascii_char ())
4951 case 'a':
4952 if (match_string_p ("ve"))
4954 /* Matched "save". */
4955 d = DECL_SAVE;
4957 break;
4959 case 't':
4960 if (match_string_p ("atic"))
4962 /* Matched "static". */
4963 d = DECL_STATIC;
4965 break;
4967 break;
4969 case 't':
4970 if (match_string_p ("target"))
4971 d = DECL_TARGET;
4972 break;
4974 case 'v':
4975 gfc_next_ascii_char ();
4976 ch = gfc_next_ascii_char ();
4977 if (ch == 'a')
4979 if (match_string_p ("lue"))
4981 /* Matched "value". */
4982 d = DECL_VALUE;
4985 else if (ch == 'o')
4987 if (match_string_p ("latile"))
4989 /* Matched "volatile". */
4990 d = DECL_VOLATILE;
4993 break;
4997 /* No double colon and no recognizable decl_type, so assume that
4998 we've been looking at something else the whole time. */
4999 if (d == DECL_NONE)
5001 m = MATCH_NO;
5002 goto cleanup;
5005 /* Check to make sure any parens are paired up correctly. */
5006 if (gfc_match_parens () == MATCH_ERROR)
5008 m = MATCH_ERROR;
5009 goto cleanup;
5012 seen[d]++;
5013 seen_at[d] = gfc_current_locus;
5015 if (d == DECL_DIMENSION || d == DECL_CODIMENSION)
5017 gfc_array_spec *as = NULL;
5019 m = gfc_match_array_spec (&as, d == DECL_DIMENSION,
5020 d == DECL_CODIMENSION);
5022 if (current_as == NULL)
5023 current_as = as;
5024 else if (m == MATCH_YES)
5026 if (!merge_array_spec (as, current_as, false))
5027 m = MATCH_ERROR;
5028 free (as);
5031 if (m == MATCH_NO)
5033 if (d == DECL_CODIMENSION)
5034 gfc_error ("Missing codimension specification at %C");
5035 else
5036 gfc_error ("Missing dimension specification at %C");
5037 m = MATCH_ERROR;
5040 if (m == MATCH_ERROR)
5041 goto cleanup;
5045 /* Since we've seen a double colon, we have to be looking at an
5046 attr-spec. This means that we can now issue errors. */
5047 for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
5048 if (seen[d] > 1)
5050 switch (d)
5052 case DECL_ALLOCATABLE:
5053 attr = "ALLOCATABLE";
5054 break;
5055 case DECL_ASYNCHRONOUS:
5056 attr = "ASYNCHRONOUS";
5057 break;
5058 case DECL_CODIMENSION:
5059 attr = "CODIMENSION";
5060 break;
5061 case DECL_CONTIGUOUS:
5062 attr = "CONTIGUOUS";
5063 break;
5064 case DECL_DIMENSION:
5065 attr = "DIMENSION";
5066 break;
5067 case DECL_EXTERNAL:
5068 attr = "EXTERNAL";
5069 break;
5070 case DECL_IN:
5071 attr = "INTENT (IN)";
5072 break;
5073 case DECL_OUT:
5074 attr = "INTENT (OUT)";
5075 break;
5076 case DECL_INOUT:
5077 attr = "INTENT (IN OUT)";
5078 break;
5079 case DECL_INTRINSIC:
5080 attr = "INTRINSIC";
5081 break;
5082 case DECL_OPTIONAL:
5083 attr = "OPTIONAL";
5084 break;
5085 case DECL_KIND:
5086 attr = "KIND";
5087 break;
5088 case DECL_LEN:
5089 attr = "LEN";
5090 break;
5091 case DECL_PARAMETER:
5092 attr = "PARAMETER";
5093 break;
5094 case DECL_POINTER:
5095 attr = "POINTER";
5096 break;
5097 case DECL_PROTECTED:
5098 attr = "PROTECTED";
5099 break;
5100 case DECL_PRIVATE:
5101 attr = "PRIVATE";
5102 break;
5103 case DECL_PUBLIC:
5104 attr = "PUBLIC";
5105 break;
5106 case DECL_SAVE:
5107 attr = "SAVE";
5108 break;
5109 case DECL_STATIC:
5110 attr = "STATIC";
5111 break;
5112 case DECL_AUTOMATIC:
5113 attr = "AUTOMATIC";
5114 break;
5115 case DECL_TARGET:
5116 attr = "TARGET";
5117 break;
5118 case DECL_IS_BIND_C:
5119 attr = "IS_BIND_C";
5120 break;
5121 case DECL_VALUE:
5122 attr = "VALUE";
5123 break;
5124 case DECL_VOLATILE:
5125 attr = "VOLATILE";
5126 break;
5127 default:
5128 attr = NULL; /* This shouldn't happen. */
5131 gfc_error ("Duplicate %s attribute at %L", attr, &seen_at[d]);
5132 m = MATCH_ERROR;
5133 goto cleanup;
5136 /* Now that we've dealt with duplicate attributes, add the attributes
5137 to the current attribute. */
5138 for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
5140 if (seen[d] == 0)
5141 continue;
5142 else
5143 attr_seen = 1;
5145 if ((d == DECL_STATIC || d == DECL_AUTOMATIC)
5146 && !flag_dec_static)
5148 gfc_error ("%s at %L is a DEC extension, enable with "
5149 "%<-fdec-static%>",
5150 d == DECL_STATIC ? "STATIC" : "AUTOMATIC", &seen_at[d]);
5151 m = MATCH_ERROR;
5152 goto cleanup;
5154 /* Allow SAVE with STATIC, but don't complain. */
5155 if (d == DECL_STATIC && seen[DECL_SAVE])
5156 continue;
5158 if (gfc_current_state () == COMP_DERIVED
5159 && d != DECL_DIMENSION && d != DECL_CODIMENSION
5160 && d != DECL_POINTER && d != DECL_PRIVATE
5161 && d != DECL_PUBLIC && d != DECL_CONTIGUOUS && d != DECL_NONE)
5163 if (d == DECL_ALLOCATABLE)
5165 if (!gfc_notify_std (GFC_STD_F2003, "ALLOCATABLE "
5166 "attribute at %C in a TYPE definition"))
5168 m = MATCH_ERROR;
5169 goto cleanup;
5172 else if (d == DECL_KIND)
5174 if (!gfc_notify_std (GFC_STD_F2003, "KIND "
5175 "attribute at %C in a TYPE definition"))
5177 m = MATCH_ERROR;
5178 goto cleanup;
5180 if (current_ts.type != BT_INTEGER)
5182 gfc_error ("Component with KIND attribute at %C must be "
5183 "INTEGER");
5184 m = MATCH_ERROR;
5185 goto cleanup;
5187 if (current_ts.kind != gfc_default_integer_kind)
5189 gfc_error ("Component with KIND attribute at %C must be "
5190 "default integer kind (%d)",
5191 gfc_default_integer_kind);
5192 m = MATCH_ERROR;
5193 goto cleanup;
5196 else if (d == DECL_LEN)
5198 if (!gfc_notify_std (GFC_STD_F2003, "LEN "
5199 "attribute at %C in a TYPE definition"))
5201 m = MATCH_ERROR;
5202 goto cleanup;
5204 if (current_ts.type != BT_INTEGER)
5206 gfc_error ("Component with LEN attribute at %C must be "
5207 "INTEGER");
5208 m = MATCH_ERROR;
5209 goto cleanup;
5211 if (current_ts.kind != gfc_default_integer_kind)
5213 gfc_error ("Component with LEN attribute at %C must be "
5214 "default integer kind (%d)",
5215 gfc_default_integer_kind);
5216 m = MATCH_ERROR;
5217 goto cleanup;
5220 else
5222 gfc_error ("Attribute at %L is not allowed in a TYPE definition",
5223 &seen_at[d]);
5224 m = MATCH_ERROR;
5225 goto cleanup;
5229 if ((d == DECL_PRIVATE || d == DECL_PUBLIC)
5230 && gfc_current_state () != COMP_MODULE)
5232 if (d == DECL_PRIVATE)
5233 attr = "PRIVATE";
5234 else
5235 attr = "PUBLIC";
5236 if (gfc_current_state () == COMP_DERIVED
5237 && gfc_state_stack->previous
5238 && gfc_state_stack->previous->state == COMP_MODULE)
5240 if (!gfc_notify_std (GFC_STD_F2003, "Attribute %s "
5241 "at %L in a TYPE definition", attr,
5242 &seen_at[d]))
5244 m = MATCH_ERROR;
5245 goto cleanup;
5248 else
5250 gfc_error ("%s attribute at %L is not allowed outside of the "
5251 "specification part of a module", attr, &seen_at[d]);
5252 m = MATCH_ERROR;
5253 goto cleanup;
5257 if (gfc_current_state () != COMP_DERIVED
5258 && (d == DECL_KIND || d == DECL_LEN))
5260 gfc_error ("Attribute at %L is not allowed outside a TYPE "
5261 "definition", &seen_at[d]);
5262 m = MATCH_ERROR;
5263 goto cleanup;
5266 switch (d)
5268 case DECL_ALLOCATABLE:
5269 t = gfc_add_allocatable (&current_attr, &seen_at[d]);
5270 break;
5272 case DECL_ASYNCHRONOUS:
5273 if (!gfc_notify_std (GFC_STD_F2003, "ASYNCHRONOUS attribute at %C"))
5274 t = false;
5275 else
5276 t = gfc_add_asynchronous (&current_attr, NULL, &seen_at[d]);
5277 break;
5279 case DECL_CODIMENSION:
5280 t = gfc_add_codimension (&current_attr, NULL, &seen_at[d]);
5281 break;
5283 case DECL_CONTIGUOUS:
5284 if (!gfc_notify_std (GFC_STD_F2008, "CONTIGUOUS attribute at %C"))
5285 t = false;
5286 else
5287 t = gfc_add_contiguous (&current_attr, NULL, &seen_at[d]);
5288 break;
5290 case DECL_DIMENSION:
5291 t = gfc_add_dimension (&current_attr, NULL, &seen_at[d]);
5292 break;
5294 case DECL_EXTERNAL:
5295 t = gfc_add_external (&current_attr, &seen_at[d]);
5296 break;
5298 case DECL_IN:
5299 t = gfc_add_intent (&current_attr, INTENT_IN, &seen_at[d]);
5300 break;
5302 case DECL_OUT:
5303 t = gfc_add_intent (&current_attr, INTENT_OUT, &seen_at[d]);
5304 break;
5306 case DECL_INOUT:
5307 t = gfc_add_intent (&current_attr, INTENT_INOUT, &seen_at[d]);
5308 break;
5310 case DECL_INTRINSIC:
5311 t = gfc_add_intrinsic (&current_attr, &seen_at[d]);
5312 break;
5314 case DECL_OPTIONAL:
5315 t = gfc_add_optional (&current_attr, &seen_at[d]);
5316 break;
5318 case DECL_KIND:
5319 t = gfc_add_kind (&current_attr, &seen_at[d]);
5320 break;
5322 case DECL_LEN:
5323 t = gfc_add_len (&current_attr, &seen_at[d]);
5324 break;
5326 case DECL_PARAMETER:
5327 t = gfc_add_flavor (&current_attr, FL_PARAMETER, NULL, &seen_at[d]);
5328 break;
5330 case DECL_POINTER:
5331 t = gfc_add_pointer (&current_attr, &seen_at[d]);
5332 break;
5334 case DECL_PROTECTED:
5335 if (gfc_current_state () != COMP_MODULE
5336 || (gfc_current_ns->proc_name
5337 && gfc_current_ns->proc_name->attr.flavor != FL_MODULE))
5339 gfc_error ("PROTECTED at %C only allowed in specification "
5340 "part of a module");
5341 t = false;
5342 break;
5345 if (!gfc_notify_std (GFC_STD_F2003, "PROTECTED attribute at %C"))
5346 t = false;
5347 else
5348 t = gfc_add_protected (&current_attr, NULL, &seen_at[d]);
5349 break;
5351 case DECL_PRIVATE:
5352 t = gfc_add_access (&current_attr, ACCESS_PRIVATE, NULL,
5353 &seen_at[d]);
5354 break;
5356 case DECL_PUBLIC:
5357 t = gfc_add_access (&current_attr, ACCESS_PUBLIC, NULL,
5358 &seen_at[d]);
5359 break;
5361 case DECL_STATIC:
5362 case DECL_SAVE:
5363 t = gfc_add_save (&current_attr, SAVE_EXPLICIT, NULL, &seen_at[d]);
5364 break;
5366 case DECL_AUTOMATIC:
5367 t = gfc_add_automatic (&current_attr, NULL, &seen_at[d]);
5368 break;
5370 case DECL_TARGET:
5371 t = gfc_add_target (&current_attr, &seen_at[d]);
5372 break;
5374 case DECL_IS_BIND_C:
5375 t = gfc_add_is_bind_c(&current_attr, NULL, &seen_at[d], 0);
5376 break;
5378 case DECL_VALUE:
5379 if (!gfc_notify_std (GFC_STD_F2003, "VALUE attribute at %C"))
5380 t = false;
5381 else
5382 t = gfc_add_value (&current_attr, NULL, &seen_at[d]);
5383 break;
5385 case DECL_VOLATILE:
5386 if (!gfc_notify_std (GFC_STD_F2003, "VOLATILE attribute at %C"))
5387 t = false;
5388 else
5389 t = gfc_add_volatile (&current_attr, NULL, &seen_at[d]);
5390 break;
5392 default:
5393 gfc_internal_error ("match_attr_spec(): Bad attribute");
5396 if (!t)
5398 m = MATCH_ERROR;
5399 goto cleanup;
5403 /* Since Fortran 2008 module variables implicitly have the SAVE attribute. */
5404 if ((gfc_current_state () == COMP_MODULE
5405 || gfc_current_state () == COMP_SUBMODULE)
5406 && !current_attr.save
5407 && (gfc_option.allow_std & GFC_STD_F2008) != 0)
5408 current_attr.save = SAVE_IMPLICIT;
5410 colon_seen = 1;
5411 return MATCH_YES;
5413 cleanup:
5414 gfc_current_locus = start;
5415 gfc_free_array_spec (current_as);
5416 current_as = NULL;
5417 attr_seen = 0;
5418 return m;
5422 /* Set the binding label, dest_label, either with the binding label
5423 stored in the given gfc_typespec, ts, or if none was provided, it
5424 will be the symbol name in all lower case, as required by the draft
5425 (J3/04-007, section 15.4.1). If a binding label was given and
5426 there is more than one argument (num_idents), it is an error. */
5428 static bool
5429 set_binding_label (const char **dest_label, const char *sym_name,
5430 int num_idents)
5432 if (num_idents > 1 && has_name_equals)
5434 gfc_error ("Multiple identifiers provided with "
5435 "single NAME= specifier at %C");
5436 return false;
5439 if (curr_binding_label)
5440 /* Binding label given; store in temp holder till have sym. */
5441 *dest_label = curr_binding_label;
5442 else
5444 /* No binding label given, and the NAME= specifier did not exist,
5445 which means there was no NAME="". */
5446 if (sym_name != NULL && has_name_equals == 0)
5447 *dest_label = IDENTIFIER_POINTER (get_identifier (sym_name));
5450 return true;
5454 /* Set the status of the given common block as being BIND(C) or not,
5455 depending on the given parameter, is_bind_c. */
5457 void
5458 set_com_block_bind_c (gfc_common_head *com_block, int is_bind_c)
5460 com_block->is_bind_c = is_bind_c;
5461 return;
5465 /* Verify that the given gfc_typespec is for a C interoperable type. */
5467 bool
5468 gfc_verify_c_interop (gfc_typespec *ts)
5470 if (ts->type == BT_DERIVED && ts->u.derived != NULL)
5471 return (ts->u.derived->ts.is_c_interop || ts->u.derived->attr.is_bind_c)
5472 ? true : false;
5473 else if (ts->type == BT_CLASS)
5474 return false;
5475 else if (ts->is_c_interop != 1 && ts->type != BT_ASSUMED)
5476 return false;
5478 return true;
5482 /* Verify that the variables of a given common block, which has been
5483 defined with the attribute specifier bind(c), to be of a C
5484 interoperable type. Errors will be reported here, if
5485 encountered. */
5487 bool
5488 verify_com_block_vars_c_interop (gfc_common_head *com_block)
5490 gfc_symbol *curr_sym = NULL;
5491 bool retval = true;
5493 curr_sym = com_block->head;
5495 /* Make sure we have at least one symbol. */
5496 if (curr_sym == NULL)
5497 return retval;
5499 /* Here we know we have a symbol, so we'll execute this loop
5500 at least once. */
5503 /* The second to last param, 1, says this is in a common block. */
5504 retval = verify_bind_c_sym (curr_sym, &(curr_sym->ts), 1, com_block);
5505 curr_sym = curr_sym->common_next;
5506 } while (curr_sym != NULL);
5508 return retval;
5512 /* Verify that a given BIND(C) symbol is C interoperable. If it is not,
5513 an appropriate error message is reported. */
5515 bool
5516 verify_bind_c_sym (gfc_symbol *tmp_sym, gfc_typespec *ts,
5517 int is_in_common, gfc_common_head *com_block)
5519 bool bind_c_function = false;
5520 bool retval = true;
5522 if (tmp_sym->attr.function && tmp_sym->attr.is_bind_c)
5523 bind_c_function = true;
5525 if (tmp_sym->attr.function && tmp_sym->result != NULL)
5527 tmp_sym = tmp_sym->result;
5528 /* Make sure it wasn't an implicitly typed result. */
5529 if (tmp_sym->attr.implicit_type && warn_c_binding_type)
5531 gfc_warning (OPT_Wc_binding_type,
5532 "Implicitly declared BIND(C) function %qs at "
5533 "%L may not be C interoperable", tmp_sym->name,
5534 &tmp_sym->declared_at);
5535 tmp_sym->ts.f90_type = tmp_sym->ts.type;
5536 /* Mark it as C interoperable to prevent duplicate warnings. */
5537 tmp_sym->ts.is_c_interop = 1;
5538 tmp_sym->attr.is_c_interop = 1;
5542 /* Here, we know we have the bind(c) attribute, so if we have
5543 enough type info, then verify that it's a C interop kind.
5544 The info could be in the symbol already, or possibly still in
5545 the given ts (current_ts), so look in both. */
5546 if (tmp_sym->ts.type != BT_UNKNOWN || ts->type != BT_UNKNOWN)
5548 if (!gfc_verify_c_interop (&(tmp_sym->ts)))
5550 /* See if we're dealing with a sym in a common block or not. */
5551 if (is_in_common == 1 && warn_c_binding_type)
5553 gfc_warning (OPT_Wc_binding_type,
5554 "Variable %qs in common block %qs at %L "
5555 "may not be a C interoperable "
5556 "kind though common block %qs is BIND(C)",
5557 tmp_sym->name, com_block->name,
5558 &(tmp_sym->declared_at), com_block->name);
5560 else
5562 if (tmp_sym->ts.type == BT_DERIVED || ts->type == BT_DERIVED)
5563 gfc_error ("Type declaration %qs at %L is not C "
5564 "interoperable but it is BIND(C)",
5565 tmp_sym->name, &(tmp_sym->declared_at));
5566 else if (warn_c_binding_type)
5567 gfc_warning (OPT_Wc_binding_type, "Variable %qs at %L "
5568 "may not be a C interoperable "
5569 "kind but it is BIND(C)",
5570 tmp_sym->name, &(tmp_sym->declared_at));
5574 /* Variables declared w/in a common block can't be bind(c)
5575 since there's no way for C to see these variables, so there's
5576 semantically no reason for the attribute. */
5577 if (is_in_common == 1 && tmp_sym->attr.is_bind_c == 1)
5579 gfc_error ("Variable %qs in common block %qs at "
5580 "%L cannot be declared with BIND(C) "
5581 "since it is not a global",
5582 tmp_sym->name, com_block->name,
5583 &(tmp_sym->declared_at));
5584 retval = false;
5587 /* Scalar variables that are bind(c) can not have the pointer
5588 or allocatable attributes. */
5589 if (tmp_sym->attr.is_bind_c == 1)
5591 if (tmp_sym->attr.pointer == 1)
5593 gfc_error ("Variable %qs at %L cannot have both the "
5594 "POINTER and BIND(C) attributes",
5595 tmp_sym->name, &(tmp_sym->declared_at));
5596 retval = false;
5599 if (tmp_sym->attr.allocatable == 1)
5601 gfc_error ("Variable %qs at %L cannot have both the "
5602 "ALLOCATABLE and BIND(C) attributes",
5603 tmp_sym->name, &(tmp_sym->declared_at));
5604 retval = false;
5609 /* If it is a BIND(C) function, make sure the return value is a
5610 scalar value. The previous tests in this function made sure
5611 the type is interoperable. */
5612 if (bind_c_function && tmp_sym->as != NULL)
5613 gfc_error ("Return type of BIND(C) function %qs at %L cannot "
5614 "be an array", tmp_sym->name, &(tmp_sym->declared_at));
5616 /* BIND(C) functions can not return a character string. */
5617 if (bind_c_function && tmp_sym->ts.type == BT_CHARACTER)
5618 if (tmp_sym->ts.u.cl == NULL || tmp_sym->ts.u.cl->length == NULL
5619 || tmp_sym->ts.u.cl->length->expr_type != EXPR_CONSTANT
5620 || mpz_cmp_si (tmp_sym->ts.u.cl->length->value.integer, 1) != 0)
5621 gfc_error ("Return type of BIND(C) function %qs at %L cannot "
5622 "be a character string", tmp_sym->name,
5623 &(tmp_sym->declared_at));
5626 /* See if the symbol has been marked as private. If it has, make sure
5627 there is no binding label and warn the user if there is one. */
5628 if (tmp_sym->attr.access == ACCESS_PRIVATE
5629 && tmp_sym->binding_label)
5630 /* Use gfc_warning_now because we won't say that the symbol fails
5631 just because of this. */
5632 gfc_warning_now (0, "Symbol %qs at %L is marked PRIVATE but has been "
5633 "given the binding label %qs", tmp_sym->name,
5634 &(tmp_sym->declared_at), tmp_sym->binding_label);
5636 return retval;
5640 /* Set the appropriate fields for a symbol that's been declared as
5641 BIND(C) (the is_bind_c flag and the binding label), and verify that
5642 the type is C interoperable. Errors are reported by the functions
5643 used to set/test these fields. */
5645 bool
5646 set_verify_bind_c_sym (gfc_symbol *tmp_sym, int num_idents)
5648 bool retval = true;
5650 /* TODO: Do we need to make sure the vars aren't marked private? */
5652 /* Set the is_bind_c bit in symbol_attribute. */
5653 gfc_add_is_bind_c (&(tmp_sym->attr), tmp_sym->name, &gfc_current_locus, 0);
5655 if (!set_binding_label (&tmp_sym->binding_label, tmp_sym->name, num_idents))
5656 return false;
5658 return retval;
5662 /* Set the fields marking the given common block as BIND(C), including
5663 a binding label, and report any errors encountered. */
5665 bool
5666 set_verify_bind_c_com_block (gfc_common_head *com_block, int num_idents)
5668 bool retval = true;
5670 /* destLabel, common name, typespec (which may have binding label). */
5671 if (!set_binding_label (&com_block->binding_label, com_block->name,
5672 num_idents))
5673 return false;
5675 /* Set the given common block (com_block) to being bind(c) (1). */
5676 set_com_block_bind_c (com_block, 1);
5678 return retval;
5682 /* Retrieve the list of one or more identifiers that the given bind(c)
5683 attribute applies to. */
5685 bool
5686 get_bind_c_idents (void)
5688 char name[GFC_MAX_SYMBOL_LEN + 1];
5689 int num_idents = 0;
5690 gfc_symbol *tmp_sym = NULL;
5691 match found_id;
5692 gfc_common_head *com_block = NULL;
5694 if (gfc_match_name (name) == MATCH_YES)
5696 found_id = MATCH_YES;
5697 gfc_get_ha_symbol (name, &tmp_sym);
5699 else if (match_common_name (name) == MATCH_YES)
5701 found_id = MATCH_YES;
5702 com_block = gfc_get_common (name, 0);
5704 else
5706 gfc_error ("Need either entity or common block name for "
5707 "attribute specification statement at %C");
5708 return false;
5711 /* Save the current identifier and look for more. */
5714 /* Increment the number of identifiers found for this spec stmt. */
5715 num_idents++;
5717 /* Make sure we have a sym or com block, and verify that it can
5718 be bind(c). Set the appropriate field(s) and look for more
5719 identifiers. */
5720 if (tmp_sym != NULL || com_block != NULL)
5722 if (tmp_sym != NULL)
5724 if (!set_verify_bind_c_sym (tmp_sym, num_idents))
5725 return false;
5727 else
5729 if (!set_verify_bind_c_com_block (com_block, num_idents))
5730 return false;
5733 /* Look to see if we have another identifier. */
5734 tmp_sym = NULL;
5735 if (gfc_match_eos () == MATCH_YES)
5736 found_id = MATCH_NO;
5737 else if (gfc_match_char (',') != MATCH_YES)
5738 found_id = MATCH_NO;
5739 else if (gfc_match_name (name) == MATCH_YES)
5741 found_id = MATCH_YES;
5742 gfc_get_ha_symbol (name, &tmp_sym);
5744 else if (match_common_name (name) == MATCH_YES)
5746 found_id = MATCH_YES;
5747 com_block = gfc_get_common (name, 0);
5749 else
5751 gfc_error ("Missing entity or common block name for "
5752 "attribute specification statement at %C");
5753 return false;
5756 else
5758 gfc_internal_error ("Missing symbol");
5760 } while (found_id == MATCH_YES);
5762 /* if we get here we were successful */
5763 return true;
5767 /* Try and match a BIND(C) attribute specification statement. */
5769 match
5770 gfc_match_bind_c_stmt (void)
5772 match found_match = MATCH_NO;
5773 gfc_typespec *ts;
5775 ts = &current_ts;
5777 /* This may not be necessary. */
5778 gfc_clear_ts (ts);
5779 /* Clear the temporary binding label holder. */
5780 curr_binding_label = NULL;
5782 /* Look for the bind(c). */
5783 found_match = gfc_match_bind_c (NULL, true);
5785 if (found_match == MATCH_YES)
5787 if (!gfc_notify_std (GFC_STD_F2003, "BIND(C) statement at %C"))
5788 return MATCH_ERROR;
5790 /* Look for the :: now, but it is not required. */
5791 gfc_match (" :: ");
5793 /* Get the identifier(s) that needs to be updated. This may need to
5794 change to hand the flag(s) for the attr specified so all identifiers
5795 found can have all appropriate parts updated (assuming that the same
5796 spec stmt can have multiple attrs, such as both bind(c) and
5797 allocatable...). */
5798 if (!get_bind_c_idents ())
5799 /* Error message should have printed already. */
5800 return MATCH_ERROR;
5803 return found_match;
5807 /* Match a data declaration statement. */
5809 match
5810 gfc_match_data_decl (void)
5812 gfc_symbol *sym;
5813 match m;
5814 int elem;
5816 type_param_spec_list = NULL;
5817 decl_type_param_list = NULL;
5819 num_idents_on_line = 0;
5821 m = gfc_match_decl_type_spec (&current_ts, 0);
5822 if (m != MATCH_YES)
5823 return m;
5825 if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS)
5826 && !gfc_comp_struct (gfc_current_state ()))
5828 sym = gfc_use_derived (current_ts.u.derived);
5830 if (sym == NULL)
5832 m = MATCH_ERROR;
5833 goto cleanup;
5836 current_ts.u.derived = sym;
5839 m = match_attr_spec ();
5840 if (m == MATCH_ERROR)
5842 m = MATCH_NO;
5843 goto cleanup;
5846 if (current_ts.type == BT_CLASS
5847 && current_ts.u.derived->attr.unlimited_polymorphic)
5848 goto ok;
5850 if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS)
5851 && current_ts.u.derived->components == NULL
5852 && !current_ts.u.derived->attr.zero_comp)
5855 if (current_attr.pointer && gfc_comp_struct (gfc_current_state ()))
5856 goto ok;
5858 if (current_attr.allocatable && gfc_current_state () == COMP_DERIVED
5859 && current_ts.u.derived == gfc_current_block ())
5860 goto ok;
5862 gfc_find_symbol (current_ts.u.derived->name,
5863 current_ts.u.derived->ns, 1, &sym);
5865 /* Any symbol that we find had better be a type definition
5866 which has its components defined, or be a structure definition
5867 actively being parsed. */
5868 if (sym != NULL && gfc_fl_struct (sym->attr.flavor)
5869 && (current_ts.u.derived->components != NULL
5870 || current_ts.u.derived->attr.zero_comp
5871 || current_ts.u.derived == gfc_new_block))
5872 goto ok;
5874 gfc_error ("Derived type at %C has not been previously defined "
5875 "and so cannot appear in a derived type definition");
5876 m = MATCH_ERROR;
5877 goto cleanup;
5881 /* If we have an old-style character declaration, and no new-style
5882 attribute specifications, then there a comma is optional between
5883 the type specification and the variable list. */
5884 if (m == MATCH_NO && current_ts.type == BT_CHARACTER && old_char_selector)
5885 gfc_match_char (',');
5887 /* Give the types/attributes to symbols that follow. Give the element
5888 a number so that repeat character length expressions can be copied. */
5889 elem = 1;
5890 for (;;)
5892 num_idents_on_line++;
5893 m = variable_decl (elem++);
5894 if (m == MATCH_ERROR)
5895 goto cleanup;
5896 if (m == MATCH_NO)
5897 break;
5899 if (gfc_match_eos () == MATCH_YES)
5900 goto cleanup;
5901 if (gfc_match_char (',') != MATCH_YES)
5902 break;
5905 if (!gfc_error_flag_test ())
5907 /* An anonymous structure declaration is unambiguous; if we matched one
5908 according to gfc_match_structure_decl, we need to return MATCH_YES
5909 here to avoid confusing the remaining matchers, even if there was an
5910 error during variable_decl. We must flush any such errors. Note this
5911 causes the parser to gracefully continue parsing the remaining input
5912 as a structure body, which likely follows. */
5913 if (current_ts.type == BT_DERIVED && current_ts.u.derived
5914 && gfc_fl_struct (current_ts.u.derived->attr.flavor))
5916 gfc_error_now ("Syntax error in anonymous structure declaration"
5917 " at %C");
5918 /* Skip the bad variable_decl and line up for the start of the
5919 structure body. */
5920 gfc_error_recovery ();
5921 m = MATCH_YES;
5922 goto cleanup;
5925 gfc_error ("Syntax error in data declaration at %C");
5928 m = MATCH_ERROR;
5930 gfc_free_data_all (gfc_current_ns);
5932 cleanup:
5933 if (saved_kind_expr)
5934 gfc_free_expr (saved_kind_expr);
5935 if (type_param_spec_list)
5936 gfc_free_actual_arglist (type_param_spec_list);
5937 if (decl_type_param_list)
5938 gfc_free_actual_arglist (decl_type_param_list);
5939 saved_kind_expr = NULL;
5940 gfc_free_array_spec (current_as);
5941 current_as = NULL;
5942 return m;
5946 /* Match a prefix associated with a function or subroutine
5947 declaration. If the typespec pointer is nonnull, then a typespec
5948 can be matched. Note that if nothing matches, MATCH_YES is
5949 returned (the null string was matched). */
5951 match
5952 gfc_match_prefix (gfc_typespec *ts)
5954 bool seen_type;
5955 bool seen_impure;
5956 bool found_prefix;
5958 gfc_clear_attr (&current_attr);
5959 seen_type = false;
5960 seen_impure = false;
5962 gcc_assert (!gfc_matching_prefix);
5963 gfc_matching_prefix = true;
5967 found_prefix = false;
5969 /* MODULE is a prefix like PURE, ELEMENTAL, etc., having a
5970 corresponding attribute seems natural and distinguishes these
5971 procedures from procedure types of PROC_MODULE, which these are
5972 as well. */
5973 if (gfc_match ("module% ") == MATCH_YES)
5975 if (!gfc_notify_std (GFC_STD_F2008, "MODULE prefix at %C"))
5976 goto error;
5978 current_attr.module_procedure = 1;
5979 found_prefix = true;
5982 if (!seen_type && ts != NULL
5983 && gfc_match_decl_type_spec (ts, 0) == MATCH_YES
5984 && gfc_match_space () == MATCH_YES)
5987 seen_type = true;
5988 found_prefix = true;
5991 if (gfc_match ("elemental% ") == MATCH_YES)
5993 if (!gfc_add_elemental (&current_attr, NULL))
5994 goto error;
5996 found_prefix = true;
5999 if (gfc_match ("pure% ") == MATCH_YES)
6001 if (!gfc_add_pure (&current_attr, NULL))
6002 goto error;
6004 found_prefix = true;
6007 if (gfc_match ("recursive% ") == MATCH_YES)
6009 if (!gfc_add_recursive (&current_attr, NULL))
6010 goto error;
6012 found_prefix = true;
6015 /* IMPURE is a somewhat special case, as it needs not set an actual
6016 attribute but rather only prevents ELEMENTAL routines from being
6017 automatically PURE. */
6018 if (gfc_match ("impure% ") == MATCH_YES)
6020 if (!gfc_notify_std (GFC_STD_F2008, "IMPURE procedure at %C"))
6021 goto error;
6023 seen_impure = true;
6024 found_prefix = true;
6027 while (found_prefix);
6029 /* IMPURE and PURE must not both appear, of course. */
6030 if (seen_impure && current_attr.pure)
6032 gfc_error ("PURE and IMPURE must not appear both at %C");
6033 goto error;
6036 /* If IMPURE it not seen but the procedure is ELEMENTAL, mark it as PURE. */
6037 if (!seen_impure && current_attr.elemental && !current_attr.pure)
6039 if (!gfc_add_pure (&current_attr, NULL))
6040 goto error;
6043 /* At this point, the next item is not a prefix. */
6044 gcc_assert (gfc_matching_prefix);
6046 gfc_matching_prefix = false;
6047 return MATCH_YES;
6049 error:
6050 gcc_assert (gfc_matching_prefix);
6051 gfc_matching_prefix = false;
6052 return MATCH_ERROR;
6056 /* Copy attributes matched by gfc_match_prefix() to attributes on a symbol. */
6058 static bool
6059 copy_prefix (symbol_attribute *dest, locus *where)
6061 if (dest->module_procedure)
6063 if (current_attr.elemental)
6064 dest->elemental = 1;
6066 if (current_attr.pure)
6067 dest->pure = 1;
6069 if (current_attr.recursive)
6070 dest->recursive = 1;
6072 /* Module procedures are unusual in that the 'dest' is copied from
6073 the interface declaration. However, this is an oportunity to
6074 check that the submodule declaration is compliant with the
6075 interface. */
6076 if (dest->elemental && !current_attr.elemental)
6078 gfc_error ("ELEMENTAL prefix in MODULE PROCEDURE interface is "
6079 "missing at %L", where);
6080 return false;
6083 if (dest->pure && !current_attr.pure)
6085 gfc_error ("PURE prefix in MODULE PROCEDURE interface is "
6086 "missing at %L", where);
6087 return false;
6090 if (dest->recursive && !current_attr.recursive)
6092 gfc_error ("RECURSIVE prefix in MODULE PROCEDURE interface is "
6093 "missing at %L", where);
6094 return false;
6097 return true;
6100 if (current_attr.elemental && !gfc_add_elemental (dest, where))
6101 return false;
6103 if (current_attr.pure && !gfc_add_pure (dest, where))
6104 return false;
6106 if (current_attr.recursive && !gfc_add_recursive (dest, where))
6107 return false;
6109 return true;
6113 /* Match a formal argument list or, if typeparam is true, a
6114 type_param_name_list. */
6116 match
6117 gfc_match_formal_arglist (gfc_symbol *progname, int st_flag,
6118 int null_flag, bool typeparam)
6120 gfc_formal_arglist *head, *tail, *p, *q;
6121 char name[GFC_MAX_SYMBOL_LEN + 1];
6122 gfc_symbol *sym;
6123 match m;
6124 gfc_formal_arglist *formal = NULL;
6126 head = tail = NULL;
6128 /* Keep the interface formal argument list and null it so that the
6129 matching for the new declaration can be done. The numbers and
6130 names of the arguments are checked here. The interface formal
6131 arguments are retained in formal_arglist and the characteristics
6132 are compared in resolve.c(resolve_fl_procedure). See the remark
6133 in get_proc_name about the eventual need to copy the formal_arglist
6134 and populate the formal namespace of the interface symbol. */
6135 if (progname->attr.module_procedure
6136 && progname->attr.host_assoc)
6138 formal = progname->formal;
6139 progname->formal = NULL;
6142 if (gfc_match_char ('(') != MATCH_YES)
6144 if (null_flag)
6145 goto ok;
6146 return MATCH_NO;
6149 if (gfc_match_char (')') == MATCH_YES)
6150 goto ok;
6152 for (;;)
6154 if (gfc_match_char ('*') == MATCH_YES)
6156 sym = NULL;
6157 if (!typeparam && !gfc_notify_std (GFC_STD_F95_OBS,
6158 "Alternate-return argument at %C"))
6160 m = MATCH_ERROR;
6161 goto cleanup;
6163 else if (typeparam)
6164 gfc_error_now ("A parameter name is required at %C");
6166 else
6168 m = gfc_match_name (name);
6169 if (m != MATCH_YES)
6171 if(typeparam)
6172 gfc_error_now ("A parameter name is required at %C");
6173 goto cleanup;
6176 if (!typeparam && gfc_get_symbol (name, NULL, &sym))
6177 goto cleanup;
6178 else if (typeparam
6179 && gfc_get_symbol (name, progname->f2k_derived, &sym))
6180 goto cleanup;
6183 p = gfc_get_formal_arglist ();
6185 if (head == NULL)
6186 head = tail = p;
6187 else
6189 tail->next = p;
6190 tail = p;
6193 tail->sym = sym;
6195 /* We don't add the VARIABLE flavor because the name could be a
6196 dummy procedure. We don't apply these attributes to formal
6197 arguments of statement functions. */
6198 if (sym != NULL && !st_flag
6199 && (!gfc_add_dummy(&sym->attr, sym->name, NULL)
6200 || !gfc_missing_attr (&sym->attr, NULL)))
6202 m = MATCH_ERROR;
6203 goto cleanup;
6206 /* The name of a program unit can be in a different namespace,
6207 so check for it explicitly. After the statement is accepted,
6208 the name is checked for especially in gfc_get_symbol(). */
6209 if (gfc_new_block != NULL && sym != NULL && !typeparam
6210 && strcmp (sym->name, gfc_new_block->name) == 0)
6212 gfc_error ("Name %qs at %C is the name of the procedure",
6213 sym->name);
6214 m = MATCH_ERROR;
6215 goto cleanup;
6218 if (gfc_match_char (')') == MATCH_YES)
6219 goto ok;
6221 m = gfc_match_char (',');
6222 if (m != MATCH_YES)
6224 if (typeparam)
6225 gfc_error_now ("Expected parameter list in type declaration "
6226 "at %C");
6227 else
6228 gfc_error ("Unexpected junk in formal argument list at %C");
6229 goto cleanup;
6234 /* Check for duplicate symbols in the formal argument list. */
6235 if (head != NULL)
6237 for (p = head; p->next; p = p->next)
6239 if (p->sym == NULL)
6240 continue;
6242 for (q = p->next; q; q = q->next)
6243 if (p->sym == q->sym)
6245 if (typeparam)
6246 gfc_error_now ("Duplicate name %qs in parameter "
6247 "list at %C", p->sym->name);
6248 else
6249 gfc_error ("Duplicate symbol %qs in formal argument "
6250 "list at %C", p->sym->name);
6252 m = MATCH_ERROR;
6253 goto cleanup;
6258 if (!gfc_add_explicit_interface (progname, IFSRC_DECL, head, NULL))
6260 m = MATCH_ERROR;
6261 goto cleanup;
6264 /* gfc_error_now used in following and return with MATCH_YES because
6265 doing otherwise results in a cascade of extraneous errors and in
6266 some cases an ICE in symbol.c(gfc_release_symbol). */
6267 if (progname->attr.module_procedure && progname->attr.host_assoc)
6269 bool arg_count_mismatch = false;
6271 if (!formal && head)
6272 arg_count_mismatch = true;
6274 /* Abbreviated module procedure declaration is not meant to have any
6275 formal arguments! */
6276 if (!progname->abr_modproc_decl && formal && !head)
6277 arg_count_mismatch = true;
6279 for (p = formal, q = head; p && q; p = p->next, q = q->next)
6281 if ((p->next != NULL && q->next == NULL)
6282 || (p->next == NULL && q->next != NULL))
6283 arg_count_mismatch = true;
6284 else if ((p->sym == NULL && q->sym == NULL)
6285 || strcmp (p->sym->name, q->sym->name) == 0)
6286 continue;
6287 else
6288 gfc_error_now ("Mismatch in MODULE PROCEDURE formal "
6289 "argument names (%s/%s) at %C",
6290 p->sym->name, q->sym->name);
6293 if (arg_count_mismatch)
6294 gfc_error_now ("Mismatch in number of MODULE PROCEDURE "
6295 "formal arguments at %C");
6298 return MATCH_YES;
6300 cleanup:
6301 gfc_free_formal_arglist (head);
6302 return m;
6306 /* Match a RESULT specification following a function declaration or
6307 ENTRY statement. Also matches the end-of-statement. */
6309 static match
6310 match_result (gfc_symbol *function, gfc_symbol **result)
6312 char name[GFC_MAX_SYMBOL_LEN + 1];
6313 gfc_symbol *r;
6314 match m;
6316 if (gfc_match (" result (") != MATCH_YES)
6317 return MATCH_NO;
6319 m = gfc_match_name (name);
6320 if (m != MATCH_YES)
6321 return m;
6323 /* Get the right paren, and that's it because there could be the
6324 bind(c) attribute after the result clause. */
6325 if (gfc_match_char (')') != MATCH_YES)
6327 /* TODO: should report the missing right paren here. */
6328 return MATCH_ERROR;
6331 if (strcmp (function->name, name) == 0)
6333 gfc_error ("RESULT variable at %C must be different than function name");
6334 return MATCH_ERROR;
6337 if (gfc_get_symbol (name, NULL, &r))
6338 return MATCH_ERROR;
6340 if (!gfc_add_result (&r->attr, r->name, NULL))
6341 return MATCH_ERROR;
6343 *result = r;
6345 return MATCH_YES;
6349 /* Match a function suffix, which could be a combination of a result
6350 clause and BIND(C), either one, or neither. The draft does not
6351 require them to come in a specific order. */
6353 match
6354 gfc_match_suffix (gfc_symbol *sym, gfc_symbol **result)
6356 match is_bind_c; /* Found bind(c). */
6357 match is_result; /* Found result clause. */
6358 match found_match; /* Status of whether we've found a good match. */
6359 char peek_char; /* Character we're going to peek at. */
6360 bool allow_binding_name;
6362 /* Initialize to having found nothing. */
6363 found_match = MATCH_NO;
6364 is_bind_c = MATCH_NO;
6365 is_result = MATCH_NO;
6367 /* Get the next char to narrow between result and bind(c). */
6368 gfc_gobble_whitespace ();
6369 peek_char = gfc_peek_ascii_char ();
6371 /* C binding names are not allowed for internal procedures. */
6372 if (gfc_current_state () == COMP_CONTAINS
6373 && sym->ns->proc_name->attr.flavor != FL_MODULE)
6374 allow_binding_name = false;
6375 else
6376 allow_binding_name = true;
6378 switch (peek_char)
6380 case 'r':
6381 /* Look for result clause. */
6382 is_result = match_result (sym, result);
6383 if (is_result == MATCH_YES)
6385 /* Now see if there is a bind(c) after it. */
6386 is_bind_c = gfc_match_bind_c (sym, allow_binding_name);
6387 /* We've found the result clause and possibly bind(c). */
6388 found_match = MATCH_YES;
6390 else
6391 /* This should only be MATCH_ERROR. */
6392 found_match = is_result;
6393 break;
6394 case 'b':
6395 /* Look for bind(c) first. */
6396 is_bind_c = gfc_match_bind_c (sym, allow_binding_name);
6397 if (is_bind_c == MATCH_YES)
6399 /* Now see if a result clause followed it. */
6400 is_result = match_result (sym, result);
6401 found_match = MATCH_YES;
6403 else
6405 /* Should only be a MATCH_ERROR if we get here after seeing 'b'. */
6406 found_match = MATCH_ERROR;
6408 break;
6409 default:
6410 gfc_error ("Unexpected junk after function declaration at %C");
6411 found_match = MATCH_ERROR;
6412 break;
6415 if (is_bind_c == MATCH_YES)
6417 /* Fortran 2008 draft allows BIND(C) for internal procedures. */
6418 if (gfc_current_state () == COMP_CONTAINS
6419 && sym->ns->proc_name->attr.flavor != FL_MODULE
6420 && !gfc_notify_std (GFC_STD_F2008, "BIND(C) attribute "
6421 "at %L may not be specified for an internal "
6422 "procedure", &gfc_current_locus))
6423 return MATCH_ERROR;
6425 if (!gfc_add_is_bind_c (&(sym->attr), sym->name, &gfc_current_locus, 1))
6426 return MATCH_ERROR;
6429 return found_match;
6433 /* Procedure pointer return value without RESULT statement:
6434 Add "hidden" result variable named "ppr@". */
6436 static bool
6437 add_hidden_procptr_result (gfc_symbol *sym)
6439 bool case1,case2;
6441 if (gfc_notification_std (GFC_STD_F2003) == ERROR)
6442 return false;
6444 /* First usage case: PROCEDURE and EXTERNAL statements. */
6445 case1 = gfc_current_state () == COMP_FUNCTION && gfc_current_block ()
6446 && strcmp (gfc_current_block ()->name, sym->name) == 0
6447 && sym->attr.external;
6448 /* Second usage case: INTERFACE statements. */
6449 case2 = gfc_current_state () == COMP_INTERFACE && gfc_state_stack->previous
6450 && gfc_state_stack->previous->state == COMP_FUNCTION
6451 && strcmp (gfc_state_stack->previous->sym->name, sym->name) == 0;
6453 if (case1 || case2)
6455 gfc_symtree *stree;
6456 if (case1)
6457 gfc_get_sym_tree ("ppr@", gfc_current_ns, &stree, false);
6458 else if (case2)
6460 gfc_symtree *st2;
6461 gfc_get_sym_tree ("ppr@", gfc_current_ns->parent, &stree, false);
6462 st2 = gfc_new_symtree (&gfc_current_ns->sym_root, "ppr@");
6463 st2->n.sym = stree->n.sym;
6464 stree->n.sym->refs++;
6466 sym->result = stree->n.sym;
6468 sym->result->attr.proc_pointer = sym->attr.proc_pointer;
6469 sym->result->attr.pointer = sym->attr.pointer;
6470 sym->result->attr.external = sym->attr.external;
6471 sym->result->attr.referenced = sym->attr.referenced;
6472 sym->result->ts = sym->ts;
6473 sym->attr.proc_pointer = 0;
6474 sym->attr.pointer = 0;
6475 sym->attr.external = 0;
6476 if (sym->result->attr.external && sym->result->attr.pointer)
6478 sym->result->attr.pointer = 0;
6479 sym->result->attr.proc_pointer = 1;
6482 return gfc_add_result (&sym->result->attr, sym->result->name, NULL);
6484 /* POINTER after PROCEDURE/EXTERNAL/INTERFACE statement. */
6485 else if (sym->attr.function && !sym->attr.external && sym->attr.pointer
6486 && sym->result && sym->result != sym && sym->result->attr.external
6487 && sym == gfc_current_ns->proc_name
6488 && sym == sym->result->ns->proc_name
6489 && strcmp ("ppr@", sym->result->name) == 0)
6491 sym->result->attr.proc_pointer = 1;
6492 sym->attr.pointer = 0;
6493 return true;
6495 else
6496 return false;
6500 /* Match the interface for a PROCEDURE declaration,
6501 including brackets (R1212). */
6503 static match
6504 match_procedure_interface (gfc_symbol **proc_if)
6506 match m;
6507 gfc_symtree *st;
6508 locus old_loc, entry_loc;
6509 gfc_namespace *old_ns = gfc_current_ns;
6510 char name[GFC_MAX_SYMBOL_LEN + 1];
6512 old_loc = entry_loc = gfc_current_locus;
6513 gfc_clear_ts (&current_ts);
6515 if (gfc_match (" (") != MATCH_YES)
6517 gfc_current_locus = entry_loc;
6518 return MATCH_NO;
6521 /* Get the type spec. for the procedure interface. */
6522 old_loc = gfc_current_locus;
6523 m = gfc_match_decl_type_spec (&current_ts, 0);
6524 gfc_gobble_whitespace ();
6525 if (m == MATCH_YES || (m == MATCH_NO && gfc_peek_ascii_char () == ')'))
6526 goto got_ts;
6528 if (m == MATCH_ERROR)
6529 return m;
6531 /* Procedure interface is itself a procedure. */
6532 gfc_current_locus = old_loc;
6533 m = gfc_match_name (name);
6535 /* First look to see if it is already accessible in the current
6536 namespace because it is use associated or contained. */
6537 st = NULL;
6538 if (gfc_find_sym_tree (name, NULL, 0, &st))
6539 return MATCH_ERROR;
6541 /* If it is still not found, then try the parent namespace, if it
6542 exists and create the symbol there if it is still not found. */
6543 if (gfc_current_ns->parent)
6544 gfc_current_ns = gfc_current_ns->parent;
6545 if (st == NULL && gfc_get_ha_sym_tree (name, &st))
6546 return MATCH_ERROR;
6548 gfc_current_ns = old_ns;
6549 *proc_if = st->n.sym;
6551 if (*proc_if)
6553 (*proc_if)->refs++;
6554 /* Resolve interface if possible. That way, attr.procedure is only set
6555 if it is declared by a later procedure-declaration-stmt, which is
6556 invalid per F08:C1216 (cf. resolve_procedure_interface). */
6557 while ((*proc_if)->ts.interface
6558 && *proc_if != (*proc_if)->ts.interface)
6559 *proc_if = (*proc_if)->ts.interface;
6561 if ((*proc_if)->attr.flavor == FL_UNKNOWN
6562 && (*proc_if)->ts.type == BT_UNKNOWN
6563 && !gfc_add_flavor (&(*proc_if)->attr, FL_PROCEDURE,
6564 (*proc_if)->name, NULL))
6565 return MATCH_ERROR;
6568 got_ts:
6569 if (gfc_match (" )") != MATCH_YES)
6571 gfc_current_locus = entry_loc;
6572 return MATCH_NO;
6575 return MATCH_YES;
6579 /* Match a PROCEDURE declaration (R1211). */
6581 static match
6582 match_procedure_decl (void)
6584 match m;
6585 gfc_symbol *sym, *proc_if = NULL;
6586 int num;
6587 gfc_expr *initializer = NULL;
6589 /* Parse interface (with brackets). */
6590 m = match_procedure_interface (&proc_if);
6591 if (m != MATCH_YES)
6592 return m;
6594 /* Parse attributes (with colons). */
6595 m = match_attr_spec();
6596 if (m == MATCH_ERROR)
6597 return MATCH_ERROR;
6599 if (proc_if && proc_if->attr.is_bind_c && !current_attr.is_bind_c)
6601 current_attr.is_bind_c = 1;
6602 has_name_equals = 0;
6603 curr_binding_label = NULL;
6606 /* Get procedure symbols. */
6607 for(num=1;;num++)
6609 m = gfc_match_symbol (&sym, 0);
6610 if (m == MATCH_NO)
6611 goto syntax;
6612 else if (m == MATCH_ERROR)
6613 return m;
6615 /* Add current_attr to the symbol attributes. */
6616 if (!gfc_copy_attr (&sym->attr, &current_attr, NULL))
6617 return MATCH_ERROR;
6619 if (sym->attr.is_bind_c)
6621 /* Check for C1218. */
6622 if (!proc_if || !proc_if->attr.is_bind_c)
6624 gfc_error ("BIND(C) attribute at %C requires "
6625 "an interface with BIND(C)");
6626 return MATCH_ERROR;
6628 /* Check for C1217. */
6629 if (has_name_equals && sym->attr.pointer)
6631 gfc_error ("BIND(C) procedure with NAME may not have "
6632 "POINTER attribute at %C");
6633 return MATCH_ERROR;
6635 if (has_name_equals && sym->attr.dummy)
6637 gfc_error ("Dummy procedure at %C may not have "
6638 "BIND(C) attribute with NAME");
6639 return MATCH_ERROR;
6641 /* Set binding label for BIND(C). */
6642 if (!set_binding_label (&sym->binding_label, sym->name, num))
6643 return MATCH_ERROR;
6646 if (!gfc_add_external (&sym->attr, NULL))
6647 return MATCH_ERROR;
6649 if (add_hidden_procptr_result (sym))
6650 sym = sym->result;
6652 if (!gfc_add_proc (&sym->attr, sym->name, NULL))
6653 return MATCH_ERROR;
6655 /* Set interface. */
6656 if (proc_if != NULL)
6658 if (sym->ts.type != BT_UNKNOWN)
6660 gfc_error ("Procedure %qs at %L already has basic type of %s",
6661 sym->name, &gfc_current_locus,
6662 gfc_basic_typename (sym->ts.type));
6663 return MATCH_ERROR;
6665 sym->ts.interface = proc_if;
6666 sym->attr.untyped = 1;
6667 sym->attr.if_source = IFSRC_IFBODY;
6669 else if (current_ts.type != BT_UNKNOWN)
6671 if (!gfc_add_type (sym, &current_ts, &gfc_current_locus))
6672 return MATCH_ERROR;
6673 sym->ts.interface = gfc_new_symbol ("", gfc_current_ns);
6674 sym->ts.interface->ts = current_ts;
6675 sym->ts.interface->attr.flavor = FL_PROCEDURE;
6676 sym->ts.interface->attr.function = 1;
6677 sym->attr.function = 1;
6678 sym->attr.if_source = IFSRC_UNKNOWN;
6681 if (gfc_match (" =>") == MATCH_YES)
6683 if (!current_attr.pointer)
6685 gfc_error ("Initialization at %C isn't for a pointer variable");
6686 m = MATCH_ERROR;
6687 goto cleanup;
6690 m = match_pointer_init (&initializer, 1);
6691 if (m != MATCH_YES)
6692 goto cleanup;
6694 if (!add_init_expr_to_sym (sym->name, &initializer, &gfc_current_locus))
6695 goto cleanup;
6699 if (gfc_match_eos () == MATCH_YES)
6700 return MATCH_YES;
6701 if (gfc_match_char (',') != MATCH_YES)
6702 goto syntax;
6705 syntax:
6706 gfc_error ("Syntax error in PROCEDURE statement at %C");
6707 return MATCH_ERROR;
6709 cleanup:
6710 /* Free stuff up and return. */
6711 gfc_free_expr (initializer);
6712 return m;
6716 static match
6717 match_binding_attributes (gfc_typebound_proc* ba, bool generic, bool ppc);
6720 /* Match a procedure pointer component declaration (R445). */
6722 static match
6723 match_ppc_decl (void)
6725 match m;
6726 gfc_symbol *proc_if = NULL;
6727 gfc_typespec ts;
6728 int num;
6729 gfc_component *c;
6730 gfc_expr *initializer = NULL;
6731 gfc_typebound_proc* tb;
6732 char name[GFC_MAX_SYMBOL_LEN + 1];
6734 /* Parse interface (with brackets). */
6735 m = match_procedure_interface (&proc_if);
6736 if (m != MATCH_YES)
6737 goto syntax;
6739 /* Parse attributes. */
6740 tb = XCNEW (gfc_typebound_proc);
6741 tb->where = gfc_current_locus;
6742 m = match_binding_attributes (tb, false, true);
6743 if (m == MATCH_ERROR)
6744 return m;
6746 gfc_clear_attr (&current_attr);
6747 current_attr.procedure = 1;
6748 current_attr.proc_pointer = 1;
6749 current_attr.access = tb->access;
6750 current_attr.flavor = FL_PROCEDURE;
6752 /* Match the colons (required). */
6753 if (gfc_match (" ::") != MATCH_YES)
6755 gfc_error ("Expected %<::%> after binding-attributes at %C");
6756 return MATCH_ERROR;
6759 /* Check for C450. */
6760 if (!tb->nopass && proc_if == NULL)
6762 gfc_error("NOPASS or explicit interface required at %C");
6763 return MATCH_ERROR;
6766 if (!gfc_notify_std (GFC_STD_F2003, "Procedure pointer component at %C"))
6767 return MATCH_ERROR;
6769 /* Match PPC names. */
6770 ts = current_ts;
6771 for(num=1;;num++)
6773 m = gfc_match_name (name);
6774 if (m == MATCH_NO)
6775 goto syntax;
6776 else if (m == MATCH_ERROR)
6777 return m;
6779 if (!gfc_add_component (gfc_current_block(), name, &c))
6780 return MATCH_ERROR;
6782 /* Add current_attr to the symbol attributes. */
6783 if (!gfc_copy_attr (&c->attr, &current_attr, NULL))
6784 return MATCH_ERROR;
6786 if (!gfc_add_external (&c->attr, NULL))
6787 return MATCH_ERROR;
6789 if (!gfc_add_proc (&c->attr, name, NULL))
6790 return MATCH_ERROR;
6792 if (num == 1)
6793 c->tb = tb;
6794 else
6796 c->tb = XCNEW (gfc_typebound_proc);
6797 c->tb->where = gfc_current_locus;
6798 *c->tb = *tb;
6801 /* Set interface. */
6802 if (proc_if != NULL)
6804 c->ts.interface = proc_if;
6805 c->attr.untyped = 1;
6806 c->attr.if_source = IFSRC_IFBODY;
6808 else if (ts.type != BT_UNKNOWN)
6810 c->ts = ts;
6811 c->ts.interface = gfc_new_symbol ("", gfc_current_ns);
6812 c->ts.interface->result = c->ts.interface;
6813 c->ts.interface->ts = ts;
6814 c->ts.interface->attr.flavor = FL_PROCEDURE;
6815 c->ts.interface->attr.function = 1;
6816 c->attr.function = 1;
6817 c->attr.if_source = IFSRC_UNKNOWN;
6820 if (gfc_match (" =>") == MATCH_YES)
6822 m = match_pointer_init (&initializer, 1);
6823 if (m != MATCH_YES)
6825 gfc_free_expr (initializer);
6826 return m;
6828 c->initializer = initializer;
6831 if (gfc_match_eos () == MATCH_YES)
6832 return MATCH_YES;
6833 if (gfc_match_char (',') != MATCH_YES)
6834 goto syntax;
6837 syntax:
6838 gfc_error ("Syntax error in procedure pointer component at %C");
6839 return MATCH_ERROR;
6843 /* Match a PROCEDURE declaration inside an interface (R1206). */
6845 static match
6846 match_procedure_in_interface (void)
6848 match m;
6849 gfc_symbol *sym;
6850 char name[GFC_MAX_SYMBOL_LEN + 1];
6851 locus old_locus;
6853 if (current_interface.type == INTERFACE_NAMELESS
6854 || current_interface.type == INTERFACE_ABSTRACT)
6856 gfc_error ("PROCEDURE at %C must be in a generic interface");
6857 return MATCH_ERROR;
6860 /* Check if the F2008 optional double colon appears. */
6861 gfc_gobble_whitespace ();
6862 old_locus = gfc_current_locus;
6863 if (gfc_match ("::") == MATCH_YES)
6865 if (!gfc_notify_std (GFC_STD_F2008, "double colon in "
6866 "MODULE PROCEDURE statement at %L", &old_locus))
6867 return MATCH_ERROR;
6869 else
6870 gfc_current_locus = old_locus;
6872 for(;;)
6874 m = gfc_match_name (name);
6875 if (m == MATCH_NO)
6876 goto syntax;
6877 else if (m == MATCH_ERROR)
6878 return m;
6879 if (gfc_get_symbol (name, gfc_current_ns->parent, &sym))
6880 return MATCH_ERROR;
6882 if (!gfc_add_interface (sym))
6883 return MATCH_ERROR;
6885 if (gfc_match_eos () == MATCH_YES)
6886 break;
6887 if (gfc_match_char (',') != MATCH_YES)
6888 goto syntax;
6891 return MATCH_YES;
6893 syntax:
6894 gfc_error ("Syntax error in PROCEDURE statement at %C");
6895 return MATCH_ERROR;
6899 /* General matcher for PROCEDURE declarations. */
6901 static match match_procedure_in_type (void);
6903 match
6904 gfc_match_procedure (void)
6906 match m;
6908 switch (gfc_current_state ())
6910 case COMP_NONE:
6911 case COMP_PROGRAM:
6912 case COMP_MODULE:
6913 case COMP_SUBMODULE:
6914 case COMP_SUBROUTINE:
6915 case COMP_FUNCTION:
6916 case COMP_BLOCK:
6917 m = match_procedure_decl ();
6918 break;
6919 case COMP_INTERFACE:
6920 m = match_procedure_in_interface ();
6921 break;
6922 case COMP_DERIVED:
6923 m = match_ppc_decl ();
6924 break;
6925 case COMP_DERIVED_CONTAINS:
6926 m = match_procedure_in_type ();
6927 break;
6928 default:
6929 return MATCH_NO;
6932 if (m != MATCH_YES)
6933 return m;
6935 if (!gfc_notify_std (GFC_STD_F2003, "PROCEDURE statement at %C"))
6936 return MATCH_ERROR;
6938 return m;
6942 /* Warn if a matched procedure has the same name as an intrinsic; this is
6943 simply a wrapper around gfc_warn_intrinsic_shadow that interprets the current
6944 parser-state-stack to find out whether we're in a module. */
6946 static void
6947 do_warn_intrinsic_shadow (const gfc_symbol* sym, bool func)
6949 bool in_module;
6951 in_module = (gfc_state_stack->previous
6952 && (gfc_state_stack->previous->state == COMP_MODULE
6953 || gfc_state_stack->previous->state == COMP_SUBMODULE));
6955 gfc_warn_intrinsic_shadow (sym, in_module, func);
6959 /* Match a function declaration. */
6961 match
6962 gfc_match_function_decl (void)
6964 char name[GFC_MAX_SYMBOL_LEN + 1];
6965 gfc_symbol *sym, *result;
6966 locus old_loc;
6967 match m;
6968 match suffix_match;
6969 match found_match; /* Status returned by match func. */
6971 if (gfc_current_state () != COMP_NONE
6972 && gfc_current_state () != COMP_INTERFACE
6973 && gfc_current_state () != COMP_CONTAINS)
6974 return MATCH_NO;
6976 gfc_clear_ts (&current_ts);
6978 old_loc = gfc_current_locus;
6980 m = gfc_match_prefix (&current_ts);
6981 if (m != MATCH_YES)
6983 gfc_current_locus = old_loc;
6984 return m;
6987 if (gfc_match ("function% %n", name) != MATCH_YES)
6989 gfc_current_locus = old_loc;
6990 return MATCH_NO;
6993 if (get_proc_name (name, &sym, false))
6994 return MATCH_ERROR;
6996 if (add_hidden_procptr_result (sym))
6997 sym = sym->result;
6999 if (current_attr.module_procedure)
7000 sym->attr.module_procedure = 1;
7002 gfc_new_block = sym;
7004 m = gfc_match_formal_arglist (sym, 0, 0);
7005 if (m == MATCH_NO)
7007 gfc_error ("Expected formal argument list in function "
7008 "definition at %C");
7009 m = MATCH_ERROR;
7010 goto cleanup;
7012 else if (m == MATCH_ERROR)
7013 goto cleanup;
7015 result = NULL;
7017 /* According to the draft, the bind(c) and result clause can
7018 come in either order after the formal_arg_list (i.e., either
7019 can be first, both can exist together or by themselves or neither
7020 one). Therefore, the match_result can't match the end of the
7021 string, and check for the bind(c) or result clause in either order. */
7022 found_match = gfc_match_eos ();
7024 /* Make sure that it isn't already declared as BIND(C). If it is, it
7025 must have been marked BIND(C) with a BIND(C) attribute and that is
7026 not allowed for procedures. */
7027 if (sym->attr.is_bind_c == 1)
7029 sym->attr.is_bind_c = 0;
7030 if (sym->old_symbol != NULL)
7031 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7032 "variables or common blocks",
7033 &(sym->old_symbol->declared_at));
7034 else
7035 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7036 "variables or common blocks", &gfc_current_locus);
7039 if (found_match != MATCH_YES)
7041 /* If we haven't found the end-of-statement, look for a suffix. */
7042 suffix_match = gfc_match_suffix (sym, &result);
7043 if (suffix_match == MATCH_YES)
7044 /* Need to get the eos now. */
7045 found_match = gfc_match_eos ();
7046 else
7047 found_match = suffix_match;
7050 if(found_match != MATCH_YES)
7051 m = MATCH_ERROR;
7052 else
7054 /* Make changes to the symbol. */
7055 m = MATCH_ERROR;
7057 if (!gfc_add_function (&sym->attr, sym->name, NULL))
7058 goto cleanup;
7060 if (!gfc_missing_attr (&sym->attr, NULL))
7061 goto cleanup;
7063 if (!copy_prefix (&sym->attr, &sym->declared_at))
7065 if(!sym->attr.module_procedure)
7066 goto cleanup;
7067 else
7068 gfc_error_check ();
7071 /* Delay matching the function characteristics until after the
7072 specification block by signalling kind=-1. */
7073 sym->declared_at = old_loc;
7074 if (current_ts.type != BT_UNKNOWN)
7075 current_ts.kind = -1;
7076 else
7077 current_ts.kind = 0;
7079 if (result == NULL)
7081 if (current_ts.type != BT_UNKNOWN
7082 && !gfc_add_type (sym, &current_ts, &gfc_current_locus))
7083 goto cleanup;
7084 sym->result = sym;
7086 else
7088 if (current_ts.type != BT_UNKNOWN
7089 && !gfc_add_type (result, &current_ts, &gfc_current_locus))
7090 goto cleanup;
7091 sym->result = result;
7094 /* Warn if this procedure has the same name as an intrinsic. */
7095 do_warn_intrinsic_shadow (sym, true);
7097 return MATCH_YES;
7100 cleanup:
7101 gfc_current_locus = old_loc;
7102 return m;
7106 /* This is mostly a copy of parse.c(add_global_procedure) but modified to
7107 pass the name of the entry, rather than the gfc_current_block name, and
7108 to return false upon finding an existing global entry. */
7110 static bool
7111 add_global_entry (const char *name, const char *binding_label, bool sub,
7112 locus *where)
7114 gfc_gsymbol *s;
7115 enum gfc_symbol_type type;
7117 type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
7119 /* Only in Fortran 2003: For procedures with a binding label also the Fortran
7120 name is a global identifier. */
7121 if (!binding_label || gfc_notification_std (GFC_STD_F2008))
7123 s = gfc_get_gsymbol (name);
7125 if (s->defined || (s->type != GSYM_UNKNOWN && s->type != type))
7127 gfc_global_used (s, where);
7128 return false;
7130 else
7132 s->type = type;
7133 s->sym_name = name;
7134 s->where = *where;
7135 s->defined = 1;
7136 s->ns = gfc_current_ns;
7140 /* Don't add the symbol multiple times. */
7141 if (binding_label
7142 && (!gfc_notification_std (GFC_STD_F2008)
7143 || strcmp (name, binding_label) != 0))
7145 s = gfc_get_gsymbol (binding_label);
7147 if (s->defined || (s->type != GSYM_UNKNOWN && s->type != type))
7149 gfc_global_used (s, where);
7150 return false;
7152 else
7154 s->type = type;
7155 s->sym_name = name;
7156 s->binding_label = binding_label;
7157 s->where = *where;
7158 s->defined = 1;
7159 s->ns = gfc_current_ns;
7163 return true;
7167 /* Match an ENTRY statement. */
7169 match
7170 gfc_match_entry (void)
7172 gfc_symbol *proc;
7173 gfc_symbol *result;
7174 gfc_symbol *entry;
7175 char name[GFC_MAX_SYMBOL_LEN + 1];
7176 gfc_compile_state state;
7177 match m;
7178 gfc_entry_list *el;
7179 locus old_loc;
7180 bool module_procedure;
7181 char peek_char;
7182 match is_bind_c;
7184 m = gfc_match_name (name);
7185 if (m != MATCH_YES)
7186 return m;
7188 if (!gfc_notify_std (GFC_STD_F2008_OBS, "ENTRY statement at %C"))
7189 return MATCH_ERROR;
7191 state = gfc_current_state ();
7192 if (state != COMP_SUBROUTINE && state != COMP_FUNCTION)
7194 switch (state)
7196 case COMP_PROGRAM:
7197 gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
7198 break;
7199 case COMP_MODULE:
7200 gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
7201 break;
7202 case COMP_SUBMODULE:
7203 gfc_error ("ENTRY statement at %C cannot appear within a SUBMODULE");
7204 break;
7205 case COMP_BLOCK_DATA:
7206 gfc_error ("ENTRY statement at %C cannot appear within "
7207 "a BLOCK DATA");
7208 break;
7209 case COMP_INTERFACE:
7210 gfc_error ("ENTRY statement at %C cannot appear within "
7211 "an INTERFACE");
7212 break;
7213 case COMP_STRUCTURE:
7214 gfc_error ("ENTRY statement at %C cannot appear within "
7215 "a STRUCTURE block");
7216 break;
7217 case COMP_DERIVED:
7218 gfc_error ("ENTRY statement at %C cannot appear within "
7219 "a DERIVED TYPE block");
7220 break;
7221 case COMP_IF:
7222 gfc_error ("ENTRY statement at %C cannot appear within "
7223 "an IF-THEN block");
7224 break;
7225 case COMP_DO:
7226 case COMP_DO_CONCURRENT:
7227 gfc_error ("ENTRY statement at %C cannot appear within "
7228 "a DO block");
7229 break;
7230 case COMP_SELECT:
7231 gfc_error ("ENTRY statement at %C cannot appear within "
7232 "a SELECT block");
7233 break;
7234 case COMP_FORALL:
7235 gfc_error ("ENTRY statement at %C cannot appear within "
7236 "a FORALL block");
7237 break;
7238 case COMP_WHERE:
7239 gfc_error ("ENTRY statement at %C cannot appear within "
7240 "a WHERE block");
7241 break;
7242 case COMP_CONTAINS:
7243 gfc_error ("ENTRY statement at %C cannot appear within "
7244 "a contained subprogram");
7245 break;
7246 default:
7247 gfc_error ("Unexpected ENTRY statement at %C");
7249 return MATCH_ERROR;
7252 if ((state == COMP_SUBROUTINE || state == COMP_FUNCTION)
7253 && gfc_state_stack->previous->state == COMP_INTERFACE)
7255 gfc_error ("ENTRY statement at %C cannot appear within an INTERFACE");
7256 return MATCH_ERROR;
7259 module_procedure = gfc_current_ns->parent != NULL
7260 && gfc_current_ns->parent->proc_name
7261 && gfc_current_ns->parent->proc_name->attr.flavor
7262 == FL_MODULE;
7264 if (gfc_current_ns->parent != NULL
7265 && gfc_current_ns->parent->proc_name
7266 && !module_procedure)
7268 gfc_error("ENTRY statement at %C cannot appear in a "
7269 "contained procedure");
7270 return MATCH_ERROR;
7273 /* Module function entries need special care in get_proc_name
7274 because previous references within the function will have
7275 created symbols attached to the current namespace. */
7276 if (get_proc_name (name, &entry,
7277 gfc_current_ns->parent != NULL
7278 && module_procedure))
7279 return MATCH_ERROR;
7281 proc = gfc_current_block ();
7283 /* Make sure that it isn't already declared as BIND(C). If it is, it
7284 must have been marked BIND(C) with a BIND(C) attribute and that is
7285 not allowed for procedures. */
7286 if (entry->attr.is_bind_c == 1)
7288 entry->attr.is_bind_c = 0;
7289 if (entry->old_symbol != NULL)
7290 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7291 "variables or common blocks",
7292 &(entry->old_symbol->declared_at));
7293 else
7294 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7295 "variables or common blocks", &gfc_current_locus);
7298 /* Check what next non-whitespace character is so we can tell if there
7299 is the required parens if we have a BIND(C). */
7300 old_loc = gfc_current_locus;
7301 gfc_gobble_whitespace ();
7302 peek_char = gfc_peek_ascii_char ();
7304 if (state == COMP_SUBROUTINE)
7306 m = gfc_match_formal_arglist (entry, 0, 1);
7307 if (m != MATCH_YES)
7308 return MATCH_ERROR;
7310 /* Call gfc_match_bind_c with allow_binding_name = true as ENTRY can
7311 never be an internal procedure. */
7312 is_bind_c = gfc_match_bind_c (entry, true);
7313 if (is_bind_c == MATCH_ERROR)
7314 return MATCH_ERROR;
7315 if (is_bind_c == MATCH_YES)
7317 if (peek_char != '(')
7319 gfc_error ("Missing required parentheses before BIND(C) at %C");
7320 return MATCH_ERROR;
7322 if (!gfc_add_is_bind_c (&(entry->attr), entry->name,
7323 &(entry->declared_at), 1))
7324 return MATCH_ERROR;
7327 if (!gfc_current_ns->parent
7328 && !add_global_entry (name, entry->binding_label, true,
7329 &old_loc))
7330 return MATCH_ERROR;
7332 /* An entry in a subroutine. */
7333 if (!gfc_add_entry (&entry->attr, entry->name, NULL)
7334 || !gfc_add_subroutine (&entry->attr, entry->name, NULL))
7335 return MATCH_ERROR;
7337 else
7339 /* An entry in a function.
7340 We need to take special care because writing
7341 ENTRY f()
7343 ENTRY f
7344 is allowed, whereas
7345 ENTRY f() RESULT (r)
7346 can't be written as
7347 ENTRY f RESULT (r). */
7348 if (gfc_match_eos () == MATCH_YES)
7350 gfc_current_locus = old_loc;
7351 /* Match the empty argument list, and add the interface to
7352 the symbol. */
7353 m = gfc_match_formal_arglist (entry, 0, 1);
7355 else
7356 m = gfc_match_formal_arglist (entry, 0, 0);
7358 if (m != MATCH_YES)
7359 return MATCH_ERROR;
7361 result = NULL;
7363 if (gfc_match_eos () == MATCH_YES)
7365 if (!gfc_add_entry (&entry->attr, entry->name, NULL)
7366 || !gfc_add_function (&entry->attr, entry->name, NULL))
7367 return MATCH_ERROR;
7369 entry->result = entry;
7371 else
7373 m = gfc_match_suffix (entry, &result);
7374 if (m == MATCH_NO)
7375 gfc_syntax_error (ST_ENTRY);
7376 if (m != MATCH_YES)
7377 return MATCH_ERROR;
7379 if (result)
7381 if (!gfc_add_result (&result->attr, result->name, NULL)
7382 || !gfc_add_entry (&entry->attr, result->name, NULL)
7383 || !gfc_add_function (&entry->attr, result->name, NULL))
7384 return MATCH_ERROR;
7385 entry->result = result;
7387 else
7389 if (!gfc_add_entry (&entry->attr, entry->name, NULL)
7390 || !gfc_add_function (&entry->attr, entry->name, NULL))
7391 return MATCH_ERROR;
7392 entry->result = entry;
7396 if (!gfc_current_ns->parent
7397 && !add_global_entry (name, entry->binding_label, false,
7398 &old_loc))
7399 return MATCH_ERROR;
7402 if (gfc_match_eos () != MATCH_YES)
7404 gfc_syntax_error (ST_ENTRY);
7405 return MATCH_ERROR;
7408 entry->attr.recursive = proc->attr.recursive;
7409 entry->attr.elemental = proc->attr.elemental;
7410 entry->attr.pure = proc->attr.pure;
7412 el = gfc_get_entry_list ();
7413 el->sym = entry;
7414 el->next = gfc_current_ns->entries;
7415 gfc_current_ns->entries = el;
7416 if (el->next)
7417 el->id = el->next->id + 1;
7418 else
7419 el->id = 1;
7421 new_st.op = EXEC_ENTRY;
7422 new_st.ext.entry = el;
7424 return MATCH_YES;
7428 /* Match a subroutine statement, including optional prefixes. */
7430 match
7431 gfc_match_subroutine (void)
7433 char name[GFC_MAX_SYMBOL_LEN + 1];
7434 gfc_symbol *sym;
7435 match m;
7436 match is_bind_c;
7437 char peek_char;
7438 bool allow_binding_name;
7440 if (gfc_current_state () != COMP_NONE
7441 && gfc_current_state () != COMP_INTERFACE
7442 && gfc_current_state () != COMP_CONTAINS)
7443 return MATCH_NO;
7445 m = gfc_match_prefix (NULL);
7446 if (m != MATCH_YES)
7447 return m;
7449 m = gfc_match ("subroutine% %n", name);
7450 if (m != MATCH_YES)
7451 return m;
7453 if (get_proc_name (name, &sym, false))
7454 return MATCH_ERROR;
7456 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
7457 the symbol existed before. */
7458 sym->declared_at = gfc_current_locus;
7460 if (current_attr.module_procedure)
7461 sym->attr.module_procedure = 1;
7463 if (add_hidden_procptr_result (sym))
7464 sym = sym->result;
7466 gfc_new_block = sym;
7468 /* Check what next non-whitespace character is so we can tell if there
7469 is the required parens if we have a BIND(C). */
7470 gfc_gobble_whitespace ();
7471 peek_char = gfc_peek_ascii_char ();
7473 if (!gfc_add_subroutine (&sym->attr, sym->name, NULL))
7474 return MATCH_ERROR;
7476 if (gfc_match_formal_arglist (sym, 0, 1) != MATCH_YES)
7477 return MATCH_ERROR;
7479 /* Make sure that it isn't already declared as BIND(C). If it is, it
7480 must have been marked BIND(C) with a BIND(C) attribute and that is
7481 not allowed for procedures. */
7482 if (sym->attr.is_bind_c == 1)
7484 sym->attr.is_bind_c = 0;
7485 if (sym->old_symbol != NULL)
7486 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7487 "variables or common blocks",
7488 &(sym->old_symbol->declared_at));
7489 else
7490 gfc_error_now ("BIND(C) attribute at %L can only be used for "
7491 "variables or common blocks", &gfc_current_locus);
7494 /* C binding names are not allowed for internal procedures. */
7495 if (gfc_current_state () == COMP_CONTAINS
7496 && sym->ns->proc_name->attr.flavor != FL_MODULE)
7497 allow_binding_name = false;
7498 else
7499 allow_binding_name = true;
7501 /* Here, we are just checking if it has the bind(c) attribute, and if
7502 so, then we need to make sure it's all correct. If it doesn't,
7503 we still need to continue matching the rest of the subroutine line. */
7504 is_bind_c = gfc_match_bind_c (sym, allow_binding_name);
7505 if (is_bind_c == MATCH_ERROR)
7507 /* There was an attempt at the bind(c), but it was wrong. An
7508 error message should have been printed w/in the gfc_match_bind_c
7509 so here we'll just return the MATCH_ERROR. */
7510 return MATCH_ERROR;
7513 if (is_bind_c == MATCH_YES)
7515 /* The following is allowed in the Fortran 2008 draft. */
7516 if (gfc_current_state () == COMP_CONTAINS
7517 && sym->ns->proc_name->attr.flavor != FL_MODULE
7518 && !gfc_notify_std (GFC_STD_F2008, "BIND(C) attribute "
7519 "at %L may not be specified for an internal "
7520 "procedure", &gfc_current_locus))
7521 return MATCH_ERROR;
7523 if (peek_char != '(')
7525 gfc_error ("Missing required parentheses before BIND(C) at %C");
7526 return MATCH_ERROR;
7528 if (!gfc_add_is_bind_c (&(sym->attr), sym->name,
7529 &(sym->declared_at), 1))
7530 return MATCH_ERROR;
7533 if (gfc_match_eos () != MATCH_YES)
7535 gfc_syntax_error (ST_SUBROUTINE);
7536 return MATCH_ERROR;
7539 if (!copy_prefix (&sym->attr, &sym->declared_at))
7541 if(!sym->attr.module_procedure)
7542 return MATCH_ERROR;
7543 else
7544 gfc_error_check ();
7547 /* Warn if it has the same name as an intrinsic. */
7548 do_warn_intrinsic_shadow (sym, false);
7550 return MATCH_YES;
7554 /* Check that the NAME identifier in a BIND attribute or statement
7555 is conform to C identifier rules. */
7557 match
7558 check_bind_name_identifier (char **name)
7560 char *n = *name, *p;
7562 /* Remove leading spaces. */
7563 while (*n == ' ')
7564 n++;
7566 /* On an empty string, free memory and set name to NULL. */
7567 if (*n == '\0')
7569 free (*name);
7570 *name = NULL;
7571 return MATCH_YES;
7574 /* Remove trailing spaces. */
7575 p = n + strlen(n) - 1;
7576 while (*p == ' ')
7577 *(p--) = '\0';
7579 /* Insert the identifier into the symbol table. */
7580 p = xstrdup (n);
7581 free (*name);
7582 *name = p;
7584 /* Now check that identifier is valid under C rules. */
7585 if (ISDIGIT (*p))
7587 gfc_error ("Invalid C identifier in NAME= specifier at %C");
7588 return MATCH_ERROR;
7591 for (; *p; p++)
7592 if (!(ISALNUM (*p) || *p == '_' || *p == '$'))
7594 gfc_error ("Invalid C identifier in NAME= specifier at %C");
7595 return MATCH_ERROR;
7598 return MATCH_YES;
7602 /* Match a BIND(C) specifier, with the optional 'name=' specifier if
7603 given, and set the binding label in either the given symbol (if not
7604 NULL), or in the current_ts. The symbol may be NULL because we may
7605 encounter the BIND(C) before the declaration itself. Return
7606 MATCH_NO if what we're looking at isn't a BIND(C) specifier,
7607 MATCH_ERROR if it is a BIND(C) clause but an error was encountered,
7608 or MATCH_YES if the specifier was correct and the binding label and
7609 bind(c) fields were set correctly for the given symbol or the
7610 current_ts. If allow_binding_name is false, no binding name may be
7611 given. */
7613 match
7614 gfc_match_bind_c (gfc_symbol *sym, bool allow_binding_name)
7616 char *binding_label = NULL;
7617 gfc_expr *e = NULL;
7619 /* Initialize the flag that specifies whether we encountered a NAME=
7620 specifier or not. */
7621 has_name_equals = 0;
7623 /* This much we have to be able to match, in this order, if
7624 there is a bind(c) label. */
7625 if (gfc_match (" bind ( c ") != MATCH_YES)
7626 return MATCH_NO;
7628 /* Now see if there is a binding label, or if we've reached the
7629 end of the bind(c) attribute without one. */
7630 if (gfc_match_char (',') == MATCH_YES)
7632 if (gfc_match (" name = ") != MATCH_YES)
7634 gfc_error ("Syntax error in NAME= specifier for binding label "
7635 "at %C");
7636 /* should give an error message here */
7637 return MATCH_ERROR;
7640 has_name_equals = 1;
7642 if (gfc_match_init_expr (&e) != MATCH_YES)
7644 gfc_free_expr (e);
7645 return MATCH_ERROR;
7648 if (!gfc_simplify_expr(e, 0))
7650 gfc_error ("NAME= specifier at %C should be a constant expression");
7651 gfc_free_expr (e);
7652 return MATCH_ERROR;
7655 if (e->expr_type != EXPR_CONSTANT || e->ts.type != BT_CHARACTER
7656 || e->ts.kind != gfc_default_character_kind || e->rank != 0)
7658 gfc_error ("NAME= specifier at %C should be a scalar of "
7659 "default character kind");
7660 gfc_free_expr(e);
7661 return MATCH_ERROR;
7664 // Get a C string from the Fortran string constant
7665 binding_label = gfc_widechar_to_char (e->value.character.string,
7666 e->value.character.length);
7667 gfc_free_expr(e);
7669 // Check that it is valid (old gfc_match_name_C)
7670 if (check_bind_name_identifier (&binding_label) != MATCH_YES)
7671 return MATCH_ERROR;
7674 /* Get the required right paren. */
7675 if (gfc_match_char (')') != MATCH_YES)
7677 gfc_error ("Missing closing paren for binding label at %C");
7678 return MATCH_ERROR;
7681 if (has_name_equals && !allow_binding_name)
7683 gfc_error ("No binding name is allowed in BIND(C) at %C");
7684 return MATCH_ERROR;
7687 if (has_name_equals && sym != NULL && sym->attr.dummy)
7689 gfc_error ("For dummy procedure %s, no binding name is "
7690 "allowed in BIND(C) at %C", sym->name);
7691 return MATCH_ERROR;
7695 /* Save the binding label to the symbol. If sym is null, we're
7696 probably matching the typespec attributes of a declaration and
7697 haven't gotten the name yet, and therefore, no symbol yet. */
7698 if (binding_label)
7700 if (sym != NULL)
7701 sym->binding_label = binding_label;
7702 else
7703 curr_binding_label = binding_label;
7705 else if (allow_binding_name)
7707 /* No binding label, but if symbol isn't null, we
7708 can set the label for it here.
7709 If name="" or allow_binding_name is false, no C binding name is
7710 created. */
7711 if (sym != NULL && sym->name != NULL && has_name_equals == 0)
7712 sym->binding_label = IDENTIFIER_POINTER (get_identifier (sym->name));
7715 if (has_name_equals && gfc_current_state () == COMP_INTERFACE
7716 && current_interface.type == INTERFACE_ABSTRACT)
7718 gfc_error ("NAME not allowed on BIND(C) for ABSTRACT INTERFACE at %C");
7719 return MATCH_ERROR;
7722 return MATCH_YES;
7726 /* Return nonzero if we're currently compiling a contained procedure. */
7728 static int
7729 contained_procedure (void)
7731 gfc_state_data *s = gfc_state_stack;
7733 if ((s->state == COMP_SUBROUTINE || s->state == COMP_FUNCTION)
7734 && s->previous != NULL && s->previous->state == COMP_CONTAINS)
7735 return 1;
7737 return 0;
7740 /* Set the kind of each enumerator. The kind is selected such that it is
7741 interoperable with the corresponding C enumeration type, making
7742 sure that -fshort-enums is honored. */
7744 static void
7745 set_enum_kind(void)
7747 enumerator_history *current_history = NULL;
7748 int kind;
7749 int i;
7751 if (max_enum == NULL || enum_history == NULL)
7752 return;
7754 if (!flag_short_enums)
7755 return;
7757 i = 0;
7760 kind = gfc_integer_kinds[i++].kind;
7762 while (kind < gfc_c_int_kind
7763 && gfc_check_integer_range (max_enum->initializer->value.integer,
7764 kind) != ARITH_OK);
7766 current_history = enum_history;
7767 while (current_history != NULL)
7769 current_history->sym->ts.kind = kind;
7770 current_history = current_history->next;
7775 /* Match any of the various end-block statements. Returns the type of
7776 END to the caller. The END INTERFACE, END IF, END DO, END SELECT
7777 and END BLOCK statements cannot be replaced by a single END statement. */
7779 match
7780 gfc_match_end (gfc_statement *st)
7782 char name[GFC_MAX_SYMBOL_LEN + 1];
7783 gfc_compile_state state;
7784 locus old_loc;
7785 const char *block_name;
7786 const char *target;
7787 int eos_ok;
7788 match m;
7789 gfc_namespace *parent_ns, *ns, *prev_ns;
7790 gfc_namespace **nsp;
7791 bool abreviated_modproc_decl = false;
7792 bool got_matching_end = false;
7794 old_loc = gfc_current_locus;
7795 if (gfc_match ("end") != MATCH_YES)
7796 return MATCH_NO;
7798 state = gfc_current_state ();
7799 block_name = gfc_current_block () == NULL
7800 ? NULL : gfc_current_block ()->name;
7802 switch (state)
7804 case COMP_ASSOCIATE:
7805 case COMP_BLOCK:
7806 if (!strncmp (block_name, "block@", strlen("block@")))
7807 block_name = NULL;
7808 break;
7810 case COMP_CONTAINS:
7811 case COMP_DERIVED_CONTAINS:
7812 state = gfc_state_stack->previous->state;
7813 block_name = gfc_state_stack->previous->sym == NULL
7814 ? NULL : gfc_state_stack->previous->sym->name;
7815 abreviated_modproc_decl = gfc_state_stack->previous->sym
7816 && gfc_state_stack->previous->sym->abr_modproc_decl;
7817 break;
7819 default:
7820 break;
7823 if (!abreviated_modproc_decl)
7824 abreviated_modproc_decl = gfc_current_block ()
7825 && gfc_current_block ()->abr_modproc_decl;
7827 switch (state)
7829 case COMP_NONE:
7830 case COMP_PROGRAM:
7831 *st = ST_END_PROGRAM;
7832 target = " program";
7833 eos_ok = 1;
7834 break;
7836 case COMP_SUBROUTINE:
7837 *st = ST_END_SUBROUTINE;
7838 if (!abreviated_modproc_decl)
7839 target = " subroutine";
7840 else
7841 target = " procedure";
7842 eos_ok = !contained_procedure ();
7843 break;
7845 case COMP_FUNCTION:
7846 *st = ST_END_FUNCTION;
7847 if (!abreviated_modproc_decl)
7848 target = " function";
7849 else
7850 target = " procedure";
7851 eos_ok = !contained_procedure ();
7852 break;
7854 case COMP_BLOCK_DATA:
7855 *st = ST_END_BLOCK_DATA;
7856 target = " block data";
7857 eos_ok = 1;
7858 break;
7860 case COMP_MODULE:
7861 *st = ST_END_MODULE;
7862 target = " module";
7863 eos_ok = 1;
7864 break;
7866 case COMP_SUBMODULE:
7867 *st = ST_END_SUBMODULE;
7868 target = " submodule";
7869 eos_ok = 1;
7870 break;
7872 case COMP_INTERFACE:
7873 *st = ST_END_INTERFACE;
7874 target = " interface";
7875 eos_ok = 0;
7876 break;
7878 case COMP_MAP:
7879 *st = ST_END_MAP;
7880 target = " map";
7881 eos_ok = 0;
7882 break;
7884 case COMP_UNION:
7885 *st = ST_END_UNION;
7886 target = " union";
7887 eos_ok = 0;
7888 break;
7890 case COMP_STRUCTURE:
7891 *st = ST_END_STRUCTURE;
7892 target = " structure";
7893 eos_ok = 0;
7894 break;
7896 case COMP_DERIVED:
7897 case COMP_DERIVED_CONTAINS:
7898 *st = ST_END_TYPE;
7899 target = " type";
7900 eos_ok = 0;
7901 break;
7903 case COMP_ASSOCIATE:
7904 *st = ST_END_ASSOCIATE;
7905 target = " associate";
7906 eos_ok = 0;
7907 break;
7909 case COMP_BLOCK:
7910 *st = ST_END_BLOCK;
7911 target = " block";
7912 eos_ok = 0;
7913 break;
7915 case COMP_IF:
7916 *st = ST_ENDIF;
7917 target = " if";
7918 eos_ok = 0;
7919 break;
7921 case COMP_DO:
7922 case COMP_DO_CONCURRENT:
7923 *st = ST_ENDDO;
7924 target = " do";
7925 eos_ok = 0;
7926 break;
7928 case COMP_CRITICAL:
7929 *st = ST_END_CRITICAL;
7930 target = " critical";
7931 eos_ok = 0;
7932 break;
7934 case COMP_SELECT:
7935 case COMP_SELECT_TYPE:
7936 *st = ST_END_SELECT;
7937 target = " select";
7938 eos_ok = 0;
7939 break;
7941 case COMP_FORALL:
7942 *st = ST_END_FORALL;
7943 target = " forall";
7944 eos_ok = 0;
7945 break;
7947 case COMP_WHERE:
7948 *st = ST_END_WHERE;
7949 target = " where";
7950 eos_ok = 0;
7951 break;
7953 case COMP_ENUM:
7954 *st = ST_END_ENUM;
7955 target = " enum";
7956 eos_ok = 0;
7957 last_initializer = NULL;
7958 set_enum_kind ();
7959 gfc_free_enum_history ();
7960 break;
7962 default:
7963 gfc_error ("Unexpected END statement at %C");
7964 goto cleanup;
7967 old_loc = gfc_current_locus;
7968 if (gfc_match_eos () == MATCH_YES)
7970 if (!eos_ok && (*st == ST_END_SUBROUTINE || *st == ST_END_FUNCTION))
7972 if (!gfc_notify_std (GFC_STD_F2008, "END statement "
7973 "instead of %s statement at %L",
7974 abreviated_modproc_decl ? "END PROCEDURE"
7975 : gfc_ascii_statement(*st), &old_loc))
7976 goto cleanup;
7978 else if (!eos_ok)
7980 /* We would have required END [something]. */
7981 gfc_error ("%s statement expected at %L",
7982 gfc_ascii_statement (*st), &old_loc);
7983 goto cleanup;
7986 return MATCH_YES;
7989 /* Verify that we've got the sort of end-block that we're expecting. */
7990 if (gfc_match (target) != MATCH_YES)
7992 gfc_error ("Expecting %s statement at %L", abreviated_modproc_decl
7993 ? "END PROCEDURE" : gfc_ascii_statement(*st), &old_loc);
7994 goto cleanup;
7996 else
7997 got_matching_end = true;
7999 old_loc = gfc_current_locus;
8000 /* If we're at the end, make sure a block name wasn't required. */
8001 if (gfc_match_eos () == MATCH_YES)
8004 if (*st != ST_ENDDO && *st != ST_ENDIF && *st != ST_END_SELECT
8005 && *st != ST_END_FORALL && *st != ST_END_WHERE && *st != ST_END_BLOCK
8006 && *st != ST_END_ASSOCIATE && *st != ST_END_CRITICAL)
8007 return MATCH_YES;
8009 if (!block_name)
8010 return MATCH_YES;
8012 gfc_error ("Expected block name of %qs in %s statement at %L",
8013 block_name, gfc_ascii_statement (*st), &old_loc);
8015 return MATCH_ERROR;
8018 /* END INTERFACE has a special handler for its several possible endings. */
8019 if (*st == ST_END_INTERFACE)
8020 return gfc_match_end_interface ();
8022 /* We haven't hit the end of statement, so what is left must be an
8023 end-name. */
8024 m = gfc_match_space ();
8025 if (m == MATCH_YES)
8026 m = gfc_match_name (name);
8028 if (m == MATCH_NO)
8029 gfc_error ("Expected terminating name at %C");
8030 if (m != MATCH_YES)
8031 goto cleanup;
8033 if (block_name == NULL)
8034 goto syntax;
8036 /* We have to pick out the declared submodule name from the composite
8037 required by F2008:11.2.3 para 2, which ends in the declared name. */
8038 if (state == COMP_SUBMODULE)
8039 block_name = strchr (block_name, '.') + 1;
8041 if (strcmp (name, block_name) != 0 && strcmp (block_name, "ppr@") != 0)
8043 gfc_error ("Expected label %qs for %s statement at %C", block_name,
8044 gfc_ascii_statement (*st));
8045 goto cleanup;
8047 /* Procedure pointer as function result. */
8048 else if (strcmp (block_name, "ppr@") == 0
8049 && strcmp (name, gfc_current_block ()->ns->proc_name->name) != 0)
8051 gfc_error ("Expected label %qs for %s statement at %C",
8052 gfc_current_block ()->ns->proc_name->name,
8053 gfc_ascii_statement (*st));
8054 goto cleanup;
8057 if (gfc_match_eos () == MATCH_YES)
8058 return MATCH_YES;
8060 syntax:
8061 gfc_syntax_error (*st);
8063 cleanup:
8064 gfc_current_locus = old_loc;
8066 /* If we are missing an END BLOCK, we created a half-ready namespace.
8067 Remove it from the parent namespace's sibling list. */
8069 while (state == COMP_BLOCK && !got_matching_end)
8071 parent_ns = gfc_current_ns->parent;
8073 nsp = &(gfc_state_stack->previous->tail->ext.block.ns);
8075 prev_ns = NULL;
8076 ns = *nsp;
8077 while (ns)
8079 if (ns == gfc_current_ns)
8081 if (prev_ns == NULL)
8082 *nsp = NULL;
8083 else
8084 prev_ns->sibling = ns->sibling;
8086 prev_ns = ns;
8087 ns = ns->sibling;
8090 gfc_free_namespace (gfc_current_ns);
8091 gfc_current_ns = parent_ns;
8092 gfc_state_stack = gfc_state_stack->previous;
8093 state = gfc_current_state ();
8096 return MATCH_ERROR;
8101 /***************** Attribute declaration statements ****************/
8103 /* Set the attribute of a single variable. */
8105 static match
8106 attr_decl1 (void)
8108 char name[GFC_MAX_SYMBOL_LEN + 1];
8109 gfc_array_spec *as;
8111 /* Workaround -Wmaybe-uninitialized false positive during
8112 profiledbootstrap by initializing them. */
8113 gfc_symbol *sym = NULL;
8114 locus var_locus;
8115 match m;
8117 as = NULL;
8119 m = gfc_match_name (name);
8120 if (m != MATCH_YES)
8121 goto cleanup;
8123 if (find_special (name, &sym, false))
8124 return MATCH_ERROR;
8126 if (!check_function_name (name))
8128 m = MATCH_ERROR;
8129 goto cleanup;
8132 var_locus = gfc_current_locus;
8134 /* Deal with possible array specification for certain attributes. */
8135 if (current_attr.dimension
8136 || current_attr.codimension
8137 || current_attr.allocatable
8138 || current_attr.pointer
8139 || current_attr.target)
8141 m = gfc_match_array_spec (&as, !current_attr.codimension,
8142 !current_attr.dimension
8143 && !current_attr.pointer
8144 && !current_attr.target);
8145 if (m == MATCH_ERROR)
8146 goto cleanup;
8148 if (current_attr.dimension && m == MATCH_NO)
8150 gfc_error ("Missing array specification at %L in DIMENSION "
8151 "statement", &var_locus);
8152 m = MATCH_ERROR;
8153 goto cleanup;
8156 if (current_attr.dimension && sym->value)
8158 gfc_error ("Dimensions specified for %s at %L after its "
8159 "initialization", sym->name, &var_locus);
8160 m = MATCH_ERROR;
8161 goto cleanup;
8164 if (current_attr.codimension && m == MATCH_NO)
8166 gfc_error ("Missing array specification at %L in CODIMENSION "
8167 "statement", &var_locus);
8168 m = MATCH_ERROR;
8169 goto cleanup;
8172 if ((current_attr.allocatable || current_attr.pointer)
8173 && (m == MATCH_YES) && (as->type != AS_DEFERRED))
8175 gfc_error ("Array specification must be deferred at %L", &var_locus);
8176 m = MATCH_ERROR;
8177 goto cleanup;
8181 /* Update symbol table. DIMENSION attribute is set in
8182 gfc_set_array_spec(). For CLASS variables, this must be applied
8183 to the first component, or '_data' field. */
8184 if (sym->ts.type == BT_CLASS && sym->ts.u.derived->attr.is_class)
8186 if (!gfc_copy_attr (&CLASS_DATA(sym)->attr, &current_attr, &var_locus))
8188 m = MATCH_ERROR;
8189 goto cleanup;
8192 else
8194 if (current_attr.dimension == 0 && current_attr.codimension == 0
8195 && !gfc_copy_attr (&sym->attr, &current_attr, &var_locus))
8197 m = MATCH_ERROR;
8198 goto cleanup;
8202 if (sym->ts.type == BT_CLASS
8203 && !gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as))
8205 m = MATCH_ERROR;
8206 goto cleanup;
8209 if (!gfc_set_array_spec (sym, as, &var_locus))
8211 m = MATCH_ERROR;
8212 goto cleanup;
8215 if (sym->attr.cray_pointee && sym->as != NULL)
8217 /* Fix the array spec. */
8218 m = gfc_mod_pointee_as (sym->as);
8219 if (m == MATCH_ERROR)
8220 goto cleanup;
8223 if (!gfc_add_attribute (&sym->attr, &var_locus))
8225 m = MATCH_ERROR;
8226 goto cleanup;
8229 if ((current_attr.external || current_attr.intrinsic)
8230 && sym->attr.flavor != FL_PROCEDURE
8231 && !gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, NULL))
8233 m = MATCH_ERROR;
8234 goto cleanup;
8237 add_hidden_procptr_result (sym);
8239 return MATCH_YES;
8241 cleanup:
8242 gfc_free_array_spec (as);
8243 return m;
8247 /* Generic attribute declaration subroutine. Used for attributes that
8248 just have a list of names. */
8250 static match
8251 attr_decl (void)
8253 match m;
8255 /* Gobble the optional double colon, by simply ignoring the result
8256 of gfc_match(). */
8257 gfc_match (" ::");
8259 for (;;)
8261 m = attr_decl1 ();
8262 if (m != MATCH_YES)
8263 break;
8265 if (gfc_match_eos () == MATCH_YES)
8267 m = MATCH_YES;
8268 break;
8271 if (gfc_match_char (',') != MATCH_YES)
8273 gfc_error ("Unexpected character in variable list at %C");
8274 m = MATCH_ERROR;
8275 break;
8279 return m;
8283 /* This routine matches Cray Pointer declarations of the form:
8284 pointer ( <pointer>, <pointee> )
8286 pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...
8287 The pointer, if already declared, should be an integer. Otherwise, we
8288 set it as BT_INTEGER with kind gfc_index_integer_kind. The pointee may
8289 be either a scalar, or an array declaration. No space is allocated for
8290 the pointee. For the statement
8291 pointer (ipt, ar(10))
8292 any subsequent uses of ar will be translated (in C-notation) as
8293 ar(i) => ((<type> *) ipt)(i)
8294 After gimplification, pointee variable will disappear in the code. */
8296 static match
8297 cray_pointer_decl (void)
8299 match m;
8300 gfc_array_spec *as = NULL;
8301 gfc_symbol *cptr; /* Pointer symbol. */
8302 gfc_symbol *cpte; /* Pointee symbol. */
8303 locus var_locus;
8304 bool done = false;
8306 while (!done)
8308 if (gfc_match_char ('(') != MATCH_YES)
8310 gfc_error ("Expected %<(%> at %C");
8311 return MATCH_ERROR;
8314 /* Match pointer. */
8315 var_locus = gfc_current_locus;
8316 gfc_clear_attr (&current_attr);
8317 gfc_add_cray_pointer (&current_attr, &var_locus);
8318 current_ts.type = BT_INTEGER;
8319 current_ts.kind = gfc_index_integer_kind;
8321 m = gfc_match_symbol (&cptr, 0);
8322 if (m != MATCH_YES)
8324 gfc_error ("Expected variable name at %C");
8325 return m;
8328 if (!gfc_add_cray_pointer (&cptr->attr, &var_locus))
8329 return MATCH_ERROR;
8331 gfc_set_sym_referenced (cptr);
8333 if (cptr->ts.type == BT_UNKNOWN) /* Override the type, if necessary. */
8335 cptr->ts.type = BT_INTEGER;
8336 cptr->ts.kind = gfc_index_integer_kind;
8338 else if (cptr->ts.type != BT_INTEGER)
8340 gfc_error ("Cray pointer at %C must be an integer");
8341 return MATCH_ERROR;
8343 else if (cptr->ts.kind < gfc_index_integer_kind)
8344 gfc_warning (0, "Cray pointer at %C has %d bytes of precision;"
8345 " memory addresses require %d bytes",
8346 cptr->ts.kind, gfc_index_integer_kind);
8348 if (gfc_match_char (',') != MATCH_YES)
8350 gfc_error ("Expected \",\" at %C");
8351 return MATCH_ERROR;
8354 /* Match Pointee. */
8355 var_locus = gfc_current_locus;
8356 gfc_clear_attr (&current_attr);
8357 gfc_add_cray_pointee (&current_attr, &var_locus);
8358 current_ts.type = BT_UNKNOWN;
8359 current_ts.kind = 0;
8361 m = gfc_match_symbol (&cpte, 0);
8362 if (m != MATCH_YES)
8364 gfc_error ("Expected variable name at %C");
8365 return m;
8368 /* Check for an optional array spec. */
8369 m = gfc_match_array_spec (&as, true, false);
8370 if (m == MATCH_ERROR)
8372 gfc_free_array_spec (as);
8373 return m;
8375 else if (m == MATCH_NO)
8377 gfc_free_array_spec (as);
8378 as = NULL;
8381 if (!gfc_add_cray_pointee (&cpte->attr, &var_locus))
8382 return MATCH_ERROR;
8384 gfc_set_sym_referenced (cpte);
8386 if (cpte->as == NULL)
8388 if (!gfc_set_array_spec (cpte, as, &var_locus))
8389 gfc_internal_error ("Couldn't set Cray pointee array spec.");
8391 else if (as != NULL)
8393 gfc_error ("Duplicate array spec for Cray pointee at %C");
8394 gfc_free_array_spec (as);
8395 return MATCH_ERROR;
8398 as = NULL;
8400 if (cpte->as != NULL)
8402 /* Fix array spec. */
8403 m = gfc_mod_pointee_as (cpte->as);
8404 if (m == MATCH_ERROR)
8405 return m;
8408 /* Point the Pointee at the Pointer. */
8409 cpte->cp_pointer = cptr;
8411 if (gfc_match_char (')') != MATCH_YES)
8413 gfc_error ("Expected \")\" at %C");
8414 return MATCH_ERROR;
8416 m = gfc_match_char (',');
8417 if (m != MATCH_YES)
8418 done = true; /* Stop searching for more declarations. */
8422 if (m == MATCH_ERROR /* Failed when trying to find ',' above. */
8423 || gfc_match_eos () != MATCH_YES)
8425 gfc_error ("Expected %<,%> or end of statement at %C");
8426 return MATCH_ERROR;
8428 return MATCH_YES;
8432 match
8433 gfc_match_external (void)
8436 gfc_clear_attr (&current_attr);
8437 current_attr.external = 1;
8439 return attr_decl ();
8443 match
8444 gfc_match_intent (void)
8446 sym_intent intent;
8448 /* This is not allowed within a BLOCK construct! */
8449 if (gfc_current_state () == COMP_BLOCK)
8451 gfc_error ("INTENT is not allowed inside of BLOCK at %C");
8452 return MATCH_ERROR;
8455 intent = match_intent_spec ();
8456 if (intent == INTENT_UNKNOWN)
8457 return MATCH_ERROR;
8459 gfc_clear_attr (&current_attr);
8460 current_attr.intent = intent;
8462 return attr_decl ();
8466 match
8467 gfc_match_intrinsic (void)
8470 gfc_clear_attr (&current_attr);
8471 current_attr.intrinsic = 1;
8473 return attr_decl ();
8477 match
8478 gfc_match_optional (void)
8480 /* This is not allowed within a BLOCK construct! */
8481 if (gfc_current_state () == COMP_BLOCK)
8483 gfc_error ("OPTIONAL is not allowed inside of BLOCK at %C");
8484 return MATCH_ERROR;
8487 gfc_clear_attr (&current_attr);
8488 current_attr.optional = 1;
8490 return attr_decl ();
8494 match
8495 gfc_match_pointer (void)
8497 gfc_gobble_whitespace ();
8498 if (gfc_peek_ascii_char () == '(')
8500 if (!flag_cray_pointer)
8502 gfc_error ("Cray pointer declaration at %C requires -fcray-pointer "
8503 "flag");
8504 return MATCH_ERROR;
8506 return cray_pointer_decl ();
8508 else
8510 gfc_clear_attr (&current_attr);
8511 current_attr.pointer = 1;
8513 return attr_decl ();
8518 match
8519 gfc_match_allocatable (void)
8521 gfc_clear_attr (&current_attr);
8522 current_attr.allocatable = 1;
8524 return attr_decl ();
8528 match
8529 gfc_match_codimension (void)
8531 gfc_clear_attr (&current_attr);
8532 current_attr.codimension = 1;
8534 return attr_decl ();
8538 match
8539 gfc_match_contiguous (void)
8541 if (!gfc_notify_std (GFC_STD_F2008, "CONTIGUOUS statement at %C"))
8542 return MATCH_ERROR;
8544 gfc_clear_attr (&current_attr);
8545 current_attr.contiguous = 1;
8547 return attr_decl ();
8551 match
8552 gfc_match_dimension (void)
8554 gfc_clear_attr (&current_attr);
8555 current_attr.dimension = 1;
8557 return attr_decl ();
8561 match
8562 gfc_match_target (void)
8564 gfc_clear_attr (&current_attr);
8565 current_attr.target = 1;
8567 return attr_decl ();
8571 /* Match the list of entities being specified in a PUBLIC or PRIVATE
8572 statement. */
8574 static match
8575 access_attr_decl (gfc_statement st)
8577 char name[GFC_MAX_SYMBOL_LEN + 1];
8578 interface_type type;
8579 gfc_user_op *uop;
8580 gfc_symbol *sym, *dt_sym;
8581 gfc_intrinsic_op op;
8582 match m;
8584 if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
8585 goto done;
8587 for (;;)
8589 m = gfc_match_generic_spec (&type, name, &op);
8590 if (m == MATCH_NO)
8591 goto syntax;
8592 if (m == MATCH_ERROR)
8593 return MATCH_ERROR;
8595 switch (type)
8597 case INTERFACE_NAMELESS:
8598 case INTERFACE_ABSTRACT:
8599 goto syntax;
8601 case INTERFACE_GENERIC:
8602 case INTERFACE_DTIO:
8604 if (gfc_get_symbol (name, NULL, &sym))
8605 goto done;
8607 if (type == INTERFACE_DTIO
8608 && gfc_current_ns->proc_name
8609 && gfc_current_ns->proc_name->attr.flavor == FL_MODULE
8610 && sym->attr.flavor == FL_UNKNOWN)
8611 sym->attr.flavor = FL_PROCEDURE;
8613 if (!gfc_add_access (&sym->attr,
8614 (st == ST_PUBLIC)
8615 ? ACCESS_PUBLIC : ACCESS_PRIVATE,
8616 sym->name, NULL))
8617 return MATCH_ERROR;
8619 if (sym->attr.generic && (dt_sym = gfc_find_dt_in_generic (sym))
8620 && !gfc_add_access (&dt_sym->attr,
8621 (st == ST_PUBLIC)
8622 ? ACCESS_PUBLIC : ACCESS_PRIVATE,
8623 sym->name, NULL))
8624 return MATCH_ERROR;
8626 break;
8628 case INTERFACE_INTRINSIC_OP:
8629 if (gfc_current_ns->operator_access[op] == ACCESS_UNKNOWN)
8631 gfc_intrinsic_op other_op;
8633 gfc_current_ns->operator_access[op] =
8634 (st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE;
8636 /* Handle the case if there is another op with the same
8637 function, for INTRINSIC_EQ vs. INTRINSIC_EQ_OS and so on. */
8638 other_op = gfc_equivalent_op (op);
8640 if (other_op != INTRINSIC_NONE)
8641 gfc_current_ns->operator_access[other_op] =
8642 (st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE;
8645 else
8647 gfc_error ("Access specification of the %s operator at %C has "
8648 "already been specified", gfc_op2string (op));
8649 goto done;
8652 break;
8654 case INTERFACE_USER_OP:
8655 uop = gfc_get_uop (name);
8657 if (uop->access == ACCESS_UNKNOWN)
8659 uop->access = (st == ST_PUBLIC)
8660 ? ACCESS_PUBLIC : ACCESS_PRIVATE;
8662 else
8664 gfc_error ("Access specification of the .%s. operator at %C "
8665 "has already been specified", sym->name);
8666 goto done;
8669 break;
8672 if (gfc_match_char (',') == MATCH_NO)
8673 break;
8676 if (gfc_match_eos () != MATCH_YES)
8677 goto syntax;
8678 return MATCH_YES;
8680 syntax:
8681 gfc_syntax_error (st);
8683 done:
8684 return MATCH_ERROR;
8688 match
8689 gfc_match_protected (void)
8691 gfc_symbol *sym;
8692 match m;
8694 if (!gfc_current_ns->proc_name
8695 || gfc_current_ns->proc_name->attr.flavor != FL_MODULE)
8697 gfc_error ("PROTECTED at %C only allowed in specification "
8698 "part of a module");
8699 return MATCH_ERROR;
8703 if (!gfc_notify_std (GFC_STD_F2003, "PROTECTED statement at %C"))
8704 return MATCH_ERROR;
8706 if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
8708 return MATCH_ERROR;
8711 if (gfc_match_eos () == MATCH_YES)
8712 goto syntax;
8714 for(;;)
8716 m = gfc_match_symbol (&sym, 0);
8717 switch (m)
8719 case MATCH_YES:
8720 if (!gfc_add_protected (&sym->attr, sym->name, &gfc_current_locus))
8721 return MATCH_ERROR;
8722 goto next_item;
8724 case MATCH_NO:
8725 break;
8727 case MATCH_ERROR:
8728 return MATCH_ERROR;
8731 next_item:
8732 if (gfc_match_eos () == MATCH_YES)
8733 break;
8734 if (gfc_match_char (',') != MATCH_YES)
8735 goto syntax;
8738 return MATCH_YES;
8740 syntax:
8741 gfc_error ("Syntax error in PROTECTED statement at %C");
8742 return MATCH_ERROR;
8746 /* The PRIVATE statement is a bit weird in that it can be an attribute
8747 declaration, but also works as a standalone statement inside of a
8748 type declaration or a module. */
8750 match
8751 gfc_match_private (gfc_statement *st)
8754 if (gfc_match ("private") != MATCH_YES)
8755 return MATCH_NO;
8757 if (gfc_current_state () != COMP_MODULE
8758 && !(gfc_current_state () == COMP_DERIVED
8759 && gfc_state_stack->previous
8760 && gfc_state_stack->previous->state == COMP_MODULE)
8761 && !(gfc_current_state () == COMP_DERIVED_CONTAINS
8762 && gfc_state_stack->previous && gfc_state_stack->previous->previous
8763 && gfc_state_stack->previous->previous->state == COMP_MODULE))
8765 gfc_error ("PRIVATE statement at %C is only allowed in the "
8766 "specification part of a module");
8767 return MATCH_ERROR;
8770 if (gfc_current_state () == COMP_DERIVED)
8772 if (gfc_match_eos () == MATCH_YES)
8774 *st = ST_PRIVATE;
8775 return MATCH_YES;
8778 gfc_syntax_error (ST_PRIVATE);
8779 return MATCH_ERROR;
8782 if (gfc_match_eos () == MATCH_YES)
8784 *st = ST_PRIVATE;
8785 return MATCH_YES;
8788 *st = ST_ATTR_DECL;
8789 return access_attr_decl (ST_PRIVATE);
8793 match
8794 gfc_match_public (gfc_statement *st)
8797 if (gfc_match ("public") != MATCH_YES)
8798 return MATCH_NO;
8800 if (gfc_current_state () != COMP_MODULE)
8802 gfc_error ("PUBLIC statement at %C is only allowed in the "
8803 "specification part of a module");
8804 return MATCH_ERROR;
8807 if (gfc_match_eos () == MATCH_YES)
8809 *st = ST_PUBLIC;
8810 return MATCH_YES;
8813 *st = ST_ATTR_DECL;
8814 return access_attr_decl (ST_PUBLIC);
8818 /* Workhorse for gfc_match_parameter. */
8820 static match
8821 do_parm (void)
8823 gfc_symbol *sym;
8824 gfc_expr *init;
8825 match m;
8826 bool t;
8828 m = gfc_match_symbol (&sym, 0);
8829 if (m == MATCH_NO)
8830 gfc_error ("Expected variable name at %C in PARAMETER statement");
8832 if (m != MATCH_YES)
8833 return m;
8835 if (gfc_match_char ('=') == MATCH_NO)
8837 gfc_error ("Expected = sign in PARAMETER statement at %C");
8838 return MATCH_ERROR;
8841 m = gfc_match_init_expr (&init);
8842 if (m == MATCH_NO)
8843 gfc_error ("Expected expression at %C in PARAMETER statement");
8844 if (m != MATCH_YES)
8845 return m;
8847 if (sym->ts.type == BT_UNKNOWN
8848 && !gfc_set_default_type (sym, 1, NULL))
8850 m = MATCH_ERROR;
8851 goto cleanup;
8854 if (!gfc_check_assign_symbol (sym, NULL, init)
8855 || !gfc_add_flavor (&sym->attr, FL_PARAMETER, sym->name, NULL))
8857 m = MATCH_ERROR;
8858 goto cleanup;
8861 if (sym->value)
8863 gfc_error ("Initializing already initialized variable at %C");
8864 m = MATCH_ERROR;
8865 goto cleanup;
8868 t = add_init_expr_to_sym (sym->name, &init, &gfc_current_locus);
8869 return (t) ? MATCH_YES : MATCH_ERROR;
8871 cleanup:
8872 gfc_free_expr (init);
8873 return m;
8877 /* Match a parameter statement, with the weird syntax that these have. */
8879 match
8880 gfc_match_parameter (void)
8882 const char *term = " )%t";
8883 match m;
8885 if (gfc_match_char ('(') == MATCH_NO)
8887 /* With legacy PARAMETER statements, don't expect a terminating ')'. */
8888 if (!gfc_notify_std (GFC_STD_LEGACY, "PARAMETER without '()' at %C"))
8889 return MATCH_NO;
8890 term = " %t";
8893 for (;;)
8895 m = do_parm ();
8896 if (m != MATCH_YES)
8897 break;
8899 if (gfc_match (term) == MATCH_YES)
8900 break;
8902 if (gfc_match_char (',') != MATCH_YES)
8904 gfc_error ("Unexpected characters in PARAMETER statement at %C");
8905 m = MATCH_ERROR;
8906 break;
8910 return m;
8914 match
8915 gfc_match_automatic (void)
8917 gfc_symbol *sym;
8918 match m;
8919 bool seen_symbol = false;
8921 if (!flag_dec_static)
8923 gfc_error ("%s at %C is a DEC extension, enable with "
8924 "%<-fdec-static%>",
8925 "AUTOMATIC"
8927 return MATCH_ERROR;
8930 gfc_match (" ::");
8932 for (;;)
8934 m = gfc_match_symbol (&sym, 0);
8935 switch (m)
8937 case MATCH_NO:
8938 break;
8940 case MATCH_ERROR:
8941 return MATCH_ERROR;
8943 case MATCH_YES:
8944 if (!gfc_add_automatic (&sym->attr, sym->name, &gfc_current_locus))
8945 return MATCH_ERROR;
8946 seen_symbol = true;
8947 break;
8950 if (gfc_match_eos () == MATCH_YES)
8951 break;
8952 if (gfc_match_char (',') != MATCH_YES)
8953 goto syntax;
8956 if (!seen_symbol)
8958 gfc_error ("Expected entity-list in AUTOMATIC statement at %C");
8959 return MATCH_ERROR;
8962 return MATCH_YES;
8964 syntax:
8965 gfc_error ("Syntax error in AUTOMATIC statement at %C");
8966 return MATCH_ERROR;
8970 match
8971 gfc_match_static (void)
8973 gfc_symbol *sym;
8974 match m;
8975 bool seen_symbol = false;
8977 if (!flag_dec_static)
8979 gfc_error ("%s at %C is a DEC extension, enable with "
8980 "%<-fdec-static%>",
8981 "STATIC");
8982 return MATCH_ERROR;
8985 gfc_match (" ::");
8987 for (;;)
8989 m = gfc_match_symbol (&sym, 0);
8990 switch (m)
8992 case MATCH_NO:
8993 break;
8995 case MATCH_ERROR:
8996 return MATCH_ERROR;
8998 case MATCH_YES:
8999 if (!gfc_add_save (&sym->attr, SAVE_EXPLICIT, sym->name,
9000 &gfc_current_locus))
9001 return MATCH_ERROR;
9002 seen_symbol = true;
9003 break;
9006 if (gfc_match_eos () == MATCH_YES)
9007 break;
9008 if (gfc_match_char (',') != MATCH_YES)
9009 goto syntax;
9012 if (!seen_symbol)
9014 gfc_error ("Expected entity-list in STATIC statement at %C");
9015 return MATCH_ERROR;
9018 return MATCH_YES;
9020 syntax:
9021 gfc_error ("Syntax error in STATIC statement at %C");
9022 return MATCH_ERROR;
9026 /* Save statements have a special syntax. */
9028 match
9029 gfc_match_save (void)
9031 char n[GFC_MAX_SYMBOL_LEN+1];
9032 gfc_common_head *c;
9033 gfc_symbol *sym;
9034 match m;
9036 if (gfc_match_eos () == MATCH_YES)
9038 if (gfc_current_ns->seen_save)
9040 if (!gfc_notify_std (GFC_STD_LEGACY, "Blanket SAVE statement at %C "
9041 "follows previous SAVE statement"))
9042 return MATCH_ERROR;
9045 gfc_current_ns->save_all = gfc_current_ns->seen_save = 1;
9046 return MATCH_YES;
9049 if (gfc_current_ns->save_all)
9051 if (!gfc_notify_std (GFC_STD_LEGACY, "SAVE statement at %C follows "
9052 "blanket SAVE statement"))
9053 return MATCH_ERROR;
9056 gfc_match (" ::");
9058 for (;;)
9060 m = gfc_match_symbol (&sym, 0);
9061 switch (m)
9063 case MATCH_YES:
9064 if (!gfc_add_save (&sym->attr, SAVE_EXPLICIT, sym->name,
9065 &gfc_current_locus))
9066 return MATCH_ERROR;
9067 goto next_item;
9069 case MATCH_NO:
9070 break;
9072 case MATCH_ERROR:
9073 return MATCH_ERROR;
9076 m = gfc_match (" / %n /", &n);
9077 if (m == MATCH_ERROR)
9078 return MATCH_ERROR;
9079 if (m == MATCH_NO)
9080 goto syntax;
9082 c = gfc_get_common (n, 0);
9083 c->saved = 1;
9085 gfc_current_ns->seen_save = 1;
9087 next_item:
9088 if (gfc_match_eos () == MATCH_YES)
9089 break;
9090 if (gfc_match_char (',') != MATCH_YES)
9091 goto syntax;
9094 return MATCH_YES;
9096 syntax:
9097 gfc_error ("Syntax error in SAVE statement at %C");
9098 return MATCH_ERROR;
9102 match
9103 gfc_match_value (void)
9105 gfc_symbol *sym;
9106 match m;
9108 /* This is not allowed within a BLOCK construct! */
9109 if (gfc_current_state () == COMP_BLOCK)
9111 gfc_error ("VALUE is not allowed inside of BLOCK at %C");
9112 return MATCH_ERROR;
9115 if (!gfc_notify_std (GFC_STD_F2003, "VALUE statement at %C"))
9116 return MATCH_ERROR;
9118 if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
9120 return MATCH_ERROR;
9123 if (gfc_match_eos () == MATCH_YES)
9124 goto syntax;
9126 for(;;)
9128 m = gfc_match_symbol (&sym, 0);
9129 switch (m)
9131 case MATCH_YES:
9132 if (!gfc_add_value (&sym->attr, sym->name, &gfc_current_locus))
9133 return MATCH_ERROR;
9134 goto next_item;
9136 case MATCH_NO:
9137 break;
9139 case MATCH_ERROR:
9140 return MATCH_ERROR;
9143 next_item:
9144 if (gfc_match_eos () == MATCH_YES)
9145 break;
9146 if (gfc_match_char (',') != MATCH_YES)
9147 goto syntax;
9150 return MATCH_YES;
9152 syntax:
9153 gfc_error ("Syntax error in VALUE statement at %C");
9154 return MATCH_ERROR;
9158 match
9159 gfc_match_volatile (void)
9161 gfc_symbol *sym;
9162 char *name;
9163 match m;
9165 if (!gfc_notify_std (GFC_STD_F2003, "VOLATILE statement at %C"))
9166 return MATCH_ERROR;
9168 if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
9170 return MATCH_ERROR;
9173 if (gfc_match_eos () == MATCH_YES)
9174 goto syntax;
9176 for(;;)
9178 /* VOLATILE is special because it can be added to host-associated
9179 symbols locally. Except for coarrays. */
9180 m = gfc_match_symbol (&sym, 1);
9181 switch (m)
9183 case MATCH_YES:
9184 name = XCNEWVAR (char, strlen (sym->name) + 1);
9185 strcpy (name, sym->name);
9186 if (!check_function_name (name))
9187 return MATCH_ERROR;
9188 /* F2008, C560+C561. VOLATILE for host-/use-associated variable or
9189 for variable in a BLOCK which is defined outside of the BLOCK. */
9190 if (sym->ns != gfc_current_ns && sym->attr.codimension)
9192 gfc_error ("Specifying VOLATILE for coarray variable %qs at "
9193 "%C, which is use-/host-associated", sym->name);
9194 return MATCH_ERROR;
9196 if (!gfc_add_volatile (&sym->attr, sym->name, &gfc_current_locus))
9197 return MATCH_ERROR;
9198 goto next_item;
9200 case MATCH_NO:
9201 break;
9203 case MATCH_ERROR:
9204 return MATCH_ERROR;
9207 next_item:
9208 if (gfc_match_eos () == MATCH_YES)
9209 break;
9210 if (gfc_match_char (',') != MATCH_YES)
9211 goto syntax;
9214 return MATCH_YES;
9216 syntax:
9217 gfc_error ("Syntax error in VOLATILE statement at %C");
9218 return MATCH_ERROR;
9222 match
9223 gfc_match_asynchronous (void)
9225 gfc_symbol *sym;
9226 char *name;
9227 match m;
9229 if (!gfc_notify_std (GFC_STD_F2003, "ASYNCHRONOUS statement at %C"))
9230 return MATCH_ERROR;
9232 if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
9234 return MATCH_ERROR;
9237 if (gfc_match_eos () == MATCH_YES)
9238 goto syntax;
9240 for(;;)
9242 /* ASYNCHRONOUS is special because it can be added to host-associated
9243 symbols locally. */
9244 m = gfc_match_symbol (&sym, 1);
9245 switch (m)
9247 case MATCH_YES:
9248 name = XCNEWVAR (char, strlen (sym->name) + 1);
9249 strcpy (name, sym->name);
9250 if (!check_function_name (name))
9251 return MATCH_ERROR;
9252 if (!gfc_add_asynchronous (&sym->attr, sym->name, &gfc_current_locus))
9253 return MATCH_ERROR;
9254 goto next_item;
9256 case MATCH_NO:
9257 break;
9259 case MATCH_ERROR:
9260 return MATCH_ERROR;
9263 next_item:
9264 if (gfc_match_eos () == MATCH_YES)
9265 break;
9266 if (gfc_match_char (',') != MATCH_YES)
9267 goto syntax;
9270 return MATCH_YES;
9272 syntax:
9273 gfc_error ("Syntax error in ASYNCHRONOUS statement at %C");
9274 return MATCH_ERROR;
9278 /* Match a module procedure statement in a submodule. */
9280 match
9281 gfc_match_submod_proc (void)
9283 char name[GFC_MAX_SYMBOL_LEN + 1];
9284 gfc_symbol *sym, *fsym;
9285 match m;
9286 gfc_formal_arglist *formal, *head, *tail;
9288 if (gfc_current_state () != COMP_CONTAINS
9289 || !(gfc_state_stack->previous
9290 && (gfc_state_stack->previous->state == COMP_SUBMODULE
9291 || gfc_state_stack->previous->state == COMP_MODULE)))
9292 return MATCH_NO;
9294 m = gfc_match (" module% procedure% %n", name);
9295 if (m != MATCH_YES)
9296 return m;
9298 if (!gfc_notify_std (GFC_STD_F2008, "MODULE PROCEDURE declaration "
9299 "at %C"))
9300 return MATCH_ERROR;
9302 if (get_proc_name (name, &sym, false))
9303 return MATCH_ERROR;
9305 /* Make sure that the result field is appropriately filled, even though
9306 the result symbol will be replaced later on. */
9307 if (sym->tlink && sym->tlink->attr.function)
9309 if (sym->tlink->result
9310 && sym->tlink->result != sym->tlink)
9311 sym->result= sym->tlink->result;
9312 else
9313 sym->result = sym;
9316 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
9317 the symbol existed before. */
9318 sym->declared_at = gfc_current_locus;
9320 if (!sym->attr.module_procedure)
9321 return MATCH_ERROR;
9323 /* Signal match_end to expect "end procedure". */
9324 sym->abr_modproc_decl = 1;
9326 /* Change from IFSRC_IFBODY coming from the interface declaration. */
9327 sym->attr.if_source = IFSRC_DECL;
9329 gfc_new_block = sym;
9331 /* Make a new formal arglist with the symbols in the procedure
9332 namespace. */
9333 head = tail = NULL;
9334 for (formal = sym->formal; formal && formal->sym; formal = formal->next)
9336 if (formal == sym->formal)
9337 head = tail = gfc_get_formal_arglist ();
9338 else
9340 tail->next = gfc_get_formal_arglist ();
9341 tail = tail->next;
9344 if (gfc_copy_dummy_sym (&fsym, formal->sym, 0))
9345 goto cleanup;
9347 tail->sym = fsym;
9348 gfc_set_sym_referenced (fsym);
9351 /* The dummy symbols get cleaned up, when the formal_namespace of the
9352 interface declaration is cleared. This allows us to add the
9353 explicit interface as is done for other type of procedure. */
9354 if (!gfc_add_explicit_interface (sym, IFSRC_DECL, head,
9355 &gfc_current_locus))
9356 return MATCH_ERROR;
9358 if (gfc_match_eos () != MATCH_YES)
9360 gfc_syntax_error (ST_MODULE_PROC);
9361 return MATCH_ERROR;
9364 return MATCH_YES;
9366 cleanup:
9367 gfc_free_formal_arglist (head);
9368 return MATCH_ERROR;
9372 /* Match a module procedure statement. Note that we have to modify
9373 symbols in the parent's namespace because the current one was there
9374 to receive symbols that are in an interface's formal argument list. */
9376 match
9377 gfc_match_modproc (void)
9379 char name[GFC_MAX_SYMBOL_LEN + 1];
9380 gfc_symbol *sym;
9381 match m;
9382 locus old_locus;
9383 gfc_namespace *module_ns;
9384 gfc_interface *old_interface_head, *interface;
9386 if (gfc_state_stack->state != COMP_INTERFACE
9387 || gfc_state_stack->previous == NULL
9388 || current_interface.type == INTERFACE_NAMELESS
9389 || current_interface.type == INTERFACE_ABSTRACT)
9391 gfc_error ("MODULE PROCEDURE at %C must be in a generic module "
9392 "interface");
9393 return MATCH_ERROR;
9396 module_ns = gfc_current_ns->parent;
9397 for (; module_ns; module_ns = module_ns->parent)
9398 if (module_ns->proc_name->attr.flavor == FL_MODULE
9399 || module_ns->proc_name->attr.flavor == FL_PROGRAM
9400 || (module_ns->proc_name->attr.flavor == FL_PROCEDURE
9401 && !module_ns->proc_name->attr.contained))
9402 break;
9404 if (module_ns == NULL)
9405 return MATCH_ERROR;
9407 /* Store the current state of the interface. We will need it if we
9408 end up with a syntax error and need to recover. */
9409 old_interface_head = gfc_current_interface_head ();
9411 /* Check if the F2008 optional double colon appears. */
9412 gfc_gobble_whitespace ();
9413 old_locus = gfc_current_locus;
9414 if (gfc_match ("::") == MATCH_YES)
9416 if (!gfc_notify_std (GFC_STD_F2008, "double colon in "
9417 "MODULE PROCEDURE statement at %L", &old_locus))
9418 return MATCH_ERROR;
9420 else
9421 gfc_current_locus = old_locus;
9423 for (;;)
9425 bool last = false;
9426 old_locus = gfc_current_locus;
9428 m = gfc_match_name (name);
9429 if (m == MATCH_NO)
9430 goto syntax;
9431 if (m != MATCH_YES)
9432 return MATCH_ERROR;
9434 /* Check for syntax error before starting to add symbols to the
9435 current namespace. */
9436 if (gfc_match_eos () == MATCH_YES)
9437 last = true;
9439 if (!last && gfc_match_char (',') != MATCH_YES)
9440 goto syntax;
9442 /* Now we're sure the syntax is valid, we process this item
9443 further. */
9444 if (gfc_get_symbol (name, module_ns, &sym))
9445 return MATCH_ERROR;
9447 if (sym->attr.intrinsic)
9449 gfc_error ("Intrinsic procedure at %L cannot be a MODULE "
9450 "PROCEDURE", &old_locus);
9451 return MATCH_ERROR;
9454 if (sym->attr.proc != PROC_MODULE
9455 && !gfc_add_procedure (&sym->attr, PROC_MODULE, sym->name, NULL))
9456 return MATCH_ERROR;
9458 if (!gfc_add_interface (sym))
9459 return MATCH_ERROR;
9461 sym->attr.mod_proc = 1;
9462 sym->declared_at = old_locus;
9464 if (last)
9465 break;
9468 return MATCH_YES;
9470 syntax:
9471 /* Restore the previous state of the interface. */
9472 interface = gfc_current_interface_head ();
9473 gfc_set_current_interface_head (old_interface_head);
9475 /* Free the new interfaces. */
9476 while (interface != old_interface_head)
9478 gfc_interface *i = interface->next;
9479 free (interface);
9480 interface = i;
9483 /* And issue a syntax error. */
9484 gfc_syntax_error (ST_MODULE_PROC);
9485 return MATCH_ERROR;
9489 /* Check a derived type that is being extended. */
9491 static gfc_symbol*
9492 check_extended_derived_type (char *name)
9494 gfc_symbol *extended;
9496 if (gfc_find_symbol (name, gfc_current_ns, 1, &extended))
9498 gfc_error ("Ambiguous symbol in TYPE definition at %C");
9499 return NULL;
9502 extended = gfc_find_dt_in_generic (extended);
9504 /* F08:C428. */
9505 if (!extended)
9507 gfc_error ("Symbol %qs at %C has not been previously defined", name);
9508 return NULL;
9511 if (extended->attr.flavor != FL_DERIVED)
9513 gfc_error ("%qs in EXTENDS expression at %C is not a "
9514 "derived type", name);
9515 return NULL;
9518 if (extended->attr.is_bind_c)
9520 gfc_error ("%qs cannot be extended at %C because it "
9521 "is BIND(C)", extended->name);
9522 return NULL;
9525 if (extended->attr.sequence)
9527 gfc_error ("%qs cannot be extended at %C because it "
9528 "is a SEQUENCE type", extended->name);
9529 return NULL;
9532 return extended;
9536 /* Match the optional attribute specifiers for a type declaration.
9537 Return MATCH_ERROR if an error is encountered in one of the handled
9538 attributes (public, private, bind(c)), MATCH_NO if what's found is
9539 not a handled attribute, and MATCH_YES otherwise. TODO: More error
9540 checking on attribute conflicts needs to be done. */
9542 match
9543 gfc_get_type_attr_spec (symbol_attribute *attr, char *name)
9545 /* See if the derived type is marked as private. */
9546 if (gfc_match (" , private") == MATCH_YES)
9548 if (gfc_current_state () != COMP_MODULE)
9550 gfc_error ("Derived type at %C can only be PRIVATE in the "
9551 "specification part of a module");
9552 return MATCH_ERROR;
9555 if (!gfc_add_access (attr, ACCESS_PRIVATE, NULL, NULL))
9556 return MATCH_ERROR;
9558 else if (gfc_match (" , public") == MATCH_YES)
9560 if (gfc_current_state () != COMP_MODULE)
9562 gfc_error ("Derived type at %C can only be PUBLIC in the "
9563 "specification part of a module");
9564 return MATCH_ERROR;
9567 if (!gfc_add_access (attr, ACCESS_PUBLIC, NULL, NULL))
9568 return MATCH_ERROR;
9570 else if (gfc_match (" , bind ( c )") == MATCH_YES)
9572 /* If the type is defined to be bind(c) it then needs to make
9573 sure that all fields are interoperable. This will
9574 need to be a semantic check on the finished derived type.
9575 See 15.2.3 (lines 9-12) of F2003 draft. */
9576 if (!gfc_add_is_bind_c (attr, NULL, &gfc_current_locus, 0))
9577 return MATCH_ERROR;
9579 /* TODO: attr conflicts need to be checked, probably in symbol.c. */
9581 else if (gfc_match (" , abstract") == MATCH_YES)
9583 if (!gfc_notify_std (GFC_STD_F2003, "ABSTRACT type at %C"))
9584 return MATCH_ERROR;
9586 if (!gfc_add_abstract (attr, &gfc_current_locus))
9587 return MATCH_ERROR;
9589 else if (name && gfc_match (" , extends ( %n )", name) == MATCH_YES)
9591 if (!gfc_add_extension (attr, &gfc_current_locus))
9592 return MATCH_ERROR;
9594 else
9595 return MATCH_NO;
9597 /* If we get here, something matched. */
9598 return MATCH_YES;
9602 /* Common function for type declaration blocks similar to derived types, such
9603 as STRUCTURES and MAPs. Unlike derived types, a structure type
9604 does NOT have a generic symbol matching the name given by the user.
9605 STRUCTUREs can share names with variables and PARAMETERs so we must allow
9606 for the creation of an independent symbol.
9607 Other parameters are a message to prefix errors with, the name of the new
9608 type to be created, and the flavor to add to the resulting symbol. */
9610 static bool
9611 get_struct_decl (const char *name, sym_flavor fl, locus *decl,
9612 gfc_symbol **result)
9614 gfc_symbol *sym;
9615 locus where;
9617 gcc_assert (name[0] == (char) TOUPPER (name[0]));
9619 if (decl)
9620 where = *decl;
9621 else
9622 where = gfc_current_locus;
9624 if (gfc_get_symbol (name, NULL, &sym))
9625 return false;
9627 if (!sym)
9629 gfc_internal_error ("Failed to create structure type '%s' at %C", name);
9630 return false;
9633 if (sym->components != NULL || sym->attr.zero_comp)
9635 gfc_error ("Type definition of %qs at %C was already defined at %L",
9636 sym->name, &sym->declared_at);
9637 return false;
9640 sym->declared_at = where;
9642 if (sym->attr.flavor != fl
9643 && !gfc_add_flavor (&sym->attr, fl, sym->name, NULL))
9644 return false;
9646 if (!sym->hash_value)
9647 /* Set the hash for the compound name for this type. */
9648 sym->hash_value = gfc_hash_value (sym);
9650 /* Normally the type is expected to have been completely parsed by the time
9651 a field declaration with this type is seen. For unions, maps, and nested
9652 structure declarations, we need to indicate that it is okay that we
9653 haven't seen any components yet. This will be updated after the structure
9654 is fully parsed. */
9655 sym->attr.zero_comp = 0;
9657 /* Structures always act like derived-types with the SEQUENCE attribute */
9658 gfc_add_sequence (&sym->attr, sym->name, NULL);
9660 if (result) *result = sym;
9662 return true;
9666 /* Match the opening of a MAP block. Like a struct within a union in C;
9667 behaves identical to STRUCTURE blocks. */
9669 match
9670 gfc_match_map (void)
9672 /* Counter used to give unique internal names to map structures. */
9673 static unsigned int gfc_map_id = 0;
9674 char name[GFC_MAX_SYMBOL_LEN + 1];
9675 gfc_symbol *sym;
9676 locus old_loc;
9678 old_loc = gfc_current_locus;
9680 if (gfc_match_eos () != MATCH_YES)
9682 gfc_error ("Junk after MAP statement at %C");
9683 gfc_current_locus = old_loc;
9684 return MATCH_ERROR;
9687 /* Map blocks are anonymous so we make up unique names for the symbol table
9688 which are invalid Fortran identifiers. */
9689 snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "MM$%u", gfc_map_id++);
9691 if (!get_struct_decl (name, FL_STRUCT, &old_loc, &sym))
9692 return MATCH_ERROR;
9694 gfc_new_block = sym;
9696 return MATCH_YES;
9700 /* Match the opening of a UNION block. */
9702 match
9703 gfc_match_union (void)
9705 /* Counter used to give unique internal names to union types. */
9706 static unsigned int gfc_union_id = 0;
9707 char name[GFC_MAX_SYMBOL_LEN + 1];
9708 gfc_symbol *sym;
9709 locus old_loc;
9711 old_loc = gfc_current_locus;
9713 if (gfc_match_eos () != MATCH_YES)
9715 gfc_error ("Junk after UNION statement at %C");
9716 gfc_current_locus = old_loc;
9717 return MATCH_ERROR;
9720 /* Unions are anonymous so we make up unique names for the symbol table
9721 which are invalid Fortran identifiers. */
9722 snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "UU$%u", gfc_union_id++);
9724 if (!get_struct_decl (name, FL_UNION, &old_loc, &sym))
9725 return MATCH_ERROR;
9727 gfc_new_block = sym;
9729 return MATCH_YES;
9733 /* Match the beginning of a STRUCTURE declaration. This is similar to
9734 matching the beginning of a derived type declaration with a few
9735 twists. The resulting type symbol has no access control or other
9736 interesting attributes. */
9738 match
9739 gfc_match_structure_decl (void)
9741 /* Counter used to give unique internal names to anonymous structures. */
9742 static unsigned int gfc_structure_id = 0;
9743 char name[GFC_MAX_SYMBOL_LEN + 1];
9744 gfc_symbol *sym;
9745 match m;
9746 locus where;
9748 if (!flag_dec_structure)
9750 gfc_error ("%s at %C is a DEC extension, enable with "
9751 "%<-fdec-structure%>",
9752 "STRUCTURE");
9753 return MATCH_ERROR;
9756 name[0] = '\0';
9758 m = gfc_match (" /%n/", name);
9759 if (m != MATCH_YES)
9761 /* Non-nested structure declarations require a structure name. */
9762 if (!gfc_comp_struct (gfc_current_state ()))
9764 gfc_error ("Structure name expected in non-nested structure "
9765 "declaration at %C");
9766 return MATCH_ERROR;
9768 /* This is an anonymous structure; make up a unique name for it
9769 (upper-case letters never make it to symbol names from the source).
9770 The important thing is initializing the type variable
9771 and setting gfc_new_symbol, which is immediately used by
9772 parse_structure () and variable_decl () to add components of
9773 this type. */
9774 snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "SS$%u", gfc_structure_id++);
9777 where = gfc_current_locus;
9778 /* No field list allowed after non-nested structure declaration. */
9779 if (!gfc_comp_struct (gfc_current_state ())
9780 && gfc_match_eos () != MATCH_YES)
9782 gfc_error ("Junk after non-nested STRUCTURE statement at %C");
9783 return MATCH_ERROR;
9786 /* Make sure the name is not the name of an intrinsic type. */
9787 if (gfc_is_intrinsic_typename (name))
9789 gfc_error ("Structure name %qs at %C cannot be the same as an"
9790 " intrinsic type", name);
9791 return MATCH_ERROR;
9794 /* Store the actual type symbol for the structure with an upper-case first
9795 letter (an invalid Fortran identifier). */
9797 if (!get_struct_decl (gfc_dt_upper_string (name), FL_STRUCT, &where, &sym))
9798 return MATCH_ERROR;
9800 gfc_new_block = sym;
9801 return MATCH_YES;
9805 /* This function does some work to determine which matcher should be used to
9806 * match a statement beginning with "TYPE". This is used to disambiguate TYPE
9807 * as an alias for PRINT from derived type declarations, TYPE IS statements,
9808 * and [parameterized] derived type declarations. */
9810 match
9811 gfc_match_type (gfc_statement *st)
9813 char name[GFC_MAX_SYMBOL_LEN + 1];
9814 match m;
9815 locus old_loc;
9817 /* Requires -fdec. */
9818 if (!flag_dec)
9819 return MATCH_NO;
9821 m = gfc_match ("type");
9822 if (m != MATCH_YES)
9823 return m;
9824 /* If we already have an error in the buffer, it is probably from failing to
9825 * match a derived type data declaration. Let it happen. */
9826 else if (gfc_error_flag_test ())
9827 return MATCH_NO;
9829 old_loc = gfc_current_locus;
9830 *st = ST_NONE;
9832 /* If we see an attribute list before anything else it's definitely a derived
9833 * type declaration. */
9834 if (gfc_match (" ,") == MATCH_YES || gfc_match (" ::") == MATCH_YES)
9835 goto derived;
9837 /* By now "TYPE" has already been matched. If we do not see a name, this may
9838 * be something like "TYPE *" or "TYPE <fmt>". */
9839 m = gfc_match_name (name);
9840 if (m != MATCH_YES)
9842 /* Let print match if it can, otherwise throw an error from
9843 * gfc_match_derived_decl. */
9844 gfc_current_locus = old_loc;
9845 if (gfc_match_print () == MATCH_YES)
9847 *st = ST_WRITE;
9848 return MATCH_YES;
9850 goto derived;
9853 /* Check for EOS. */
9854 if (gfc_match_eos () == MATCH_YES)
9856 /* By now we have "TYPE <name> <EOS>". Check first if the name is an
9857 * intrinsic typename - if so let gfc_match_derived_decl dump an error.
9858 * Otherwise if gfc_match_derived_decl fails it's probably an existing
9859 * symbol which can be printed. */
9860 gfc_current_locus = old_loc;
9861 m = gfc_match_derived_decl ();
9862 if (gfc_is_intrinsic_typename (name) || m == MATCH_YES)
9864 *st = ST_DERIVED_DECL;
9865 return m;
9868 else
9870 /* Here we have "TYPE <name>". Check for <TYPE IS (> or a PDT declaration
9871 like <type name(parameter)>. */
9872 gfc_gobble_whitespace ();
9873 bool paren = gfc_peek_ascii_char () == '(';
9874 if (paren)
9876 if (strcmp ("is", name) == 0)
9877 goto typeis;
9878 else
9879 goto derived;
9883 /* Treat TYPE... like PRINT... */
9884 gfc_current_locus = old_loc;
9885 *st = ST_WRITE;
9886 return gfc_match_print ();
9888 derived:
9889 gfc_current_locus = old_loc;
9890 *st = ST_DERIVED_DECL;
9891 return gfc_match_derived_decl ();
9893 typeis:
9894 gfc_current_locus = old_loc;
9895 *st = ST_TYPE_IS;
9896 return gfc_match_type_is ();
9900 /* Match the beginning of a derived type declaration. If a type name
9901 was the result of a function, then it is possible to have a symbol
9902 already to be known as a derived type yet have no components. */
9904 match
9905 gfc_match_derived_decl (void)
9907 char name[GFC_MAX_SYMBOL_LEN + 1];
9908 char parent[GFC_MAX_SYMBOL_LEN + 1];
9909 symbol_attribute attr;
9910 gfc_symbol *sym, *gensym;
9911 gfc_symbol *extended;
9912 match m;
9913 match is_type_attr_spec = MATCH_NO;
9914 bool seen_attr = false;
9915 gfc_interface *intr = NULL, *head;
9916 bool parameterized_type = false;
9917 bool seen_colons = false;
9919 if (gfc_comp_struct (gfc_current_state ()))
9920 return MATCH_NO;
9922 name[0] = '\0';
9923 parent[0] = '\0';
9924 gfc_clear_attr (&attr);
9925 extended = NULL;
9929 is_type_attr_spec = gfc_get_type_attr_spec (&attr, parent);
9930 if (is_type_attr_spec == MATCH_ERROR)
9931 return MATCH_ERROR;
9932 if (is_type_attr_spec == MATCH_YES)
9933 seen_attr = true;
9934 } while (is_type_attr_spec == MATCH_YES);
9936 /* Deal with derived type extensions. The extension attribute has
9937 been added to 'attr' but now the parent type must be found and
9938 checked. */
9939 if (parent[0])
9940 extended = check_extended_derived_type (parent);
9942 if (parent[0] && !extended)
9943 return MATCH_ERROR;
9945 m = gfc_match (" ::");
9946 if (m == MATCH_YES)
9948 seen_colons = true;
9950 else if (seen_attr)
9952 gfc_error ("Expected :: in TYPE definition at %C");
9953 return MATCH_ERROR;
9956 m = gfc_match (" %n ", name);
9957 if (m != MATCH_YES)
9958 return m;
9960 /* Make sure that we don't identify TYPE IS (...) as a parameterized
9961 derived type named 'is'.
9962 TODO Expand the check, when 'name' = "is" by matching " (tname) "
9963 and checking if this is a(n intrinsic) typename. his picks up
9964 misplaced TYPE IS statements such as in select_type_1.f03. */
9965 if (gfc_peek_ascii_char () == '(')
9967 if (gfc_current_state () == COMP_SELECT_TYPE
9968 || (!seen_colons && !strcmp (name, "is")))
9969 return MATCH_NO;
9970 parameterized_type = true;
9973 m = gfc_match_eos ();
9974 if (m != MATCH_YES && !parameterized_type)
9975 return m;
9977 /* Make sure the name is not the name of an intrinsic type. */
9978 if (gfc_is_intrinsic_typename (name))
9980 gfc_error ("Type name %qs at %C cannot be the same as an intrinsic "
9981 "type", name);
9982 return MATCH_ERROR;
9985 if (gfc_get_symbol (name, NULL, &gensym))
9986 return MATCH_ERROR;
9988 if (!gensym->attr.generic && gensym->ts.type != BT_UNKNOWN)
9990 if (gensym->ts.u.derived)
9991 gfc_error ("Derived type name %qs at %C already has a basic type "
9992 "of %s", gensym->name, gfc_typename (&gensym->ts));
9993 else
9994 gfc_error ("Derived type name %qs at %C already has a basic type",
9995 gensym->name);
9996 return MATCH_ERROR;
9999 if (!gensym->attr.generic
10000 && !gfc_add_generic (&gensym->attr, gensym->name, NULL))
10001 return MATCH_ERROR;
10003 if (!gensym->attr.function
10004 && !gfc_add_function (&gensym->attr, gensym->name, NULL))
10005 return MATCH_ERROR;
10007 sym = gfc_find_dt_in_generic (gensym);
10009 if (sym && (sym->components != NULL || sym->attr.zero_comp))
10011 gfc_error ("Derived type definition of %qs at %C has already been "
10012 "defined", sym->name);
10013 return MATCH_ERROR;
10016 if (!sym)
10018 /* Use upper case to save the actual derived-type symbol. */
10019 gfc_get_symbol (gfc_dt_upper_string (gensym->name), NULL, &sym);
10020 sym->name = gfc_get_string ("%s", gensym->name);
10021 head = gensym->generic;
10022 intr = gfc_get_interface ();
10023 intr->sym = sym;
10024 intr->where = gfc_current_locus;
10025 intr->sym->declared_at = gfc_current_locus;
10026 intr->next = head;
10027 gensym->generic = intr;
10028 gensym->attr.if_source = IFSRC_DECL;
10031 /* The symbol may already have the derived attribute without the
10032 components. The ways this can happen is via a function
10033 definition, an INTRINSIC statement or a subtype in another
10034 derived type that is a pointer. The first part of the AND clause
10035 is true if the symbol is not the return value of a function. */
10036 if (sym->attr.flavor != FL_DERIVED
10037 && !gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL))
10038 return MATCH_ERROR;
10040 if (attr.access != ACCESS_UNKNOWN
10041 && !gfc_add_access (&sym->attr, attr.access, sym->name, NULL))
10042 return MATCH_ERROR;
10043 else if (sym->attr.access == ACCESS_UNKNOWN
10044 && gensym->attr.access != ACCESS_UNKNOWN
10045 && !gfc_add_access (&sym->attr, gensym->attr.access,
10046 sym->name, NULL))
10047 return MATCH_ERROR;
10049 if (sym->attr.access != ACCESS_UNKNOWN
10050 && gensym->attr.access == ACCESS_UNKNOWN)
10051 gensym->attr.access = sym->attr.access;
10053 /* See if the derived type was labeled as bind(c). */
10054 if (attr.is_bind_c != 0)
10055 sym->attr.is_bind_c = attr.is_bind_c;
10057 /* Construct the f2k_derived namespace if it is not yet there. */
10058 if (!sym->f2k_derived)
10059 sym->f2k_derived = gfc_get_namespace (NULL, 0);
10061 if (parameterized_type)
10063 /* Ignore error or mismatches by going to the end of the statement
10064 in order to avoid the component declarations causing problems. */
10065 m = gfc_match_formal_arglist (sym, 0, 0, true);
10066 if (m != MATCH_YES)
10067 gfc_error_recovery ();
10068 m = gfc_match_eos ();
10069 if (m != MATCH_YES)
10071 gfc_error_recovery ();
10072 gfc_error_now ("Garbage after PARAMETERIZED TYPE declaration at %C");
10074 sym->attr.pdt_template = 1;
10077 if (extended && !sym->components)
10079 gfc_component *p;
10080 gfc_formal_arglist *f, *g, *h;
10082 /* Add the extended derived type as the first component. */
10083 gfc_add_component (sym, parent, &p);
10084 extended->refs++;
10085 gfc_set_sym_referenced (extended);
10087 p->ts.type = BT_DERIVED;
10088 p->ts.u.derived = extended;
10089 p->initializer = gfc_default_initializer (&p->ts);
10091 /* Set extension level. */
10092 if (extended->attr.extension == 255)
10094 /* Since the extension field is 8 bit wide, we can only have
10095 up to 255 extension levels. */
10096 gfc_error ("Maximum extension level reached with type %qs at %L",
10097 extended->name, &extended->declared_at);
10098 return MATCH_ERROR;
10100 sym->attr.extension = extended->attr.extension + 1;
10102 /* Provide the links between the extended type and its extension. */
10103 if (!extended->f2k_derived)
10104 extended->f2k_derived = gfc_get_namespace (NULL, 0);
10106 /* Copy the extended type-param-name-list from the extended type,
10107 append those of the extension and add the whole lot to the
10108 extension. */
10109 if (extended->attr.pdt_template)
10111 g = h = NULL;
10112 sym->attr.pdt_template = 1;
10113 for (f = extended->formal; f; f = f->next)
10115 if (f == extended->formal)
10117 g = gfc_get_formal_arglist ();
10118 h = g;
10120 else
10122 g->next = gfc_get_formal_arglist ();
10123 g = g->next;
10125 g->sym = f->sym;
10127 g->next = sym->formal;
10128 sym->formal = h;
10132 if (!sym->hash_value)
10133 /* Set the hash for the compound name for this type. */
10134 sym->hash_value = gfc_hash_value (sym);
10136 /* Take over the ABSTRACT attribute. */
10137 sym->attr.abstract = attr.abstract;
10139 gfc_new_block = sym;
10141 return MATCH_YES;
10145 /* Cray Pointees can be declared as:
10146 pointer (ipt, a (n,m,...,*)) */
10148 match
10149 gfc_mod_pointee_as (gfc_array_spec *as)
10151 as->cray_pointee = true; /* This will be useful to know later. */
10152 if (as->type == AS_ASSUMED_SIZE)
10153 as->cp_was_assumed = true;
10154 else if (as->type == AS_ASSUMED_SHAPE)
10156 gfc_error ("Cray Pointee at %C cannot be assumed shape array");
10157 return MATCH_ERROR;
10159 return MATCH_YES;
10163 /* Match the enum definition statement, here we are trying to match
10164 the first line of enum definition statement.
10165 Returns MATCH_YES if match is found. */
10167 match
10168 gfc_match_enum (void)
10170 match m;
10172 m = gfc_match_eos ();
10173 if (m != MATCH_YES)
10174 return m;
10176 if (!gfc_notify_std (GFC_STD_F2003, "ENUM and ENUMERATOR at %C"))
10177 return MATCH_ERROR;
10179 return MATCH_YES;
10183 /* Returns an initializer whose value is one higher than the value of the
10184 LAST_INITIALIZER argument. If the argument is NULL, the
10185 initializers value will be set to zero. The initializer's kind
10186 will be set to gfc_c_int_kind.
10188 If -fshort-enums is given, the appropriate kind will be selected
10189 later after all enumerators have been parsed. A warning is issued
10190 here if an initializer exceeds gfc_c_int_kind. */
10192 static gfc_expr *
10193 enum_initializer (gfc_expr *last_initializer, locus where)
10195 gfc_expr *result;
10196 result = gfc_get_constant_expr (BT_INTEGER, gfc_c_int_kind, &where);
10198 mpz_init (result->value.integer);
10200 if (last_initializer != NULL)
10202 mpz_add_ui (result->value.integer, last_initializer->value.integer, 1);
10203 result->where = last_initializer->where;
10205 if (gfc_check_integer_range (result->value.integer,
10206 gfc_c_int_kind) != ARITH_OK)
10208 gfc_error ("Enumerator exceeds the C integer type at %C");
10209 return NULL;
10212 else
10214 /* Control comes here, if it's the very first enumerator and no
10215 initializer has been given. It will be initialized to zero. */
10216 mpz_set_si (result->value.integer, 0);
10219 return result;
10223 /* Match a variable name with an optional initializer. When this
10224 subroutine is called, a variable is expected to be parsed next.
10225 Depending on what is happening at the moment, updates either the
10226 symbol table or the current interface. */
10228 static match
10229 enumerator_decl (void)
10231 char name[GFC_MAX_SYMBOL_LEN + 1];
10232 gfc_expr *initializer;
10233 gfc_array_spec *as = NULL;
10234 gfc_symbol *sym;
10235 locus var_locus;
10236 match m;
10237 bool t;
10238 locus old_locus;
10240 initializer = NULL;
10241 old_locus = gfc_current_locus;
10243 /* When we get here, we've just matched a list of attributes and
10244 maybe a type and a double colon. The next thing we expect to see
10245 is the name of the symbol. */
10246 m = gfc_match_name (name);
10247 if (m != MATCH_YES)
10248 goto cleanup;
10250 var_locus = gfc_current_locus;
10252 /* OK, we've successfully matched the declaration. Now put the
10253 symbol in the current namespace. If we fail to create the symbol,
10254 bail out. */
10255 if (!build_sym (name, NULL, false, &as, &var_locus))
10257 m = MATCH_ERROR;
10258 goto cleanup;
10261 /* The double colon must be present in order to have initializers.
10262 Otherwise the statement is ambiguous with an assignment statement. */
10263 if (colon_seen)
10265 if (gfc_match_char ('=') == MATCH_YES)
10267 m = gfc_match_init_expr (&initializer);
10268 if (m == MATCH_NO)
10270 gfc_error ("Expected an initialization expression at %C");
10271 m = MATCH_ERROR;
10274 if (m != MATCH_YES)
10275 goto cleanup;
10279 /* If we do not have an initializer, the initialization value of the
10280 previous enumerator (stored in last_initializer) is incremented
10281 by 1 and is used to initialize the current enumerator. */
10282 if (initializer == NULL)
10283 initializer = enum_initializer (last_initializer, old_locus);
10285 if (initializer == NULL || initializer->ts.type != BT_INTEGER)
10287 gfc_error ("ENUMERATOR %L not initialized with integer expression",
10288 &var_locus);
10289 m = MATCH_ERROR;
10290 goto cleanup;
10293 /* Store this current initializer, for the next enumerator variable
10294 to be parsed. add_init_expr_to_sym() zeros initializer, so we
10295 use last_initializer below. */
10296 last_initializer = initializer;
10297 t = add_init_expr_to_sym (name, &initializer, &var_locus);
10299 /* Maintain enumerator history. */
10300 gfc_find_symbol (name, NULL, 0, &sym);
10301 create_enum_history (sym, last_initializer);
10303 return (t) ? MATCH_YES : MATCH_ERROR;
10305 cleanup:
10306 /* Free stuff up and return. */
10307 gfc_free_expr (initializer);
10309 return m;
10313 /* Match the enumerator definition statement. */
10315 match
10316 gfc_match_enumerator_def (void)
10318 match m;
10319 bool t;
10321 gfc_clear_ts (&current_ts);
10323 m = gfc_match (" enumerator");
10324 if (m != MATCH_YES)
10325 return m;
10327 m = gfc_match (" :: ");
10328 if (m == MATCH_ERROR)
10329 return m;
10331 colon_seen = (m == MATCH_YES);
10333 if (gfc_current_state () != COMP_ENUM)
10335 gfc_error ("ENUM definition statement expected before %C");
10336 gfc_free_enum_history ();
10337 return MATCH_ERROR;
10340 (&current_ts)->type = BT_INTEGER;
10341 (&current_ts)->kind = gfc_c_int_kind;
10343 gfc_clear_attr (&current_attr);
10344 t = gfc_add_flavor (&current_attr, FL_PARAMETER, NULL, NULL);
10345 if (!t)
10347 m = MATCH_ERROR;
10348 goto cleanup;
10351 for (;;)
10353 m = enumerator_decl ();
10354 if (m == MATCH_ERROR)
10356 gfc_free_enum_history ();
10357 goto cleanup;
10359 if (m == MATCH_NO)
10360 break;
10362 if (gfc_match_eos () == MATCH_YES)
10363 goto cleanup;
10364 if (gfc_match_char (',') != MATCH_YES)
10365 break;
10368 if (gfc_current_state () == COMP_ENUM)
10370 gfc_free_enum_history ();
10371 gfc_error ("Syntax error in ENUMERATOR definition at %C");
10372 m = MATCH_ERROR;
10375 cleanup:
10376 gfc_free_array_spec (current_as);
10377 current_as = NULL;
10378 return m;
10383 /* Match binding attributes. */
10385 static match
10386 match_binding_attributes (gfc_typebound_proc* ba, bool generic, bool ppc)
10388 bool found_passing = false;
10389 bool seen_ptr = false;
10390 match m = MATCH_YES;
10392 /* Initialize to defaults. Do so even before the MATCH_NO check so that in
10393 this case the defaults are in there. */
10394 ba->access = ACCESS_UNKNOWN;
10395 ba->pass_arg = NULL;
10396 ba->pass_arg_num = 0;
10397 ba->nopass = 0;
10398 ba->non_overridable = 0;
10399 ba->deferred = 0;
10400 ba->ppc = ppc;
10402 /* If we find a comma, we believe there are binding attributes. */
10403 m = gfc_match_char (',');
10404 if (m == MATCH_NO)
10405 goto done;
10409 /* Access specifier. */
10411 m = gfc_match (" public");
10412 if (m == MATCH_ERROR)
10413 goto error;
10414 if (m == MATCH_YES)
10416 if (ba->access != ACCESS_UNKNOWN)
10418 gfc_error ("Duplicate access-specifier at %C");
10419 goto error;
10422 ba->access = ACCESS_PUBLIC;
10423 continue;
10426 m = gfc_match (" private");
10427 if (m == MATCH_ERROR)
10428 goto error;
10429 if (m == MATCH_YES)
10431 if (ba->access != ACCESS_UNKNOWN)
10433 gfc_error ("Duplicate access-specifier at %C");
10434 goto error;
10437 ba->access = ACCESS_PRIVATE;
10438 continue;
10441 /* If inside GENERIC, the following is not allowed. */
10442 if (!generic)
10445 /* NOPASS flag. */
10446 m = gfc_match (" nopass");
10447 if (m == MATCH_ERROR)
10448 goto error;
10449 if (m == MATCH_YES)
10451 if (found_passing)
10453 gfc_error ("Binding attributes already specify passing,"
10454 " illegal NOPASS at %C");
10455 goto error;
10458 found_passing = true;
10459 ba->nopass = 1;
10460 continue;
10463 /* PASS possibly including argument. */
10464 m = gfc_match (" pass");
10465 if (m == MATCH_ERROR)
10466 goto error;
10467 if (m == MATCH_YES)
10469 char arg[GFC_MAX_SYMBOL_LEN + 1];
10471 if (found_passing)
10473 gfc_error ("Binding attributes already specify passing,"
10474 " illegal PASS at %C");
10475 goto error;
10478 m = gfc_match (" ( %n )", arg);
10479 if (m == MATCH_ERROR)
10480 goto error;
10481 if (m == MATCH_YES)
10482 ba->pass_arg = gfc_get_string ("%s", arg);
10483 gcc_assert ((m == MATCH_YES) == (ba->pass_arg != NULL));
10485 found_passing = true;
10486 ba->nopass = 0;
10487 continue;
10490 if (ppc)
10492 /* POINTER flag. */
10493 m = gfc_match (" pointer");
10494 if (m == MATCH_ERROR)
10495 goto error;
10496 if (m == MATCH_YES)
10498 if (seen_ptr)
10500 gfc_error ("Duplicate POINTER attribute at %C");
10501 goto error;
10504 seen_ptr = true;
10505 continue;
10508 else
10510 /* NON_OVERRIDABLE flag. */
10511 m = gfc_match (" non_overridable");
10512 if (m == MATCH_ERROR)
10513 goto error;
10514 if (m == MATCH_YES)
10516 if (ba->non_overridable)
10518 gfc_error ("Duplicate NON_OVERRIDABLE at %C");
10519 goto error;
10522 ba->non_overridable = 1;
10523 continue;
10526 /* DEFERRED flag. */
10527 m = gfc_match (" deferred");
10528 if (m == MATCH_ERROR)
10529 goto error;
10530 if (m == MATCH_YES)
10532 if (ba->deferred)
10534 gfc_error ("Duplicate DEFERRED at %C");
10535 goto error;
10538 ba->deferred = 1;
10539 continue;
10545 /* Nothing matching found. */
10546 if (generic)
10547 gfc_error ("Expected access-specifier at %C");
10548 else
10549 gfc_error ("Expected binding attribute at %C");
10550 goto error;
10552 while (gfc_match_char (',') == MATCH_YES);
10554 /* NON_OVERRIDABLE and DEFERRED exclude themselves. */
10555 if (ba->non_overridable && ba->deferred)
10557 gfc_error ("NON_OVERRIDABLE and DEFERRED can't both appear at %C");
10558 goto error;
10561 m = MATCH_YES;
10563 done:
10564 if (ba->access == ACCESS_UNKNOWN)
10565 ba->access = gfc_typebound_default_access;
10567 if (ppc && !seen_ptr)
10569 gfc_error ("POINTER attribute is required for procedure pointer component"
10570 " at %C");
10571 goto error;
10574 return m;
10576 error:
10577 return MATCH_ERROR;
10581 /* Match a PROCEDURE specific binding inside a derived type. */
10583 static match
10584 match_procedure_in_type (void)
10586 char name[GFC_MAX_SYMBOL_LEN + 1];
10587 char target_buf[GFC_MAX_SYMBOL_LEN + 1];
10588 char* target = NULL, *ifc = NULL;
10589 gfc_typebound_proc tb;
10590 bool seen_colons;
10591 bool seen_attrs;
10592 match m;
10593 gfc_symtree* stree;
10594 gfc_namespace* ns;
10595 gfc_symbol* block;
10596 int num;
10598 /* Check current state. */
10599 gcc_assert (gfc_state_stack->state == COMP_DERIVED_CONTAINS);
10600 block = gfc_state_stack->previous->sym;
10601 gcc_assert (block);
10603 /* Try to match PROCEDURE(interface). */
10604 if (gfc_match (" (") == MATCH_YES)
10606 m = gfc_match_name (target_buf);
10607 if (m == MATCH_ERROR)
10608 return m;
10609 if (m != MATCH_YES)
10611 gfc_error ("Interface-name expected after %<(%> at %C");
10612 return MATCH_ERROR;
10615 if (gfc_match (" )") != MATCH_YES)
10617 gfc_error ("%<)%> expected at %C");
10618 return MATCH_ERROR;
10621 ifc = target_buf;
10624 /* Construct the data structure. */
10625 memset (&tb, 0, sizeof (tb));
10626 tb.where = gfc_current_locus;
10628 /* Match binding attributes. */
10629 m = match_binding_attributes (&tb, false, false);
10630 if (m == MATCH_ERROR)
10631 return m;
10632 seen_attrs = (m == MATCH_YES);
10634 /* Check that attribute DEFERRED is given if an interface is specified. */
10635 if (tb.deferred && !ifc)
10637 gfc_error ("Interface must be specified for DEFERRED binding at %C");
10638 return MATCH_ERROR;
10640 if (ifc && !tb.deferred)
10642 gfc_error ("PROCEDURE(interface) at %C should be declared DEFERRED");
10643 return MATCH_ERROR;
10646 /* Match the colons. */
10647 m = gfc_match (" ::");
10648 if (m == MATCH_ERROR)
10649 return m;
10650 seen_colons = (m == MATCH_YES);
10651 if (seen_attrs && !seen_colons)
10653 gfc_error ("Expected %<::%> after binding-attributes at %C");
10654 return MATCH_ERROR;
10657 /* Match the binding names. */
10658 for(num=1;;num++)
10660 m = gfc_match_name (name);
10661 if (m == MATCH_ERROR)
10662 return m;
10663 if (m == MATCH_NO)
10665 gfc_error ("Expected binding name at %C");
10666 return MATCH_ERROR;
10669 if (num>1 && !gfc_notify_std (GFC_STD_F2008, "PROCEDURE list at %C"))
10670 return MATCH_ERROR;
10672 /* Try to match the '=> target', if it's there. */
10673 target = ifc;
10674 m = gfc_match (" =>");
10675 if (m == MATCH_ERROR)
10676 return m;
10677 if (m == MATCH_YES)
10679 if (tb.deferred)
10681 gfc_error ("%<=> target%> is invalid for DEFERRED binding at %C");
10682 return MATCH_ERROR;
10685 if (!seen_colons)
10687 gfc_error ("%<::%> needed in PROCEDURE binding with explicit target"
10688 " at %C");
10689 return MATCH_ERROR;
10692 m = gfc_match_name (target_buf);
10693 if (m == MATCH_ERROR)
10694 return m;
10695 if (m == MATCH_NO)
10697 gfc_error ("Expected binding target after %<=>%> at %C");
10698 return MATCH_ERROR;
10700 target = target_buf;
10703 /* If no target was found, it has the same name as the binding. */
10704 if (!target)
10705 target = name;
10707 /* Get the namespace to insert the symbols into. */
10708 ns = block->f2k_derived;
10709 gcc_assert (ns);
10711 /* If the binding is DEFERRED, check that the containing type is ABSTRACT. */
10712 if (tb.deferred && !block->attr.abstract)
10714 gfc_error ("Type %qs containing DEFERRED binding at %C "
10715 "is not ABSTRACT", block->name);
10716 return MATCH_ERROR;
10719 /* See if we already have a binding with this name in the symtree which
10720 would be an error. If a GENERIC already targeted this binding, it may
10721 be already there but then typebound is still NULL. */
10722 stree = gfc_find_symtree (ns->tb_sym_root, name);
10723 if (stree && stree->n.tb)
10725 gfc_error ("There is already a procedure with binding name %qs for "
10726 "the derived type %qs at %C", name, block->name);
10727 return MATCH_ERROR;
10730 /* Insert it and set attributes. */
10732 if (!stree)
10734 stree = gfc_new_symtree (&ns->tb_sym_root, name);
10735 gcc_assert (stree);
10737 stree->n.tb = gfc_get_typebound_proc (&tb);
10739 if (gfc_get_sym_tree (target, gfc_current_ns, &stree->n.tb->u.specific,
10740 false))
10741 return MATCH_ERROR;
10742 gfc_set_sym_referenced (stree->n.tb->u.specific->n.sym);
10743 gfc_add_flavor(&stree->n.tb->u.specific->n.sym->attr, FL_PROCEDURE,
10744 target, &stree->n.tb->u.specific->n.sym->declared_at);
10746 if (gfc_match_eos () == MATCH_YES)
10747 return MATCH_YES;
10748 if (gfc_match_char (',') != MATCH_YES)
10749 goto syntax;
10752 syntax:
10753 gfc_error ("Syntax error in PROCEDURE statement at %C");
10754 return MATCH_ERROR;
10758 /* Match a GENERIC procedure binding inside a derived type. */
10760 match
10761 gfc_match_generic (void)
10763 char name[GFC_MAX_SYMBOL_LEN + 1];
10764 char bind_name[GFC_MAX_SYMBOL_LEN + 16]; /* Allow space for OPERATOR(...). */
10765 gfc_symbol* block;
10766 gfc_typebound_proc tbattr; /* Used for match_binding_attributes. */
10767 gfc_typebound_proc* tb;
10768 gfc_namespace* ns;
10769 interface_type op_type;
10770 gfc_intrinsic_op op;
10771 match m;
10773 /* Check current state. */
10774 if (gfc_current_state () == COMP_DERIVED)
10776 gfc_error ("GENERIC at %C must be inside a derived-type CONTAINS");
10777 return MATCH_ERROR;
10779 if (gfc_current_state () != COMP_DERIVED_CONTAINS)
10780 return MATCH_NO;
10781 block = gfc_state_stack->previous->sym;
10782 ns = block->f2k_derived;
10783 gcc_assert (block && ns);
10785 memset (&tbattr, 0, sizeof (tbattr));
10786 tbattr.where = gfc_current_locus;
10788 /* See if we get an access-specifier. */
10789 m = match_binding_attributes (&tbattr, true, false);
10790 if (m == MATCH_ERROR)
10791 goto error;
10793 /* Now the colons, those are required. */
10794 if (gfc_match (" ::") != MATCH_YES)
10796 gfc_error ("Expected %<::%> at %C");
10797 goto error;
10800 /* Match the binding name; depending on type (operator / generic) format
10801 it for future error messages into bind_name. */
10803 m = gfc_match_generic_spec (&op_type, name, &op);
10804 if (m == MATCH_ERROR)
10805 return MATCH_ERROR;
10806 if (m == MATCH_NO)
10808 gfc_error ("Expected generic name or operator descriptor at %C");
10809 goto error;
10812 switch (op_type)
10814 case INTERFACE_GENERIC:
10815 case INTERFACE_DTIO:
10816 snprintf (bind_name, sizeof (bind_name), "%s", name);
10817 break;
10819 case INTERFACE_USER_OP:
10820 snprintf (bind_name, sizeof (bind_name), "OPERATOR(.%s.)", name);
10821 break;
10823 case INTERFACE_INTRINSIC_OP:
10824 snprintf (bind_name, sizeof (bind_name), "OPERATOR(%s)",
10825 gfc_op2string (op));
10826 break;
10828 case INTERFACE_NAMELESS:
10829 gfc_error ("Malformed GENERIC statement at %C");
10830 goto error;
10831 break;
10833 default:
10834 gcc_unreachable ();
10837 /* Match the required =>. */
10838 if (gfc_match (" =>") != MATCH_YES)
10840 gfc_error ("Expected %<=>%> at %C");
10841 goto error;
10844 /* Try to find existing GENERIC binding with this name / for this operator;
10845 if there is something, check that it is another GENERIC and then extend
10846 it rather than building a new node. Otherwise, create it and put it
10847 at the right position. */
10849 switch (op_type)
10851 case INTERFACE_DTIO:
10852 case INTERFACE_USER_OP:
10853 case INTERFACE_GENERIC:
10855 const bool is_op = (op_type == INTERFACE_USER_OP);
10856 gfc_symtree* st;
10858 st = gfc_find_symtree (is_op ? ns->tb_uop_root : ns->tb_sym_root, name);
10859 tb = st ? st->n.tb : NULL;
10860 break;
10863 case INTERFACE_INTRINSIC_OP:
10864 tb = ns->tb_op[op];
10865 break;
10867 default:
10868 gcc_unreachable ();
10871 if (tb)
10873 if (!tb->is_generic)
10875 gcc_assert (op_type == INTERFACE_GENERIC);
10876 gfc_error ("There's already a non-generic procedure with binding name"
10877 " %qs for the derived type %qs at %C",
10878 bind_name, block->name);
10879 goto error;
10882 if (tb->access != tbattr.access)
10884 gfc_error ("Binding at %C must have the same access as already"
10885 " defined binding %qs", bind_name);
10886 goto error;
10889 else
10891 tb = gfc_get_typebound_proc (NULL);
10892 tb->where = gfc_current_locus;
10893 tb->access = tbattr.access;
10894 tb->is_generic = 1;
10895 tb->u.generic = NULL;
10897 switch (op_type)
10899 case INTERFACE_DTIO:
10900 case INTERFACE_GENERIC:
10901 case INTERFACE_USER_OP:
10903 const bool is_op = (op_type == INTERFACE_USER_OP);
10904 gfc_symtree* st = gfc_get_tbp_symtree (is_op ? &ns->tb_uop_root :
10905 &ns->tb_sym_root, name);
10906 gcc_assert (st);
10907 st->n.tb = tb;
10909 break;
10912 case INTERFACE_INTRINSIC_OP:
10913 ns->tb_op[op] = tb;
10914 break;
10916 default:
10917 gcc_unreachable ();
10921 /* Now, match all following names as specific targets. */
10924 gfc_symtree* target_st;
10925 gfc_tbp_generic* target;
10927 m = gfc_match_name (name);
10928 if (m == MATCH_ERROR)
10929 goto error;
10930 if (m == MATCH_NO)
10932 gfc_error ("Expected specific binding name at %C");
10933 goto error;
10936 target_st = gfc_get_tbp_symtree (&ns->tb_sym_root, name);
10938 /* See if this is a duplicate specification. */
10939 for (target = tb->u.generic; target; target = target->next)
10940 if (target_st == target->specific_st)
10942 gfc_error ("%qs already defined as specific binding for the"
10943 " generic %qs at %C", name, bind_name);
10944 goto error;
10947 target = gfc_get_tbp_generic ();
10948 target->specific_st = target_st;
10949 target->specific = NULL;
10950 target->next = tb->u.generic;
10951 target->is_operator = ((op_type == INTERFACE_USER_OP)
10952 || (op_type == INTERFACE_INTRINSIC_OP));
10953 tb->u.generic = target;
10955 while (gfc_match (" ,") == MATCH_YES);
10957 /* Here should be the end. */
10958 if (gfc_match_eos () != MATCH_YES)
10960 gfc_error ("Junk after GENERIC binding at %C");
10961 goto error;
10964 return MATCH_YES;
10966 error:
10967 return MATCH_ERROR;
10971 /* Match a FINAL declaration inside a derived type. */
10973 match
10974 gfc_match_final_decl (void)
10976 char name[GFC_MAX_SYMBOL_LEN + 1];
10977 gfc_symbol* sym;
10978 match m;
10979 gfc_namespace* module_ns;
10980 bool first, last;
10981 gfc_symbol* block;
10983 if (gfc_current_form == FORM_FREE)
10985 char c = gfc_peek_ascii_char ();
10986 if (!gfc_is_whitespace (c) && c != ':')
10987 return MATCH_NO;
10990 if (gfc_state_stack->state != COMP_DERIVED_CONTAINS)
10992 if (gfc_current_form == FORM_FIXED)
10993 return MATCH_NO;
10995 gfc_error ("FINAL declaration at %C must be inside a derived type "
10996 "CONTAINS section");
10997 return MATCH_ERROR;
11000 block = gfc_state_stack->previous->sym;
11001 gcc_assert (block);
11003 if (!gfc_state_stack->previous || !gfc_state_stack->previous->previous
11004 || gfc_state_stack->previous->previous->state != COMP_MODULE)
11006 gfc_error ("Derived type declaration with FINAL at %C must be in the"
11007 " specification part of a MODULE");
11008 return MATCH_ERROR;
11011 module_ns = gfc_current_ns;
11012 gcc_assert (module_ns);
11013 gcc_assert (module_ns->proc_name->attr.flavor == FL_MODULE);
11015 /* Match optional ::, don't care about MATCH_YES or MATCH_NO. */
11016 if (gfc_match (" ::") == MATCH_ERROR)
11017 return MATCH_ERROR;
11019 /* Match the sequence of procedure names. */
11020 first = true;
11021 last = false;
11024 gfc_finalizer* f;
11026 if (first && gfc_match_eos () == MATCH_YES)
11028 gfc_error ("Empty FINAL at %C");
11029 return MATCH_ERROR;
11032 m = gfc_match_name (name);
11033 if (m == MATCH_NO)
11035 gfc_error ("Expected module procedure name at %C");
11036 return MATCH_ERROR;
11038 else if (m != MATCH_YES)
11039 return MATCH_ERROR;
11041 if (gfc_match_eos () == MATCH_YES)
11042 last = true;
11043 if (!last && gfc_match_char (',') != MATCH_YES)
11045 gfc_error ("Expected %<,%> at %C");
11046 return MATCH_ERROR;
11049 if (gfc_get_symbol (name, module_ns, &sym))
11051 gfc_error ("Unknown procedure name %qs at %C", name);
11052 return MATCH_ERROR;
11055 /* Mark the symbol as module procedure. */
11056 if (sym->attr.proc != PROC_MODULE
11057 && !gfc_add_procedure (&sym->attr, PROC_MODULE, sym->name, NULL))
11058 return MATCH_ERROR;
11060 /* Check if we already have this symbol in the list, this is an error. */
11061 for (f = block->f2k_derived->finalizers; f; f = f->next)
11062 if (f->proc_sym == sym)
11064 gfc_error ("%qs at %C is already defined as FINAL procedure",
11065 name);
11066 return MATCH_ERROR;
11069 /* Add this symbol to the list of finalizers. */
11070 gcc_assert (block->f2k_derived);
11071 sym->refs++;
11072 f = XCNEW (gfc_finalizer);
11073 f->proc_sym = sym;
11074 f->proc_tree = NULL;
11075 f->where = gfc_current_locus;
11076 f->next = block->f2k_derived->finalizers;
11077 block->f2k_derived->finalizers = f;
11079 first = false;
11081 while (!last);
11083 return MATCH_YES;
11087 const ext_attr_t ext_attr_list[] = {
11088 { "dllimport", EXT_ATTR_DLLIMPORT, "dllimport" },
11089 { "dllexport", EXT_ATTR_DLLEXPORT, "dllexport" },
11090 { "cdecl", EXT_ATTR_CDECL, "cdecl" },
11091 { "stdcall", EXT_ATTR_STDCALL, "stdcall" },
11092 { "fastcall", EXT_ATTR_FASTCALL, "fastcall" },
11093 { "no_arg_check", EXT_ATTR_NO_ARG_CHECK, NULL },
11094 { NULL, EXT_ATTR_LAST, NULL }
11097 /* Match a !GCC$ ATTRIBUTES statement of the form:
11098 !GCC$ ATTRIBUTES attribute-list :: var-name [, var-name] ...
11099 When we come here, we have already matched the !GCC$ ATTRIBUTES string.
11101 TODO: We should support all GCC attributes using the same syntax for
11102 the attribute list, i.e. the list in C
11103 __attributes(( attribute-list ))
11104 matches then
11105 !GCC$ ATTRIBUTES attribute-list ::
11106 Cf. c-parser.c's c_parser_attributes; the data can then directly be
11107 saved into a TREE.
11109 As there is absolutely no risk of confusion, we should never return
11110 MATCH_NO. */
11111 match
11112 gfc_match_gcc_attributes (void)
11114 symbol_attribute attr;
11115 char name[GFC_MAX_SYMBOL_LEN + 1];
11116 unsigned id;
11117 gfc_symbol *sym;
11118 match m;
11120 gfc_clear_attr (&attr);
11121 for(;;)
11123 char ch;
11125 if (gfc_match_name (name) != MATCH_YES)
11126 return MATCH_ERROR;
11128 for (id = 0; id < EXT_ATTR_LAST; id++)
11129 if (strcmp (name, ext_attr_list[id].name) == 0)
11130 break;
11132 if (id == EXT_ATTR_LAST)
11134 gfc_error ("Unknown attribute in !GCC$ ATTRIBUTES statement at %C");
11135 return MATCH_ERROR;
11138 if (!gfc_add_ext_attribute (&attr, (ext_attr_id_t)id, &gfc_current_locus))
11139 return MATCH_ERROR;
11141 gfc_gobble_whitespace ();
11142 ch = gfc_next_ascii_char ();
11143 if (ch == ':')
11145 /* This is the successful exit condition for the loop. */
11146 if (gfc_next_ascii_char () == ':')
11147 break;
11150 if (ch == ',')
11151 continue;
11153 goto syntax;
11156 if (gfc_match_eos () == MATCH_YES)
11157 goto syntax;
11159 for(;;)
11161 m = gfc_match_name (name);
11162 if (m != MATCH_YES)
11163 return m;
11165 if (find_special (name, &sym, true))
11166 return MATCH_ERROR;
11168 sym->attr.ext_attr |= attr.ext_attr;
11170 if (gfc_match_eos () == MATCH_YES)
11171 break;
11173 if (gfc_match_char (',') != MATCH_YES)
11174 goto syntax;
11177 return MATCH_YES;
11179 syntax:
11180 gfc_error ("Syntax error in !GCC$ ATTRIBUTES statement at %C");
11181 return MATCH_ERROR;
11185 /* Match a !GCC$ UNROLL statement of the form:
11186 !GCC$ UNROLL n
11188 The parameter n is the number of times we are supposed to unroll.
11190 When we come here, we have already matched the !GCC$ UNROLL string. */
11191 match
11192 gfc_match_gcc_unroll (void)
11194 int value;
11196 if (gfc_match_small_int (&value) == MATCH_YES)
11198 if (value < 0 || value > USHRT_MAX)
11200 gfc_error ("%<GCC unroll%> directive requires a"
11201 " non-negative integral constant"
11202 " less than or equal to %u at %C",
11203 USHRT_MAX
11205 return MATCH_ERROR;
11207 if (gfc_match_eos () == MATCH_YES)
11209 directive_unroll = value == 0 ? 1 : value;
11210 return MATCH_YES;
11214 gfc_error ("Syntax error in !GCC$ UNROLL directive at %C");
11215 return MATCH_ERROR;