* ggc.h (empty_string): Delete.
[official-gcc.git] / gcc / fortran / decl.c
blobbd310703557a1b576de317df47af9e79a0a35ff9
1 /* Declaration statement matcher
2 Copyright (C) 2002-2017 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;
58 /* The current binding label (if any). */
59 static const char* curr_binding_label;
60 /* Need to know how many identifiers are on the current data declaration
61 line in case we're given the BIND(C) attribute with a NAME= specifier. */
62 static int num_idents_on_line;
63 /* Need to know if a NAME= specifier was found during gfc_match_bind_c so we
64 can supply a name if the curr_binding_label is nil and NAME= was not. */
65 static int has_name_equals = 0;
67 /* Initializer of the previous enumerator. */
69 static gfc_expr *last_initializer;
71 /* History of all the enumerators is maintained, so that
72 kind values of all the enumerators could be updated depending
73 upon the maximum initialized value. */
75 typedef struct enumerator_history
77 gfc_symbol *sym;
78 gfc_expr *initializer;
79 struct enumerator_history *next;
81 enumerator_history;
83 /* Header of enum history chain. */
85 static enumerator_history *enum_history = NULL;
87 /* Pointer of enum history node containing largest initializer. */
89 static enumerator_history *max_enum = NULL;
91 /* gfc_new_block points to the symbol of a newly matched block. */
93 gfc_symbol *gfc_new_block;
95 bool gfc_matching_function;
98 /********************* DATA statement subroutines *********************/
100 static bool in_match_data = false;
102 bool
103 gfc_in_match_data (void)
105 return in_match_data;
108 static void
109 set_in_match_data (bool set_value)
111 in_match_data = set_value;
114 /* Free a gfc_data_variable structure and everything beneath it. */
116 static void
117 free_variable (gfc_data_variable *p)
119 gfc_data_variable *q;
121 for (; p; p = q)
123 q = p->next;
124 gfc_free_expr (p->expr);
125 gfc_free_iterator (&p->iter, 0);
126 free_variable (p->list);
127 free (p);
132 /* Free a gfc_data_value structure and everything beneath it. */
134 static void
135 free_value (gfc_data_value *p)
137 gfc_data_value *q;
139 for (; p; p = q)
141 q = p->next;
142 mpz_clear (p->repeat);
143 gfc_free_expr (p->expr);
144 free (p);
149 /* Free a list of gfc_data structures. */
151 void
152 gfc_free_data (gfc_data *p)
154 gfc_data *q;
156 for (; p; p = q)
158 q = p->next;
159 free_variable (p->var);
160 free_value (p->value);
161 free (p);
166 /* Free all data in a namespace. */
168 static void
169 gfc_free_data_all (gfc_namespace *ns)
171 gfc_data *d;
173 for (;ns->data;)
175 d = ns->data->next;
176 free (ns->data);
177 ns->data = d;
181 /* Reject data parsed since the last restore point was marked. */
183 void
184 gfc_reject_data (gfc_namespace *ns)
186 gfc_data *d;
188 while (ns->data && ns->data != ns->old_data)
190 d = ns->data->next;
191 free (ns->data);
192 ns->data = d;
196 static match var_element (gfc_data_variable *);
198 /* Match a list of variables terminated by an iterator and a right
199 parenthesis. */
201 static match
202 var_list (gfc_data_variable *parent)
204 gfc_data_variable *tail, var;
205 match m;
207 m = var_element (&var);
208 if (m == MATCH_ERROR)
209 return MATCH_ERROR;
210 if (m == MATCH_NO)
211 goto syntax;
213 tail = gfc_get_data_variable ();
214 *tail = var;
216 parent->list = tail;
218 for (;;)
220 if (gfc_match_char (',') != MATCH_YES)
221 goto syntax;
223 m = gfc_match_iterator (&parent->iter, 1);
224 if (m == MATCH_YES)
225 break;
226 if (m == MATCH_ERROR)
227 return MATCH_ERROR;
229 m = var_element (&var);
230 if (m == MATCH_ERROR)
231 return MATCH_ERROR;
232 if (m == MATCH_NO)
233 goto syntax;
235 tail->next = gfc_get_data_variable ();
236 tail = tail->next;
238 *tail = var;
241 if (gfc_match_char (')') != MATCH_YES)
242 goto syntax;
243 return MATCH_YES;
245 syntax:
246 gfc_syntax_error (ST_DATA);
247 return MATCH_ERROR;
251 /* Match a single element in a data variable list, which can be a
252 variable-iterator list. */
254 static match
255 var_element (gfc_data_variable *new_var)
257 match m;
258 gfc_symbol *sym;
260 memset (new_var, 0, sizeof (gfc_data_variable));
262 if (gfc_match_char ('(') == MATCH_YES)
263 return var_list (new_var);
265 m = gfc_match_variable (&new_var->expr, 0);
266 if (m != MATCH_YES)
267 return m;
269 sym = new_var->expr->symtree->n.sym;
271 /* Symbol should already have an associated type. */
272 if (!gfc_check_symbol_typed (sym, gfc_current_ns, false, gfc_current_locus))
273 return MATCH_ERROR;
275 if (!sym->attr.function && gfc_current_ns->parent
276 && gfc_current_ns->parent == sym->ns)
278 gfc_error ("Host associated variable %qs may not be in the DATA "
279 "statement at %C", sym->name);
280 return MATCH_ERROR;
283 if (gfc_current_state () != COMP_BLOCK_DATA
284 && sym->attr.in_common
285 && !gfc_notify_std (GFC_STD_GNU, "initialization of "
286 "common block variable %qs in DATA statement at %C",
287 sym->name))
288 return MATCH_ERROR;
290 if (!gfc_add_data (&sym->attr, sym->name, &new_var->expr->where))
291 return MATCH_ERROR;
293 return MATCH_YES;
297 /* Match the top-level list of data variables. */
299 static match
300 top_var_list (gfc_data *d)
302 gfc_data_variable var, *tail, *new_var;
303 match m;
305 tail = NULL;
307 for (;;)
309 m = var_element (&var);
310 if (m == MATCH_NO)
311 goto syntax;
312 if (m == MATCH_ERROR)
313 return MATCH_ERROR;
315 new_var = gfc_get_data_variable ();
316 *new_var = var;
318 if (tail == NULL)
319 d->var = new_var;
320 else
321 tail->next = new_var;
323 tail = new_var;
325 if (gfc_match_char ('/') == MATCH_YES)
326 break;
327 if (gfc_match_char (',') != MATCH_YES)
328 goto syntax;
331 return MATCH_YES;
333 syntax:
334 gfc_syntax_error (ST_DATA);
335 gfc_free_data_all (gfc_current_ns);
336 return MATCH_ERROR;
340 static match
341 match_data_constant (gfc_expr **result)
343 char name[GFC_MAX_SYMBOL_LEN + 1];
344 gfc_symbol *sym, *dt_sym = NULL;
345 gfc_expr *expr;
346 match m;
347 locus old_loc;
349 m = gfc_match_literal_constant (&expr, 1);
350 if (m == MATCH_YES)
352 *result = expr;
353 return MATCH_YES;
356 if (m == MATCH_ERROR)
357 return MATCH_ERROR;
359 m = gfc_match_null (result);
360 if (m != MATCH_NO)
361 return m;
363 old_loc = gfc_current_locus;
365 /* Should this be a structure component, try to match it
366 before matching a name. */
367 m = gfc_match_rvalue (result);
368 if (m == MATCH_ERROR)
369 return m;
371 if (m == MATCH_YES && (*result)->expr_type == EXPR_STRUCTURE)
373 if (!gfc_simplify_expr (*result, 0))
374 m = MATCH_ERROR;
375 return m;
377 else if (m == MATCH_YES)
378 gfc_free_expr (*result);
380 gfc_current_locus = old_loc;
382 m = gfc_match_name (name);
383 if (m != MATCH_YES)
384 return m;
386 if (gfc_find_symbol (name, NULL, 1, &sym))
387 return MATCH_ERROR;
389 if (sym && sym->attr.generic)
390 dt_sym = gfc_find_dt_in_generic (sym);
392 if (sym == NULL
393 || (sym->attr.flavor != FL_PARAMETER
394 && (!dt_sym || !gfc_fl_struct (dt_sym->attr.flavor))))
396 gfc_error ("Symbol %qs must be a PARAMETER in DATA statement at %C",
397 name);
398 *result = NULL;
399 return MATCH_ERROR;
401 else if (dt_sym && gfc_fl_struct (dt_sym->attr.flavor))
402 return gfc_match_structure_constructor (dt_sym, result);
404 /* Check to see if the value is an initialization array expression. */
405 if (sym->value->expr_type == EXPR_ARRAY)
407 gfc_current_locus = old_loc;
409 m = gfc_match_init_expr (result);
410 if (m == MATCH_ERROR)
411 return m;
413 if (m == MATCH_YES)
415 if (!gfc_simplify_expr (*result, 0))
416 m = MATCH_ERROR;
418 if ((*result)->expr_type == EXPR_CONSTANT)
419 return m;
420 else
422 gfc_error ("Invalid initializer %s in Data statement at %C", name);
423 return MATCH_ERROR;
428 *result = gfc_copy_expr (sym->value);
429 return MATCH_YES;
433 /* Match a list of values in a DATA statement. The leading '/' has
434 already been seen at this point. */
436 static match
437 top_val_list (gfc_data *data)
439 gfc_data_value *new_val, *tail;
440 gfc_expr *expr;
441 match m;
443 tail = NULL;
445 for (;;)
447 m = match_data_constant (&expr);
448 if (m == MATCH_NO)
449 goto syntax;
450 if (m == MATCH_ERROR)
451 return MATCH_ERROR;
453 new_val = gfc_get_data_value ();
454 mpz_init (new_val->repeat);
456 if (tail == NULL)
457 data->value = new_val;
458 else
459 tail->next = new_val;
461 tail = new_val;
463 if (expr->ts.type != BT_INTEGER || gfc_match_char ('*') != MATCH_YES)
465 tail->expr = expr;
466 mpz_set_ui (tail->repeat, 1);
468 else
470 mpz_set (tail->repeat, expr->value.integer);
471 gfc_free_expr (expr);
473 m = match_data_constant (&tail->expr);
474 if (m == MATCH_NO)
475 goto syntax;
476 if (m == MATCH_ERROR)
477 return MATCH_ERROR;
480 if (gfc_match_char ('/') == MATCH_YES)
481 break;
482 if (gfc_match_char (',') == MATCH_NO)
483 goto syntax;
486 return MATCH_YES;
488 syntax:
489 gfc_syntax_error (ST_DATA);
490 gfc_free_data_all (gfc_current_ns);
491 return MATCH_ERROR;
495 /* Matches an old style initialization. */
497 static match
498 match_old_style_init (const char *name)
500 match m;
501 gfc_symtree *st;
502 gfc_symbol *sym;
503 gfc_data *newdata;
505 /* Set up data structure to hold initializers. */
506 gfc_find_sym_tree (name, NULL, 0, &st);
507 sym = st->n.sym;
509 newdata = gfc_get_data ();
510 newdata->var = gfc_get_data_variable ();
511 newdata->var->expr = gfc_get_variable_expr (st);
512 newdata->where = gfc_current_locus;
514 /* Match initial value list. This also eats the terminal '/'. */
515 m = top_val_list (newdata);
516 if (m != MATCH_YES)
518 free (newdata);
519 return m;
522 if (gfc_pure (NULL))
524 gfc_error ("Initialization at %C is not allowed in a PURE procedure");
525 free (newdata);
526 return MATCH_ERROR;
528 gfc_unset_implicit_pure (gfc_current_ns->proc_name);
530 /* Mark the variable as having appeared in a data statement. */
531 if (!gfc_add_data (&sym->attr, sym->name, &sym->declared_at))
533 free (newdata);
534 return MATCH_ERROR;
537 /* Chain in namespace list of DATA initializers. */
538 newdata->next = gfc_current_ns->data;
539 gfc_current_ns->data = newdata;
541 return m;
545 /* Match the stuff following a DATA statement. If ERROR_FLAG is set,
546 we are matching a DATA statement and are therefore issuing an error
547 if we encounter something unexpected, if not, we're trying to match
548 an old-style initialization expression of the form INTEGER I /2/. */
550 match
551 gfc_match_data (void)
553 gfc_data *new_data;
554 match m;
556 /* Before parsing the rest of a DATA statement, check F2008:c1206. */
557 if ((gfc_current_state () == COMP_FUNCTION
558 || gfc_current_state () == COMP_SUBROUTINE)
559 && gfc_state_stack->previous->state == COMP_INTERFACE)
561 gfc_error ("DATA statement at %C cannot appear within an INTERFACE");
562 return MATCH_ERROR;
565 set_in_match_data (true);
567 for (;;)
569 new_data = gfc_get_data ();
570 new_data->where = gfc_current_locus;
572 m = top_var_list (new_data);
573 if (m != MATCH_YES)
574 goto cleanup;
576 m = top_val_list (new_data);
577 if (m != MATCH_YES)
578 goto cleanup;
580 new_data->next = gfc_current_ns->data;
581 gfc_current_ns->data = new_data;
583 if (gfc_match_eos () == MATCH_YES)
584 break;
586 gfc_match_char (','); /* Optional comma */
589 set_in_match_data (false);
591 if (gfc_pure (NULL))
593 gfc_error ("DATA statement at %C is not allowed in a PURE procedure");
594 return MATCH_ERROR;
596 gfc_unset_implicit_pure (gfc_current_ns->proc_name);
598 return MATCH_YES;
600 cleanup:
601 set_in_match_data (false);
602 gfc_free_data (new_data);
603 return MATCH_ERROR;
607 /************************ Declaration statements *********************/
610 /* Like gfc_match_init_expr, but matches a 'clist' (old-style initialization
611 list). The difference here is the expression is a list of constants
612 and is surrounded by '/'.
613 The typespec ts must match the typespec of the variable which the
614 clist is initializing.
615 The arrayspec tells whether this should match a list of constants
616 corresponding to array elements or a scalar (as == NULL). */
618 static match
619 match_clist_expr (gfc_expr **result, gfc_typespec *ts, gfc_array_spec *as)
621 gfc_constructor_base array_head = NULL;
622 gfc_expr *expr = NULL;
623 match m;
624 locus where;
625 mpz_t repeat, size;
626 bool scalar;
627 int cmp;
629 gcc_assert (ts);
631 mpz_init_set_ui (repeat, 0);
632 mpz_init (size);
633 scalar = !as || !as->rank;
635 /* We have already matched '/' - now look for a constant list, as with
636 top_val_list from decl.c, but append the result to an array. */
637 if (gfc_match ("/") == MATCH_YES)
639 gfc_error ("Empty old style initializer list at %C");
640 goto cleanup;
643 where = gfc_current_locus;
644 for (;;)
646 m = match_data_constant (&expr);
647 if (m != MATCH_YES)
648 expr = NULL; /* match_data_constant may set expr to garbage */
649 if (m == MATCH_NO)
650 goto syntax;
651 if (m == MATCH_ERROR)
652 goto cleanup;
654 /* Found r in repeat spec r*c; look for the constant to repeat. */
655 if ( gfc_match_char ('*') == MATCH_YES)
657 if (scalar)
659 gfc_error ("Repeat spec invalid in scalar initializer at %C");
660 goto cleanup;
662 if (expr->ts.type != BT_INTEGER)
664 gfc_error ("Repeat spec must be an integer at %C");
665 goto cleanup;
667 mpz_set (repeat, expr->value.integer);
668 gfc_free_expr (expr);
669 expr = NULL;
671 m = match_data_constant (&expr);
672 if (m == MATCH_NO)
673 gfc_error ("Expected data constant after repeat spec at %C");
674 if (m != MATCH_YES)
675 goto cleanup;
677 /* No repeat spec, we matched the data constant itself. */
678 else
679 mpz_set_ui (repeat, 1);
681 if (!scalar)
683 /* Add the constant initializer as many times as repeated. */
684 for (; mpz_cmp_ui (repeat, 0) > 0; mpz_sub_ui (repeat, repeat, 1))
686 /* Make sure types of elements match */
687 if(ts && !gfc_compare_types (&expr->ts, ts)
688 && !gfc_convert_type (expr, ts, 1))
689 goto cleanup;
691 gfc_constructor_append_expr (&array_head,
692 gfc_copy_expr (expr), &gfc_current_locus);
695 gfc_free_expr (expr);
696 expr = NULL;
699 /* For scalar initializers quit after one element. */
700 else
702 if(gfc_match_char ('/') != MATCH_YES)
704 gfc_error ("End of scalar initializer expected at %C");
705 goto cleanup;
707 break;
710 if (gfc_match_char ('/') == MATCH_YES)
711 break;
712 if (gfc_match_char (',') == MATCH_NO)
713 goto syntax;
716 /* Set up expr as an array constructor. */
717 if (!scalar)
719 expr = gfc_get_array_expr (ts->type, ts->kind, &where);
720 expr->ts = *ts;
721 expr->value.constructor = array_head;
723 expr->rank = as->rank;
724 expr->shape = gfc_get_shape (expr->rank);
726 /* Validate sizes. */
727 gcc_assert (gfc_array_size (expr, &size));
728 gcc_assert (spec_size (as, &repeat));
729 cmp = mpz_cmp (size, repeat);
730 if (cmp < 0)
731 gfc_error ("Not enough elements in array initializer at %C");
732 else if (cmp > 0)
733 gfc_error ("Too many elements in array initializer at %C");
734 if (cmp)
735 goto cleanup;
738 /* Make sure scalar types match. */
739 else if (!gfc_compare_types (&expr->ts, ts)
740 && !gfc_convert_type (expr, ts, 1))
741 goto cleanup;
743 if (expr->ts.u.cl)
744 expr->ts.u.cl->length_from_typespec = 1;
746 *result = expr;
747 mpz_clear (size);
748 mpz_clear (repeat);
749 return MATCH_YES;
751 syntax:
752 gfc_error ("Syntax error in old style initializer list at %C");
754 cleanup:
755 if (expr)
756 expr->value.constructor = NULL;
757 gfc_free_expr (expr);
758 gfc_constructor_free (array_head);
759 mpz_clear (size);
760 mpz_clear (repeat);
761 return MATCH_ERROR;
765 /* Auxiliary function to merge DIMENSION and CODIMENSION array specs. */
767 static bool
768 merge_array_spec (gfc_array_spec *from, gfc_array_spec *to, bool copy)
770 int i;
772 if ((from->type == AS_ASSUMED_RANK && to->corank)
773 || (to->type == AS_ASSUMED_RANK && from->corank))
775 gfc_error ("The assumed-rank array at %C shall not have a codimension");
776 return false;
779 if (to->rank == 0 && from->rank > 0)
781 to->rank = from->rank;
782 to->type = from->type;
783 to->cray_pointee = from->cray_pointee;
784 to->cp_was_assumed = from->cp_was_assumed;
786 for (i = 0; i < to->corank; i++)
788 to->lower[from->rank + i] = to->lower[i];
789 to->upper[from->rank + i] = to->upper[i];
791 for (i = 0; i < from->rank; i++)
793 if (copy)
795 to->lower[i] = gfc_copy_expr (from->lower[i]);
796 to->upper[i] = gfc_copy_expr (from->upper[i]);
798 else
800 to->lower[i] = from->lower[i];
801 to->upper[i] = from->upper[i];
805 else if (to->corank == 0 && from->corank > 0)
807 to->corank = from->corank;
808 to->cotype = from->cotype;
810 for (i = 0; i < from->corank; i++)
812 if (copy)
814 to->lower[to->rank + i] = gfc_copy_expr (from->lower[i]);
815 to->upper[to->rank + i] = gfc_copy_expr (from->upper[i]);
817 else
819 to->lower[to->rank + i] = from->lower[i];
820 to->upper[to->rank + i] = from->upper[i];
825 return true;
829 /* Match an intent specification. Since this can only happen after an
830 INTENT word, a legal intent-spec must follow. */
832 static sym_intent
833 match_intent_spec (void)
836 if (gfc_match (" ( in out )") == MATCH_YES)
837 return INTENT_INOUT;
838 if (gfc_match (" ( in )") == MATCH_YES)
839 return INTENT_IN;
840 if (gfc_match (" ( out )") == MATCH_YES)
841 return INTENT_OUT;
843 gfc_error ("Bad INTENT specification at %C");
844 return INTENT_UNKNOWN;
848 /* Matches a character length specification, which is either a
849 specification expression, '*', or ':'. */
851 static match
852 char_len_param_value (gfc_expr **expr, bool *deferred)
854 match m;
856 *expr = NULL;
857 *deferred = false;
859 if (gfc_match_char ('*') == MATCH_YES)
860 return MATCH_YES;
862 if (gfc_match_char (':') == MATCH_YES)
864 if (!gfc_notify_std (GFC_STD_F2003, "deferred type parameter at %C"))
865 return MATCH_ERROR;
867 *deferred = true;
869 return MATCH_YES;
872 m = gfc_match_expr (expr);
874 if (m == MATCH_NO || m == MATCH_ERROR)
875 return m;
877 if (!gfc_expr_check_typed (*expr, gfc_current_ns, false))
878 return MATCH_ERROR;
880 if ((*expr)->expr_type == EXPR_FUNCTION)
882 if ((*expr)->ts.type == BT_INTEGER
883 || ((*expr)->ts.type == BT_UNKNOWN
884 && strcmp((*expr)->symtree->name, "null") != 0))
885 return MATCH_YES;
887 goto syntax;
889 else if ((*expr)->expr_type == EXPR_CONSTANT)
891 /* F2008, 4.4.3.1: The length is a type parameter; its kind is
892 processor dependent and its value is greater than or equal to zero.
893 F2008, 4.4.3.2: If the character length parameter value evaluates
894 to a negative value, the length of character entities declared
895 is zero. */
897 if ((*expr)->ts.type == BT_INTEGER)
899 if (mpz_cmp_si ((*expr)->value.integer, 0) < 0)
900 mpz_set_si ((*expr)->value.integer, 0);
902 else
903 goto syntax;
905 else if ((*expr)->expr_type == EXPR_ARRAY)
906 goto syntax;
907 else if ((*expr)->expr_type == EXPR_VARIABLE)
909 bool t;
910 gfc_expr *e;
912 e = gfc_copy_expr (*expr);
914 /* This catches the invalid code "[character(m(2:3)) :: 'x', 'y']",
915 which causes an ICE if gfc_reduce_init_expr() is called. */
916 if (e->ref && e->ref->type == REF_ARRAY
917 && e->ref->u.ar.type == AR_UNKNOWN
918 && e->ref->u.ar.dimen_type[0] == DIMEN_RANGE)
919 goto syntax;
921 t = gfc_reduce_init_expr (e);
923 if (!t && e->ts.type == BT_UNKNOWN
924 && e->symtree->n.sym->attr.untyped == 1
925 && (flag_implicit_none
926 || e->symtree->n.sym->ns->seen_implicit_none == 1
927 || e->symtree->n.sym->ns->parent->seen_implicit_none == 1))
929 gfc_free_expr (e);
930 goto syntax;
933 if ((e->ref && e->ref->type == REF_ARRAY
934 && e->ref->u.ar.type != AR_ELEMENT)
935 || (!e->ref && e->expr_type == EXPR_ARRAY))
937 gfc_free_expr (e);
938 goto syntax;
941 gfc_free_expr (e);
944 return m;
946 syntax:
947 gfc_error ("Scalar INTEGER expression expected at %L", &(*expr)->where);
948 return MATCH_ERROR;
952 /* A character length is a '*' followed by a literal integer or a
953 char_len_param_value in parenthesis. */
955 static match
956 match_char_length (gfc_expr **expr, bool *deferred, bool obsolescent_check)
958 int length;
959 match m;
961 *deferred = false;
962 m = gfc_match_char ('*');
963 if (m != MATCH_YES)
964 return m;
966 m = gfc_match_small_literal_int (&length, NULL);
967 if (m == MATCH_ERROR)
968 return m;
970 if (m == MATCH_YES)
972 if (obsolescent_check
973 && !gfc_notify_std (GFC_STD_F95_OBS, "Old-style character length at %C"))
974 return MATCH_ERROR;
975 *expr = gfc_get_int_expr (gfc_default_integer_kind, NULL, length);
976 return m;
979 if (gfc_match_char ('(') == MATCH_NO)
980 goto syntax;
982 m = char_len_param_value (expr, deferred);
983 if (m != MATCH_YES && gfc_matching_function)
985 gfc_undo_symbols ();
986 m = MATCH_YES;
989 if (m == MATCH_ERROR)
990 return m;
991 if (m == MATCH_NO)
992 goto syntax;
994 if (gfc_match_char (')') == MATCH_NO)
996 gfc_free_expr (*expr);
997 *expr = NULL;
998 goto syntax;
1001 return MATCH_YES;
1003 syntax:
1004 gfc_error ("Syntax error in character length specification at %C");
1005 return MATCH_ERROR;
1009 /* Special subroutine for finding a symbol. Check if the name is found
1010 in the current name space. If not, and we're compiling a function or
1011 subroutine and the parent compilation unit is an interface, then check
1012 to see if the name we've been given is the name of the interface
1013 (located in another namespace). */
1015 static int
1016 find_special (const char *name, gfc_symbol **result, bool allow_subroutine)
1018 gfc_state_data *s;
1019 gfc_symtree *st;
1020 int i;
1022 i = gfc_get_sym_tree (name, NULL, &st, allow_subroutine);
1023 if (i == 0)
1025 *result = st ? st->n.sym : NULL;
1026 goto end;
1029 if (gfc_current_state () != COMP_SUBROUTINE
1030 && gfc_current_state () != COMP_FUNCTION)
1031 goto end;
1033 s = gfc_state_stack->previous;
1034 if (s == NULL)
1035 goto end;
1037 if (s->state != COMP_INTERFACE)
1038 goto end;
1039 if (s->sym == NULL)
1040 goto end; /* Nameless interface. */
1042 if (strcmp (name, s->sym->name) == 0)
1044 *result = s->sym;
1045 return 0;
1048 end:
1049 return i;
1053 /* Special subroutine for getting a symbol node associated with a
1054 procedure name, used in SUBROUTINE and FUNCTION statements. The
1055 symbol is created in the parent using with symtree node in the
1056 child unit pointing to the symbol. If the current namespace has no
1057 parent, then the symbol is just created in the current unit. */
1059 static int
1060 get_proc_name (const char *name, gfc_symbol **result, bool module_fcn_entry)
1062 gfc_symtree *st;
1063 gfc_symbol *sym;
1064 int rc = 0;
1066 /* Module functions have to be left in their own namespace because
1067 they have potentially (almost certainly!) already been referenced.
1068 In this sense, they are rather like external functions. This is
1069 fixed up in resolve.c(resolve_entries), where the symbol name-
1070 space is set to point to the master function, so that the fake
1071 result mechanism can work. */
1072 if (module_fcn_entry)
1074 /* Present if entry is declared to be a module procedure. */
1075 rc = gfc_find_symbol (name, gfc_current_ns->parent, 0, result);
1077 if (*result == NULL)
1078 rc = gfc_get_symbol (name, NULL, result);
1079 else if (!gfc_get_symbol (name, NULL, &sym) && sym
1080 && (*result)->ts.type == BT_UNKNOWN
1081 && sym->attr.flavor == FL_UNKNOWN)
1082 /* Pick up the typespec for the entry, if declared in the function
1083 body. Note that this symbol is FL_UNKNOWN because it will
1084 only have appeared in a type declaration. The local symtree
1085 is set to point to the module symbol and a unique symtree
1086 to the local version. This latter ensures a correct clearing
1087 of the symbols. */
1089 /* If the ENTRY proceeds its specification, we need to ensure
1090 that this does not raise a "has no IMPLICIT type" error. */
1091 if (sym->ts.type == BT_UNKNOWN)
1092 sym->attr.untyped = 1;
1094 (*result)->ts = sym->ts;
1096 /* Put the symbol in the procedure namespace so that, should
1097 the ENTRY precede its specification, the specification
1098 can be applied. */
1099 (*result)->ns = gfc_current_ns;
1101 gfc_find_sym_tree (name, gfc_current_ns, 0, &st);
1102 st->n.sym = *result;
1103 st = gfc_get_unique_symtree (gfc_current_ns);
1104 sym->refs++;
1105 st->n.sym = sym;
1108 else
1109 rc = gfc_get_symbol (name, gfc_current_ns->parent, result);
1111 if (rc)
1112 return rc;
1114 sym = *result;
1115 if (sym->attr.proc == PROC_ST_FUNCTION)
1116 return rc;
1118 if (sym->attr.module_procedure
1119 && sym->attr.if_source == IFSRC_IFBODY)
1121 /* Create a partially populated interface symbol to carry the
1122 characteristics of the procedure and the result. */
1123 sym->tlink = gfc_new_symbol (name, sym->ns);
1124 gfc_add_type (sym->tlink, &(sym->ts),
1125 &gfc_current_locus);
1126 gfc_copy_attr (&sym->tlink->attr, &sym->attr, NULL);
1127 if (sym->attr.dimension)
1128 sym->tlink->as = gfc_copy_array_spec (sym->as);
1130 /* Ideally, at this point, a copy would be made of the formal
1131 arguments and their namespace. However, this does not appear
1132 to be necessary, albeit at the expense of not being able to
1133 use gfc_compare_interfaces directly. */
1135 if (sym->result && sym->result != sym)
1137 sym->tlink->result = sym->result;
1138 sym->result = NULL;
1140 else if (sym->result)
1142 sym->tlink->result = sym->tlink;
1145 else if (sym && !sym->gfc_new
1146 && gfc_current_state () != COMP_INTERFACE)
1148 /* Trap another encompassed procedure with the same name. All
1149 these conditions are necessary to avoid picking up an entry
1150 whose name clashes with that of the encompassing procedure;
1151 this is handled using gsymbols to register unique, globally
1152 accessible names. */
1153 if (sym->attr.flavor != 0
1154 && sym->attr.proc != 0
1155 && (sym->attr.subroutine || sym->attr.function)
1156 && sym->attr.if_source != IFSRC_UNKNOWN)
1157 gfc_error_now ("Procedure %qs at %C is already defined at %L",
1158 name, &sym->declared_at);
1160 /* Trap a procedure with a name the same as interface in the
1161 encompassing scope. */
1162 if (sym->attr.generic != 0
1163 && (sym->attr.subroutine || sym->attr.function)
1164 && !sym->attr.mod_proc)
1165 gfc_error_now ("Name %qs at %C is already defined"
1166 " as a generic interface at %L",
1167 name, &sym->declared_at);
1169 /* Trap declarations of attributes in encompassing scope. The
1170 signature for this is that ts.kind is set. Legitimate
1171 references only set ts.type. */
1172 if (sym->ts.kind != 0
1173 && !sym->attr.implicit_type
1174 && sym->attr.proc == 0
1175 && gfc_current_ns->parent != NULL
1176 && sym->attr.access == 0
1177 && !module_fcn_entry)
1178 gfc_error_now ("Procedure %qs at %C has an explicit interface "
1179 "and must not have attributes declared at %L",
1180 name, &sym->declared_at);
1183 if (gfc_current_ns->parent == NULL || *result == NULL)
1184 return rc;
1186 /* Module function entries will already have a symtree in
1187 the current namespace but will need one at module level. */
1188 if (module_fcn_entry)
1190 /* Present if entry is declared to be a module procedure. */
1191 rc = gfc_find_sym_tree (name, gfc_current_ns->parent, 0, &st);
1192 if (st == NULL)
1193 st = gfc_new_symtree (&gfc_current_ns->parent->sym_root, name);
1195 else
1196 st = gfc_new_symtree (&gfc_current_ns->sym_root, name);
1198 st->n.sym = sym;
1199 sym->refs++;
1201 /* See if the procedure should be a module procedure. */
1203 if (((sym->ns->proc_name != NULL
1204 && sym->ns->proc_name->attr.flavor == FL_MODULE
1205 && sym->attr.proc != PROC_MODULE)
1206 || (module_fcn_entry && sym->attr.proc != PROC_MODULE))
1207 && !gfc_add_procedure (&sym->attr, PROC_MODULE, sym->name, NULL))
1208 rc = 2;
1210 return rc;
1214 /* Verify that the given symbol representing a parameter is C
1215 interoperable, by checking to see if it was marked as such after
1216 its declaration. If the given symbol is not interoperable, a
1217 warning is reported, thus removing the need to return the status to
1218 the calling function. The standard does not require the user use
1219 one of the iso_c_binding named constants to declare an
1220 interoperable parameter, but we can't be sure if the param is C
1221 interop or not if the user doesn't. For example, integer(4) may be
1222 legal Fortran, but doesn't have meaning in C. It may interop with
1223 a number of the C types, which causes a problem because the
1224 compiler can't know which one. This code is almost certainly not
1225 portable, and the user will get what they deserve if the C type
1226 across platforms isn't always interoperable with integer(4). If
1227 the user had used something like integer(c_int) or integer(c_long),
1228 the compiler could have automatically handled the varying sizes
1229 across platforms. */
1231 bool
1232 gfc_verify_c_interop_param (gfc_symbol *sym)
1234 int is_c_interop = 0;
1235 bool retval = true;
1237 /* We check implicitly typed variables in symbol.c:gfc_set_default_type().
1238 Don't repeat the checks here. */
1239 if (sym->attr.implicit_type)
1240 return true;
1242 /* For subroutines or functions that are passed to a BIND(C) procedure,
1243 they're interoperable if they're BIND(C) and their params are all
1244 interoperable. */
1245 if (sym->attr.flavor == FL_PROCEDURE)
1247 if (sym->attr.is_bind_c == 0)
1249 gfc_error_now ("Procedure %qs at %L must have the BIND(C) "
1250 "attribute to be C interoperable", sym->name,
1251 &(sym->declared_at));
1252 return false;
1254 else
1256 if (sym->attr.is_c_interop == 1)
1257 /* We've already checked this procedure; don't check it again. */
1258 return true;
1259 else
1260 return verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
1261 sym->common_block);
1265 /* See if we've stored a reference to a procedure that owns sym. */
1266 if (sym->ns != NULL && sym->ns->proc_name != NULL)
1268 if (sym->ns->proc_name->attr.is_bind_c == 1)
1270 is_c_interop = (gfc_verify_c_interop(&(sym->ts)) ? 1 : 0);
1272 if (is_c_interop != 1)
1274 /* Make personalized messages to give better feedback. */
1275 if (sym->ts.type == BT_DERIVED)
1276 gfc_error ("Variable %qs at %L is a dummy argument to the "
1277 "BIND(C) procedure %qs but is not C interoperable "
1278 "because derived type %qs is not C interoperable",
1279 sym->name, &(sym->declared_at),
1280 sym->ns->proc_name->name,
1281 sym->ts.u.derived->name);
1282 else if (sym->ts.type == BT_CLASS)
1283 gfc_error ("Variable %qs at %L is a dummy argument to the "
1284 "BIND(C) procedure %qs but is not C interoperable "
1285 "because it is polymorphic",
1286 sym->name, &(sym->declared_at),
1287 sym->ns->proc_name->name);
1288 else if (warn_c_binding_type)
1289 gfc_warning (OPT_Wc_binding_type,
1290 "Variable %qs at %L is a dummy argument of the "
1291 "BIND(C) procedure %qs but may not be C "
1292 "interoperable",
1293 sym->name, &(sym->declared_at),
1294 sym->ns->proc_name->name);
1297 /* Character strings are only C interoperable if they have a
1298 length of 1. */
1299 if (sym->ts.type == BT_CHARACTER)
1301 gfc_charlen *cl = sym->ts.u.cl;
1302 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT
1303 || mpz_cmp_si (cl->length->value.integer, 1) != 0)
1305 gfc_error ("Character argument %qs at %L "
1306 "must be length 1 because "
1307 "procedure %qs is BIND(C)",
1308 sym->name, &sym->declared_at,
1309 sym->ns->proc_name->name);
1310 retval = false;
1314 /* We have to make sure that any param to a bind(c) routine does
1315 not have the allocatable, pointer, or optional attributes,
1316 according to J3/04-007, section 5.1. */
1317 if (sym->attr.allocatable == 1
1318 && !gfc_notify_std (GFC_STD_F2008_TS, "Variable %qs at %L with "
1319 "ALLOCATABLE attribute in procedure %qs "
1320 "with BIND(C)", sym->name,
1321 &(sym->declared_at),
1322 sym->ns->proc_name->name))
1323 retval = false;
1325 if (sym->attr.pointer == 1
1326 && !gfc_notify_std (GFC_STD_F2008_TS, "Variable %qs at %L with "
1327 "POINTER attribute in procedure %qs "
1328 "with BIND(C)", sym->name,
1329 &(sym->declared_at),
1330 sym->ns->proc_name->name))
1331 retval = false;
1333 if ((sym->attr.allocatable || sym->attr.pointer) && !sym->as)
1335 gfc_error ("Scalar variable %qs at %L with POINTER or "
1336 "ALLOCATABLE in procedure %qs with BIND(C) is not yet"
1337 " supported", sym->name, &(sym->declared_at),
1338 sym->ns->proc_name->name);
1339 retval = false;
1342 if (sym->attr.optional == 1 && sym->attr.value)
1344 gfc_error ("Variable %qs at %L cannot have both the OPTIONAL "
1345 "and the VALUE attribute because procedure %qs "
1346 "is BIND(C)", sym->name, &(sym->declared_at),
1347 sym->ns->proc_name->name);
1348 retval = false;
1350 else if (sym->attr.optional == 1
1351 && !gfc_notify_std (GFC_STD_F2008_TS, "Variable %qs "
1352 "at %L with OPTIONAL attribute in "
1353 "procedure %qs which is BIND(C)",
1354 sym->name, &(sym->declared_at),
1355 sym->ns->proc_name->name))
1356 retval = false;
1358 /* Make sure that if it has the dimension attribute, that it is
1359 either assumed size or explicit shape. Deferred shape is already
1360 covered by the pointer/allocatable attribute. */
1361 if (sym->as != NULL && sym->as->type == AS_ASSUMED_SHAPE
1362 && !gfc_notify_std (GFC_STD_F2008_TS, "Assumed-shape array %qs "
1363 "at %L as dummy argument to the BIND(C) "
1364 "procedure %qs at %L", sym->name,
1365 &(sym->declared_at),
1366 sym->ns->proc_name->name,
1367 &(sym->ns->proc_name->declared_at)))
1368 retval = false;
1372 return retval;
1377 /* Function called by variable_decl() that adds a name to the symbol table. */
1379 static bool
1380 build_sym (const char *name, gfc_charlen *cl, bool cl_deferred,
1381 gfc_array_spec **as, locus *var_locus)
1383 symbol_attribute attr;
1384 gfc_symbol *sym;
1385 int upper;
1386 gfc_symtree *st;
1388 /* Symbols in a submodule are host associated from the parent module or
1389 submodules. Therefore, they can be overridden by declarations in the
1390 submodule scope. Deal with this by attaching the existing symbol to
1391 a new symtree and recycling the old symtree with a new symbol... */
1392 st = gfc_find_symtree (gfc_current_ns->sym_root, name);
1393 if (st != NULL && gfc_state_stack->state == COMP_SUBMODULE
1394 && st->n.sym != NULL
1395 && st->n.sym->attr.host_assoc && st->n.sym->attr.used_in_submodule)
1397 gfc_symtree *s = gfc_get_unique_symtree (gfc_current_ns);
1398 s->n.sym = st->n.sym;
1399 sym = gfc_new_symbol (name, gfc_current_ns);
1402 st->n.sym = sym;
1403 sym->refs++;
1404 gfc_set_sym_referenced (sym);
1406 /* ...Otherwise generate a new symtree and new symbol. */
1407 else if (gfc_get_symbol (name, NULL, &sym))
1408 return false;
1410 /* Check if the name has already been defined as a type. The
1411 first letter of the symtree will be in upper case then. Of
1412 course, this is only necessary if the upper case letter is
1413 actually different. */
1415 upper = TOUPPER(name[0]);
1416 if (upper != name[0])
1418 char u_name[GFC_MAX_SYMBOL_LEN + 1];
1419 gfc_symtree *st;
1420 int nlen;
1422 nlen = strlen(name);
1423 gcc_assert (nlen <= GFC_MAX_SYMBOL_LEN);
1424 strncpy (u_name, name, nlen + 1);
1425 u_name[0] = upper;
1427 st = gfc_find_symtree (gfc_current_ns->sym_root, u_name);
1429 /* STRUCTURE types can alias symbol names */
1430 if (st != 0 && st->n.sym->attr.flavor != FL_STRUCT)
1432 gfc_error ("Symbol %qs at %C also declared as a type at %L", name,
1433 &st->n.sym->declared_at);
1434 return false;
1438 /* Start updating the symbol table. Add basic type attribute if present. */
1439 if (current_ts.type != BT_UNKNOWN
1440 && (sym->attr.implicit_type == 0
1441 || !gfc_compare_types (&sym->ts, &current_ts))
1442 && !gfc_add_type (sym, &current_ts, var_locus))
1443 return false;
1445 if (sym->ts.type == BT_CHARACTER)
1447 sym->ts.u.cl = cl;
1448 sym->ts.deferred = cl_deferred;
1451 /* Add dimension attribute if present. */
1452 if (!gfc_set_array_spec (sym, *as, var_locus))
1453 return false;
1454 *as = NULL;
1456 /* Add attribute to symbol. The copy is so that we can reset the
1457 dimension attribute. */
1458 attr = current_attr;
1459 attr.dimension = 0;
1460 attr.codimension = 0;
1462 if (!gfc_copy_attr (&sym->attr, &attr, var_locus))
1463 return false;
1465 /* Finish any work that may need to be done for the binding label,
1466 if it's a bind(c). The bind(c) attr is found before the symbol
1467 is made, and before the symbol name (for data decls), so the
1468 current_ts is holding the binding label, or nothing if the
1469 name= attr wasn't given. Therefore, test here if we're dealing
1470 with a bind(c) and make sure the binding label is set correctly. */
1471 if (sym->attr.is_bind_c == 1)
1473 if (!sym->binding_label)
1475 /* Set the binding label and verify that if a NAME= was specified
1476 then only one identifier was in the entity-decl-list. */
1477 if (!set_binding_label (&sym->binding_label, sym->name,
1478 num_idents_on_line))
1479 return false;
1483 /* See if we know we're in a common block, and if it's a bind(c)
1484 common then we need to make sure we're an interoperable type. */
1485 if (sym->attr.in_common == 1)
1487 /* Test the common block object. */
1488 if (sym->common_block != NULL && sym->common_block->is_bind_c == 1
1489 && sym->ts.is_c_interop != 1)
1491 gfc_error_now ("Variable %qs in common block %qs at %C "
1492 "must be declared with a C interoperable "
1493 "kind since common block %qs is BIND(C)",
1494 sym->name, sym->common_block->name,
1495 sym->common_block->name);
1496 gfc_clear_error ();
1500 sym->attr.implied_index = 0;
1502 if (sym->ts.type == BT_CLASS)
1503 return gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as);
1505 return true;
1509 /* Set character constant to the given length. The constant will be padded or
1510 truncated. If we're inside an array constructor without a typespec, we
1511 additionally check that all elements have the same length; check_len -1
1512 means no checking. */
1514 void
1515 gfc_set_constant_character_len (int len, gfc_expr *expr, int check_len)
1517 gfc_char_t *s;
1518 int slen;
1520 if (expr->ts.type != BT_CHARACTER)
1521 return;
1523 if (expr->expr_type != EXPR_CONSTANT)
1525 gfc_error_now ("CHARACTER length must be a constant at %L", &expr->where);
1526 return;
1529 slen = expr->value.character.length;
1530 if (len != slen)
1532 s = gfc_get_wide_string (len + 1);
1533 memcpy (s, expr->value.character.string,
1534 MIN (len, slen) * sizeof (gfc_char_t));
1535 if (len > slen)
1536 gfc_wide_memset (&s[slen], ' ', len - slen);
1538 if (warn_character_truncation && slen > len)
1539 gfc_warning_now (OPT_Wcharacter_truncation,
1540 "CHARACTER expression at %L is being truncated "
1541 "(%d/%d)", &expr->where, slen, len);
1543 /* Apply the standard by 'hand' otherwise it gets cleared for
1544 initializers. */
1545 if (check_len != -1 && slen != check_len
1546 && !(gfc_option.allow_std & GFC_STD_GNU))
1547 gfc_error_now ("The CHARACTER elements of the array constructor "
1548 "at %L must have the same length (%d/%d)",
1549 &expr->where, slen, check_len);
1551 s[len] = '\0';
1552 free (expr->value.character.string);
1553 expr->value.character.string = s;
1554 expr->value.character.length = len;
1559 /* Function to create and update the enumerator history
1560 using the information passed as arguments.
1561 Pointer "max_enum" is also updated, to point to
1562 enum history node containing largest initializer.
1564 SYM points to the symbol node of enumerator.
1565 INIT points to its enumerator value. */
1567 static void
1568 create_enum_history (gfc_symbol *sym, gfc_expr *init)
1570 enumerator_history *new_enum_history;
1571 gcc_assert (sym != NULL && init != NULL);
1573 new_enum_history = XCNEW (enumerator_history);
1575 new_enum_history->sym = sym;
1576 new_enum_history->initializer = init;
1577 new_enum_history->next = NULL;
1579 if (enum_history == NULL)
1581 enum_history = new_enum_history;
1582 max_enum = enum_history;
1584 else
1586 new_enum_history->next = enum_history;
1587 enum_history = new_enum_history;
1589 if (mpz_cmp (max_enum->initializer->value.integer,
1590 new_enum_history->initializer->value.integer) < 0)
1591 max_enum = new_enum_history;
1596 /* Function to free enum kind history. */
1598 void
1599 gfc_free_enum_history (void)
1601 enumerator_history *current = enum_history;
1602 enumerator_history *next;
1604 while (current != NULL)
1606 next = current->next;
1607 free (current);
1608 current = next;
1610 max_enum = NULL;
1611 enum_history = NULL;
1615 /* Function called by variable_decl() that adds an initialization
1616 expression to a symbol. */
1618 static bool
1619 add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus)
1621 symbol_attribute attr;
1622 gfc_symbol *sym;
1623 gfc_expr *init;
1625 init = *initp;
1626 if (find_special (name, &sym, false))
1627 return false;
1629 attr = sym->attr;
1631 /* If this symbol is confirming an implicit parameter type,
1632 then an initialization expression is not allowed. */
1633 if (attr.flavor == FL_PARAMETER
1634 && sym->value != NULL
1635 && *initp != NULL)
1637 gfc_error ("Initializer not allowed for PARAMETER %qs at %C",
1638 sym->name);
1639 return false;
1642 if (init == NULL)
1644 /* An initializer is required for PARAMETER declarations. */
1645 if (attr.flavor == FL_PARAMETER)
1647 gfc_error ("PARAMETER at %L is missing an initializer", var_locus);
1648 return false;
1651 else
1653 /* If a variable appears in a DATA block, it cannot have an
1654 initializer. */
1655 if (sym->attr.data)
1657 gfc_error ("Variable %qs at %C with an initializer already "
1658 "appears in a DATA statement", sym->name);
1659 return false;
1662 /* Check if the assignment can happen. This has to be put off
1663 until later for derived type variables and procedure pointers. */
1664 if (!gfc_bt_struct (sym->ts.type) && !gfc_bt_struct (init->ts.type)
1665 && sym->ts.type != BT_CLASS && init->ts.type != BT_CLASS
1666 && !sym->attr.proc_pointer
1667 && !gfc_check_assign_symbol (sym, NULL, init))
1668 return false;
1670 if (sym->ts.type == BT_CHARACTER && sym->ts.u.cl
1671 && init->ts.type == BT_CHARACTER)
1673 /* Update symbol character length according initializer. */
1674 if (!gfc_check_assign_symbol (sym, NULL, init))
1675 return false;
1677 if (sym->ts.u.cl->length == NULL)
1679 int clen;
1680 /* If there are multiple CHARACTER variables declared on the
1681 same line, we don't want them to share the same length. */
1682 sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
1684 if (sym->attr.flavor == FL_PARAMETER)
1686 if (init->expr_type == EXPR_CONSTANT)
1688 clen = init->value.character.length;
1689 sym->ts.u.cl->length
1690 = gfc_get_int_expr (gfc_default_integer_kind,
1691 NULL, clen);
1693 else if (init->expr_type == EXPR_ARRAY)
1695 if (init->ts.u.cl)
1697 const gfc_expr *length = init->ts.u.cl->length;
1698 if (length->expr_type != EXPR_CONSTANT)
1700 gfc_error ("Cannot initialize parameter array "
1701 "at %L "
1702 "with variable length elements",
1703 &sym->declared_at);
1704 return false;
1706 clen = mpz_get_si (length->value.integer);
1708 else if (init->value.constructor)
1710 gfc_constructor *c;
1711 c = gfc_constructor_first (init->value.constructor);
1712 clen = c->expr->value.character.length;
1714 else
1715 gcc_unreachable ();
1716 sym->ts.u.cl->length
1717 = gfc_get_int_expr (gfc_default_integer_kind,
1718 NULL, clen);
1720 else if (init->ts.u.cl && init->ts.u.cl->length)
1721 sym->ts.u.cl->length =
1722 gfc_copy_expr (sym->value->ts.u.cl->length);
1725 /* Update initializer character length according symbol. */
1726 else if (sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
1728 int len;
1730 if (!gfc_specification_expr (sym->ts.u.cl->length))
1731 return false;
1733 len = mpz_get_si (sym->ts.u.cl->length->value.integer);
1735 if (init->expr_type == EXPR_CONSTANT)
1736 gfc_set_constant_character_len (len, init, -1);
1737 else if (init->expr_type == EXPR_ARRAY)
1739 gfc_constructor *c;
1741 /* Build a new charlen to prevent simplification from
1742 deleting the length before it is resolved. */
1743 init->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
1744 init->ts.u.cl->length = gfc_copy_expr (sym->ts.u.cl->length);
1746 for (c = gfc_constructor_first (init->value.constructor);
1747 c; c = gfc_constructor_next (c))
1748 gfc_set_constant_character_len (len, c->expr, -1);
1753 /* If sym is implied-shape, set its upper bounds from init. */
1754 if (sym->attr.flavor == FL_PARAMETER && sym->attr.dimension
1755 && sym->as->type == AS_IMPLIED_SHAPE)
1757 int dim;
1759 if (init->rank == 0)
1761 gfc_error ("Can't initialize implied-shape array at %L"
1762 " with scalar", &sym->declared_at);
1763 return false;
1766 /* Shape should be present, we get an initialization expression. */
1767 gcc_assert (init->shape);
1769 for (dim = 0; dim < sym->as->rank; ++dim)
1771 int k;
1772 gfc_expr *e, *lower;
1774 lower = sym->as->lower[dim];
1776 /* If the lower bound is an array element from another
1777 parameterized array, then it is marked with EXPR_VARIABLE and
1778 is an initialization expression. Try to reduce it. */
1779 if (lower->expr_type == EXPR_VARIABLE)
1780 gfc_reduce_init_expr (lower);
1782 if (lower->expr_type == EXPR_CONSTANT)
1784 /* All dimensions must be without upper bound. */
1785 gcc_assert (!sym->as->upper[dim]);
1787 k = lower->ts.kind;
1788 e = gfc_get_constant_expr (BT_INTEGER, k, &sym->declared_at);
1789 mpz_add (e->value.integer, lower->value.integer,
1790 init->shape[dim]);
1791 mpz_sub_ui (e->value.integer, e->value.integer, 1);
1792 sym->as->upper[dim] = e;
1794 else
1796 gfc_error ("Non-constant lower bound in implied-shape"
1797 " declaration at %L", &lower->where);
1798 return false;
1802 sym->as->type = AS_EXPLICIT;
1805 /* Need to check if the expression we initialized this
1806 to was one of the iso_c_binding named constants. If so,
1807 and we're a parameter (constant), let it be iso_c.
1808 For example:
1809 integer(c_int), parameter :: my_int = c_int
1810 integer(my_int) :: my_int_2
1811 If we mark my_int as iso_c (since we can see it's value
1812 is equal to one of the named constants), then my_int_2
1813 will be considered C interoperable. */
1814 if (sym->ts.type != BT_CHARACTER && !gfc_bt_struct (sym->ts.type))
1816 sym->ts.is_iso_c |= init->ts.is_iso_c;
1817 sym->ts.is_c_interop |= init->ts.is_c_interop;
1818 /* attr bits needed for module files. */
1819 sym->attr.is_iso_c |= init->ts.is_iso_c;
1820 sym->attr.is_c_interop |= init->ts.is_c_interop;
1821 if (init->ts.is_iso_c)
1822 sym->ts.f90_type = init->ts.f90_type;
1825 /* Add initializer. Make sure we keep the ranks sane. */
1826 if (sym->attr.dimension && init->rank == 0)
1828 mpz_t size;
1829 gfc_expr *array;
1830 int n;
1831 if (sym->attr.flavor == FL_PARAMETER
1832 && init->expr_type == EXPR_CONSTANT
1833 && spec_size (sym->as, &size)
1834 && mpz_cmp_si (size, 0) > 0)
1836 array = gfc_get_array_expr (init->ts.type, init->ts.kind,
1837 &init->where);
1838 for (n = 0; n < (int)mpz_get_si (size); n++)
1839 gfc_constructor_append_expr (&array->value.constructor,
1840 n == 0
1841 ? init
1842 : gfc_copy_expr (init),
1843 &init->where);
1845 array->shape = gfc_get_shape (sym->as->rank);
1846 for (n = 0; n < sym->as->rank; n++)
1847 spec_dimen_size (sym->as, n, &array->shape[n]);
1849 init = array;
1850 mpz_clear (size);
1852 init->rank = sym->as->rank;
1855 sym->value = init;
1856 if (sym->attr.save == SAVE_NONE)
1857 sym->attr.save = SAVE_IMPLICIT;
1858 *initp = NULL;
1861 return true;
1865 /* Function called by variable_decl() that adds a name to a structure
1866 being built. */
1868 static bool
1869 build_struct (const char *name, gfc_charlen *cl, gfc_expr **init,
1870 gfc_array_spec **as)
1872 gfc_state_data *s;
1873 gfc_component *c;
1875 /* F03:C438/C439. If the current symbol is of the same derived type that we're
1876 constructing, it must have the pointer attribute. */
1877 if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS)
1878 && current_ts.u.derived == gfc_current_block ()
1879 && current_attr.pointer == 0)
1881 if (current_attr.allocatable
1882 && !gfc_notify_std(GFC_STD_F2008, "Component at %C "
1883 "must have the POINTER attribute"))
1885 return false;
1887 else if (current_attr.allocatable == 0)
1889 gfc_error ("Component at %C must have the POINTER attribute");
1890 return false;
1894 /* F03:C437. */
1895 if (current_ts.type == BT_CLASS
1896 && !(current_attr.pointer || current_attr.allocatable))
1898 gfc_error ("Component %qs with CLASS at %C must be allocatable "
1899 "or pointer", name);
1900 return false;
1903 if (gfc_current_block ()->attr.pointer && (*as)->rank != 0)
1905 if ((*as)->type != AS_DEFERRED && (*as)->type != AS_EXPLICIT)
1907 gfc_error ("Array component of structure at %C must have explicit "
1908 "or deferred shape");
1909 return false;
1913 /* If we are in a nested union/map definition, gfc_add_component will not
1914 properly find repeated components because:
1915 (i) gfc_add_component does a flat search, where components of unions
1916 and maps are implicity chained so nested components may conflict.
1917 (ii) Unions and maps are not linked as components of their parent
1918 structures until after they are parsed.
1919 For (i) we use gfc_find_component which searches recursively, and for (ii)
1920 we search each block directly from the parse stack until we find the top
1921 level structure. */
1923 s = gfc_state_stack;
1924 if (s->state == COMP_UNION || s->state == COMP_MAP)
1926 while (s->state == COMP_UNION || gfc_comp_struct (s->state))
1928 c = gfc_find_component (s->sym, name, true, true, NULL);
1929 if (c != NULL)
1931 gfc_error_now ("Component %qs at %C already declared at %L",
1932 name, &c->loc);
1933 return false;
1935 /* Break after we've searched the entire chain. */
1936 if (s->state == COMP_DERIVED || s->state == COMP_STRUCTURE)
1937 break;
1938 s = s->previous;
1942 if (!gfc_add_component (gfc_current_block(), name, &c))
1943 return false;
1945 c->ts = current_ts;
1946 if (c->ts.type == BT_CHARACTER)
1947 c->ts.u.cl = cl;
1948 c->attr = current_attr;
1950 c->initializer = *init;
1951 *init = NULL;
1953 c->as = *as;
1954 if (c->as != NULL)
1956 if (c->as->corank)
1957 c->attr.codimension = 1;
1958 if (c->as->rank)
1959 c->attr.dimension = 1;
1961 *as = NULL;
1963 gfc_apply_init (&c->ts, &c->attr, c->initializer);
1965 /* Check array components. */
1966 if (!c->attr.dimension)
1967 goto scalar;
1969 if (c->attr.pointer)
1971 if (c->as->type != AS_DEFERRED)
1973 gfc_error ("Pointer array component of structure at %C must have a "
1974 "deferred shape");
1975 return false;
1978 else if (c->attr.allocatable)
1980 if (c->as->type != AS_DEFERRED)
1982 gfc_error ("Allocatable component of structure at %C must have a "
1983 "deferred shape");
1984 return false;
1987 else
1989 if (c->as->type != AS_EXPLICIT)
1991 gfc_error ("Array component of structure at %C must have an "
1992 "explicit shape");
1993 return false;
1997 scalar:
1998 if (c->ts.type == BT_CLASS)
1999 return gfc_build_class_symbol (&c->ts, &c->attr, &c->as);
2001 return true;
2005 /* Match a 'NULL()', and possibly take care of some side effects. */
2007 match
2008 gfc_match_null (gfc_expr **result)
2010 gfc_symbol *sym;
2011 match m, m2 = MATCH_NO;
2013 if ((m = gfc_match (" null ( )")) == MATCH_ERROR)
2014 return MATCH_ERROR;
2016 if (m == MATCH_NO)
2018 locus old_loc;
2019 char name[GFC_MAX_SYMBOL_LEN + 1];
2021 if ((m2 = gfc_match (" null (")) != MATCH_YES)
2022 return m2;
2024 old_loc = gfc_current_locus;
2025 if ((m2 = gfc_match (" %n ) ", name)) == MATCH_ERROR)
2026 return MATCH_ERROR;
2027 if (m2 != MATCH_YES
2028 && ((m2 = gfc_match (" mold = %n )", name)) == MATCH_ERROR))
2029 return MATCH_ERROR;
2030 if (m2 == MATCH_NO)
2032 gfc_current_locus = old_loc;
2033 return MATCH_NO;
2037 /* The NULL symbol now has to be/become an intrinsic function. */
2038 if (gfc_get_symbol ("null", NULL, &sym))
2040 gfc_error ("NULL() initialization at %C is ambiguous");
2041 return MATCH_ERROR;
2044 gfc_intrinsic_symbol (sym);
2046 if (sym->attr.proc != PROC_INTRINSIC
2047 && !(sym->attr.use_assoc && sym->attr.intrinsic)
2048 && (!gfc_add_procedure(&sym->attr, PROC_INTRINSIC, sym->name, NULL)
2049 || !gfc_add_function (&sym->attr, sym->name, NULL)))
2050 return MATCH_ERROR;
2052 *result = gfc_get_null_expr (&gfc_current_locus);
2054 /* Invalid per F2008, C512. */
2055 if (m2 == MATCH_YES)
2057 gfc_error ("NULL() initialization at %C may not have MOLD");
2058 return MATCH_ERROR;
2061 return MATCH_YES;
2065 /* Match the initialization expr for a data pointer or procedure pointer. */
2067 static match
2068 match_pointer_init (gfc_expr **init, int procptr)
2070 match m;
2072 if (gfc_pure (NULL) && !gfc_comp_struct (gfc_state_stack->state))
2074 gfc_error ("Initialization of pointer at %C is not allowed in "
2075 "a PURE procedure");
2076 return MATCH_ERROR;
2078 gfc_unset_implicit_pure (gfc_current_ns->proc_name);
2080 /* Match NULL() initialization. */
2081 m = gfc_match_null (init);
2082 if (m != MATCH_NO)
2083 return m;
2085 /* Match non-NULL initialization. */
2086 gfc_matching_ptr_assignment = !procptr;
2087 gfc_matching_procptr_assignment = procptr;
2088 m = gfc_match_rvalue (init);
2089 gfc_matching_ptr_assignment = 0;
2090 gfc_matching_procptr_assignment = 0;
2091 if (m == MATCH_ERROR)
2092 return MATCH_ERROR;
2093 else if (m == MATCH_NO)
2095 gfc_error ("Error in pointer initialization at %C");
2096 return MATCH_ERROR;
2099 if (!procptr && !gfc_resolve_expr (*init))
2100 return MATCH_ERROR;
2102 if (!gfc_notify_std (GFC_STD_F2008, "non-NULL pointer "
2103 "initialization at %C"))
2104 return MATCH_ERROR;
2106 return MATCH_YES;
2110 static bool
2111 check_function_name (char *name)
2113 /* In functions that have a RESULT variable defined, the function name always
2114 refers to function calls. Therefore, the name is not allowed to appear in
2115 specification statements. When checking this, be careful about
2116 'hidden' procedure pointer results ('ppr@'). */
2118 if (gfc_current_state () == COMP_FUNCTION)
2120 gfc_symbol *block = gfc_current_block ();
2121 if (block && block->result && block->result != block
2122 && strcmp (block->result->name, "ppr@") != 0
2123 && strcmp (block->name, name) == 0)
2125 gfc_error ("Function name %qs not allowed at %C", name);
2126 return false;
2130 return true;
2134 /* Match a variable name with an optional initializer. When this
2135 subroutine is called, a variable is expected to be parsed next.
2136 Depending on what is happening at the moment, updates either the
2137 symbol table or the current interface. */
2139 static match
2140 variable_decl (int elem)
2142 char name[GFC_MAX_SYMBOL_LEN + 1];
2143 gfc_expr *initializer, *char_len;
2144 gfc_array_spec *as;
2145 gfc_array_spec *cp_as; /* Extra copy for Cray Pointees. */
2146 gfc_charlen *cl;
2147 bool cl_deferred;
2148 locus var_locus;
2149 match m;
2150 bool t;
2151 gfc_symbol *sym;
2153 initializer = NULL;
2154 as = NULL;
2155 cp_as = NULL;
2157 /* When we get here, we've just matched a list of attributes and
2158 maybe a type and a double colon. The next thing we expect to see
2159 is the name of the symbol. */
2160 m = gfc_match_name (name);
2161 if (m != MATCH_YES)
2162 goto cleanup;
2164 var_locus = gfc_current_locus;
2166 /* Now we could see the optional array spec. or character length. */
2167 m = gfc_match_array_spec (&as, true, true);
2168 if (m == MATCH_ERROR)
2169 goto cleanup;
2171 if (m == MATCH_NO)
2172 as = gfc_copy_array_spec (current_as);
2173 else if (current_as
2174 && !merge_array_spec (current_as, as, true))
2176 m = MATCH_ERROR;
2177 goto cleanup;
2180 if (flag_cray_pointer)
2181 cp_as = gfc_copy_array_spec (as);
2183 /* At this point, we know for sure if the symbol is PARAMETER and can thus
2184 determine (and check) whether it can be implied-shape. If it
2185 was parsed as assumed-size, change it because PARAMETERs can not
2186 be assumed-size. */
2187 if (as)
2189 if (as->type == AS_IMPLIED_SHAPE && current_attr.flavor != FL_PARAMETER)
2191 m = MATCH_ERROR;
2192 gfc_error ("Non-PARAMETER symbol %qs at %L can't be implied-shape",
2193 name, &var_locus);
2194 goto cleanup;
2197 if (as->type == AS_ASSUMED_SIZE && as->rank == 1
2198 && current_attr.flavor == FL_PARAMETER)
2199 as->type = AS_IMPLIED_SHAPE;
2201 if (as->type == AS_IMPLIED_SHAPE
2202 && !gfc_notify_std (GFC_STD_F2008, "Implied-shape array at %L",
2203 &var_locus))
2205 m = MATCH_ERROR;
2206 goto cleanup;
2210 char_len = NULL;
2211 cl = NULL;
2212 cl_deferred = false;
2214 if (current_ts.type == BT_CHARACTER)
2216 switch (match_char_length (&char_len, &cl_deferred, false))
2218 case MATCH_YES:
2219 cl = gfc_new_charlen (gfc_current_ns, NULL);
2221 cl->length = char_len;
2222 break;
2224 /* Non-constant lengths need to be copied after the first
2225 element. Also copy assumed lengths. */
2226 case MATCH_NO:
2227 if (elem > 1
2228 && (current_ts.u.cl->length == NULL
2229 || current_ts.u.cl->length->expr_type != EXPR_CONSTANT))
2231 cl = gfc_new_charlen (gfc_current_ns, NULL);
2232 cl->length = gfc_copy_expr (current_ts.u.cl->length);
2234 else
2235 cl = current_ts.u.cl;
2237 cl_deferred = current_ts.deferred;
2239 break;
2241 case MATCH_ERROR:
2242 goto cleanup;
2246 /* The dummy arguments and result of the abreviated form of MODULE
2247 PROCEDUREs, used in SUBMODULES should not be redefined. */
2248 if (gfc_current_ns->proc_name
2249 && gfc_current_ns->proc_name->abr_modproc_decl)
2251 gfc_find_symbol (name, gfc_current_ns, 1, &sym);
2252 if (sym != NULL && (sym->attr.dummy || sym->attr.result))
2254 m = MATCH_ERROR;
2255 gfc_error ("%qs at %C is a redefinition of the declaration "
2256 "in the corresponding interface for MODULE "
2257 "PROCEDURE %qs", sym->name,
2258 gfc_current_ns->proc_name->name);
2259 goto cleanup;
2263 /* If this symbol has already shown up in a Cray Pointer declaration,
2264 and this is not a component declaration,
2265 then we want to set the type & bail out. */
2266 if (flag_cray_pointer && !gfc_comp_struct (gfc_current_state ()))
2268 gfc_find_symbol (name, gfc_current_ns, 1, &sym);
2269 if (sym != NULL && sym->attr.cray_pointee)
2271 sym->ts.type = current_ts.type;
2272 sym->ts.kind = current_ts.kind;
2273 sym->ts.u.cl = cl;
2274 sym->ts.u.derived = current_ts.u.derived;
2275 sym->ts.is_c_interop = current_ts.is_c_interop;
2276 sym->ts.is_iso_c = current_ts.is_iso_c;
2277 m = MATCH_YES;
2279 /* Check to see if we have an array specification. */
2280 if (cp_as != NULL)
2282 if (sym->as != NULL)
2284 gfc_error ("Duplicate array spec for Cray pointee at %C");
2285 gfc_free_array_spec (cp_as);
2286 m = MATCH_ERROR;
2287 goto cleanup;
2289 else
2291 if (!gfc_set_array_spec (sym, cp_as, &var_locus))
2292 gfc_internal_error ("Couldn't set pointee array spec.");
2294 /* Fix the array spec. */
2295 m = gfc_mod_pointee_as (sym->as);
2296 if (m == MATCH_ERROR)
2297 goto cleanup;
2300 goto cleanup;
2302 else
2304 gfc_free_array_spec (cp_as);
2308 /* Procedure pointer as function result. */
2309 if (gfc_current_state () == COMP_FUNCTION
2310 && strcmp ("ppr@", gfc_current_block ()->name) == 0
2311 && strcmp (name, gfc_current_block ()->ns->proc_name->name) == 0)
2312 strcpy (name, "ppr@");
2314 if (gfc_current_state () == COMP_FUNCTION
2315 && strcmp (name, gfc_current_block ()->name) == 0
2316 && gfc_current_block ()->result
2317 && strcmp ("ppr@", gfc_current_block ()->result->name) == 0)
2318 strcpy (name, "ppr@");
2320 /* OK, we've successfully matched the declaration. Now put the
2321 symbol in the current namespace, because it might be used in the
2322 optional initialization expression for this symbol, e.g. this is
2323 perfectly legal:
2325 integer, parameter :: i = huge(i)
2327 This is only true for parameters or variables of a basic type.
2328 For components of derived types, it is not true, so we don't
2329 create a symbol for those yet. If we fail to create the symbol,
2330 bail out. */
2331 if (!gfc_comp_struct (gfc_current_state ())
2332 && !build_sym (name, cl, cl_deferred, &as, &var_locus))
2334 m = MATCH_ERROR;
2335 goto cleanup;
2338 if (!check_function_name (name))
2340 m = MATCH_ERROR;
2341 goto cleanup;
2344 /* We allow old-style initializations of the form
2345 integer i /2/, j(4) /3*3, 1/
2346 (if no colon has been seen). These are different from data
2347 statements in that initializers are only allowed to apply to the
2348 variable immediately preceding, i.e.
2349 integer i, j /1, 2/
2350 is not allowed. Therefore we have to do some work manually, that
2351 could otherwise be left to the matchers for DATA statements. */
2353 if (!colon_seen && gfc_match (" /") == MATCH_YES)
2355 if (!gfc_notify_std (GFC_STD_GNU, "Old-style "
2356 "initialization at %C"))
2357 return MATCH_ERROR;
2359 /* Allow old style initializations for components of STRUCTUREs and MAPs
2360 but not components of derived types. */
2361 else if (gfc_current_state () == COMP_DERIVED)
2363 gfc_error ("Invalid old style initialization for derived type "
2364 "component at %C");
2365 m = MATCH_ERROR;
2366 goto cleanup;
2369 /* For structure components, read the initializer as a special
2370 expression and let the rest of this function apply the initializer
2371 as usual. */
2372 else if (gfc_comp_struct (gfc_current_state ()))
2374 m = match_clist_expr (&initializer, &current_ts, as);
2375 if (m == MATCH_NO)
2376 gfc_error ("Syntax error in old style initialization of %s at %C",
2377 name);
2378 if (m != MATCH_YES)
2379 goto cleanup;
2382 /* Otherwise we treat the old style initialization just like a
2383 DATA declaration for the current variable. */
2384 else
2385 return match_old_style_init (name);
2388 /* The double colon must be present in order to have initializers.
2389 Otherwise the statement is ambiguous with an assignment statement. */
2390 if (colon_seen)
2392 if (gfc_match (" =>") == MATCH_YES)
2394 if (!current_attr.pointer)
2396 gfc_error ("Initialization at %C isn't for a pointer variable");
2397 m = MATCH_ERROR;
2398 goto cleanup;
2401 m = match_pointer_init (&initializer, 0);
2402 if (m != MATCH_YES)
2403 goto cleanup;
2405 else if (gfc_match_char ('=') == MATCH_YES)
2407 if (current_attr.pointer)
2409 gfc_error ("Pointer initialization at %C requires %<=>%>, "
2410 "not %<=%>");
2411 m = MATCH_ERROR;
2412 goto cleanup;
2415 m = gfc_match_init_expr (&initializer);
2416 if (m == MATCH_NO)
2418 gfc_error ("Expected an initialization expression at %C");
2419 m = MATCH_ERROR;
2422 if (current_attr.flavor != FL_PARAMETER && gfc_pure (NULL)
2423 && !gfc_comp_struct (gfc_state_stack->state))
2425 gfc_error ("Initialization of variable at %C is not allowed in "
2426 "a PURE procedure");
2427 m = MATCH_ERROR;
2430 if (current_attr.flavor != FL_PARAMETER
2431 && !gfc_comp_struct (gfc_state_stack->state))
2432 gfc_unset_implicit_pure (gfc_current_ns->proc_name);
2434 if (m != MATCH_YES)
2435 goto cleanup;
2439 if (initializer != NULL && current_attr.allocatable
2440 && gfc_comp_struct (gfc_current_state ()))
2442 gfc_error ("Initialization of allocatable component at %C is not "
2443 "allowed");
2444 m = MATCH_ERROR;
2445 goto cleanup;
2448 /* Add the initializer. Note that it is fine if initializer is
2449 NULL here, because we sometimes also need to check if a
2450 declaration *must* have an initialization expression. */
2451 if (!gfc_comp_struct (gfc_current_state ()))
2452 t = add_init_expr_to_sym (name, &initializer, &var_locus);
2453 else
2455 if (current_ts.type == BT_DERIVED
2456 && !current_attr.pointer && !initializer)
2457 initializer = gfc_default_initializer (&current_ts);
2458 t = build_struct (name, cl, &initializer, &as);
2460 /* If we match a nested structure definition we expect to see the
2461 * body even if the variable declarations blow up, so we need to keep
2462 * the structure declaration around. */
2463 if (gfc_new_block && gfc_new_block->attr.flavor == FL_STRUCT)
2464 gfc_commit_symbol (gfc_new_block);
2467 m = (t) ? MATCH_YES : MATCH_ERROR;
2469 cleanup:
2470 /* Free stuff up and return. */
2471 gfc_free_expr (initializer);
2472 gfc_free_array_spec (as);
2474 return m;
2478 /* Match an extended-f77 "TYPESPEC*bytesize"-style kind specification.
2479 This assumes that the byte size is equal to the kind number for
2480 non-COMPLEX types, and equal to twice the kind number for COMPLEX. */
2482 match
2483 gfc_match_old_kind_spec (gfc_typespec *ts)
2485 match m;
2486 int original_kind;
2488 if (gfc_match_char ('*') != MATCH_YES)
2489 return MATCH_NO;
2491 m = gfc_match_small_literal_int (&ts->kind, NULL);
2492 if (m != MATCH_YES)
2493 return MATCH_ERROR;
2495 original_kind = ts->kind;
2497 /* Massage the kind numbers for complex types. */
2498 if (ts->type == BT_COMPLEX)
2500 if (ts->kind % 2)
2502 gfc_error ("Old-style type declaration %s*%d not supported at %C",
2503 gfc_basic_typename (ts->type), original_kind);
2504 return MATCH_ERROR;
2506 ts->kind /= 2;
2510 if (ts->type == BT_INTEGER && ts->kind == 4 && flag_integer4_kind == 8)
2511 ts->kind = 8;
2513 if (ts->type == BT_REAL || ts->type == BT_COMPLEX)
2515 if (ts->kind == 4)
2517 if (flag_real4_kind == 8)
2518 ts->kind = 8;
2519 if (flag_real4_kind == 10)
2520 ts->kind = 10;
2521 if (flag_real4_kind == 16)
2522 ts->kind = 16;
2525 if (ts->kind == 8)
2527 if (flag_real8_kind == 4)
2528 ts->kind = 4;
2529 if (flag_real8_kind == 10)
2530 ts->kind = 10;
2531 if (flag_real8_kind == 16)
2532 ts->kind = 16;
2536 if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
2538 gfc_error ("Old-style type declaration %s*%d not supported at %C",
2539 gfc_basic_typename (ts->type), original_kind);
2540 return MATCH_ERROR;
2543 if (!gfc_notify_std (GFC_STD_GNU,
2544 "Nonstandard type declaration %s*%d at %C",
2545 gfc_basic_typename(ts->type), original_kind))
2546 return MATCH_ERROR;
2548 return MATCH_YES;
2552 /* Match a kind specification. Since kinds are generally optional, we
2553 usually return MATCH_NO if something goes wrong. If a "kind="
2554 string is found, then we know we have an error. */
2556 match
2557 gfc_match_kind_spec (gfc_typespec *ts, bool kind_expr_only)
2559 locus where, loc;
2560 gfc_expr *e;
2561 match m, n;
2562 char c;
2564 m = MATCH_NO;
2565 n = MATCH_YES;
2566 e = NULL;
2568 where = loc = gfc_current_locus;
2570 if (kind_expr_only)
2571 goto kind_expr;
2573 if (gfc_match_char ('(') == MATCH_NO)
2574 return MATCH_NO;
2576 /* Also gobbles optional text. */
2577 if (gfc_match (" kind = ") == MATCH_YES)
2578 m = MATCH_ERROR;
2580 loc = gfc_current_locus;
2582 kind_expr:
2583 n = gfc_match_init_expr (&e);
2585 if (n != MATCH_YES)
2587 if (gfc_matching_function)
2589 /* The function kind expression might include use associated or
2590 imported parameters and try again after the specification
2591 expressions..... */
2592 if (gfc_match_char (')') != MATCH_YES)
2594 gfc_error ("Missing right parenthesis at %C");
2595 m = MATCH_ERROR;
2596 goto no_match;
2599 gfc_free_expr (e);
2600 gfc_undo_symbols ();
2601 return MATCH_YES;
2603 else
2605 /* ....or else, the match is real. */
2606 if (n == MATCH_NO)
2607 gfc_error ("Expected initialization expression at %C");
2608 if (n != MATCH_YES)
2609 return MATCH_ERROR;
2613 if (e->rank != 0)
2615 gfc_error ("Expected scalar initialization expression at %C");
2616 m = MATCH_ERROR;
2617 goto no_match;
2620 if (gfc_extract_int (e, &ts->kind, 1))
2622 m = MATCH_ERROR;
2623 goto no_match;
2626 /* Before throwing away the expression, let's see if we had a
2627 C interoperable kind (and store the fact). */
2628 if (e->ts.is_c_interop == 1)
2630 /* Mark this as C interoperable if being declared with one
2631 of the named constants from iso_c_binding. */
2632 ts->is_c_interop = e->ts.is_iso_c;
2633 ts->f90_type = e->ts.f90_type;
2636 gfc_free_expr (e);
2637 e = NULL;
2639 /* Ignore errors to this point, if we've gotten here. This means
2640 we ignore the m=MATCH_ERROR from above. */
2641 if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
2643 gfc_error ("Kind %d not supported for type %s at %C", ts->kind,
2644 gfc_basic_typename (ts->type));
2645 gfc_current_locus = where;
2646 return MATCH_ERROR;
2649 /* Warn if, e.g., c_int is used for a REAL variable, but not
2650 if, e.g., c_double is used for COMPLEX as the standard
2651 explicitly says that the kind type parameter for complex and real
2652 variable is the same, i.e. c_float == c_float_complex. */
2653 if (ts->f90_type != BT_UNKNOWN && ts->f90_type != ts->type
2654 && !((ts->f90_type == BT_REAL && ts->type == BT_COMPLEX)
2655 || (ts->f90_type == BT_COMPLEX && ts->type == BT_REAL)))
2656 gfc_warning_now (0, "C kind type parameter is for type %s but type at %L "
2657 "is %s", gfc_basic_typename (ts->f90_type), &where,
2658 gfc_basic_typename (ts->type));
2660 gfc_gobble_whitespace ();
2661 if ((c = gfc_next_ascii_char ()) != ')'
2662 && (ts->type != BT_CHARACTER || c != ','))
2664 if (ts->type == BT_CHARACTER)
2665 gfc_error ("Missing right parenthesis or comma at %C");
2666 else
2667 gfc_error ("Missing right parenthesis at %C");
2668 m = MATCH_ERROR;
2670 else
2671 /* All tests passed. */
2672 m = MATCH_YES;
2674 if(m == MATCH_ERROR)
2675 gfc_current_locus = where;
2677 if (ts->type == BT_INTEGER && ts->kind == 4 && flag_integer4_kind == 8)
2678 ts->kind = 8;
2680 if (ts->type == BT_REAL || ts->type == BT_COMPLEX)
2682 if (ts->kind == 4)
2684 if (flag_real4_kind == 8)
2685 ts->kind = 8;
2686 if (flag_real4_kind == 10)
2687 ts->kind = 10;
2688 if (flag_real4_kind == 16)
2689 ts->kind = 16;
2692 if (ts->kind == 8)
2694 if (flag_real8_kind == 4)
2695 ts->kind = 4;
2696 if (flag_real8_kind == 10)
2697 ts->kind = 10;
2698 if (flag_real8_kind == 16)
2699 ts->kind = 16;
2703 /* Return what we know from the test(s). */
2704 return m;
2706 no_match:
2707 gfc_free_expr (e);
2708 gfc_current_locus = where;
2709 return m;
2713 static match
2714 match_char_kind (int * kind, int * is_iso_c)
2716 locus where;
2717 gfc_expr *e;
2718 match m, n;
2719 bool fail;
2721 m = MATCH_NO;
2722 e = NULL;
2723 where = gfc_current_locus;
2725 n = gfc_match_init_expr (&e);
2727 if (n != MATCH_YES && gfc_matching_function)
2729 /* The expression might include use-associated or imported
2730 parameters and try again after the specification
2731 expressions. */
2732 gfc_free_expr (e);
2733 gfc_undo_symbols ();
2734 return MATCH_YES;
2737 if (n == MATCH_NO)
2738 gfc_error ("Expected initialization expression at %C");
2739 if (n != MATCH_YES)
2740 return MATCH_ERROR;
2742 if (e->rank != 0)
2744 gfc_error ("Expected scalar initialization expression at %C");
2745 m = MATCH_ERROR;
2746 goto no_match;
2749 fail = gfc_extract_int (e, kind, 1);
2750 *is_iso_c = e->ts.is_iso_c;
2751 if (fail)
2753 m = MATCH_ERROR;
2754 goto no_match;
2757 gfc_free_expr (e);
2759 /* Ignore errors to this point, if we've gotten here. This means
2760 we ignore the m=MATCH_ERROR from above. */
2761 if (gfc_validate_kind (BT_CHARACTER, *kind, true) < 0)
2763 gfc_error ("Kind %d is not supported for CHARACTER at %C", *kind);
2764 m = MATCH_ERROR;
2766 else
2767 /* All tests passed. */
2768 m = MATCH_YES;
2770 if (m == MATCH_ERROR)
2771 gfc_current_locus = where;
2773 /* Return what we know from the test(s). */
2774 return m;
2776 no_match:
2777 gfc_free_expr (e);
2778 gfc_current_locus = where;
2779 return m;
2783 /* Match the various kind/length specifications in a CHARACTER
2784 declaration. We don't return MATCH_NO. */
2786 match
2787 gfc_match_char_spec (gfc_typespec *ts)
2789 int kind, seen_length, is_iso_c;
2790 gfc_charlen *cl;
2791 gfc_expr *len;
2792 match m;
2793 bool deferred;
2795 len = NULL;
2796 seen_length = 0;
2797 kind = 0;
2798 is_iso_c = 0;
2799 deferred = false;
2801 /* Try the old-style specification first. */
2802 old_char_selector = 0;
2804 m = match_char_length (&len, &deferred, true);
2805 if (m != MATCH_NO)
2807 if (m == MATCH_YES)
2808 old_char_selector = 1;
2809 seen_length = 1;
2810 goto done;
2813 m = gfc_match_char ('(');
2814 if (m != MATCH_YES)
2816 m = MATCH_YES; /* Character without length is a single char. */
2817 goto done;
2820 /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ). */
2821 if (gfc_match (" kind =") == MATCH_YES)
2823 m = match_char_kind (&kind, &is_iso_c);
2825 if (m == MATCH_ERROR)
2826 goto done;
2827 if (m == MATCH_NO)
2828 goto syntax;
2830 if (gfc_match (" , len =") == MATCH_NO)
2831 goto rparen;
2833 m = char_len_param_value (&len, &deferred);
2834 if (m == MATCH_NO)
2835 goto syntax;
2836 if (m == MATCH_ERROR)
2837 goto done;
2838 seen_length = 1;
2840 goto rparen;
2843 /* Try to match "LEN = <len-param>" or "LEN = <len-param>, KIND = <int>". */
2844 if (gfc_match (" len =") == MATCH_YES)
2846 m = char_len_param_value (&len, &deferred);
2847 if (m == MATCH_NO)
2848 goto syntax;
2849 if (m == MATCH_ERROR)
2850 goto done;
2851 seen_length = 1;
2853 if (gfc_match_char (')') == MATCH_YES)
2854 goto done;
2856 if (gfc_match (" , kind =") != MATCH_YES)
2857 goto syntax;
2859 if (match_char_kind (&kind, &is_iso_c) == MATCH_ERROR)
2860 goto done;
2862 goto rparen;
2865 /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ). */
2866 m = char_len_param_value (&len, &deferred);
2867 if (m == MATCH_NO)
2868 goto syntax;
2869 if (m == MATCH_ERROR)
2870 goto done;
2871 seen_length = 1;
2873 m = gfc_match_char (')');
2874 if (m == MATCH_YES)
2875 goto done;
2877 if (gfc_match_char (',') != MATCH_YES)
2878 goto syntax;
2880 gfc_match (" kind ="); /* Gobble optional text. */
2882 m = match_char_kind (&kind, &is_iso_c);
2883 if (m == MATCH_ERROR)
2884 goto done;
2885 if (m == MATCH_NO)
2886 goto syntax;
2888 rparen:
2889 /* Require a right-paren at this point. */
2890 m = gfc_match_char (')');
2891 if (m == MATCH_YES)
2892 goto done;
2894 syntax:
2895 gfc_error ("Syntax error in CHARACTER declaration at %C");
2896 m = MATCH_ERROR;
2897 gfc_free_expr (len);
2898 return m;
2900 done:
2901 /* Deal with character functions after USE and IMPORT statements. */
2902 if (gfc_matching_function)
2904 gfc_free_expr (len);
2905 gfc_undo_symbols ();
2906 return MATCH_YES;
2909 if (m != MATCH_YES)
2911 gfc_free_expr (len);
2912 return m;
2915 /* Do some final massaging of the length values. */
2916 cl = gfc_new_charlen (gfc_current_ns, NULL);
2918 if (seen_length == 0)
2919 cl->length = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
2920 else
2921 cl->length = len;
2923 ts->u.cl = cl;
2924 ts->kind = kind == 0 ? gfc_default_character_kind : kind;
2925 ts->deferred = deferred;
2927 /* We have to know if it was a C interoperable kind so we can
2928 do accurate type checking of bind(c) procs, etc. */
2929 if (kind != 0)
2930 /* Mark this as C interoperable if being declared with one
2931 of the named constants from iso_c_binding. */
2932 ts->is_c_interop = is_iso_c;
2933 else if (len != NULL)
2934 /* Here, we might have parsed something such as: character(c_char)
2935 In this case, the parsing code above grabs the c_char when
2936 looking for the length (line 1690, roughly). it's the last
2937 testcase for parsing the kind params of a character variable.
2938 However, it's not actually the length. this seems like it
2939 could be an error.
2940 To see if the user used a C interop kind, test the expr
2941 of the so called length, and see if it's C interoperable. */
2942 ts->is_c_interop = len->ts.is_iso_c;
2944 return MATCH_YES;
2948 /* Matches a RECORD declaration. */
2950 static match
2951 match_record_decl (char *name)
2953 locus old_loc;
2954 old_loc = gfc_current_locus;
2955 match m;
2957 m = gfc_match (" record /");
2958 if (m == MATCH_YES)
2960 if (!flag_dec_structure)
2962 gfc_current_locus = old_loc;
2963 gfc_error ("RECORD at %C is an extension, enable it with "
2964 "-fdec-structure");
2965 return MATCH_ERROR;
2967 m = gfc_match (" %n/", name);
2968 if (m == MATCH_YES)
2969 return MATCH_YES;
2972 gfc_current_locus = old_loc;
2973 if (flag_dec_structure
2974 && (gfc_match (" record% ") == MATCH_YES
2975 || gfc_match (" record%t") == MATCH_YES))
2976 gfc_error ("Structure name expected after RECORD at %C");
2977 if (m == MATCH_NO)
2978 return MATCH_NO;
2980 return MATCH_ERROR;
2983 /* Matches a declaration-type-spec (F03:R502). If successful, sets the ts
2984 structure to the matched specification. This is necessary for FUNCTION and
2985 IMPLICIT statements.
2987 If implicit_flag is nonzero, then we don't check for the optional
2988 kind specification. Not doing so is needed for matching an IMPLICIT
2989 statement correctly. */
2991 match
2992 gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
2994 char name[GFC_MAX_SYMBOL_LEN + 1];
2995 gfc_symbol *sym, *dt_sym;
2996 match m;
2997 char c;
2998 bool seen_deferred_kind, matched_type;
2999 const char *dt_name;
3001 /* A belt and braces check that the typespec is correctly being treated
3002 as a deferred characteristic association. */
3003 seen_deferred_kind = (gfc_current_state () == COMP_FUNCTION)
3004 && (gfc_current_block ()->result->ts.kind == -1)
3005 && (ts->kind == -1);
3006 gfc_clear_ts (ts);
3007 if (seen_deferred_kind)
3008 ts->kind = -1;
3010 /* Clear the current binding label, in case one is given. */
3011 curr_binding_label = NULL;
3013 if (gfc_match (" byte") == MATCH_YES)
3015 if (!gfc_notify_std (GFC_STD_GNU, "BYTE type at %C"))
3016 return MATCH_ERROR;
3018 if (gfc_validate_kind (BT_INTEGER, 1, true) < 0)
3020 gfc_error ("BYTE type used at %C "
3021 "is not available on the target machine");
3022 return MATCH_ERROR;
3025 ts->type = BT_INTEGER;
3026 ts->kind = 1;
3027 return MATCH_YES;
3031 m = gfc_match (" type (");
3032 matched_type = (m == MATCH_YES);
3033 if (matched_type)
3035 gfc_gobble_whitespace ();
3036 if (gfc_peek_ascii_char () == '*')
3038 if ((m = gfc_match ("*)")) != MATCH_YES)
3039 return m;
3040 if (gfc_comp_struct (gfc_current_state ()))
3042 gfc_error ("Assumed type at %C is not allowed for components");
3043 return MATCH_ERROR;
3045 if (!gfc_notify_std (GFC_STD_F2008_TS, "Assumed type "
3046 "at %C"))
3047 return MATCH_ERROR;
3048 ts->type = BT_ASSUMED;
3049 return MATCH_YES;
3052 m = gfc_match ("%n", name);
3053 matched_type = (m == MATCH_YES);
3056 if ((matched_type && strcmp ("integer", name) == 0)
3057 || (!matched_type && gfc_match (" integer") == MATCH_YES))
3059 ts->type = BT_INTEGER;
3060 ts->kind = gfc_default_integer_kind;
3061 goto get_kind;
3064 if ((matched_type && strcmp ("character", name) == 0)
3065 || (!matched_type && gfc_match (" character") == MATCH_YES))
3067 if (matched_type
3068 && !gfc_notify_std (GFC_STD_F2008, "TYPE with "
3069 "intrinsic-type-spec at %C"))
3070 return MATCH_ERROR;
3072 ts->type = BT_CHARACTER;
3073 if (implicit_flag == 0)
3074 m = gfc_match_char_spec (ts);
3075 else
3076 m = MATCH_YES;
3078 if (matched_type && m == MATCH_YES && gfc_match_char (')') != MATCH_YES)
3079 m = MATCH_ERROR;
3081 return m;
3084 if ((matched_type && strcmp ("real", name) == 0)
3085 || (!matched_type && gfc_match (" real") == MATCH_YES))
3087 ts->type = BT_REAL;
3088 ts->kind = gfc_default_real_kind;
3089 goto get_kind;
3092 if ((matched_type
3093 && (strcmp ("doubleprecision", name) == 0
3094 || (strcmp ("double", name) == 0
3095 && gfc_match (" precision") == MATCH_YES)))
3096 || (!matched_type && gfc_match (" double precision") == MATCH_YES))
3098 if (matched_type
3099 && !gfc_notify_std (GFC_STD_F2008, "TYPE with "
3100 "intrinsic-type-spec at %C"))
3101 return MATCH_ERROR;
3102 if (matched_type && gfc_match_char (')') != MATCH_YES)
3103 return MATCH_ERROR;
3105 ts->type = BT_REAL;
3106 ts->kind = gfc_default_double_kind;
3107 return MATCH_YES;
3110 if ((matched_type && strcmp ("complex", name) == 0)
3111 || (!matched_type && gfc_match (" complex") == MATCH_YES))
3113 ts->type = BT_COMPLEX;
3114 ts->kind = gfc_default_complex_kind;
3115 goto get_kind;
3118 if ((matched_type
3119 && (strcmp ("doublecomplex", name) == 0
3120 || (strcmp ("double", name) == 0
3121 && gfc_match (" complex") == MATCH_YES)))
3122 || (!matched_type && gfc_match (" double complex") == MATCH_YES))
3124 if (!gfc_notify_std (GFC_STD_GNU, "DOUBLE COMPLEX at %C"))
3125 return MATCH_ERROR;
3127 if (matched_type
3128 && !gfc_notify_std (GFC_STD_F2008, "TYPE with "
3129 "intrinsic-type-spec at %C"))
3130 return MATCH_ERROR;
3132 if (matched_type && gfc_match_char (')') != MATCH_YES)
3133 return MATCH_ERROR;
3135 ts->type = BT_COMPLEX;
3136 ts->kind = gfc_default_double_kind;
3137 return MATCH_YES;
3140 if ((matched_type && strcmp ("logical", name) == 0)
3141 || (!matched_type && gfc_match (" logical") == MATCH_YES))
3143 ts->type = BT_LOGICAL;
3144 ts->kind = gfc_default_logical_kind;
3145 goto get_kind;
3148 if (matched_type)
3149 m = gfc_match_char (')');
3151 if (m != MATCH_YES)
3152 m = match_record_decl (name);
3154 if (matched_type || m == MATCH_YES)
3156 ts->type = BT_DERIVED;
3157 /* We accept record/s/ or type(s) where s is a structure, but we
3158 * don't need all the extra derived-type stuff for structures. */
3159 if (gfc_find_symbol (gfc_dt_upper_string (name), NULL, 1, &sym))
3161 gfc_error ("Type name %qs at %C is ambiguous", name);
3162 return MATCH_ERROR;
3164 if (sym && sym->attr.flavor == FL_STRUCT)
3166 ts->u.derived = sym;
3167 return MATCH_YES;
3169 /* Actually a derived type. */
3172 else
3174 /* Match nested STRUCTURE declarations; only valid within another
3175 structure declaration. */
3176 if (flag_dec_structure
3177 && (gfc_current_state () == COMP_STRUCTURE
3178 || gfc_current_state () == COMP_MAP))
3180 m = gfc_match (" structure");
3181 if (m == MATCH_YES)
3183 m = gfc_match_structure_decl ();
3184 if (m == MATCH_YES)
3186 /* gfc_new_block is updated by match_structure_decl. */
3187 ts->type = BT_DERIVED;
3188 ts->u.derived = gfc_new_block;
3189 return MATCH_YES;
3192 if (m == MATCH_ERROR)
3193 return MATCH_ERROR;
3196 /* Match CLASS declarations. */
3197 m = gfc_match (" class ( * )");
3198 if (m == MATCH_ERROR)
3199 return MATCH_ERROR;
3200 else if (m == MATCH_YES)
3202 gfc_symbol *upe;
3203 gfc_symtree *st;
3204 ts->type = BT_CLASS;
3205 gfc_find_symbol ("STAR", gfc_current_ns, 1, &upe);
3206 if (upe == NULL)
3208 upe = gfc_new_symbol ("STAR", gfc_current_ns);
3209 st = gfc_new_symtree (&gfc_current_ns->sym_root, "STAR");
3210 st->n.sym = upe;
3211 gfc_set_sym_referenced (upe);
3212 upe->refs++;
3213 upe->ts.type = BT_VOID;
3214 upe->attr.unlimited_polymorphic = 1;
3215 /* This is essential to force the construction of
3216 unlimited polymorphic component class containers. */
3217 upe->attr.zero_comp = 1;
3218 if (!gfc_add_flavor (&upe->attr, FL_DERIVED, NULL,
3219 &gfc_current_locus))
3220 return MATCH_ERROR;
3222 else
3224 st = gfc_get_tbp_symtree (&gfc_current_ns->sym_root, "STAR");
3225 st->n.sym = upe;
3226 upe->refs++;
3228 ts->u.derived = upe;
3229 return m;
3232 m = gfc_match (" class ( %n )", name);
3233 if (m != MATCH_YES)
3234 return m;
3235 ts->type = BT_CLASS;
3237 if (!gfc_notify_std (GFC_STD_F2003, "CLASS statement at %C"))
3238 return MATCH_ERROR;
3241 /* Defer association of the derived type until the end of the
3242 specification block. However, if the derived type can be
3243 found, add it to the typespec. */
3244 if (gfc_matching_function)
3246 ts->u.derived = NULL;
3247 if (gfc_current_state () != COMP_INTERFACE
3248 && !gfc_find_symbol (name, NULL, 1, &sym) && sym)
3250 sym = gfc_find_dt_in_generic (sym);
3251 ts->u.derived = sym;
3253 return MATCH_YES;
3256 /* Search for the name but allow the components to be defined later. If
3257 type = -1, this typespec has been seen in a function declaration but
3258 the type could not be accessed at that point. The actual derived type is
3259 stored in a symtree with the first letter of the name capitalized; the
3260 symtree with the all lower-case name contains the associated
3261 generic function. */
3262 dt_name = gfc_dt_upper_string (name);
3263 sym = NULL;
3264 dt_sym = NULL;
3265 if (ts->kind != -1)
3267 gfc_get_ha_symbol (name, &sym);
3268 if (sym->generic && gfc_find_symbol (dt_name, NULL, 0, &dt_sym))
3270 gfc_error ("Type name %qs at %C is ambiguous", name);
3271 return MATCH_ERROR;
3273 if (sym->generic && !dt_sym)
3274 dt_sym = gfc_find_dt_in_generic (sym);
3276 else if (ts->kind == -1)
3278 int iface = gfc_state_stack->previous->state != COMP_INTERFACE
3279 || gfc_current_ns->has_import_set;
3280 gfc_find_symbol (name, NULL, iface, &sym);
3281 if (sym && sym->generic && gfc_find_symbol (dt_name, NULL, 1, &dt_sym))
3283 gfc_error ("Type name %qs at %C is ambiguous", name);
3284 return MATCH_ERROR;
3286 if (sym && sym->generic && !dt_sym)
3287 dt_sym = gfc_find_dt_in_generic (sym);
3289 ts->kind = 0;
3290 if (sym == NULL)
3291 return MATCH_NO;
3294 if ((sym->attr.flavor != FL_UNKNOWN && sym->attr.flavor != FL_STRUCT
3295 && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.generic))
3296 || sym->attr.subroutine)
3298 gfc_error ("Type name %qs at %C conflicts with previously declared "
3299 "entity at %L, which has the same name", name,
3300 &sym->declared_at);
3301 return MATCH_ERROR;
3304 gfc_save_symbol_data (sym);
3305 gfc_set_sym_referenced (sym);
3306 if (!sym->attr.generic
3307 && !gfc_add_generic (&sym->attr, sym->name, NULL))
3308 return MATCH_ERROR;
3310 if (!sym->attr.function
3311 && !gfc_add_function (&sym->attr, sym->name, NULL))
3312 return MATCH_ERROR;
3314 if (!dt_sym)
3316 gfc_interface *intr, *head;
3318 /* Use upper case to save the actual derived-type symbol. */
3319 gfc_get_symbol (dt_name, NULL, &dt_sym);
3320 dt_sym->name = gfc_get_string ("%s", sym->name);
3321 head = sym->generic;
3322 intr = gfc_get_interface ();
3323 intr->sym = dt_sym;
3324 intr->where = gfc_current_locus;
3325 intr->next = head;
3326 sym->generic = intr;
3327 sym->attr.if_source = IFSRC_DECL;
3329 else
3330 gfc_save_symbol_data (dt_sym);
3332 gfc_set_sym_referenced (dt_sym);
3334 if (dt_sym->attr.flavor != FL_DERIVED && dt_sym->attr.flavor != FL_STRUCT
3335 && !gfc_add_flavor (&dt_sym->attr, FL_DERIVED, sym->name, NULL))
3336 return MATCH_ERROR;
3338 ts->u.derived = dt_sym;
3340 return MATCH_YES;
3342 get_kind:
3343 if (matched_type
3344 && !gfc_notify_std (GFC_STD_F2008, "TYPE with "
3345 "intrinsic-type-spec at %C"))
3346 return MATCH_ERROR;
3348 /* For all types except double, derived and character, look for an
3349 optional kind specifier. MATCH_NO is actually OK at this point. */
3350 if (implicit_flag == 1)
3352 if (matched_type && gfc_match_char (')') != MATCH_YES)
3353 return MATCH_ERROR;
3355 return MATCH_YES;
3358 if (gfc_current_form == FORM_FREE)
3360 c = gfc_peek_ascii_char ();
3361 if (!gfc_is_whitespace (c) && c != '*' && c != '('
3362 && c != ':' && c != ',')
3364 if (matched_type && c == ')')
3366 gfc_next_ascii_char ();
3367 return MATCH_YES;
3369 return MATCH_NO;
3373 m = gfc_match_kind_spec (ts, false);
3374 if (m == MATCH_NO && ts->type != BT_CHARACTER)
3376 m = gfc_match_old_kind_spec (ts);
3377 if (gfc_validate_kind (ts->type, ts->kind, true) == -1)
3378 return MATCH_ERROR;
3381 if (matched_type && gfc_match_char (')') != MATCH_YES)
3382 return MATCH_ERROR;
3384 /* Defer association of the KIND expression of function results
3385 until after USE and IMPORT statements. */
3386 if ((gfc_current_state () == COMP_NONE && gfc_error_flag_test ())
3387 || gfc_matching_function)
3388 return MATCH_YES;
3390 if (m == MATCH_NO)
3391 m = MATCH_YES; /* No kind specifier found. */
3393 return m;
3397 /* Match an IMPLICIT NONE statement. Actually, this statement is
3398 already matched in parse.c, or we would not end up here in the
3399 first place. So the only thing we need to check, is if there is
3400 trailing garbage. If not, the match is successful. */
3402 match
3403 gfc_match_implicit_none (void)
3405 char c;
3406 match m;
3407 char name[GFC_MAX_SYMBOL_LEN + 1];
3408 bool type = false;
3409 bool external = false;
3410 locus cur_loc = gfc_current_locus;
3412 if (gfc_current_ns->seen_implicit_none
3413 || gfc_current_ns->has_implicit_none_export)
3415 gfc_error ("Duplicate IMPLICIT NONE statement at %C");
3416 return MATCH_ERROR;
3419 gfc_gobble_whitespace ();
3420 c = gfc_peek_ascii_char ();
3421 if (c == '(')
3423 (void) gfc_next_ascii_char ();
3424 if (!gfc_notify_std (GFC_STD_F2015, "IMPORT NONE with spec list at %C"))
3425 return MATCH_ERROR;
3427 gfc_gobble_whitespace ();
3428 if (gfc_peek_ascii_char () == ')')
3430 (void) gfc_next_ascii_char ();
3431 type = true;
3433 else
3434 for(;;)
3436 m = gfc_match (" %n", name);
3437 if (m != MATCH_YES)
3438 return MATCH_ERROR;
3440 if (strcmp (name, "type") == 0)
3441 type = true;
3442 else if (strcmp (name, "external") == 0)
3443 external = true;
3444 else
3445 return MATCH_ERROR;
3447 gfc_gobble_whitespace ();
3448 c = gfc_next_ascii_char ();
3449 if (c == ',')
3450 continue;
3451 if (c == ')')
3452 break;
3453 return MATCH_ERROR;
3456 else
3457 type = true;
3459 if (gfc_match_eos () != MATCH_YES)
3460 return MATCH_ERROR;
3462 gfc_set_implicit_none (type, external, &cur_loc);
3464 return MATCH_YES;
3468 /* Match the letter range(s) of an IMPLICIT statement. */
3470 static match
3471 match_implicit_range (void)
3473 char c, c1, c2;
3474 int inner;
3475 locus cur_loc;
3477 cur_loc = gfc_current_locus;
3479 gfc_gobble_whitespace ();
3480 c = gfc_next_ascii_char ();
3481 if (c != '(')
3483 gfc_error ("Missing character range in IMPLICIT at %C");
3484 goto bad;
3487 inner = 1;
3488 while (inner)
3490 gfc_gobble_whitespace ();
3491 c1 = gfc_next_ascii_char ();
3492 if (!ISALPHA (c1))
3493 goto bad;
3495 gfc_gobble_whitespace ();
3496 c = gfc_next_ascii_char ();
3498 switch (c)
3500 case ')':
3501 inner = 0; /* Fall through. */
3503 case ',':
3504 c2 = c1;
3505 break;
3507 case '-':
3508 gfc_gobble_whitespace ();
3509 c2 = gfc_next_ascii_char ();
3510 if (!ISALPHA (c2))
3511 goto bad;
3513 gfc_gobble_whitespace ();
3514 c = gfc_next_ascii_char ();
3516 if ((c != ',') && (c != ')'))
3517 goto bad;
3518 if (c == ')')
3519 inner = 0;
3521 break;
3523 default:
3524 goto bad;
3527 if (c1 > c2)
3529 gfc_error ("Letters must be in alphabetic order in "
3530 "IMPLICIT statement at %C");
3531 goto bad;
3534 /* See if we can add the newly matched range to the pending
3535 implicits from this IMPLICIT statement. We do not check for
3536 conflicts with whatever earlier IMPLICIT statements may have
3537 set. This is done when we've successfully finished matching
3538 the current one. */
3539 if (!gfc_add_new_implicit_range (c1, c2))
3540 goto bad;
3543 return MATCH_YES;
3545 bad:
3546 gfc_syntax_error (ST_IMPLICIT);
3548 gfc_current_locus = cur_loc;
3549 return MATCH_ERROR;
3553 /* Match an IMPLICIT statement, storing the types for
3554 gfc_set_implicit() if the statement is accepted by the parser.
3555 There is a strange looking, but legal syntactic construction
3556 possible. It looks like:
3558 IMPLICIT INTEGER (a-b) (c-d)
3560 This is legal if "a-b" is a constant expression that happens to
3561 equal one of the legal kinds for integers. The real problem
3562 happens with an implicit specification that looks like:
3564 IMPLICIT INTEGER (a-b)
3566 In this case, a typespec matcher that is "greedy" (as most of the
3567 matchers are) gobbles the character range as a kindspec, leaving
3568 nothing left. We therefore have to go a bit more slowly in the
3569 matching process by inhibiting the kindspec checking during
3570 typespec matching and checking for a kind later. */
3572 match
3573 gfc_match_implicit (void)
3575 gfc_typespec ts;
3576 locus cur_loc;
3577 char c;
3578 match m;
3580 if (gfc_current_ns->seen_implicit_none)
3582 gfc_error ("IMPLICIT statement at %C following an IMPLICIT NONE (type) "
3583 "statement");
3584 return MATCH_ERROR;
3587 gfc_clear_ts (&ts);
3589 /* We don't allow empty implicit statements. */
3590 if (gfc_match_eos () == MATCH_YES)
3592 gfc_error ("Empty IMPLICIT statement at %C");
3593 return MATCH_ERROR;
3598 /* First cleanup. */
3599 gfc_clear_new_implicit ();
3601 /* A basic type is mandatory here. */
3602 m = gfc_match_decl_type_spec (&ts, 1);
3603 if (m == MATCH_ERROR)
3604 goto error;
3605 if (m == MATCH_NO)
3606 goto syntax;
3608 cur_loc = gfc_current_locus;
3609 m = match_implicit_range ();
3611 if (m == MATCH_YES)
3613 /* We may have <TYPE> (<RANGE>). */
3614 gfc_gobble_whitespace ();
3615 c = gfc_peek_ascii_char ();
3616 if (c == ',' || c == '\n' || c == ';' || c == '!')
3618 /* Check for CHARACTER with no length parameter. */
3619 if (ts.type == BT_CHARACTER && !ts.u.cl)
3621 ts.kind = gfc_default_character_kind;
3622 ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
3623 ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind,
3624 NULL, 1);
3627 /* Record the Successful match. */
3628 if (!gfc_merge_new_implicit (&ts))
3629 return MATCH_ERROR;
3630 if (c == ',')
3631 c = gfc_next_ascii_char ();
3632 else if (gfc_match_eos () == MATCH_ERROR)
3633 goto error;
3634 continue;
3637 gfc_current_locus = cur_loc;
3640 /* Discard the (incorrectly) matched range. */
3641 gfc_clear_new_implicit ();
3643 /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
3644 if (ts.type == BT_CHARACTER)
3645 m = gfc_match_char_spec (&ts);
3646 else
3648 m = gfc_match_kind_spec (&ts, false);
3649 if (m == MATCH_NO)
3651 m = gfc_match_old_kind_spec (&ts);
3652 if (m == MATCH_ERROR)
3653 goto error;
3654 if (m == MATCH_NO)
3655 goto syntax;
3658 if (m == MATCH_ERROR)
3659 goto error;
3661 m = match_implicit_range ();
3662 if (m == MATCH_ERROR)
3663 goto error;
3664 if (m == MATCH_NO)
3665 goto syntax;
3667 gfc_gobble_whitespace ();
3668 c = gfc_next_ascii_char ();
3669 if (c != ',' && gfc_match_eos () != MATCH_YES)
3670 goto syntax;
3672 if (!gfc_merge_new_implicit (&ts))
3673 return MATCH_ERROR;
3675 while (c == ',');
3677 return MATCH_YES;
3679 syntax:
3680 gfc_syntax_error (ST_IMPLICIT);
3682 error:
3683 return MATCH_ERROR;
3687 match
3688 gfc_match_import (void)
3690 char name[GFC_MAX_SYMBOL_LEN + 1];
3691 match m;
3692 gfc_symbol *sym;
3693 gfc_symtree *st;
3695 if (gfc_current_ns->proc_name == NULL
3696 || gfc_current_ns->proc_name->attr.if_source != IFSRC_IFBODY)
3698 gfc_error ("IMPORT statement at %C only permitted in "
3699 "an INTERFACE body");
3700 return MATCH_ERROR;
3703 if (gfc_current_ns->proc_name->attr.module_procedure)
3705 gfc_error ("F2008: C1210 IMPORT statement at %C is not permitted "
3706 "in a module procedure interface body");
3707 return MATCH_ERROR;
3710 if (!gfc_notify_std (GFC_STD_F2003, "IMPORT statement at %C"))
3711 return MATCH_ERROR;
3713 if (gfc_match_eos () == MATCH_YES)
3715 /* All host variables should be imported. */
3716 gfc_current_ns->has_import_set = 1;
3717 return MATCH_YES;
3720 if (gfc_match (" ::") == MATCH_YES)
3722 if (gfc_match_eos () == MATCH_YES)
3724 gfc_error ("Expecting list of named entities at %C");
3725 return MATCH_ERROR;
3729 for(;;)
3731 sym = NULL;
3732 m = gfc_match (" %n", name);
3733 switch (m)
3735 case MATCH_YES:
3736 if (gfc_current_ns->parent != NULL
3737 && gfc_find_symbol (name, gfc_current_ns->parent, 1, &sym))
3739 gfc_error ("Type name %qs at %C is ambiguous", name);
3740 return MATCH_ERROR;
3742 else if (!sym && gfc_current_ns->proc_name->ns->parent != NULL
3743 && gfc_find_symbol (name,
3744 gfc_current_ns->proc_name->ns->parent,
3745 1, &sym))
3747 gfc_error ("Type name %qs at %C is ambiguous", name);
3748 return MATCH_ERROR;
3751 if (sym == NULL)
3753 gfc_error ("Cannot IMPORT %qs from host scoping unit "
3754 "at %C - does not exist.", name);
3755 return MATCH_ERROR;
3758 if (gfc_find_symtree (gfc_current_ns->sym_root, name))
3760 gfc_warning (0, "%qs is already IMPORTed from host scoping unit "
3761 "at %C", name);
3762 goto next_item;
3765 st = gfc_new_symtree (&gfc_current_ns->sym_root, name);
3766 st->n.sym = sym;
3767 sym->refs++;
3768 sym->attr.imported = 1;
3770 if (sym->attr.generic && (sym = gfc_find_dt_in_generic (sym)))
3772 /* The actual derived type is stored in a symtree with the first
3773 letter of the name capitalized; the symtree with the all
3774 lower-case name contains the associated generic function. */
3775 st = gfc_new_symtree (&gfc_current_ns->sym_root,
3776 gfc_dt_upper_string (name));
3777 st->n.sym = sym;
3778 sym->refs++;
3779 sym->attr.imported = 1;
3782 goto next_item;
3784 case MATCH_NO:
3785 break;
3787 case MATCH_ERROR:
3788 return MATCH_ERROR;
3791 next_item:
3792 if (gfc_match_eos () == MATCH_YES)
3793 break;
3794 if (gfc_match_char (',') != MATCH_YES)
3795 goto syntax;
3798 return MATCH_YES;
3800 syntax:
3801 gfc_error ("Syntax error in IMPORT statement at %C");
3802 return MATCH_ERROR;
3806 /* A minimal implementation of gfc_match without whitespace, escape
3807 characters or variable arguments. Returns true if the next
3808 characters match the TARGET template exactly. */
3810 static bool
3811 match_string_p (const char *target)
3813 const char *p;
3815 for (p = target; *p; p++)
3816 if ((char) gfc_next_ascii_char () != *p)
3817 return false;
3818 return true;
3821 /* Matches an attribute specification including array specs. If
3822 successful, leaves the variables current_attr and current_as
3823 holding the specification. Also sets the colon_seen variable for
3824 later use by matchers associated with initializations.
3826 This subroutine is a little tricky in the sense that we don't know
3827 if we really have an attr-spec until we hit the double colon.
3828 Until that time, we can only return MATCH_NO. This forces us to
3829 check for duplicate specification at this level. */
3831 static match
3832 match_attr_spec (void)
3834 /* Modifiers that can exist in a type statement. */
3835 enum
3836 { GFC_DECL_BEGIN = 0,
3837 DECL_ALLOCATABLE = GFC_DECL_BEGIN, DECL_DIMENSION, DECL_EXTERNAL,
3838 DECL_IN, DECL_OUT, DECL_INOUT, DECL_INTRINSIC, DECL_OPTIONAL,
3839 DECL_PARAMETER, DECL_POINTER, DECL_PROTECTED, DECL_PRIVATE,
3840 DECL_STATIC, DECL_AUTOMATIC,
3841 DECL_PUBLIC, DECL_SAVE, DECL_TARGET, DECL_VALUE, DECL_VOLATILE,
3842 DECL_IS_BIND_C, DECL_CODIMENSION, DECL_ASYNCHRONOUS, DECL_CONTIGUOUS,
3843 DECL_NONE, GFC_DECL_END /* Sentinel */
3846 /* GFC_DECL_END is the sentinel, index starts at 0. */
3847 #define NUM_DECL GFC_DECL_END
3849 locus start, seen_at[NUM_DECL];
3850 int seen[NUM_DECL];
3851 unsigned int d;
3852 const char *attr;
3853 match m;
3854 bool t;
3856 gfc_clear_attr (&current_attr);
3857 start = gfc_current_locus;
3859 current_as = NULL;
3860 colon_seen = 0;
3862 /* See if we get all of the keywords up to the final double colon. */
3863 for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
3864 seen[d] = 0;
3866 for (;;)
3868 char ch;
3870 d = DECL_NONE;
3871 gfc_gobble_whitespace ();
3873 ch = gfc_next_ascii_char ();
3874 if (ch == ':')
3876 /* This is the successful exit condition for the loop. */
3877 if (gfc_next_ascii_char () == ':')
3878 break;
3880 else if (ch == ',')
3882 gfc_gobble_whitespace ();
3883 switch (gfc_peek_ascii_char ())
3885 case 'a':
3886 gfc_next_ascii_char ();
3887 switch (gfc_next_ascii_char ())
3889 case 'l':
3890 if (match_string_p ("locatable"))
3892 /* Matched "allocatable". */
3893 d = DECL_ALLOCATABLE;
3895 break;
3897 case 's':
3898 if (match_string_p ("ynchronous"))
3900 /* Matched "asynchronous". */
3901 d = DECL_ASYNCHRONOUS;
3903 break;
3905 case 'u':
3906 if (match_string_p ("tomatic"))
3908 /* Matched "automatic". */
3909 d = DECL_AUTOMATIC;
3911 break;
3913 break;
3915 case 'b':
3916 /* Try and match the bind(c). */
3917 m = gfc_match_bind_c (NULL, true);
3918 if (m == MATCH_YES)
3919 d = DECL_IS_BIND_C;
3920 else if (m == MATCH_ERROR)
3921 goto cleanup;
3922 break;
3924 case 'c':
3925 gfc_next_ascii_char ();
3926 if ('o' != gfc_next_ascii_char ())
3927 break;
3928 switch (gfc_next_ascii_char ())
3930 case 'd':
3931 if (match_string_p ("imension"))
3933 d = DECL_CODIMENSION;
3934 break;
3936 /* FALLTHRU */
3937 case 'n':
3938 if (match_string_p ("tiguous"))
3940 d = DECL_CONTIGUOUS;
3941 break;
3944 break;
3946 case 'd':
3947 if (match_string_p ("dimension"))
3948 d = DECL_DIMENSION;
3949 break;
3951 case 'e':
3952 if (match_string_p ("external"))
3953 d = DECL_EXTERNAL;
3954 break;
3956 case 'i':
3957 if (match_string_p ("int"))
3959 ch = gfc_next_ascii_char ();
3960 if (ch == 'e')
3962 if (match_string_p ("nt"))
3964 /* Matched "intent". */
3965 /* TODO: Call match_intent_spec from here. */
3966 if (gfc_match (" ( in out )") == MATCH_YES)
3967 d = DECL_INOUT;
3968 else if (gfc_match (" ( in )") == MATCH_YES)
3969 d = DECL_IN;
3970 else if (gfc_match (" ( out )") == MATCH_YES)
3971 d = DECL_OUT;
3974 else if (ch == 'r')
3976 if (match_string_p ("insic"))
3978 /* Matched "intrinsic". */
3979 d = DECL_INTRINSIC;
3983 break;
3985 case 'o':
3986 if (match_string_p ("optional"))
3987 d = DECL_OPTIONAL;
3988 break;
3990 case 'p':
3991 gfc_next_ascii_char ();
3992 switch (gfc_next_ascii_char ())
3994 case 'a':
3995 if (match_string_p ("rameter"))
3997 /* Matched "parameter". */
3998 d = DECL_PARAMETER;
4000 break;
4002 case 'o':
4003 if (match_string_p ("inter"))
4005 /* Matched "pointer". */
4006 d = DECL_POINTER;
4008 break;
4010 case 'r':
4011 ch = gfc_next_ascii_char ();
4012 if (ch == 'i')
4014 if (match_string_p ("vate"))
4016 /* Matched "private". */
4017 d = DECL_PRIVATE;
4020 else if (ch == 'o')
4022 if (match_string_p ("tected"))
4024 /* Matched "protected". */
4025 d = DECL_PROTECTED;
4028 break;
4030 case 'u':
4031 if (match_string_p ("blic"))
4033 /* Matched "public". */
4034 d = DECL_PUBLIC;
4036 break;
4038 break;
4040 case 's':
4041 gfc_next_ascii_char ();
4042 switch (gfc_next_ascii_char ())
4044 case 'a':
4045 if (match_string_p ("ve"))
4047 /* Matched "save". */
4048 d = DECL_SAVE;
4050 break;
4052 case 't':
4053 if (match_string_p ("atic"))
4055 /* Matched "static". */
4056 d = DECL_STATIC;
4058 break;
4060 break;
4062 case 't':
4063 if (match_string_p ("target"))
4064 d = DECL_TARGET;
4065 break;
4067 case 'v':
4068 gfc_next_ascii_char ();
4069 ch = gfc_next_ascii_char ();
4070 if (ch == 'a')
4072 if (match_string_p ("lue"))
4074 /* Matched "value". */
4075 d = DECL_VALUE;
4078 else if (ch == 'o')
4080 if (match_string_p ("latile"))
4082 /* Matched "volatile". */
4083 d = DECL_VOLATILE;
4086 break;
4090 /* No double colon and no recognizable decl_type, so assume that
4091 we've been looking at something else the whole time. */
4092 if (d == DECL_NONE)
4094 m = MATCH_NO;
4095 goto cleanup;
4098 /* Check to make sure any parens are paired up correctly. */
4099 if (gfc_match_parens () == MATCH_ERROR)
4101 m = MATCH_ERROR;
4102 goto cleanup;
4105 seen[d]++;
4106 seen_at[d] = gfc_current_locus;
4108 if (d == DECL_DIMENSION || d == DECL_CODIMENSION)
4110 gfc_array_spec *as = NULL;
4112 m = gfc_match_array_spec (&as, d == DECL_DIMENSION,
4113 d == DECL_CODIMENSION);
4115 if (current_as == NULL)
4116 current_as = as;
4117 else if (m == MATCH_YES)
4119 if (!merge_array_spec (as, current_as, false))
4120 m = MATCH_ERROR;
4121 free (as);
4124 if (m == MATCH_NO)
4126 if (d == DECL_CODIMENSION)
4127 gfc_error ("Missing codimension specification at %C");
4128 else
4129 gfc_error ("Missing dimension specification at %C");
4130 m = MATCH_ERROR;
4133 if (m == MATCH_ERROR)
4134 goto cleanup;
4138 /* Since we've seen a double colon, we have to be looking at an
4139 attr-spec. This means that we can now issue errors. */
4140 for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
4141 if (seen[d] > 1)
4143 switch (d)
4145 case DECL_ALLOCATABLE:
4146 attr = "ALLOCATABLE";
4147 break;
4148 case DECL_ASYNCHRONOUS:
4149 attr = "ASYNCHRONOUS";
4150 break;
4151 case DECL_CODIMENSION:
4152 attr = "CODIMENSION";
4153 break;
4154 case DECL_CONTIGUOUS:
4155 attr = "CONTIGUOUS";
4156 break;
4157 case DECL_DIMENSION:
4158 attr = "DIMENSION";
4159 break;
4160 case DECL_EXTERNAL:
4161 attr = "EXTERNAL";
4162 break;
4163 case DECL_IN:
4164 attr = "INTENT (IN)";
4165 break;
4166 case DECL_OUT:
4167 attr = "INTENT (OUT)";
4168 break;
4169 case DECL_INOUT:
4170 attr = "INTENT (IN OUT)";
4171 break;
4172 case DECL_INTRINSIC:
4173 attr = "INTRINSIC";
4174 break;
4175 case DECL_OPTIONAL:
4176 attr = "OPTIONAL";
4177 break;
4178 case DECL_PARAMETER:
4179 attr = "PARAMETER";
4180 break;
4181 case DECL_POINTER:
4182 attr = "POINTER";
4183 break;
4184 case DECL_PROTECTED:
4185 attr = "PROTECTED";
4186 break;
4187 case DECL_PRIVATE:
4188 attr = "PRIVATE";
4189 break;
4190 case DECL_PUBLIC:
4191 attr = "PUBLIC";
4192 break;
4193 case DECL_SAVE:
4194 attr = "SAVE";
4195 break;
4196 case DECL_STATIC:
4197 attr = "STATIC";
4198 break;
4199 case DECL_AUTOMATIC:
4200 attr = "AUTOMATIC";
4201 break;
4202 case DECL_TARGET:
4203 attr = "TARGET";
4204 break;
4205 case DECL_IS_BIND_C:
4206 attr = "IS_BIND_C";
4207 break;
4208 case DECL_VALUE:
4209 attr = "VALUE";
4210 break;
4211 case DECL_VOLATILE:
4212 attr = "VOLATILE";
4213 break;
4214 default:
4215 attr = NULL; /* This shouldn't happen. */
4218 gfc_error ("Duplicate %s attribute at %L", attr, &seen_at[d]);
4219 m = MATCH_ERROR;
4220 goto cleanup;
4223 /* Now that we've dealt with duplicate attributes, add the attributes
4224 to the current attribute. */
4225 for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
4227 if (seen[d] == 0)
4228 continue;
4230 if ((d == DECL_STATIC || d == DECL_AUTOMATIC)
4231 && !flag_dec_static)
4233 gfc_error ("%s at %L is a DEC extension, enable with "
4234 "%<-fdec-static%>",
4235 d == DECL_STATIC ? "STATIC" : "AUTOMATIC", &seen_at[d]);
4236 m = MATCH_ERROR;
4237 goto cleanup;
4239 /* Allow SAVE with STATIC, but don't complain. */
4240 if (d == DECL_STATIC && seen[DECL_SAVE])
4241 continue;
4243 if (gfc_current_state () == COMP_DERIVED
4244 && d != DECL_DIMENSION && d != DECL_CODIMENSION
4245 && d != DECL_POINTER && d != DECL_PRIVATE
4246 && d != DECL_PUBLIC && d != DECL_CONTIGUOUS && d != DECL_NONE)
4248 if (d == DECL_ALLOCATABLE)
4250 if (!gfc_notify_std (GFC_STD_F2003, "ALLOCATABLE "
4251 "attribute at %C in a TYPE definition"))
4253 m = MATCH_ERROR;
4254 goto cleanup;
4257 else
4259 gfc_error ("Attribute at %L is not allowed in a TYPE definition",
4260 &seen_at[d]);
4261 m = MATCH_ERROR;
4262 goto cleanup;
4266 if ((d == DECL_PRIVATE || d == DECL_PUBLIC)
4267 && gfc_current_state () != COMP_MODULE)
4269 if (d == DECL_PRIVATE)
4270 attr = "PRIVATE";
4271 else
4272 attr = "PUBLIC";
4273 if (gfc_current_state () == COMP_DERIVED
4274 && gfc_state_stack->previous
4275 && gfc_state_stack->previous->state == COMP_MODULE)
4277 if (!gfc_notify_std (GFC_STD_F2003, "Attribute %s "
4278 "at %L in a TYPE definition", attr,
4279 &seen_at[d]))
4281 m = MATCH_ERROR;
4282 goto cleanup;
4285 else
4287 gfc_error ("%s attribute at %L is not allowed outside of the "
4288 "specification part of a module", attr, &seen_at[d]);
4289 m = MATCH_ERROR;
4290 goto cleanup;
4294 switch (d)
4296 case DECL_ALLOCATABLE:
4297 t = gfc_add_allocatable (&current_attr, &seen_at[d]);
4298 break;
4300 case DECL_ASYNCHRONOUS:
4301 if (!gfc_notify_std (GFC_STD_F2003, "ASYNCHRONOUS attribute at %C"))
4302 t = false;
4303 else
4304 t = gfc_add_asynchronous (&current_attr, NULL, &seen_at[d]);
4305 break;
4307 case DECL_CODIMENSION:
4308 t = gfc_add_codimension (&current_attr, NULL, &seen_at[d]);
4309 break;
4311 case DECL_CONTIGUOUS:
4312 if (!gfc_notify_std (GFC_STD_F2008, "CONTIGUOUS attribute at %C"))
4313 t = false;
4314 else
4315 t = gfc_add_contiguous (&current_attr, NULL, &seen_at[d]);
4316 break;
4318 case DECL_DIMENSION:
4319 t = gfc_add_dimension (&current_attr, NULL, &seen_at[d]);
4320 break;
4322 case DECL_EXTERNAL:
4323 t = gfc_add_external (&current_attr, &seen_at[d]);
4324 break;
4326 case DECL_IN:
4327 t = gfc_add_intent (&current_attr, INTENT_IN, &seen_at[d]);
4328 break;
4330 case DECL_OUT:
4331 t = gfc_add_intent (&current_attr, INTENT_OUT, &seen_at[d]);
4332 break;
4334 case DECL_INOUT:
4335 t = gfc_add_intent (&current_attr, INTENT_INOUT, &seen_at[d]);
4336 break;
4338 case DECL_INTRINSIC:
4339 t = gfc_add_intrinsic (&current_attr, &seen_at[d]);
4340 break;
4342 case DECL_OPTIONAL:
4343 t = gfc_add_optional (&current_attr, &seen_at[d]);
4344 break;
4346 case DECL_PARAMETER:
4347 t = gfc_add_flavor (&current_attr, FL_PARAMETER, NULL, &seen_at[d]);
4348 break;
4350 case DECL_POINTER:
4351 t = gfc_add_pointer (&current_attr, &seen_at[d]);
4352 break;
4354 case DECL_PROTECTED:
4355 if (gfc_current_state () != COMP_MODULE
4356 || (gfc_current_ns->proc_name
4357 && gfc_current_ns->proc_name->attr.flavor != FL_MODULE))
4359 gfc_error ("PROTECTED at %C only allowed in specification "
4360 "part of a module");
4361 t = false;
4362 break;
4365 if (!gfc_notify_std (GFC_STD_F2003, "PROTECTED attribute at %C"))
4366 t = false;
4367 else
4368 t = gfc_add_protected (&current_attr, NULL, &seen_at[d]);
4369 break;
4371 case DECL_PRIVATE:
4372 t = gfc_add_access (&current_attr, ACCESS_PRIVATE, NULL,
4373 &seen_at[d]);
4374 break;
4376 case DECL_PUBLIC:
4377 t = gfc_add_access (&current_attr, ACCESS_PUBLIC, NULL,
4378 &seen_at[d]);
4379 break;
4381 case DECL_STATIC:
4382 case DECL_SAVE:
4383 t = gfc_add_save (&current_attr, SAVE_EXPLICIT, NULL, &seen_at[d]);
4384 break;
4386 case DECL_AUTOMATIC:
4387 t = gfc_add_automatic (&current_attr, NULL, &seen_at[d]);
4388 break;
4390 case DECL_TARGET:
4391 t = gfc_add_target (&current_attr, &seen_at[d]);
4392 break;
4394 case DECL_IS_BIND_C:
4395 t = gfc_add_is_bind_c(&current_attr, NULL, &seen_at[d], 0);
4396 break;
4398 case DECL_VALUE:
4399 if (!gfc_notify_std (GFC_STD_F2003, "VALUE attribute at %C"))
4400 t = false;
4401 else
4402 t = gfc_add_value (&current_attr, NULL, &seen_at[d]);
4403 break;
4405 case DECL_VOLATILE:
4406 if (!gfc_notify_std (GFC_STD_F2003, "VOLATILE attribute at %C"))
4407 t = false;
4408 else
4409 t = gfc_add_volatile (&current_attr, NULL, &seen_at[d]);
4410 break;
4412 default:
4413 gfc_internal_error ("match_attr_spec(): Bad attribute");
4416 if (!t)
4418 m = MATCH_ERROR;
4419 goto cleanup;
4423 /* Since Fortran 2008 module variables implicitly have the SAVE attribute. */
4424 if ((gfc_current_state () == COMP_MODULE
4425 || gfc_current_state () == COMP_SUBMODULE)
4426 && !current_attr.save
4427 && (gfc_option.allow_std & GFC_STD_F2008) != 0)
4428 current_attr.save = SAVE_IMPLICIT;
4430 colon_seen = 1;
4431 return MATCH_YES;
4433 cleanup:
4434 gfc_current_locus = start;
4435 gfc_free_array_spec (current_as);
4436 current_as = NULL;
4437 return m;
4441 /* Set the binding label, dest_label, either with the binding label
4442 stored in the given gfc_typespec, ts, or if none was provided, it
4443 will be the symbol name in all lower case, as required by the draft
4444 (J3/04-007, section 15.4.1). If a binding label was given and
4445 there is more than one argument (num_idents), it is an error. */
4447 static bool
4448 set_binding_label (const char **dest_label, const char *sym_name,
4449 int num_idents)
4451 if (num_idents > 1 && has_name_equals)
4453 gfc_error ("Multiple identifiers provided with "
4454 "single NAME= specifier at %C");
4455 return false;
4458 if (curr_binding_label)
4459 /* Binding label given; store in temp holder till have sym. */
4460 *dest_label = curr_binding_label;
4461 else
4463 /* No binding label given, and the NAME= specifier did not exist,
4464 which means there was no NAME="". */
4465 if (sym_name != NULL && has_name_equals == 0)
4466 *dest_label = IDENTIFIER_POINTER (get_identifier (sym_name));
4469 return true;
4473 /* Set the status of the given common block as being BIND(C) or not,
4474 depending on the given parameter, is_bind_c. */
4476 void
4477 set_com_block_bind_c (gfc_common_head *com_block, int is_bind_c)
4479 com_block->is_bind_c = is_bind_c;
4480 return;
4484 /* Verify that the given gfc_typespec is for a C interoperable type. */
4486 bool
4487 gfc_verify_c_interop (gfc_typespec *ts)
4489 if (ts->type == BT_DERIVED && ts->u.derived != NULL)
4490 return (ts->u.derived->ts.is_c_interop || ts->u.derived->attr.is_bind_c)
4491 ? true : false;
4492 else if (ts->type == BT_CLASS)
4493 return false;
4494 else if (ts->is_c_interop != 1 && ts->type != BT_ASSUMED)
4495 return false;
4497 return true;
4501 /* Verify that the variables of a given common block, which has been
4502 defined with the attribute specifier bind(c), to be of a C
4503 interoperable type. Errors will be reported here, if
4504 encountered. */
4506 bool
4507 verify_com_block_vars_c_interop (gfc_common_head *com_block)
4509 gfc_symbol *curr_sym = NULL;
4510 bool retval = true;
4512 curr_sym = com_block->head;
4514 /* Make sure we have at least one symbol. */
4515 if (curr_sym == NULL)
4516 return retval;
4518 /* Here we know we have a symbol, so we'll execute this loop
4519 at least once. */
4522 /* The second to last param, 1, says this is in a common block. */
4523 retval = verify_bind_c_sym (curr_sym, &(curr_sym->ts), 1, com_block);
4524 curr_sym = curr_sym->common_next;
4525 } while (curr_sym != NULL);
4527 return retval;
4531 /* Verify that a given BIND(C) symbol is C interoperable. If it is not,
4532 an appropriate error message is reported. */
4534 bool
4535 verify_bind_c_sym (gfc_symbol *tmp_sym, gfc_typespec *ts,
4536 int is_in_common, gfc_common_head *com_block)
4538 bool bind_c_function = false;
4539 bool retval = true;
4541 if (tmp_sym->attr.function && tmp_sym->attr.is_bind_c)
4542 bind_c_function = true;
4544 if (tmp_sym->attr.function && tmp_sym->result != NULL)
4546 tmp_sym = tmp_sym->result;
4547 /* Make sure it wasn't an implicitly typed result. */
4548 if (tmp_sym->attr.implicit_type && warn_c_binding_type)
4550 gfc_warning (OPT_Wc_binding_type,
4551 "Implicitly declared BIND(C) function %qs at "
4552 "%L may not be C interoperable", tmp_sym->name,
4553 &tmp_sym->declared_at);
4554 tmp_sym->ts.f90_type = tmp_sym->ts.type;
4555 /* Mark it as C interoperable to prevent duplicate warnings. */
4556 tmp_sym->ts.is_c_interop = 1;
4557 tmp_sym->attr.is_c_interop = 1;
4561 /* Here, we know we have the bind(c) attribute, so if we have
4562 enough type info, then verify that it's a C interop kind.
4563 The info could be in the symbol already, or possibly still in
4564 the given ts (current_ts), so look in both. */
4565 if (tmp_sym->ts.type != BT_UNKNOWN || ts->type != BT_UNKNOWN)
4567 if (!gfc_verify_c_interop (&(tmp_sym->ts)))
4569 /* See if we're dealing with a sym in a common block or not. */
4570 if (is_in_common == 1 && warn_c_binding_type)
4572 gfc_warning (OPT_Wc_binding_type,
4573 "Variable %qs in common block %qs at %L "
4574 "may not be a C interoperable "
4575 "kind though common block %qs is BIND(C)",
4576 tmp_sym->name, com_block->name,
4577 &(tmp_sym->declared_at), com_block->name);
4579 else
4581 if (tmp_sym->ts.type == BT_DERIVED || ts->type == BT_DERIVED)
4582 gfc_error ("Type declaration %qs at %L is not C "
4583 "interoperable but it is BIND(C)",
4584 tmp_sym->name, &(tmp_sym->declared_at));
4585 else if (warn_c_binding_type)
4586 gfc_warning (OPT_Wc_binding_type, "Variable %qs at %L "
4587 "may not be a C interoperable "
4588 "kind but it is BIND(C)",
4589 tmp_sym->name, &(tmp_sym->declared_at));
4593 /* Variables declared w/in a common block can't be bind(c)
4594 since there's no way for C to see these variables, so there's
4595 semantically no reason for the attribute. */
4596 if (is_in_common == 1 && tmp_sym->attr.is_bind_c == 1)
4598 gfc_error ("Variable %qs in common block %qs at "
4599 "%L cannot be declared with BIND(C) "
4600 "since it is not a global",
4601 tmp_sym->name, com_block->name,
4602 &(tmp_sym->declared_at));
4603 retval = false;
4606 /* Scalar variables that are bind(c) can not have the pointer
4607 or allocatable attributes. */
4608 if (tmp_sym->attr.is_bind_c == 1)
4610 if (tmp_sym->attr.pointer == 1)
4612 gfc_error ("Variable %qs at %L cannot have both the "
4613 "POINTER and BIND(C) attributes",
4614 tmp_sym->name, &(tmp_sym->declared_at));
4615 retval = false;
4618 if (tmp_sym->attr.allocatable == 1)
4620 gfc_error ("Variable %qs at %L cannot have both the "
4621 "ALLOCATABLE and BIND(C) attributes",
4622 tmp_sym->name, &(tmp_sym->declared_at));
4623 retval = false;
4628 /* If it is a BIND(C) function, make sure the return value is a
4629 scalar value. The previous tests in this function made sure
4630 the type is interoperable. */
4631 if (bind_c_function && tmp_sym->as != NULL)
4632 gfc_error ("Return type of BIND(C) function %qs at %L cannot "
4633 "be an array", tmp_sym->name, &(tmp_sym->declared_at));
4635 /* BIND(C) functions can not return a character string. */
4636 if (bind_c_function && tmp_sym->ts.type == BT_CHARACTER)
4637 if (tmp_sym->ts.u.cl == NULL || tmp_sym->ts.u.cl->length == NULL
4638 || tmp_sym->ts.u.cl->length->expr_type != EXPR_CONSTANT
4639 || mpz_cmp_si (tmp_sym->ts.u.cl->length->value.integer, 1) != 0)
4640 gfc_error ("Return type of BIND(C) function %qs at %L cannot "
4641 "be a character string", tmp_sym->name,
4642 &(tmp_sym->declared_at));
4645 /* See if the symbol has been marked as private. If it has, make sure
4646 there is no binding label and warn the user if there is one. */
4647 if (tmp_sym->attr.access == ACCESS_PRIVATE
4648 && tmp_sym->binding_label)
4649 /* Use gfc_warning_now because we won't say that the symbol fails
4650 just because of this. */
4651 gfc_warning_now (0, "Symbol %qs at %L is marked PRIVATE but has been "
4652 "given the binding label %qs", tmp_sym->name,
4653 &(tmp_sym->declared_at), tmp_sym->binding_label);
4655 return retval;
4659 /* Set the appropriate fields for a symbol that's been declared as
4660 BIND(C) (the is_bind_c flag and the binding label), and verify that
4661 the type is C interoperable. Errors are reported by the functions
4662 used to set/test these fields. */
4664 bool
4665 set_verify_bind_c_sym (gfc_symbol *tmp_sym, int num_idents)
4667 bool retval = true;
4669 /* TODO: Do we need to make sure the vars aren't marked private? */
4671 /* Set the is_bind_c bit in symbol_attribute. */
4672 gfc_add_is_bind_c (&(tmp_sym->attr), tmp_sym->name, &gfc_current_locus, 0);
4674 if (!set_binding_label (&tmp_sym->binding_label, tmp_sym->name, num_idents))
4675 return false;
4677 return retval;
4681 /* Set the fields marking the given common block as BIND(C), including
4682 a binding label, and report any errors encountered. */
4684 bool
4685 set_verify_bind_c_com_block (gfc_common_head *com_block, int num_idents)
4687 bool retval = true;
4689 /* destLabel, common name, typespec (which may have binding label). */
4690 if (!set_binding_label (&com_block->binding_label, com_block->name,
4691 num_idents))
4692 return false;
4694 /* Set the given common block (com_block) to being bind(c) (1). */
4695 set_com_block_bind_c (com_block, 1);
4697 return retval;
4701 /* Retrieve the list of one or more identifiers that the given bind(c)
4702 attribute applies to. */
4704 bool
4705 get_bind_c_idents (void)
4707 char name[GFC_MAX_SYMBOL_LEN + 1];
4708 int num_idents = 0;
4709 gfc_symbol *tmp_sym = NULL;
4710 match found_id;
4711 gfc_common_head *com_block = NULL;
4713 if (gfc_match_name (name) == MATCH_YES)
4715 found_id = MATCH_YES;
4716 gfc_get_ha_symbol (name, &tmp_sym);
4718 else if (match_common_name (name) == MATCH_YES)
4720 found_id = MATCH_YES;
4721 com_block = gfc_get_common (name, 0);
4723 else
4725 gfc_error ("Need either entity or common block name for "
4726 "attribute specification statement at %C");
4727 return false;
4730 /* Save the current identifier and look for more. */
4733 /* Increment the number of identifiers found for this spec stmt. */
4734 num_idents++;
4736 /* Make sure we have a sym or com block, and verify that it can
4737 be bind(c). Set the appropriate field(s) and look for more
4738 identifiers. */
4739 if (tmp_sym != NULL || com_block != NULL)
4741 if (tmp_sym != NULL)
4743 if (!set_verify_bind_c_sym (tmp_sym, num_idents))
4744 return false;
4746 else
4748 if (!set_verify_bind_c_com_block (com_block, num_idents))
4749 return false;
4752 /* Look to see if we have another identifier. */
4753 tmp_sym = NULL;
4754 if (gfc_match_eos () == MATCH_YES)
4755 found_id = MATCH_NO;
4756 else if (gfc_match_char (',') != MATCH_YES)
4757 found_id = MATCH_NO;
4758 else if (gfc_match_name (name) == MATCH_YES)
4760 found_id = MATCH_YES;
4761 gfc_get_ha_symbol (name, &tmp_sym);
4763 else if (match_common_name (name) == MATCH_YES)
4765 found_id = MATCH_YES;
4766 com_block = gfc_get_common (name, 0);
4768 else
4770 gfc_error ("Missing entity or common block name for "
4771 "attribute specification statement at %C");
4772 return false;
4775 else
4777 gfc_internal_error ("Missing symbol");
4779 } while (found_id == MATCH_YES);
4781 /* if we get here we were successful */
4782 return true;
4786 /* Try and match a BIND(C) attribute specification statement. */
4788 match
4789 gfc_match_bind_c_stmt (void)
4791 match found_match = MATCH_NO;
4792 gfc_typespec *ts;
4794 ts = &current_ts;
4796 /* This may not be necessary. */
4797 gfc_clear_ts (ts);
4798 /* Clear the temporary binding label holder. */
4799 curr_binding_label = NULL;
4801 /* Look for the bind(c). */
4802 found_match = gfc_match_bind_c (NULL, true);
4804 if (found_match == MATCH_YES)
4806 if (!gfc_notify_std (GFC_STD_F2003, "BIND(C) statement at %C"))
4807 return MATCH_ERROR;
4809 /* Look for the :: now, but it is not required. */
4810 gfc_match (" :: ");
4812 /* Get the identifier(s) that needs to be updated. This may need to
4813 change to hand the flag(s) for the attr specified so all identifiers
4814 found can have all appropriate parts updated (assuming that the same
4815 spec stmt can have multiple attrs, such as both bind(c) and
4816 allocatable...). */
4817 if (!get_bind_c_idents ())
4818 /* Error message should have printed already. */
4819 return MATCH_ERROR;
4822 return found_match;
4826 /* Match a data declaration statement. */
4828 match
4829 gfc_match_data_decl (void)
4831 gfc_symbol *sym;
4832 match m;
4833 int elem;
4835 num_idents_on_line = 0;
4837 m = gfc_match_decl_type_spec (&current_ts, 0);
4838 if (m != MATCH_YES)
4839 return m;
4841 if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS)
4842 && !gfc_comp_struct (gfc_current_state ()))
4844 sym = gfc_use_derived (current_ts.u.derived);
4846 if (sym == NULL)
4848 m = MATCH_ERROR;
4849 goto cleanup;
4852 current_ts.u.derived = sym;
4855 m = match_attr_spec ();
4856 if (m == MATCH_ERROR)
4858 m = MATCH_NO;
4859 goto cleanup;
4862 if (current_ts.type == BT_CLASS
4863 && current_ts.u.derived->attr.unlimited_polymorphic)
4864 goto ok;
4866 if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS)
4867 && current_ts.u.derived->components == NULL
4868 && !current_ts.u.derived->attr.zero_comp)
4871 if (current_attr.pointer && gfc_comp_struct (gfc_current_state ()))
4872 goto ok;
4874 if (current_attr.allocatable && gfc_current_state () == COMP_DERIVED
4875 && current_ts.u.derived == gfc_current_block ())
4876 goto ok;
4878 gfc_find_symbol (current_ts.u.derived->name,
4879 current_ts.u.derived->ns, 1, &sym);
4881 /* Any symbol that we find had better be a type definition
4882 which has its components defined, or be a structure definition
4883 actively being parsed. */
4884 if (sym != NULL && gfc_fl_struct (sym->attr.flavor)
4885 && (current_ts.u.derived->components != NULL
4886 || current_ts.u.derived->attr.zero_comp
4887 || current_ts.u.derived == gfc_new_block))
4888 goto ok;
4890 gfc_error ("Derived type at %C has not been previously defined "
4891 "and so cannot appear in a derived type definition");
4892 m = MATCH_ERROR;
4893 goto cleanup;
4897 /* If we have an old-style character declaration, and no new-style
4898 attribute specifications, then there a comma is optional between
4899 the type specification and the variable list. */
4900 if (m == MATCH_NO && current_ts.type == BT_CHARACTER && old_char_selector)
4901 gfc_match_char (',');
4903 /* Give the types/attributes to symbols that follow. Give the element
4904 a number so that repeat character length expressions can be copied. */
4905 elem = 1;
4906 for (;;)
4908 num_idents_on_line++;
4909 m = variable_decl (elem++);
4910 if (m == MATCH_ERROR)
4911 goto cleanup;
4912 if (m == MATCH_NO)
4913 break;
4915 if (gfc_match_eos () == MATCH_YES)
4916 goto cleanup;
4917 if (gfc_match_char (',') != MATCH_YES)
4918 break;
4921 if (!gfc_error_flag_test ())
4923 /* An anonymous structure declaration is unambiguous; if we matched one
4924 according to gfc_match_structure_decl, we need to return MATCH_YES
4925 here to avoid confusing the remaining matchers, even if there was an
4926 error during variable_decl. We must flush any such errors. Note this
4927 causes the parser to gracefully continue parsing the remaining input
4928 as a structure body, which likely follows. */
4929 if (current_ts.type == BT_DERIVED && current_ts.u.derived
4930 && gfc_fl_struct (current_ts.u.derived->attr.flavor))
4932 gfc_error_now ("Syntax error in anonymous structure declaration"
4933 " at %C");
4934 /* Skip the bad variable_decl and line up for the start of the
4935 structure body. */
4936 gfc_error_recovery ();
4937 m = MATCH_YES;
4938 goto cleanup;
4941 gfc_error ("Syntax error in data declaration at %C");
4944 m = MATCH_ERROR;
4946 gfc_free_data_all (gfc_current_ns);
4948 cleanup:
4949 gfc_free_array_spec (current_as);
4950 current_as = NULL;
4951 return m;
4955 /* Match a prefix associated with a function or subroutine
4956 declaration. If the typespec pointer is nonnull, then a typespec
4957 can be matched. Note that if nothing matches, MATCH_YES is
4958 returned (the null string was matched). */
4960 match
4961 gfc_match_prefix (gfc_typespec *ts)
4963 bool seen_type;
4964 bool seen_impure;
4965 bool found_prefix;
4967 gfc_clear_attr (&current_attr);
4968 seen_type = false;
4969 seen_impure = false;
4971 gcc_assert (!gfc_matching_prefix);
4972 gfc_matching_prefix = true;
4976 found_prefix = false;
4978 /* MODULE is a prefix like PURE, ELEMENTAL, etc., having a
4979 corresponding attribute seems natural and distinguishes these
4980 procedures from procedure types of PROC_MODULE, which these are
4981 as well. */
4982 if (gfc_match ("module% ") == MATCH_YES)
4984 if (!gfc_notify_std (GFC_STD_F2008, "MODULE prefix at %C"))
4985 goto error;
4987 current_attr.module_procedure = 1;
4988 found_prefix = true;
4991 if (!seen_type && ts != NULL
4992 && gfc_match_decl_type_spec (ts, 0) == MATCH_YES
4993 && gfc_match_space () == MATCH_YES)
4996 seen_type = true;
4997 found_prefix = true;
5000 if (gfc_match ("elemental% ") == MATCH_YES)
5002 if (!gfc_add_elemental (&current_attr, NULL))
5003 goto error;
5005 found_prefix = true;
5008 if (gfc_match ("pure% ") == MATCH_YES)
5010 if (!gfc_add_pure (&current_attr, NULL))
5011 goto error;
5013 found_prefix = true;
5016 if (gfc_match ("recursive% ") == MATCH_YES)
5018 if (!gfc_add_recursive (&current_attr, NULL))
5019 goto error;
5021 found_prefix = true;
5024 /* IMPURE is a somewhat special case, as it needs not set an actual
5025 attribute but rather only prevents ELEMENTAL routines from being
5026 automatically PURE. */
5027 if (gfc_match ("impure% ") == MATCH_YES)
5029 if (!gfc_notify_std (GFC_STD_F2008, "IMPURE procedure at %C"))
5030 goto error;
5032 seen_impure = true;
5033 found_prefix = true;
5036 while (found_prefix);
5038 /* IMPURE and PURE must not both appear, of course. */
5039 if (seen_impure && current_attr.pure)
5041 gfc_error ("PURE and IMPURE must not appear both at %C");
5042 goto error;
5045 /* If IMPURE it not seen but the procedure is ELEMENTAL, mark it as PURE. */
5046 if (!seen_impure && current_attr.elemental && !current_attr.pure)
5048 if (!gfc_add_pure (&current_attr, NULL))
5049 goto error;
5052 /* At this point, the next item is not a prefix. */
5053 gcc_assert (gfc_matching_prefix);
5055 gfc_matching_prefix = false;
5056 return MATCH_YES;
5058 error:
5059 gcc_assert (gfc_matching_prefix);
5060 gfc_matching_prefix = false;
5061 return MATCH_ERROR;
5065 /* Copy attributes matched by gfc_match_prefix() to attributes on a symbol. */
5067 static bool
5068 copy_prefix (symbol_attribute *dest, locus *where)
5070 if (dest->module_procedure)
5072 if (current_attr.elemental)
5073 dest->elemental = 1;
5075 if (current_attr.pure)
5076 dest->pure = 1;
5078 if (current_attr.recursive)
5079 dest->recursive = 1;
5081 /* Module procedures are unusual in that the 'dest' is copied from
5082 the interface declaration. However, this is an oportunity to
5083 check that the submodule declaration is compliant with the
5084 interface. */
5085 if (dest->elemental && !current_attr.elemental)
5087 gfc_error ("ELEMENTAL prefix in MODULE PROCEDURE interface is "
5088 "missing at %L", where);
5089 return false;
5092 if (dest->pure && !current_attr.pure)
5094 gfc_error ("PURE prefix in MODULE PROCEDURE interface is "
5095 "missing at %L", where);
5096 return false;
5099 if (dest->recursive && !current_attr.recursive)
5101 gfc_error ("RECURSIVE prefix in MODULE PROCEDURE interface is "
5102 "missing at %L", where);
5103 return false;
5106 return true;
5109 if (current_attr.elemental && !gfc_add_elemental (dest, where))
5110 return false;
5112 if (current_attr.pure && !gfc_add_pure (dest, where))
5113 return false;
5115 if (current_attr.recursive && !gfc_add_recursive (dest, where))
5116 return false;
5118 return true;
5122 /* Match a formal argument list. */
5124 match
5125 gfc_match_formal_arglist (gfc_symbol *progname, int st_flag, int null_flag)
5127 gfc_formal_arglist *head, *tail, *p, *q;
5128 char name[GFC_MAX_SYMBOL_LEN + 1];
5129 gfc_symbol *sym;
5130 match m;
5131 gfc_formal_arglist *formal = NULL;
5133 head = tail = NULL;
5135 /* Keep the interface formal argument list and null it so that the
5136 matching for the new declaration can be done. The numbers and
5137 names of the arguments are checked here. The interface formal
5138 arguments are retained in formal_arglist and the characteristics
5139 are compared in resolve.c(resolve_fl_procedure). See the remark
5140 in get_proc_name about the eventual need to copy the formal_arglist
5141 and populate the formal namespace of the interface symbol. */
5142 if (progname->attr.module_procedure
5143 && progname->attr.host_assoc)
5145 formal = progname->formal;
5146 progname->formal = NULL;
5149 if (gfc_match_char ('(') != MATCH_YES)
5151 if (null_flag)
5152 goto ok;
5153 return MATCH_NO;
5156 if (gfc_match_char (')') == MATCH_YES)
5157 goto ok;
5159 for (;;)
5161 if (gfc_match_char ('*') == MATCH_YES)
5163 sym = NULL;
5164 if (!gfc_notify_std (GFC_STD_F95_OBS, "Alternate-return argument "
5165 "at %C"))
5167 m = MATCH_ERROR;
5168 goto cleanup;
5171 else
5173 m = gfc_match_name (name);
5174 if (m != MATCH_YES)
5175 goto cleanup;
5177 if (gfc_get_symbol (name, NULL, &sym))
5178 goto cleanup;
5181 p = gfc_get_formal_arglist ();
5183 if (head == NULL)
5184 head = tail = p;
5185 else
5187 tail->next = p;
5188 tail = p;
5191 tail->sym = sym;
5193 /* We don't add the VARIABLE flavor because the name could be a
5194 dummy procedure. We don't apply these attributes to formal
5195 arguments of statement functions. */
5196 if (sym != NULL && !st_flag
5197 && (!gfc_add_dummy(&sym->attr, sym->name, NULL)
5198 || !gfc_missing_attr (&sym->attr, NULL)))
5200 m = MATCH_ERROR;
5201 goto cleanup;
5204 /* The name of a program unit can be in a different namespace,
5205 so check for it explicitly. After the statement is accepted,
5206 the name is checked for especially in gfc_get_symbol(). */
5207 if (gfc_new_block != NULL && sym != NULL
5208 && strcmp (sym->name, gfc_new_block->name) == 0)
5210 gfc_error ("Name %qs at %C is the name of the procedure",
5211 sym->name);
5212 m = MATCH_ERROR;
5213 goto cleanup;
5216 if (gfc_match_char (')') == MATCH_YES)
5217 goto ok;
5219 m = gfc_match_char (',');
5220 if (m != MATCH_YES)
5222 gfc_error ("Unexpected junk in formal argument list at %C");
5223 goto cleanup;
5228 /* Check for duplicate symbols in the formal argument list. */
5229 if (head != NULL)
5231 for (p = head; p->next; p = p->next)
5233 if (p->sym == NULL)
5234 continue;
5236 for (q = p->next; q; q = q->next)
5237 if (p->sym == q->sym)
5239 gfc_error ("Duplicate symbol %qs in formal argument list "
5240 "at %C", p->sym->name);
5242 m = MATCH_ERROR;
5243 goto cleanup;
5248 if (!gfc_add_explicit_interface (progname, IFSRC_DECL, head, NULL))
5250 m = MATCH_ERROR;
5251 goto cleanup;
5254 /* gfc_error_now used in following and return with MATCH_YES because
5255 doing otherwise results in a cascade of extraneous errors and in
5256 some cases an ICE in symbol.c(gfc_release_symbol). */
5257 if (progname->attr.module_procedure && progname->attr.host_assoc)
5259 bool arg_count_mismatch = false;
5261 if (!formal && head)
5262 arg_count_mismatch = true;
5264 /* Abbreviated module procedure declaration is not meant to have any
5265 formal arguments! */
5266 if (!progname->abr_modproc_decl && formal && !head)
5267 arg_count_mismatch = true;
5269 for (p = formal, q = head; p && q; p = p->next, q = q->next)
5271 if ((p->next != NULL && q->next == NULL)
5272 || (p->next == NULL && q->next != NULL))
5273 arg_count_mismatch = true;
5274 else if ((p->sym == NULL && q->sym == NULL)
5275 || strcmp (p->sym->name, q->sym->name) == 0)
5276 continue;
5277 else
5278 gfc_error_now ("Mismatch in MODULE PROCEDURE formal "
5279 "argument names (%s/%s) at %C",
5280 p->sym->name, q->sym->name);
5283 if (arg_count_mismatch)
5284 gfc_error_now ("Mismatch in number of MODULE PROCEDURE "
5285 "formal arguments at %C");
5288 return MATCH_YES;
5290 cleanup:
5291 gfc_free_formal_arglist (head);
5292 return m;
5296 /* Match a RESULT specification following a function declaration or
5297 ENTRY statement. Also matches the end-of-statement. */
5299 static match
5300 match_result (gfc_symbol *function, gfc_symbol **result)
5302 char name[GFC_MAX_SYMBOL_LEN + 1];
5303 gfc_symbol *r;
5304 match m;
5306 if (gfc_match (" result (") != MATCH_YES)
5307 return MATCH_NO;
5309 m = gfc_match_name (name);
5310 if (m != MATCH_YES)
5311 return m;
5313 /* Get the right paren, and that's it because there could be the
5314 bind(c) attribute after the result clause. */
5315 if (gfc_match_char (')') != MATCH_YES)
5317 /* TODO: should report the missing right paren here. */
5318 return MATCH_ERROR;
5321 if (strcmp (function->name, name) == 0)
5323 gfc_error ("RESULT variable at %C must be different than function name");
5324 return MATCH_ERROR;
5327 if (gfc_get_symbol (name, NULL, &r))
5328 return MATCH_ERROR;
5330 if (!gfc_add_result (&r->attr, r->name, NULL))
5331 return MATCH_ERROR;
5333 *result = r;
5335 return MATCH_YES;
5339 /* Match a function suffix, which could be a combination of a result
5340 clause and BIND(C), either one, or neither. The draft does not
5341 require them to come in a specific order. */
5343 match
5344 gfc_match_suffix (gfc_symbol *sym, gfc_symbol **result)
5346 match is_bind_c; /* Found bind(c). */
5347 match is_result; /* Found result clause. */
5348 match found_match; /* Status of whether we've found a good match. */
5349 char peek_char; /* Character we're going to peek at. */
5350 bool allow_binding_name;
5352 /* Initialize to having found nothing. */
5353 found_match = MATCH_NO;
5354 is_bind_c = MATCH_NO;
5355 is_result = MATCH_NO;
5357 /* Get the next char to narrow between result and bind(c). */
5358 gfc_gobble_whitespace ();
5359 peek_char = gfc_peek_ascii_char ();
5361 /* C binding names are not allowed for internal procedures. */
5362 if (gfc_current_state () == COMP_CONTAINS
5363 && sym->ns->proc_name->attr.flavor != FL_MODULE)
5364 allow_binding_name = false;
5365 else
5366 allow_binding_name = true;
5368 switch (peek_char)
5370 case 'r':
5371 /* Look for result clause. */
5372 is_result = match_result (sym, result);
5373 if (is_result == MATCH_YES)
5375 /* Now see if there is a bind(c) after it. */
5376 is_bind_c = gfc_match_bind_c (sym, allow_binding_name);
5377 /* We've found the result clause and possibly bind(c). */
5378 found_match = MATCH_YES;
5380 else
5381 /* This should only be MATCH_ERROR. */
5382 found_match = is_result;
5383 break;
5384 case 'b':
5385 /* Look for bind(c) first. */
5386 is_bind_c = gfc_match_bind_c (sym, allow_binding_name);
5387 if (is_bind_c == MATCH_YES)
5389 /* Now see if a result clause followed it. */
5390 is_result = match_result (sym, result);
5391 found_match = MATCH_YES;
5393 else
5395 /* Should only be a MATCH_ERROR if we get here after seeing 'b'. */
5396 found_match = MATCH_ERROR;
5398 break;
5399 default:
5400 gfc_error ("Unexpected junk after function declaration at %C");
5401 found_match = MATCH_ERROR;
5402 break;
5405 if (is_bind_c == MATCH_YES)
5407 /* Fortran 2008 draft allows BIND(C) for internal procedures. */
5408 if (gfc_current_state () == COMP_CONTAINS
5409 && sym->ns->proc_name->attr.flavor != FL_MODULE
5410 && !gfc_notify_std (GFC_STD_F2008, "BIND(C) attribute "
5411 "at %L may not be specified for an internal "
5412 "procedure", &gfc_current_locus))
5413 return MATCH_ERROR;
5415 if (!gfc_add_is_bind_c (&(sym->attr), sym->name, &gfc_current_locus, 1))
5416 return MATCH_ERROR;
5419 return found_match;
5423 /* Procedure pointer return value without RESULT statement:
5424 Add "hidden" result variable named "ppr@". */
5426 static bool
5427 add_hidden_procptr_result (gfc_symbol *sym)
5429 bool case1,case2;
5431 if (gfc_notification_std (GFC_STD_F2003) == ERROR)
5432 return false;
5434 /* First usage case: PROCEDURE and EXTERNAL statements. */
5435 case1 = gfc_current_state () == COMP_FUNCTION && gfc_current_block ()
5436 && strcmp (gfc_current_block ()->name, sym->name) == 0
5437 && sym->attr.external;
5438 /* Second usage case: INTERFACE statements. */
5439 case2 = gfc_current_state () == COMP_INTERFACE && gfc_state_stack->previous
5440 && gfc_state_stack->previous->state == COMP_FUNCTION
5441 && strcmp (gfc_state_stack->previous->sym->name, sym->name) == 0;
5443 if (case1 || case2)
5445 gfc_symtree *stree;
5446 if (case1)
5447 gfc_get_sym_tree ("ppr@", gfc_current_ns, &stree, false);
5448 else if (case2)
5450 gfc_symtree *st2;
5451 gfc_get_sym_tree ("ppr@", gfc_current_ns->parent, &stree, false);
5452 st2 = gfc_new_symtree (&gfc_current_ns->sym_root, "ppr@");
5453 st2->n.sym = stree->n.sym;
5454 stree->n.sym->refs++;
5456 sym->result = stree->n.sym;
5458 sym->result->attr.proc_pointer = sym->attr.proc_pointer;
5459 sym->result->attr.pointer = sym->attr.pointer;
5460 sym->result->attr.external = sym->attr.external;
5461 sym->result->attr.referenced = sym->attr.referenced;
5462 sym->result->ts = sym->ts;
5463 sym->attr.proc_pointer = 0;
5464 sym->attr.pointer = 0;
5465 sym->attr.external = 0;
5466 if (sym->result->attr.external && sym->result->attr.pointer)
5468 sym->result->attr.pointer = 0;
5469 sym->result->attr.proc_pointer = 1;
5472 return gfc_add_result (&sym->result->attr, sym->result->name, NULL);
5474 /* POINTER after PROCEDURE/EXTERNAL/INTERFACE statement. */
5475 else if (sym->attr.function && !sym->attr.external && sym->attr.pointer
5476 && sym->result && sym->result != sym && sym->result->attr.external
5477 && sym == gfc_current_ns->proc_name
5478 && sym == sym->result->ns->proc_name
5479 && strcmp ("ppr@", sym->result->name) == 0)
5481 sym->result->attr.proc_pointer = 1;
5482 sym->attr.pointer = 0;
5483 return true;
5485 else
5486 return false;
5490 /* Match the interface for a PROCEDURE declaration,
5491 including brackets (R1212). */
5493 static match
5494 match_procedure_interface (gfc_symbol **proc_if)
5496 match m;
5497 gfc_symtree *st;
5498 locus old_loc, entry_loc;
5499 gfc_namespace *old_ns = gfc_current_ns;
5500 char name[GFC_MAX_SYMBOL_LEN + 1];
5502 old_loc = entry_loc = gfc_current_locus;
5503 gfc_clear_ts (&current_ts);
5505 if (gfc_match (" (") != MATCH_YES)
5507 gfc_current_locus = entry_loc;
5508 return MATCH_NO;
5511 /* Get the type spec. for the procedure interface. */
5512 old_loc = gfc_current_locus;
5513 m = gfc_match_decl_type_spec (&current_ts, 0);
5514 gfc_gobble_whitespace ();
5515 if (m == MATCH_YES || (m == MATCH_NO && gfc_peek_ascii_char () == ')'))
5516 goto got_ts;
5518 if (m == MATCH_ERROR)
5519 return m;
5521 /* Procedure interface is itself a procedure. */
5522 gfc_current_locus = old_loc;
5523 m = gfc_match_name (name);
5525 /* First look to see if it is already accessible in the current
5526 namespace because it is use associated or contained. */
5527 st = NULL;
5528 if (gfc_find_sym_tree (name, NULL, 0, &st))
5529 return MATCH_ERROR;
5531 /* If it is still not found, then try the parent namespace, if it
5532 exists and create the symbol there if it is still not found. */
5533 if (gfc_current_ns->parent)
5534 gfc_current_ns = gfc_current_ns->parent;
5535 if (st == NULL && gfc_get_ha_sym_tree (name, &st))
5536 return MATCH_ERROR;
5538 gfc_current_ns = old_ns;
5539 *proc_if = st->n.sym;
5541 if (*proc_if)
5543 (*proc_if)->refs++;
5544 /* Resolve interface if possible. That way, attr.procedure is only set
5545 if it is declared by a later procedure-declaration-stmt, which is
5546 invalid per F08:C1216 (cf. resolve_procedure_interface). */
5547 while ((*proc_if)->ts.interface
5548 && *proc_if != (*proc_if)->ts.interface)
5549 *proc_if = (*proc_if)->ts.interface;
5551 if ((*proc_if)->attr.flavor == FL_UNKNOWN
5552 && (*proc_if)->ts.type == BT_UNKNOWN
5553 && !gfc_add_flavor (&(*proc_if)->attr, FL_PROCEDURE,
5554 (*proc_if)->name, NULL))
5555 return MATCH_ERROR;
5558 got_ts:
5559 if (gfc_match (" )") != MATCH_YES)
5561 gfc_current_locus = entry_loc;
5562 return MATCH_NO;
5565 return MATCH_YES;
5569 /* Match a PROCEDURE declaration (R1211). */
5571 static match
5572 match_procedure_decl (void)
5574 match m;
5575 gfc_symbol *sym, *proc_if = NULL;
5576 int num;
5577 gfc_expr *initializer = NULL;
5579 /* Parse interface (with brackets). */
5580 m = match_procedure_interface (&proc_if);
5581 if (m != MATCH_YES)
5582 return m;
5584 /* Parse attributes (with colons). */
5585 m = match_attr_spec();
5586 if (m == MATCH_ERROR)
5587 return MATCH_ERROR;
5589 if (proc_if && proc_if->attr.is_bind_c && !current_attr.is_bind_c)
5591 current_attr.is_bind_c = 1;
5592 has_name_equals = 0;
5593 curr_binding_label = NULL;
5596 /* Get procedure symbols. */
5597 for(num=1;;num++)
5599 m = gfc_match_symbol (&sym, 0);
5600 if (m == MATCH_NO)
5601 goto syntax;
5602 else if (m == MATCH_ERROR)
5603 return m;
5605 /* Add current_attr to the symbol attributes. */
5606 if (!gfc_copy_attr (&sym->attr, &current_attr, NULL))
5607 return MATCH_ERROR;
5609 if (sym->attr.is_bind_c)
5611 /* Check for C1218. */
5612 if (!proc_if || !proc_if->attr.is_bind_c)
5614 gfc_error ("BIND(C) attribute at %C requires "
5615 "an interface with BIND(C)");
5616 return MATCH_ERROR;
5618 /* Check for C1217. */
5619 if (has_name_equals && sym->attr.pointer)
5621 gfc_error ("BIND(C) procedure with NAME may not have "
5622 "POINTER attribute at %C");
5623 return MATCH_ERROR;
5625 if (has_name_equals && sym->attr.dummy)
5627 gfc_error ("Dummy procedure at %C may not have "
5628 "BIND(C) attribute with NAME");
5629 return MATCH_ERROR;
5631 /* Set binding label for BIND(C). */
5632 if (!set_binding_label (&sym->binding_label, sym->name, num))
5633 return MATCH_ERROR;
5636 if (!gfc_add_external (&sym->attr, NULL))
5637 return MATCH_ERROR;
5639 if (add_hidden_procptr_result (sym))
5640 sym = sym->result;
5642 if (!gfc_add_proc (&sym->attr, sym->name, NULL))
5643 return MATCH_ERROR;
5645 /* Set interface. */
5646 if (proc_if != NULL)
5648 if (sym->ts.type != BT_UNKNOWN)
5650 gfc_error ("Procedure %qs at %L already has basic type of %s",
5651 sym->name, &gfc_current_locus,
5652 gfc_basic_typename (sym->ts.type));
5653 return MATCH_ERROR;
5655 sym->ts.interface = proc_if;
5656 sym->attr.untyped = 1;
5657 sym->attr.if_source = IFSRC_IFBODY;
5659 else if (current_ts.type != BT_UNKNOWN)
5661 if (!gfc_add_type (sym, &current_ts, &gfc_current_locus))
5662 return MATCH_ERROR;
5663 sym->ts.interface = gfc_new_symbol ("", gfc_current_ns);
5664 sym->ts.interface->ts = current_ts;
5665 sym->ts.interface->attr.flavor = FL_PROCEDURE;
5666 sym->ts.interface->attr.function = 1;
5667 sym->attr.function = 1;
5668 sym->attr.if_source = IFSRC_UNKNOWN;
5671 if (gfc_match (" =>") == MATCH_YES)
5673 if (!current_attr.pointer)
5675 gfc_error ("Initialization at %C isn't for a pointer variable");
5676 m = MATCH_ERROR;
5677 goto cleanup;
5680 m = match_pointer_init (&initializer, 1);
5681 if (m != MATCH_YES)
5682 goto cleanup;
5684 if (!add_init_expr_to_sym (sym->name, &initializer, &gfc_current_locus))
5685 goto cleanup;
5689 if (gfc_match_eos () == MATCH_YES)
5690 return MATCH_YES;
5691 if (gfc_match_char (',') != MATCH_YES)
5692 goto syntax;
5695 syntax:
5696 gfc_error ("Syntax error in PROCEDURE statement at %C");
5697 return MATCH_ERROR;
5699 cleanup:
5700 /* Free stuff up and return. */
5701 gfc_free_expr (initializer);
5702 return m;
5706 static match
5707 match_binding_attributes (gfc_typebound_proc* ba, bool generic, bool ppc);
5710 /* Match a procedure pointer component declaration (R445). */
5712 static match
5713 match_ppc_decl (void)
5715 match m;
5716 gfc_symbol *proc_if = NULL;
5717 gfc_typespec ts;
5718 int num;
5719 gfc_component *c;
5720 gfc_expr *initializer = NULL;
5721 gfc_typebound_proc* tb;
5722 char name[GFC_MAX_SYMBOL_LEN + 1];
5724 /* Parse interface (with brackets). */
5725 m = match_procedure_interface (&proc_if);
5726 if (m != MATCH_YES)
5727 goto syntax;
5729 /* Parse attributes. */
5730 tb = XCNEW (gfc_typebound_proc);
5731 tb->where = gfc_current_locus;
5732 m = match_binding_attributes (tb, false, true);
5733 if (m == MATCH_ERROR)
5734 return m;
5736 gfc_clear_attr (&current_attr);
5737 current_attr.procedure = 1;
5738 current_attr.proc_pointer = 1;
5739 current_attr.access = tb->access;
5740 current_attr.flavor = FL_PROCEDURE;
5742 /* Match the colons (required). */
5743 if (gfc_match (" ::") != MATCH_YES)
5745 gfc_error ("Expected %<::%> after binding-attributes at %C");
5746 return MATCH_ERROR;
5749 /* Check for C450. */
5750 if (!tb->nopass && proc_if == NULL)
5752 gfc_error("NOPASS or explicit interface required at %C");
5753 return MATCH_ERROR;
5756 if (!gfc_notify_std (GFC_STD_F2003, "Procedure pointer component at %C"))
5757 return MATCH_ERROR;
5759 /* Match PPC names. */
5760 ts = current_ts;
5761 for(num=1;;num++)
5763 m = gfc_match_name (name);
5764 if (m == MATCH_NO)
5765 goto syntax;
5766 else if (m == MATCH_ERROR)
5767 return m;
5769 if (!gfc_add_component (gfc_current_block(), name, &c))
5770 return MATCH_ERROR;
5772 /* Add current_attr to the symbol attributes. */
5773 if (!gfc_copy_attr (&c->attr, &current_attr, NULL))
5774 return MATCH_ERROR;
5776 if (!gfc_add_external (&c->attr, NULL))
5777 return MATCH_ERROR;
5779 if (!gfc_add_proc (&c->attr, name, NULL))
5780 return MATCH_ERROR;
5782 if (num == 1)
5783 c->tb = tb;
5784 else
5786 c->tb = XCNEW (gfc_typebound_proc);
5787 c->tb->where = gfc_current_locus;
5788 *c->tb = *tb;
5791 /* Set interface. */
5792 if (proc_if != NULL)
5794 c->ts.interface = proc_if;
5795 c->attr.untyped = 1;
5796 c->attr.if_source = IFSRC_IFBODY;
5798 else if (ts.type != BT_UNKNOWN)
5800 c->ts = ts;
5801 c->ts.interface = gfc_new_symbol ("", gfc_current_ns);
5802 c->ts.interface->result = c->ts.interface;
5803 c->ts.interface->ts = ts;
5804 c->ts.interface->attr.flavor = FL_PROCEDURE;
5805 c->ts.interface->attr.function = 1;
5806 c->attr.function = 1;
5807 c->attr.if_source = IFSRC_UNKNOWN;
5810 if (gfc_match (" =>") == MATCH_YES)
5812 m = match_pointer_init (&initializer, 1);
5813 if (m != MATCH_YES)
5815 gfc_free_expr (initializer);
5816 return m;
5818 c->initializer = initializer;
5821 if (gfc_match_eos () == MATCH_YES)
5822 return MATCH_YES;
5823 if (gfc_match_char (',') != MATCH_YES)
5824 goto syntax;
5827 syntax:
5828 gfc_error ("Syntax error in procedure pointer component at %C");
5829 return MATCH_ERROR;
5833 /* Match a PROCEDURE declaration inside an interface (R1206). */
5835 static match
5836 match_procedure_in_interface (void)
5838 match m;
5839 gfc_symbol *sym;
5840 char name[GFC_MAX_SYMBOL_LEN + 1];
5841 locus old_locus;
5843 if (current_interface.type == INTERFACE_NAMELESS
5844 || current_interface.type == INTERFACE_ABSTRACT)
5846 gfc_error ("PROCEDURE at %C must be in a generic interface");
5847 return MATCH_ERROR;
5850 /* Check if the F2008 optional double colon appears. */
5851 gfc_gobble_whitespace ();
5852 old_locus = gfc_current_locus;
5853 if (gfc_match ("::") == MATCH_YES)
5855 if (!gfc_notify_std (GFC_STD_F2008, "double colon in "
5856 "MODULE PROCEDURE statement at %L", &old_locus))
5857 return MATCH_ERROR;
5859 else
5860 gfc_current_locus = old_locus;
5862 for(;;)
5864 m = gfc_match_name (name);
5865 if (m == MATCH_NO)
5866 goto syntax;
5867 else if (m == MATCH_ERROR)
5868 return m;
5869 if (gfc_get_symbol (name, gfc_current_ns->parent, &sym))
5870 return MATCH_ERROR;
5872 if (!gfc_add_interface (sym))
5873 return MATCH_ERROR;
5875 if (gfc_match_eos () == MATCH_YES)
5876 break;
5877 if (gfc_match_char (',') != MATCH_YES)
5878 goto syntax;
5881 return MATCH_YES;
5883 syntax:
5884 gfc_error ("Syntax error in PROCEDURE statement at %C");
5885 return MATCH_ERROR;
5889 /* General matcher for PROCEDURE declarations. */
5891 static match match_procedure_in_type (void);
5893 match
5894 gfc_match_procedure (void)
5896 match m;
5898 switch (gfc_current_state ())
5900 case COMP_NONE:
5901 case COMP_PROGRAM:
5902 case COMP_MODULE:
5903 case COMP_SUBMODULE:
5904 case COMP_SUBROUTINE:
5905 case COMP_FUNCTION:
5906 case COMP_BLOCK:
5907 m = match_procedure_decl ();
5908 break;
5909 case COMP_INTERFACE:
5910 m = match_procedure_in_interface ();
5911 break;
5912 case COMP_DERIVED:
5913 m = match_ppc_decl ();
5914 break;
5915 case COMP_DERIVED_CONTAINS:
5916 m = match_procedure_in_type ();
5917 break;
5918 default:
5919 return MATCH_NO;
5922 if (m != MATCH_YES)
5923 return m;
5925 if (!gfc_notify_std (GFC_STD_F2003, "PROCEDURE statement at %C"))
5926 return MATCH_ERROR;
5928 return m;
5932 /* Warn if a matched procedure has the same name as an intrinsic; this is
5933 simply a wrapper around gfc_warn_intrinsic_shadow that interprets the current
5934 parser-state-stack to find out whether we're in a module. */
5936 static void
5937 do_warn_intrinsic_shadow (const gfc_symbol* sym, bool func)
5939 bool in_module;
5941 in_module = (gfc_state_stack->previous
5942 && (gfc_state_stack->previous->state == COMP_MODULE
5943 || gfc_state_stack->previous->state == COMP_SUBMODULE));
5945 gfc_warn_intrinsic_shadow (sym, in_module, func);
5949 /* Match a function declaration. */
5951 match
5952 gfc_match_function_decl (void)
5954 char name[GFC_MAX_SYMBOL_LEN + 1];
5955 gfc_symbol *sym, *result;
5956 locus old_loc;
5957 match m;
5958 match suffix_match;
5959 match found_match; /* Status returned by match func. */
5961 if (gfc_current_state () != COMP_NONE
5962 && gfc_current_state () != COMP_INTERFACE
5963 && gfc_current_state () != COMP_CONTAINS)
5964 return MATCH_NO;
5966 gfc_clear_ts (&current_ts);
5968 old_loc = gfc_current_locus;
5970 m = gfc_match_prefix (&current_ts);
5971 if (m != MATCH_YES)
5973 gfc_current_locus = old_loc;
5974 return m;
5977 if (gfc_match ("function% %n", name) != MATCH_YES)
5979 gfc_current_locus = old_loc;
5980 return MATCH_NO;
5983 if (get_proc_name (name, &sym, false))
5984 return MATCH_ERROR;
5986 if (add_hidden_procptr_result (sym))
5987 sym = sym->result;
5989 if (current_attr.module_procedure)
5990 sym->attr.module_procedure = 1;
5992 gfc_new_block = sym;
5994 m = gfc_match_formal_arglist (sym, 0, 0);
5995 if (m == MATCH_NO)
5997 gfc_error ("Expected formal argument list in function "
5998 "definition at %C");
5999 m = MATCH_ERROR;
6000 goto cleanup;
6002 else if (m == MATCH_ERROR)
6003 goto cleanup;
6005 result = NULL;
6007 /* According to the draft, the bind(c) and result clause can
6008 come in either order after the formal_arg_list (i.e., either
6009 can be first, both can exist together or by themselves or neither
6010 one). Therefore, the match_result can't match the end of the
6011 string, and check for the bind(c) or result clause in either order. */
6012 found_match = gfc_match_eos ();
6014 /* Make sure that it isn't already declared as BIND(C). If it is, it
6015 must have been marked BIND(C) with a BIND(C) attribute and that is
6016 not allowed for procedures. */
6017 if (sym->attr.is_bind_c == 1)
6019 sym->attr.is_bind_c = 0;
6020 if (sym->old_symbol != NULL)
6021 gfc_error_now ("BIND(C) attribute at %L can only be used for "
6022 "variables or common blocks",
6023 &(sym->old_symbol->declared_at));
6024 else
6025 gfc_error_now ("BIND(C) attribute at %L can only be used for "
6026 "variables or common blocks", &gfc_current_locus);
6029 if (found_match != MATCH_YES)
6031 /* If we haven't found the end-of-statement, look for a suffix. */
6032 suffix_match = gfc_match_suffix (sym, &result);
6033 if (suffix_match == MATCH_YES)
6034 /* Need to get the eos now. */
6035 found_match = gfc_match_eos ();
6036 else
6037 found_match = suffix_match;
6040 if(found_match != MATCH_YES)
6041 m = MATCH_ERROR;
6042 else
6044 /* Make changes to the symbol. */
6045 m = MATCH_ERROR;
6047 if (!gfc_add_function (&sym->attr, sym->name, NULL))
6048 goto cleanup;
6050 if (!gfc_missing_attr (&sym->attr, NULL))
6051 goto cleanup;
6053 if (!copy_prefix (&sym->attr, &sym->declared_at))
6055 if(!sym->attr.module_procedure)
6056 goto cleanup;
6057 else
6058 gfc_error_check ();
6061 /* Delay matching the function characteristics until after the
6062 specification block by signalling kind=-1. */
6063 sym->declared_at = old_loc;
6064 if (current_ts.type != BT_UNKNOWN)
6065 current_ts.kind = -1;
6066 else
6067 current_ts.kind = 0;
6069 if (result == NULL)
6071 if (current_ts.type != BT_UNKNOWN
6072 && !gfc_add_type (sym, &current_ts, &gfc_current_locus))
6073 goto cleanup;
6074 sym->result = sym;
6076 else
6078 if (current_ts.type != BT_UNKNOWN
6079 && !gfc_add_type (result, &current_ts, &gfc_current_locus))
6080 goto cleanup;
6081 sym->result = result;
6084 /* Warn if this procedure has the same name as an intrinsic. */
6085 do_warn_intrinsic_shadow (sym, true);
6087 return MATCH_YES;
6090 cleanup:
6091 gfc_current_locus = old_loc;
6092 return m;
6096 /* This is mostly a copy of parse.c(add_global_procedure) but modified to
6097 pass the name of the entry, rather than the gfc_current_block name, and
6098 to return false upon finding an existing global entry. */
6100 static bool
6101 add_global_entry (const char *name, const char *binding_label, bool sub,
6102 locus *where)
6104 gfc_gsymbol *s;
6105 enum gfc_symbol_type type;
6107 type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
6109 /* Only in Fortran 2003: For procedures with a binding label also the Fortran
6110 name is a global identifier. */
6111 if (!binding_label || gfc_notification_std (GFC_STD_F2008))
6113 s = gfc_get_gsymbol (name);
6115 if (s->defined || (s->type != GSYM_UNKNOWN && s->type != type))
6117 gfc_global_used (s, where);
6118 return false;
6120 else
6122 s->type = type;
6123 s->sym_name = name;
6124 s->where = *where;
6125 s->defined = 1;
6126 s->ns = gfc_current_ns;
6130 /* Don't add the symbol multiple times. */
6131 if (binding_label
6132 && (!gfc_notification_std (GFC_STD_F2008)
6133 || strcmp (name, binding_label) != 0))
6135 s = gfc_get_gsymbol (binding_label);
6137 if (s->defined || (s->type != GSYM_UNKNOWN && s->type != type))
6139 gfc_global_used (s, where);
6140 return false;
6142 else
6144 s->type = type;
6145 s->sym_name = name;
6146 s->binding_label = binding_label;
6147 s->where = *where;
6148 s->defined = 1;
6149 s->ns = gfc_current_ns;
6153 return true;
6157 /* Match an ENTRY statement. */
6159 match
6160 gfc_match_entry (void)
6162 gfc_symbol *proc;
6163 gfc_symbol *result;
6164 gfc_symbol *entry;
6165 char name[GFC_MAX_SYMBOL_LEN + 1];
6166 gfc_compile_state state;
6167 match m;
6168 gfc_entry_list *el;
6169 locus old_loc;
6170 bool module_procedure;
6171 char peek_char;
6172 match is_bind_c;
6174 m = gfc_match_name (name);
6175 if (m != MATCH_YES)
6176 return m;
6178 if (!gfc_notify_std (GFC_STD_F2008_OBS, "ENTRY statement at %C"))
6179 return MATCH_ERROR;
6181 state = gfc_current_state ();
6182 if (state != COMP_SUBROUTINE && state != COMP_FUNCTION)
6184 switch (state)
6186 case COMP_PROGRAM:
6187 gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
6188 break;
6189 case COMP_MODULE:
6190 gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
6191 break;
6192 case COMP_SUBMODULE:
6193 gfc_error ("ENTRY statement at %C cannot appear within a SUBMODULE");
6194 break;
6195 case COMP_BLOCK_DATA:
6196 gfc_error ("ENTRY statement at %C cannot appear within "
6197 "a BLOCK DATA");
6198 break;
6199 case COMP_INTERFACE:
6200 gfc_error ("ENTRY statement at %C cannot appear within "
6201 "an INTERFACE");
6202 break;
6203 case COMP_STRUCTURE:
6204 gfc_error ("ENTRY statement at %C cannot appear within "
6205 "a STRUCTURE block");
6206 break;
6207 case COMP_DERIVED:
6208 gfc_error ("ENTRY statement at %C cannot appear within "
6209 "a DERIVED TYPE block");
6210 break;
6211 case COMP_IF:
6212 gfc_error ("ENTRY statement at %C cannot appear within "
6213 "an IF-THEN block");
6214 break;
6215 case COMP_DO:
6216 case COMP_DO_CONCURRENT:
6217 gfc_error ("ENTRY statement at %C cannot appear within "
6218 "a DO block");
6219 break;
6220 case COMP_SELECT:
6221 gfc_error ("ENTRY statement at %C cannot appear within "
6222 "a SELECT block");
6223 break;
6224 case COMP_FORALL:
6225 gfc_error ("ENTRY statement at %C cannot appear within "
6226 "a FORALL block");
6227 break;
6228 case COMP_WHERE:
6229 gfc_error ("ENTRY statement at %C cannot appear within "
6230 "a WHERE block");
6231 break;
6232 case COMP_CONTAINS:
6233 gfc_error ("ENTRY statement at %C cannot appear within "
6234 "a contained subprogram");
6235 break;
6236 default:
6237 gfc_error ("Unexpected ENTRY statement at %C");
6239 return MATCH_ERROR;
6242 if ((state == COMP_SUBROUTINE || state == COMP_FUNCTION)
6243 && gfc_state_stack->previous->state == COMP_INTERFACE)
6245 gfc_error ("ENTRY statement at %C cannot appear within an INTERFACE");
6246 return MATCH_ERROR;
6249 module_procedure = gfc_current_ns->parent != NULL
6250 && gfc_current_ns->parent->proc_name
6251 && gfc_current_ns->parent->proc_name->attr.flavor
6252 == FL_MODULE;
6254 if (gfc_current_ns->parent != NULL
6255 && gfc_current_ns->parent->proc_name
6256 && !module_procedure)
6258 gfc_error("ENTRY statement at %C cannot appear in a "
6259 "contained procedure");
6260 return MATCH_ERROR;
6263 /* Module function entries need special care in get_proc_name
6264 because previous references within the function will have
6265 created symbols attached to the current namespace. */
6266 if (get_proc_name (name, &entry,
6267 gfc_current_ns->parent != NULL
6268 && module_procedure))
6269 return MATCH_ERROR;
6271 proc = gfc_current_block ();
6273 /* Make sure that it isn't already declared as BIND(C). If it is, it
6274 must have been marked BIND(C) with a BIND(C) attribute and that is
6275 not allowed for procedures. */
6276 if (entry->attr.is_bind_c == 1)
6278 entry->attr.is_bind_c = 0;
6279 if (entry->old_symbol != NULL)
6280 gfc_error_now ("BIND(C) attribute at %L can only be used for "
6281 "variables or common blocks",
6282 &(entry->old_symbol->declared_at));
6283 else
6284 gfc_error_now ("BIND(C) attribute at %L can only be used for "
6285 "variables or common blocks", &gfc_current_locus);
6288 /* Check what next non-whitespace character is so we can tell if there
6289 is the required parens if we have a BIND(C). */
6290 old_loc = gfc_current_locus;
6291 gfc_gobble_whitespace ();
6292 peek_char = gfc_peek_ascii_char ();
6294 if (state == COMP_SUBROUTINE)
6296 m = gfc_match_formal_arglist (entry, 0, 1);
6297 if (m != MATCH_YES)
6298 return MATCH_ERROR;
6300 /* Call gfc_match_bind_c with allow_binding_name = true as ENTRY can
6301 never be an internal procedure. */
6302 is_bind_c = gfc_match_bind_c (entry, true);
6303 if (is_bind_c == MATCH_ERROR)
6304 return MATCH_ERROR;
6305 if (is_bind_c == MATCH_YES)
6307 if (peek_char != '(')
6309 gfc_error ("Missing required parentheses before BIND(C) at %C");
6310 return MATCH_ERROR;
6312 if (!gfc_add_is_bind_c (&(entry->attr), entry->name,
6313 &(entry->declared_at), 1))
6314 return MATCH_ERROR;
6317 if (!gfc_current_ns->parent
6318 && !add_global_entry (name, entry->binding_label, true,
6319 &old_loc))
6320 return MATCH_ERROR;
6322 /* An entry in a subroutine. */
6323 if (!gfc_add_entry (&entry->attr, entry->name, NULL)
6324 || !gfc_add_subroutine (&entry->attr, entry->name, NULL))
6325 return MATCH_ERROR;
6327 else
6329 /* An entry in a function.
6330 We need to take special care because writing
6331 ENTRY f()
6333 ENTRY f
6334 is allowed, whereas
6335 ENTRY f() RESULT (r)
6336 can't be written as
6337 ENTRY f RESULT (r). */
6338 if (gfc_match_eos () == MATCH_YES)
6340 gfc_current_locus = old_loc;
6341 /* Match the empty argument list, and add the interface to
6342 the symbol. */
6343 m = gfc_match_formal_arglist (entry, 0, 1);
6345 else
6346 m = gfc_match_formal_arglist (entry, 0, 0);
6348 if (m != MATCH_YES)
6349 return MATCH_ERROR;
6351 result = NULL;
6353 if (gfc_match_eos () == MATCH_YES)
6355 if (!gfc_add_entry (&entry->attr, entry->name, NULL)
6356 || !gfc_add_function (&entry->attr, entry->name, NULL))
6357 return MATCH_ERROR;
6359 entry->result = entry;
6361 else
6363 m = gfc_match_suffix (entry, &result);
6364 if (m == MATCH_NO)
6365 gfc_syntax_error (ST_ENTRY);
6366 if (m != MATCH_YES)
6367 return MATCH_ERROR;
6369 if (result)
6371 if (!gfc_add_result (&result->attr, result->name, NULL)
6372 || !gfc_add_entry (&entry->attr, result->name, NULL)
6373 || !gfc_add_function (&entry->attr, result->name, NULL))
6374 return MATCH_ERROR;
6375 entry->result = result;
6377 else
6379 if (!gfc_add_entry (&entry->attr, entry->name, NULL)
6380 || !gfc_add_function (&entry->attr, entry->name, NULL))
6381 return MATCH_ERROR;
6382 entry->result = entry;
6386 if (!gfc_current_ns->parent
6387 && !add_global_entry (name, entry->binding_label, false,
6388 &old_loc))
6389 return MATCH_ERROR;
6392 if (gfc_match_eos () != MATCH_YES)
6394 gfc_syntax_error (ST_ENTRY);
6395 return MATCH_ERROR;
6398 entry->attr.recursive = proc->attr.recursive;
6399 entry->attr.elemental = proc->attr.elemental;
6400 entry->attr.pure = proc->attr.pure;
6402 el = gfc_get_entry_list ();
6403 el->sym = entry;
6404 el->next = gfc_current_ns->entries;
6405 gfc_current_ns->entries = el;
6406 if (el->next)
6407 el->id = el->next->id + 1;
6408 else
6409 el->id = 1;
6411 new_st.op = EXEC_ENTRY;
6412 new_st.ext.entry = el;
6414 return MATCH_YES;
6418 /* Match a subroutine statement, including optional prefixes. */
6420 match
6421 gfc_match_subroutine (void)
6423 char name[GFC_MAX_SYMBOL_LEN + 1];
6424 gfc_symbol *sym;
6425 match m;
6426 match is_bind_c;
6427 char peek_char;
6428 bool allow_binding_name;
6430 if (gfc_current_state () != COMP_NONE
6431 && gfc_current_state () != COMP_INTERFACE
6432 && gfc_current_state () != COMP_CONTAINS)
6433 return MATCH_NO;
6435 m = gfc_match_prefix (NULL);
6436 if (m != MATCH_YES)
6437 return m;
6439 m = gfc_match ("subroutine% %n", name);
6440 if (m != MATCH_YES)
6441 return m;
6443 if (get_proc_name (name, &sym, false))
6444 return MATCH_ERROR;
6446 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
6447 the symbol existed before. */
6448 sym->declared_at = gfc_current_locus;
6450 if (current_attr.module_procedure)
6451 sym->attr.module_procedure = 1;
6453 if (add_hidden_procptr_result (sym))
6454 sym = sym->result;
6456 gfc_new_block = sym;
6458 /* Check what next non-whitespace character is so we can tell if there
6459 is the required parens if we have a BIND(C). */
6460 gfc_gobble_whitespace ();
6461 peek_char = gfc_peek_ascii_char ();
6463 if (!gfc_add_subroutine (&sym->attr, sym->name, NULL))
6464 return MATCH_ERROR;
6466 if (gfc_match_formal_arglist (sym, 0, 1) != MATCH_YES)
6467 return MATCH_ERROR;
6469 /* Make sure that it isn't already declared as BIND(C). If it is, it
6470 must have been marked BIND(C) with a BIND(C) attribute and that is
6471 not allowed for procedures. */
6472 if (sym->attr.is_bind_c == 1)
6474 sym->attr.is_bind_c = 0;
6475 if (sym->old_symbol != NULL)
6476 gfc_error_now ("BIND(C) attribute at %L can only be used for "
6477 "variables or common blocks",
6478 &(sym->old_symbol->declared_at));
6479 else
6480 gfc_error_now ("BIND(C) attribute at %L can only be used for "
6481 "variables or common blocks", &gfc_current_locus);
6484 /* C binding names are not allowed for internal procedures. */
6485 if (gfc_current_state () == COMP_CONTAINS
6486 && sym->ns->proc_name->attr.flavor != FL_MODULE)
6487 allow_binding_name = false;
6488 else
6489 allow_binding_name = true;
6491 /* Here, we are just checking if it has the bind(c) attribute, and if
6492 so, then we need to make sure it's all correct. If it doesn't,
6493 we still need to continue matching the rest of the subroutine line. */
6494 is_bind_c = gfc_match_bind_c (sym, allow_binding_name);
6495 if (is_bind_c == MATCH_ERROR)
6497 /* There was an attempt at the bind(c), but it was wrong. An
6498 error message should have been printed w/in the gfc_match_bind_c
6499 so here we'll just return the MATCH_ERROR. */
6500 return MATCH_ERROR;
6503 if (is_bind_c == MATCH_YES)
6505 /* The following is allowed in the Fortran 2008 draft. */
6506 if (gfc_current_state () == COMP_CONTAINS
6507 && sym->ns->proc_name->attr.flavor != FL_MODULE
6508 && !gfc_notify_std (GFC_STD_F2008, "BIND(C) attribute "
6509 "at %L may not be specified for an internal "
6510 "procedure", &gfc_current_locus))
6511 return MATCH_ERROR;
6513 if (peek_char != '(')
6515 gfc_error ("Missing required parentheses before BIND(C) at %C");
6516 return MATCH_ERROR;
6518 if (!gfc_add_is_bind_c (&(sym->attr), sym->name,
6519 &(sym->declared_at), 1))
6520 return MATCH_ERROR;
6523 if (gfc_match_eos () != MATCH_YES)
6525 gfc_syntax_error (ST_SUBROUTINE);
6526 return MATCH_ERROR;
6529 if (!copy_prefix (&sym->attr, &sym->declared_at))
6531 if(!sym->attr.module_procedure)
6532 return MATCH_ERROR;
6533 else
6534 gfc_error_check ();
6537 /* Warn if it has the same name as an intrinsic. */
6538 do_warn_intrinsic_shadow (sym, false);
6540 return MATCH_YES;
6544 /* Check that the NAME identifier in a BIND attribute or statement
6545 is conform to C identifier rules. */
6547 match
6548 check_bind_name_identifier (char **name)
6550 char *n = *name, *p;
6552 /* Remove leading spaces. */
6553 while (*n == ' ')
6554 n++;
6556 /* On an empty string, free memory and set name to NULL. */
6557 if (*n == '\0')
6559 free (*name);
6560 *name = NULL;
6561 return MATCH_YES;
6564 /* Remove trailing spaces. */
6565 p = n + strlen(n) - 1;
6566 while (*p == ' ')
6567 *(p--) = '\0';
6569 /* Insert the identifier into the symbol table. */
6570 p = xstrdup (n);
6571 free (*name);
6572 *name = p;
6574 /* Now check that identifier is valid under C rules. */
6575 if (ISDIGIT (*p))
6577 gfc_error ("Invalid C identifier in NAME= specifier at %C");
6578 return MATCH_ERROR;
6581 for (; *p; p++)
6582 if (!(ISALNUM (*p) || *p == '_' || *p == '$'))
6584 gfc_error ("Invalid C identifier in NAME= specifier at %C");
6585 return MATCH_ERROR;
6588 return MATCH_YES;
6592 /* Match a BIND(C) specifier, with the optional 'name=' specifier if
6593 given, and set the binding label in either the given symbol (if not
6594 NULL), or in the current_ts. The symbol may be NULL because we may
6595 encounter the BIND(C) before the declaration itself. Return
6596 MATCH_NO if what we're looking at isn't a BIND(C) specifier,
6597 MATCH_ERROR if it is a BIND(C) clause but an error was encountered,
6598 or MATCH_YES if the specifier was correct and the binding label and
6599 bind(c) fields were set correctly for the given symbol or the
6600 current_ts. If allow_binding_name is false, no binding name may be
6601 given. */
6603 match
6604 gfc_match_bind_c (gfc_symbol *sym, bool allow_binding_name)
6606 char *binding_label = NULL;
6607 gfc_expr *e = NULL;
6609 /* Initialize the flag that specifies whether we encountered a NAME=
6610 specifier or not. */
6611 has_name_equals = 0;
6613 /* This much we have to be able to match, in this order, if
6614 there is a bind(c) label. */
6615 if (gfc_match (" bind ( c ") != MATCH_YES)
6616 return MATCH_NO;
6618 /* Now see if there is a binding label, or if we've reached the
6619 end of the bind(c) attribute without one. */
6620 if (gfc_match_char (',') == MATCH_YES)
6622 if (gfc_match (" name = ") != MATCH_YES)
6624 gfc_error ("Syntax error in NAME= specifier for binding label "
6625 "at %C");
6626 /* should give an error message here */
6627 return MATCH_ERROR;
6630 has_name_equals = 1;
6632 if (gfc_match_init_expr (&e) != MATCH_YES)
6634 gfc_free_expr (e);
6635 return MATCH_ERROR;
6638 if (!gfc_simplify_expr(e, 0))
6640 gfc_error ("NAME= specifier at %C should be a constant expression");
6641 gfc_free_expr (e);
6642 return MATCH_ERROR;
6645 if (e->expr_type != EXPR_CONSTANT || e->ts.type != BT_CHARACTER
6646 || e->ts.kind != gfc_default_character_kind || e->rank != 0)
6648 gfc_error ("NAME= specifier at %C should be a scalar of "
6649 "default character kind");
6650 gfc_free_expr(e);
6651 return MATCH_ERROR;
6654 // Get a C string from the Fortran string constant
6655 binding_label = gfc_widechar_to_char (e->value.character.string,
6656 e->value.character.length);
6657 gfc_free_expr(e);
6659 // Check that it is valid (old gfc_match_name_C)
6660 if (check_bind_name_identifier (&binding_label) != MATCH_YES)
6661 return MATCH_ERROR;
6664 /* Get the required right paren. */
6665 if (gfc_match_char (')') != MATCH_YES)
6667 gfc_error ("Missing closing paren for binding label at %C");
6668 return MATCH_ERROR;
6671 if (has_name_equals && !allow_binding_name)
6673 gfc_error ("No binding name is allowed in BIND(C) at %C");
6674 return MATCH_ERROR;
6677 if (has_name_equals && sym != NULL && sym->attr.dummy)
6679 gfc_error ("For dummy procedure %s, no binding name is "
6680 "allowed in BIND(C) at %C", sym->name);
6681 return MATCH_ERROR;
6685 /* Save the binding label to the symbol. If sym is null, we're
6686 probably matching the typespec attributes of a declaration and
6687 haven't gotten the name yet, and therefore, no symbol yet. */
6688 if (binding_label)
6690 if (sym != NULL)
6691 sym->binding_label = binding_label;
6692 else
6693 curr_binding_label = binding_label;
6695 else if (allow_binding_name)
6697 /* No binding label, but if symbol isn't null, we
6698 can set the label for it here.
6699 If name="" or allow_binding_name is false, no C binding name is
6700 created. */
6701 if (sym != NULL && sym->name != NULL && has_name_equals == 0)
6702 sym->binding_label = IDENTIFIER_POINTER (get_identifier (sym->name));
6705 if (has_name_equals && gfc_current_state () == COMP_INTERFACE
6706 && current_interface.type == INTERFACE_ABSTRACT)
6708 gfc_error ("NAME not allowed on BIND(C) for ABSTRACT INTERFACE at %C");
6709 return MATCH_ERROR;
6712 return MATCH_YES;
6716 /* Return nonzero if we're currently compiling a contained procedure. */
6718 static int
6719 contained_procedure (void)
6721 gfc_state_data *s = gfc_state_stack;
6723 if ((s->state == COMP_SUBROUTINE || s->state == COMP_FUNCTION)
6724 && s->previous != NULL && s->previous->state == COMP_CONTAINS)
6725 return 1;
6727 return 0;
6730 /* Set the kind of each enumerator. The kind is selected such that it is
6731 interoperable with the corresponding C enumeration type, making
6732 sure that -fshort-enums is honored. */
6734 static void
6735 set_enum_kind(void)
6737 enumerator_history *current_history = NULL;
6738 int kind;
6739 int i;
6741 if (max_enum == NULL || enum_history == NULL)
6742 return;
6744 if (!flag_short_enums)
6745 return;
6747 i = 0;
6750 kind = gfc_integer_kinds[i++].kind;
6752 while (kind < gfc_c_int_kind
6753 && gfc_check_integer_range (max_enum->initializer->value.integer,
6754 kind) != ARITH_OK);
6756 current_history = enum_history;
6757 while (current_history != NULL)
6759 current_history->sym->ts.kind = kind;
6760 current_history = current_history->next;
6765 /* Match any of the various end-block statements. Returns the type of
6766 END to the caller. The END INTERFACE, END IF, END DO, END SELECT
6767 and END BLOCK statements cannot be replaced by a single END statement. */
6769 match
6770 gfc_match_end (gfc_statement *st)
6772 char name[GFC_MAX_SYMBOL_LEN + 1];
6773 gfc_compile_state state;
6774 locus old_loc;
6775 const char *block_name;
6776 const char *target;
6777 int eos_ok;
6778 match m;
6779 gfc_namespace *parent_ns, *ns, *prev_ns;
6780 gfc_namespace **nsp;
6781 bool abreviated_modproc_decl = false;
6782 bool got_matching_end = false;
6784 old_loc = gfc_current_locus;
6785 if (gfc_match ("end") != MATCH_YES)
6786 return MATCH_NO;
6788 state = gfc_current_state ();
6789 block_name = gfc_current_block () == NULL
6790 ? NULL : gfc_current_block ()->name;
6792 switch (state)
6794 case COMP_ASSOCIATE:
6795 case COMP_BLOCK:
6796 if (!strncmp (block_name, "block@", strlen("block@")))
6797 block_name = NULL;
6798 break;
6800 case COMP_CONTAINS:
6801 case COMP_DERIVED_CONTAINS:
6802 state = gfc_state_stack->previous->state;
6803 block_name = gfc_state_stack->previous->sym == NULL
6804 ? NULL : gfc_state_stack->previous->sym->name;
6805 abreviated_modproc_decl = gfc_state_stack->previous->sym
6806 && gfc_state_stack->previous->sym->abr_modproc_decl;
6807 break;
6809 default:
6810 break;
6813 if (!abreviated_modproc_decl)
6814 abreviated_modproc_decl = gfc_current_block ()
6815 && gfc_current_block ()->abr_modproc_decl;
6817 switch (state)
6819 case COMP_NONE:
6820 case COMP_PROGRAM:
6821 *st = ST_END_PROGRAM;
6822 target = " program";
6823 eos_ok = 1;
6824 break;
6826 case COMP_SUBROUTINE:
6827 *st = ST_END_SUBROUTINE;
6828 if (!abreviated_modproc_decl)
6829 target = " subroutine";
6830 else
6831 target = " procedure";
6832 eos_ok = !contained_procedure ();
6833 break;
6835 case COMP_FUNCTION:
6836 *st = ST_END_FUNCTION;
6837 if (!abreviated_modproc_decl)
6838 target = " function";
6839 else
6840 target = " procedure";
6841 eos_ok = !contained_procedure ();
6842 break;
6844 case COMP_BLOCK_DATA:
6845 *st = ST_END_BLOCK_DATA;
6846 target = " block data";
6847 eos_ok = 1;
6848 break;
6850 case COMP_MODULE:
6851 *st = ST_END_MODULE;
6852 target = " module";
6853 eos_ok = 1;
6854 break;
6856 case COMP_SUBMODULE:
6857 *st = ST_END_SUBMODULE;
6858 target = " submodule";
6859 eos_ok = 1;
6860 break;
6862 case COMP_INTERFACE:
6863 *st = ST_END_INTERFACE;
6864 target = " interface";
6865 eos_ok = 0;
6866 break;
6868 case COMP_MAP:
6869 *st = ST_END_MAP;
6870 target = " map";
6871 eos_ok = 0;
6872 break;
6874 case COMP_UNION:
6875 *st = ST_END_UNION;
6876 target = " union";
6877 eos_ok = 0;
6878 break;
6880 case COMP_STRUCTURE:
6881 *st = ST_END_STRUCTURE;
6882 target = " structure";
6883 eos_ok = 0;
6884 break;
6886 case COMP_DERIVED:
6887 case COMP_DERIVED_CONTAINS:
6888 *st = ST_END_TYPE;
6889 target = " type";
6890 eos_ok = 0;
6891 break;
6893 case COMP_ASSOCIATE:
6894 *st = ST_END_ASSOCIATE;
6895 target = " associate";
6896 eos_ok = 0;
6897 break;
6899 case COMP_BLOCK:
6900 *st = ST_END_BLOCK;
6901 target = " block";
6902 eos_ok = 0;
6903 break;
6905 case COMP_IF:
6906 *st = ST_ENDIF;
6907 target = " if";
6908 eos_ok = 0;
6909 break;
6911 case COMP_DO:
6912 case COMP_DO_CONCURRENT:
6913 *st = ST_ENDDO;
6914 target = " do";
6915 eos_ok = 0;
6916 break;
6918 case COMP_CRITICAL:
6919 *st = ST_END_CRITICAL;
6920 target = " critical";
6921 eos_ok = 0;
6922 break;
6924 case COMP_SELECT:
6925 case COMP_SELECT_TYPE:
6926 *st = ST_END_SELECT;
6927 target = " select";
6928 eos_ok = 0;
6929 break;
6931 case COMP_FORALL:
6932 *st = ST_END_FORALL;
6933 target = " forall";
6934 eos_ok = 0;
6935 break;
6937 case COMP_WHERE:
6938 *st = ST_END_WHERE;
6939 target = " where";
6940 eos_ok = 0;
6941 break;
6943 case COMP_ENUM:
6944 *st = ST_END_ENUM;
6945 target = " enum";
6946 eos_ok = 0;
6947 last_initializer = NULL;
6948 set_enum_kind ();
6949 gfc_free_enum_history ();
6950 break;
6952 default:
6953 gfc_error ("Unexpected END statement at %C");
6954 goto cleanup;
6957 old_loc = gfc_current_locus;
6958 if (gfc_match_eos () == MATCH_YES)
6960 if (!eos_ok && (*st == ST_END_SUBROUTINE || *st == ST_END_FUNCTION))
6962 if (!gfc_notify_std (GFC_STD_F2008, "END statement "
6963 "instead of %s statement at %L",
6964 abreviated_modproc_decl ? "END PROCEDURE"
6965 : gfc_ascii_statement(*st), &old_loc))
6966 goto cleanup;
6968 else if (!eos_ok)
6970 /* We would have required END [something]. */
6971 gfc_error ("%s statement expected at %L",
6972 gfc_ascii_statement (*st), &old_loc);
6973 goto cleanup;
6976 return MATCH_YES;
6979 /* Verify that we've got the sort of end-block that we're expecting. */
6980 if (gfc_match (target) != MATCH_YES)
6982 gfc_error ("Expecting %s statement at %L", abreviated_modproc_decl
6983 ? "END PROCEDURE" : gfc_ascii_statement(*st), &old_loc);
6984 goto cleanup;
6986 else
6987 got_matching_end = true;
6989 old_loc = gfc_current_locus;
6990 /* If we're at the end, make sure a block name wasn't required. */
6991 if (gfc_match_eos () == MATCH_YES)
6994 if (*st != ST_ENDDO && *st != ST_ENDIF && *st != ST_END_SELECT
6995 && *st != ST_END_FORALL && *st != ST_END_WHERE && *st != ST_END_BLOCK
6996 && *st != ST_END_ASSOCIATE && *st != ST_END_CRITICAL)
6997 return MATCH_YES;
6999 if (!block_name)
7000 return MATCH_YES;
7002 gfc_error ("Expected block name of %qs in %s statement at %L",
7003 block_name, gfc_ascii_statement (*st), &old_loc);
7005 return MATCH_ERROR;
7008 /* END INTERFACE has a special handler for its several possible endings. */
7009 if (*st == ST_END_INTERFACE)
7010 return gfc_match_end_interface ();
7012 /* We haven't hit the end of statement, so what is left must be an
7013 end-name. */
7014 m = gfc_match_space ();
7015 if (m == MATCH_YES)
7016 m = gfc_match_name (name);
7018 if (m == MATCH_NO)
7019 gfc_error ("Expected terminating name at %C");
7020 if (m != MATCH_YES)
7021 goto cleanup;
7023 if (block_name == NULL)
7024 goto syntax;
7026 /* We have to pick out the declared submodule name from the composite
7027 required by F2008:11.2.3 para 2, which ends in the declared name. */
7028 if (state == COMP_SUBMODULE)
7029 block_name = strchr (block_name, '.') + 1;
7031 if (strcmp (name, block_name) != 0 && strcmp (block_name, "ppr@") != 0)
7033 gfc_error ("Expected label %qs for %s statement at %C", block_name,
7034 gfc_ascii_statement (*st));
7035 goto cleanup;
7037 /* Procedure pointer as function result. */
7038 else if (strcmp (block_name, "ppr@") == 0
7039 && strcmp (name, gfc_current_block ()->ns->proc_name->name) != 0)
7041 gfc_error ("Expected label %qs for %s statement at %C",
7042 gfc_current_block ()->ns->proc_name->name,
7043 gfc_ascii_statement (*st));
7044 goto cleanup;
7047 if (gfc_match_eos () == MATCH_YES)
7048 return MATCH_YES;
7050 syntax:
7051 gfc_syntax_error (*st);
7053 cleanup:
7054 gfc_current_locus = old_loc;
7056 /* If we are missing an END BLOCK, we created a half-ready namespace.
7057 Remove it from the parent namespace's sibling list. */
7059 while (state == COMP_BLOCK && !got_matching_end)
7061 parent_ns = gfc_current_ns->parent;
7063 nsp = &(gfc_state_stack->previous->tail->ext.block.ns);
7065 prev_ns = NULL;
7066 ns = *nsp;
7067 while (ns)
7069 if (ns == gfc_current_ns)
7071 if (prev_ns == NULL)
7072 *nsp = NULL;
7073 else
7074 prev_ns->sibling = ns->sibling;
7076 prev_ns = ns;
7077 ns = ns->sibling;
7080 gfc_free_namespace (gfc_current_ns);
7081 gfc_current_ns = parent_ns;
7082 gfc_state_stack = gfc_state_stack->previous;
7083 state = gfc_current_state ();
7086 return MATCH_ERROR;
7091 /***************** Attribute declaration statements ****************/
7093 /* Set the attribute of a single variable. */
7095 static match
7096 attr_decl1 (void)
7098 char name[GFC_MAX_SYMBOL_LEN + 1];
7099 gfc_array_spec *as;
7101 /* Workaround -Wmaybe-uninitialized false positive during
7102 profiledbootstrap by initializing them. */
7103 gfc_symbol *sym = NULL;
7104 locus var_locus;
7105 match m;
7107 as = NULL;
7109 m = gfc_match_name (name);
7110 if (m != MATCH_YES)
7111 goto cleanup;
7113 if (find_special (name, &sym, false))
7114 return MATCH_ERROR;
7116 if (!check_function_name (name))
7118 m = MATCH_ERROR;
7119 goto cleanup;
7122 var_locus = gfc_current_locus;
7124 /* Deal with possible array specification for certain attributes. */
7125 if (current_attr.dimension
7126 || current_attr.codimension
7127 || current_attr.allocatable
7128 || current_attr.pointer
7129 || current_attr.target)
7131 m = gfc_match_array_spec (&as, !current_attr.codimension,
7132 !current_attr.dimension
7133 && !current_attr.pointer
7134 && !current_attr.target);
7135 if (m == MATCH_ERROR)
7136 goto cleanup;
7138 if (current_attr.dimension && m == MATCH_NO)
7140 gfc_error ("Missing array specification at %L in DIMENSION "
7141 "statement", &var_locus);
7142 m = MATCH_ERROR;
7143 goto cleanup;
7146 if (current_attr.dimension && sym->value)
7148 gfc_error ("Dimensions specified for %s at %L after its "
7149 "initialization", sym->name, &var_locus);
7150 m = MATCH_ERROR;
7151 goto cleanup;
7154 if (current_attr.codimension && m == MATCH_NO)
7156 gfc_error ("Missing array specification at %L in CODIMENSION "
7157 "statement", &var_locus);
7158 m = MATCH_ERROR;
7159 goto cleanup;
7162 if ((current_attr.allocatable || current_attr.pointer)
7163 && (m == MATCH_YES) && (as->type != AS_DEFERRED))
7165 gfc_error ("Array specification must be deferred at %L", &var_locus);
7166 m = MATCH_ERROR;
7167 goto cleanup;
7171 /* Update symbol table. DIMENSION attribute is set in
7172 gfc_set_array_spec(). For CLASS variables, this must be applied
7173 to the first component, or '_data' field. */
7174 if (sym->ts.type == BT_CLASS && sym->ts.u.derived->attr.is_class)
7176 if (!gfc_copy_attr (&CLASS_DATA(sym)->attr, &current_attr, &var_locus))
7178 m = MATCH_ERROR;
7179 goto cleanup;
7182 else
7184 if (current_attr.dimension == 0 && current_attr.codimension == 0
7185 && !gfc_copy_attr (&sym->attr, &current_attr, &var_locus))
7187 m = MATCH_ERROR;
7188 goto cleanup;
7192 if (sym->ts.type == BT_CLASS
7193 && !gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as))
7195 m = MATCH_ERROR;
7196 goto cleanup;
7199 if (!gfc_set_array_spec (sym, as, &var_locus))
7201 m = MATCH_ERROR;
7202 goto cleanup;
7205 if (sym->attr.cray_pointee && sym->as != NULL)
7207 /* Fix the array spec. */
7208 m = gfc_mod_pointee_as (sym->as);
7209 if (m == MATCH_ERROR)
7210 goto cleanup;
7213 if (!gfc_add_attribute (&sym->attr, &var_locus))
7215 m = MATCH_ERROR;
7216 goto cleanup;
7219 if ((current_attr.external || current_attr.intrinsic)
7220 && sym->attr.flavor != FL_PROCEDURE
7221 && !gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, NULL))
7223 m = MATCH_ERROR;
7224 goto cleanup;
7227 add_hidden_procptr_result (sym);
7229 return MATCH_YES;
7231 cleanup:
7232 gfc_free_array_spec (as);
7233 return m;
7237 /* Generic attribute declaration subroutine. Used for attributes that
7238 just have a list of names. */
7240 static match
7241 attr_decl (void)
7243 match m;
7245 /* Gobble the optional double colon, by simply ignoring the result
7246 of gfc_match(). */
7247 gfc_match (" ::");
7249 for (;;)
7251 m = attr_decl1 ();
7252 if (m != MATCH_YES)
7253 break;
7255 if (gfc_match_eos () == MATCH_YES)
7257 m = MATCH_YES;
7258 break;
7261 if (gfc_match_char (',') != MATCH_YES)
7263 gfc_error ("Unexpected character in variable list at %C");
7264 m = MATCH_ERROR;
7265 break;
7269 return m;
7273 /* This routine matches Cray Pointer declarations of the form:
7274 pointer ( <pointer>, <pointee> )
7276 pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...
7277 The pointer, if already declared, should be an integer. Otherwise, we
7278 set it as BT_INTEGER with kind gfc_index_integer_kind. The pointee may
7279 be either a scalar, or an array declaration. No space is allocated for
7280 the pointee. For the statement
7281 pointer (ipt, ar(10))
7282 any subsequent uses of ar will be translated (in C-notation) as
7283 ar(i) => ((<type> *) ipt)(i)
7284 After gimplification, pointee variable will disappear in the code. */
7286 static match
7287 cray_pointer_decl (void)
7289 match m;
7290 gfc_array_spec *as = NULL;
7291 gfc_symbol *cptr; /* Pointer symbol. */
7292 gfc_symbol *cpte; /* Pointee symbol. */
7293 locus var_locus;
7294 bool done = false;
7296 while (!done)
7298 if (gfc_match_char ('(') != MATCH_YES)
7300 gfc_error ("Expected %<(%> at %C");
7301 return MATCH_ERROR;
7304 /* Match pointer. */
7305 var_locus = gfc_current_locus;
7306 gfc_clear_attr (&current_attr);
7307 gfc_add_cray_pointer (&current_attr, &var_locus);
7308 current_ts.type = BT_INTEGER;
7309 current_ts.kind = gfc_index_integer_kind;
7311 m = gfc_match_symbol (&cptr, 0);
7312 if (m != MATCH_YES)
7314 gfc_error ("Expected variable name at %C");
7315 return m;
7318 if (!gfc_add_cray_pointer (&cptr->attr, &var_locus))
7319 return MATCH_ERROR;
7321 gfc_set_sym_referenced (cptr);
7323 if (cptr->ts.type == BT_UNKNOWN) /* Override the type, if necessary. */
7325 cptr->ts.type = BT_INTEGER;
7326 cptr->ts.kind = gfc_index_integer_kind;
7328 else if (cptr->ts.type != BT_INTEGER)
7330 gfc_error ("Cray pointer at %C must be an integer");
7331 return MATCH_ERROR;
7333 else if (cptr->ts.kind < gfc_index_integer_kind)
7334 gfc_warning (0, "Cray pointer at %C has %d bytes of precision;"
7335 " memory addresses require %d bytes",
7336 cptr->ts.kind, gfc_index_integer_kind);
7338 if (gfc_match_char (',') != MATCH_YES)
7340 gfc_error ("Expected \",\" at %C");
7341 return MATCH_ERROR;
7344 /* Match Pointee. */
7345 var_locus = gfc_current_locus;
7346 gfc_clear_attr (&current_attr);
7347 gfc_add_cray_pointee (&current_attr, &var_locus);
7348 current_ts.type = BT_UNKNOWN;
7349 current_ts.kind = 0;
7351 m = gfc_match_symbol (&cpte, 0);
7352 if (m != MATCH_YES)
7354 gfc_error ("Expected variable name at %C");
7355 return m;
7358 /* Check for an optional array spec. */
7359 m = gfc_match_array_spec (&as, true, false);
7360 if (m == MATCH_ERROR)
7362 gfc_free_array_spec (as);
7363 return m;
7365 else if (m == MATCH_NO)
7367 gfc_free_array_spec (as);
7368 as = NULL;
7371 if (!gfc_add_cray_pointee (&cpte->attr, &var_locus))
7372 return MATCH_ERROR;
7374 gfc_set_sym_referenced (cpte);
7376 if (cpte->as == NULL)
7378 if (!gfc_set_array_spec (cpte, as, &var_locus))
7379 gfc_internal_error ("Couldn't set Cray pointee array spec.");
7381 else if (as != NULL)
7383 gfc_error ("Duplicate array spec for Cray pointee at %C");
7384 gfc_free_array_spec (as);
7385 return MATCH_ERROR;
7388 as = NULL;
7390 if (cpte->as != NULL)
7392 /* Fix array spec. */
7393 m = gfc_mod_pointee_as (cpte->as);
7394 if (m == MATCH_ERROR)
7395 return m;
7398 /* Point the Pointee at the Pointer. */
7399 cpte->cp_pointer = cptr;
7401 if (gfc_match_char (')') != MATCH_YES)
7403 gfc_error ("Expected \")\" at %C");
7404 return MATCH_ERROR;
7406 m = gfc_match_char (',');
7407 if (m != MATCH_YES)
7408 done = true; /* Stop searching for more declarations. */
7412 if (m == MATCH_ERROR /* Failed when trying to find ',' above. */
7413 || gfc_match_eos () != MATCH_YES)
7415 gfc_error ("Expected %<,%> or end of statement at %C");
7416 return MATCH_ERROR;
7418 return MATCH_YES;
7422 match
7423 gfc_match_external (void)
7426 gfc_clear_attr (&current_attr);
7427 current_attr.external = 1;
7429 return attr_decl ();
7433 match
7434 gfc_match_intent (void)
7436 sym_intent intent;
7438 /* This is not allowed within a BLOCK construct! */
7439 if (gfc_current_state () == COMP_BLOCK)
7441 gfc_error ("INTENT is not allowed inside of BLOCK at %C");
7442 return MATCH_ERROR;
7445 intent = match_intent_spec ();
7446 if (intent == INTENT_UNKNOWN)
7447 return MATCH_ERROR;
7449 gfc_clear_attr (&current_attr);
7450 current_attr.intent = intent;
7452 return attr_decl ();
7456 match
7457 gfc_match_intrinsic (void)
7460 gfc_clear_attr (&current_attr);
7461 current_attr.intrinsic = 1;
7463 return attr_decl ();
7467 match
7468 gfc_match_optional (void)
7470 /* This is not allowed within a BLOCK construct! */
7471 if (gfc_current_state () == COMP_BLOCK)
7473 gfc_error ("OPTIONAL is not allowed inside of BLOCK at %C");
7474 return MATCH_ERROR;
7477 gfc_clear_attr (&current_attr);
7478 current_attr.optional = 1;
7480 return attr_decl ();
7484 match
7485 gfc_match_pointer (void)
7487 gfc_gobble_whitespace ();
7488 if (gfc_peek_ascii_char () == '(')
7490 if (!flag_cray_pointer)
7492 gfc_error ("Cray pointer declaration at %C requires -fcray-pointer "
7493 "flag");
7494 return MATCH_ERROR;
7496 return cray_pointer_decl ();
7498 else
7500 gfc_clear_attr (&current_attr);
7501 current_attr.pointer = 1;
7503 return attr_decl ();
7508 match
7509 gfc_match_allocatable (void)
7511 gfc_clear_attr (&current_attr);
7512 current_attr.allocatable = 1;
7514 return attr_decl ();
7518 match
7519 gfc_match_codimension (void)
7521 gfc_clear_attr (&current_attr);
7522 current_attr.codimension = 1;
7524 return attr_decl ();
7528 match
7529 gfc_match_contiguous (void)
7531 if (!gfc_notify_std (GFC_STD_F2008, "CONTIGUOUS statement at %C"))
7532 return MATCH_ERROR;
7534 gfc_clear_attr (&current_attr);
7535 current_attr.contiguous = 1;
7537 return attr_decl ();
7541 match
7542 gfc_match_dimension (void)
7544 gfc_clear_attr (&current_attr);
7545 current_attr.dimension = 1;
7547 return attr_decl ();
7551 match
7552 gfc_match_target (void)
7554 gfc_clear_attr (&current_attr);
7555 current_attr.target = 1;
7557 return attr_decl ();
7561 /* Match the list of entities being specified in a PUBLIC or PRIVATE
7562 statement. */
7564 static match
7565 access_attr_decl (gfc_statement st)
7567 char name[GFC_MAX_SYMBOL_LEN + 1];
7568 interface_type type;
7569 gfc_user_op *uop;
7570 gfc_symbol *sym, *dt_sym;
7571 gfc_intrinsic_op op;
7572 match m;
7574 if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
7575 goto done;
7577 for (;;)
7579 m = gfc_match_generic_spec (&type, name, &op);
7580 if (m == MATCH_NO)
7581 goto syntax;
7582 if (m == MATCH_ERROR)
7583 return MATCH_ERROR;
7585 switch (type)
7587 case INTERFACE_NAMELESS:
7588 case INTERFACE_ABSTRACT:
7589 goto syntax;
7591 case INTERFACE_GENERIC:
7592 case INTERFACE_DTIO:
7594 if (gfc_get_symbol (name, NULL, &sym))
7595 goto done;
7597 if (type == INTERFACE_DTIO
7598 && gfc_current_ns->proc_name
7599 && gfc_current_ns->proc_name->attr.flavor == FL_MODULE
7600 && sym->attr.flavor == FL_UNKNOWN)
7601 sym->attr.flavor = FL_PROCEDURE;
7603 if (!gfc_add_access (&sym->attr,
7604 (st == ST_PUBLIC)
7605 ? ACCESS_PUBLIC : ACCESS_PRIVATE,
7606 sym->name, NULL))
7607 return MATCH_ERROR;
7609 if (sym->attr.generic && (dt_sym = gfc_find_dt_in_generic (sym))
7610 && !gfc_add_access (&dt_sym->attr,
7611 (st == ST_PUBLIC)
7612 ? ACCESS_PUBLIC : ACCESS_PRIVATE,
7613 sym->name, NULL))
7614 return MATCH_ERROR;
7616 break;
7618 case INTERFACE_INTRINSIC_OP:
7619 if (gfc_current_ns->operator_access[op] == ACCESS_UNKNOWN)
7621 gfc_intrinsic_op other_op;
7623 gfc_current_ns->operator_access[op] =
7624 (st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE;
7626 /* Handle the case if there is another op with the same
7627 function, for INTRINSIC_EQ vs. INTRINSIC_EQ_OS and so on. */
7628 other_op = gfc_equivalent_op (op);
7630 if (other_op != INTRINSIC_NONE)
7631 gfc_current_ns->operator_access[other_op] =
7632 (st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE;
7635 else
7637 gfc_error ("Access specification of the %s operator at %C has "
7638 "already been specified", gfc_op2string (op));
7639 goto done;
7642 break;
7644 case INTERFACE_USER_OP:
7645 uop = gfc_get_uop (name);
7647 if (uop->access == ACCESS_UNKNOWN)
7649 uop->access = (st == ST_PUBLIC)
7650 ? ACCESS_PUBLIC : ACCESS_PRIVATE;
7652 else
7654 gfc_error ("Access specification of the .%s. operator at %C "
7655 "has already been specified", sym->name);
7656 goto done;
7659 break;
7662 if (gfc_match_char (',') == MATCH_NO)
7663 break;
7666 if (gfc_match_eos () != MATCH_YES)
7667 goto syntax;
7668 return MATCH_YES;
7670 syntax:
7671 gfc_syntax_error (st);
7673 done:
7674 return MATCH_ERROR;
7678 match
7679 gfc_match_protected (void)
7681 gfc_symbol *sym;
7682 match m;
7684 if (!gfc_current_ns->proc_name
7685 || gfc_current_ns->proc_name->attr.flavor != FL_MODULE)
7687 gfc_error ("PROTECTED at %C only allowed in specification "
7688 "part of a module");
7689 return MATCH_ERROR;
7693 if (!gfc_notify_std (GFC_STD_F2003, "PROTECTED statement at %C"))
7694 return MATCH_ERROR;
7696 if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
7698 return MATCH_ERROR;
7701 if (gfc_match_eos () == MATCH_YES)
7702 goto syntax;
7704 for(;;)
7706 m = gfc_match_symbol (&sym, 0);
7707 switch (m)
7709 case MATCH_YES:
7710 if (!gfc_add_protected (&sym->attr, sym->name, &gfc_current_locus))
7711 return MATCH_ERROR;
7712 goto next_item;
7714 case MATCH_NO:
7715 break;
7717 case MATCH_ERROR:
7718 return MATCH_ERROR;
7721 next_item:
7722 if (gfc_match_eos () == MATCH_YES)
7723 break;
7724 if (gfc_match_char (',') != MATCH_YES)
7725 goto syntax;
7728 return MATCH_YES;
7730 syntax:
7731 gfc_error ("Syntax error in PROTECTED statement at %C");
7732 return MATCH_ERROR;
7736 /* The PRIVATE statement is a bit weird in that it can be an attribute
7737 declaration, but also works as a standalone statement inside of a
7738 type declaration or a module. */
7740 match
7741 gfc_match_private (gfc_statement *st)
7744 if (gfc_match ("private") != MATCH_YES)
7745 return MATCH_NO;
7747 if (gfc_current_state () != COMP_MODULE
7748 && !(gfc_current_state () == COMP_DERIVED
7749 && gfc_state_stack->previous
7750 && gfc_state_stack->previous->state == COMP_MODULE)
7751 && !(gfc_current_state () == COMP_DERIVED_CONTAINS
7752 && gfc_state_stack->previous && gfc_state_stack->previous->previous
7753 && gfc_state_stack->previous->previous->state == COMP_MODULE))
7755 gfc_error ("PRIVATE statement at %C is only allowed in the "
7756 "specification part of a module");
7757 return MATCH_ERROR;
7760 if (gfc_current_state () == COMP_DERIVED)
7762 if (gfc_match_eos () == MATCH_YES)
7764 *st = ST_PRIVATE;
7765 return MATCH_YES;
7768 gfc_syntax_error (ST_PRIVATE);
7769 return MATCH_ERROR;
7772 if (gfc_match_eos () == MATCH_YES)
7774 *st = ST_PRIVATE;
7775 return MATCH_YES;
7778 *st = ST_ATTR_DECL;
7779 return access_attr_decl (ST_PRIVATE);
7783 match
7784 gfc_match_public (gfc_statement *st)
7787 if (gfc_match ("public") != MATCH_YES)
7788 return MATCH_NO;
7790 if (gfc_current_state () != COMP_MODULE)
7792 gfc_error ("PUBLIC statement at %C is only allowed in the "
7793 "specification part of a module");
7794 return MATCH_ERROR;
7797 if (gfc_match_eos () == MATCH_YES)
7799 *st = ST_PUBLIC;
7800 return MATCH_YES;
7803 *st = ST_ATTR_DECL;
7804 return access_attr_decl (ST_PUBLIC);
7808 /* Workhorse for gfc_match_parameter. */
7810 static match
7811 do_parm (void)
7813 gfc_symbol *sym;
7814 gfc_expr *init;
7815 match m;
7816 bool t;
7818 m = gfc_match_symbol (&sym, 0);
7819 if (m == MATCH_NO)
7820 gfc_error ("Expected variable name at %C in PARAMETER statement");
7822 if (m != MATCH_YES)
7823 return m;
7825 if (gfc_match_char ('=') == MATCH_NO)
7827 gfc_error ("Expected = sign in PARAMETER statement at %C");
7828 return MATCH_ERROR;
7831 m = gfc_match_init_expr (&init);
7832 if (m == MATCH_NO)
7833 gfc_error ("Expected expression at %C in PARAMETER statement");
7834 if (m != MATCH_YES)
7835 return m;
7837 if (sym->ts.type == BT_UNKNOWN
7838 && !gfc_set_default_type (sym, 1, NULL))
7840 m = MATCH_ERROR;
7841 goto cleanup;
7844 if (!gfc_check_assign_symbol (sym, NULL, init)
7845 || !gfc_add_flavor (&sym->attr, FL_PARAMETER, sym->name, NULL))
7847 m = MATCH_ERROR;
7848 goto cleanup;
7851 if (sym->value)
7853 gfc_error ("Initializing already initialized variable at %C");
7854 m = MATCH_ERROR;
7855 goto cleanup;
7858 t = add_init_expr_to_sym (sym->name, &init, &gfc_current_locus);
7859 return (t) ? MATCH_YES : MATCH_ERROR;
7861 cleanup:
7862 gfc_free_expr (init);
7863 return m;
7867 /* Match a parameter statement, with the weird syntax that these have. */
7869 match
7870 gfc_match_parameter (void)
7872 const char *term = " )%t";
7873 match m;
7875 if (gfc_match_char ('(') == MATCH_NO)
7877 /* With legacy PARAMETER statements, don't expect a terminating ')'. */
7878 if (!gfc_notify_std (GFC_STD_LEGACY, "PARAMETER without '()' at %C"))
7879 return MATCH_NO;
7880 term = " %t";
7883 for (;;)
7885 m = do_parm ();
7886 if (m != MATCH_YES)
7887 break;
7889 if (gfc_match (term) == MATCH_YES)
7890 break;
7892 if (gfc_match_char (',') != MATCH_YES)
7894 gfc_error ("Unexpected characters in PARAMETER statement at %C");
7895 m = MATCH_ERROR;
7896 break;
7900 return m;
7904 match
7905 gfc_match_automatic (void)
7907 gfc_symbol *sym;
7908 match m;
7909 bool seen_symbol = false;
7911 if (!flag_dec_static)
7913 gfc_error ("%s at %C is a DEC extension, enable with "
7914 "%<-fdec-static%>",
7915 "AUTOMATIC"
7917 return MATCH_ERROR;
7920 gfc_match (" ::");
7922 for (;;)
7924 m = gfc_match_symbol (&sym, 0);
7925 switch (m)
7927 case MATCH_NO:
7928 break;
7930 case MATCH_ERROR:
7931 return MATCH_ERROR;
7933 case MATCH_YES:
7934 if (!gfc_add_automatic (&sym->attr, sym->name, &gfc_current_locus))
7935 return MATCH_ERROR;
7936 seen_symbol = true;
7937 break;
7940 if (gfc_match_eos () == MATCH_YES)
7941 break;
7942 if (gfc_match_char (',') != MATCH_YES)
7943 goto syntax;
7946 if (!seen_symbol)
7948 gfc_error ("Expected entity-list in AUTOMATIC statement at %C");
7949 return MATCH_ERROR;
7952 return MATCH_YES;
7954 syntax:
7955 gfc_error ("Syntax error in AUTOMATIC statement at %C");
7956 return MATCH_ERROR;
7960 match
7961 gfc_match_static (void)
7963 gfc_symbol *sym;
7964 match m;
7965 bool seen_symbol = false;
7967 if (!flag_dec_static)
7969 gfc_error ("%s at %C is a DEC extension, enable with "
7970 "%<-fdec-static%>",
7971 "STATIC");
7972 return MATCH_ERROR;
7975 gfc_match (" ::");
7977 for (;;)
7979 m = gfc_match_symbol (&sym, 0);
7980 switch (m)
7982 case MATCH_NO:
7983 break;
7985 case MATCH_ERROR:
7986 return MATCH_ERROR;
7988 case MATCH_YES:
7989 if (!gfc_add_save (&sym->attr, SAVE_EXPLICIT, sym->name,
7990 &gfc_current_locus))
7991 return MATCH_ERROR;
7992 seen_symbol = true;
7993 break;
7996 if (gfc_match_eos () == MATCH_YES)
7997 break;
7998 if (gfc_match_char (',') != MATCH_YES)
7999 goto syntax;
8002 if (!seen_symbol)
8004 gfc_error ("Expected entity-list in STATIC statement at %C");
8005 return MATCH_ERROR;
8008 return MATCH_YES;
8010 syntax:
8011 gfc_error ("Syntax error in STATIC statement at %C");
8012 return MATCH_ERROR;
8016 /* Save statements have a special syntax. */
8018 match
8019 gfc_match_save (void)
8021 char n[GFC_MAX_SYMBOL_LEN+1];
8022 gfc_common_head *c;
8023 gfc_symbol *sym;
8024 match m;
8026 if (gfc_match_eos () == MATCH_YES)
8028 if (gfc_current_ns->seen_save)
8030 if (!gfc_notify_std (GFC_STD_LEGACY, "Blanket SAVE statement at %C "
8031 "follows previous SAVE statement"))
8032 return MATCH_ERROR;
8035 gfc_current_ns->save_all = gfc_current_ns->seen_save = 1;
8036 return MATCH_YES;
8039 if (gfc_current_ns->save_all)
8041 if (!gfc_notify_std (GFC_STD_LEGACY, "SAVE statement at %C follows "
8042 "blanket SAVE statement"))
8043 return MATCH_ERROR;
8046 gfc_match (" ::");
8048 for (;;)
8050 m = gfc_match_symbol (&sym, 0);
8051 switch (m)
8053 case MATCH_YES:
8054 if (!gfc_add_save (&sym->attr, SAVE_EXPLICIT, sym->name,
8055 &gfc_current_locus))
8056 return MATCH_ERROR;
8057 goto next_item;
8059 case MATCH_NO:
8060 break;
8062 case MATCH_ERROR:
8063 return MATCH_ERROR;
8066 m = gfc_match (" / %n /", &n);
8067 if (m == MATCH_ERROR)
8068 return MATCH_ERROR;
8069 if (m == MATCH_NO)
8070 goto syntax;
8072 c = gfc_get_common (n, 0);
8073 c->saved = 1;
8075 gfc_current_ns->seen_save = 1;
8077 next_item:
8078 if (gfc_match_eos () == MATCH_YES)
8079 break;
8080 if (gfc_match_char (',') != MATCH_YES)
8081 goto syntax;
8084 return MATCH_YES;
8086 syntax:
8087 gfc_error ("Syntax error in SAVE statement at %C");
8088 return MATCH_ERROR;
8092 match
8093 gfc_match_value (void)
8095 gfc_symbol *sym;
8096 match m;
8098 /* This is not allowed within a BLOCK construct! */
8099 if (gfc_current_state () == COMP_BLOCK)
8101 gfc_error ("VALUE is not allowed inside of BLOCK at %C");
8102 return MATCH_ERROR;
8105 if (!gfc_notify_std (GFC_STD_F2003, "VALUE statement at %C"))
8106 return MATCH_ERROR;
8108 if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
8110 return MATCH_ERROR;
8113 if (gfc_match_eos () == MATCH_YES)
8114 goto syntax;
8116 for(;;)
8118 m = gfc_match_symbol (&sym, 0);
8119 switch (m)
8121 case MATCH_YES:
8122 if (!gfc_add_value (&sym->attr, sym->name, &gfc_current_locus))
8123 return MATCH_ERROR;
8124 goto next_item;
8126 case MATCH_NO:
8127 break;
8129 case MATCH_ERROR:
8130 return MATCH_ERROR;
8133 next_item:
8134 if (gfc_match_eos () == MATCH_YES)
8135 break;
8136 if (gfc_match_char (',') != MATCH_YES)
8137 goto syntax;
8140 return MATCH_YES;
8142 syntax:
8143 gfc_error ("Syntax error in VALUE statement at %C");
8144 return MATCH_ERROR;
8148 match
8149 gfc_match_volatile (void)
8151 gfc_symbol *sym;
8152 match m;
8154 if (!gfc_notify_std (GFC_STD_F2003, "VOLATILE statement at %C"))
8155 return MATCH_ERROR;
8157 if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
8159 return MATCH_ERROR;
8162 if (gfc_match_eos () == MATCH_YES)
8163 goto syntax;
8165 for(;;)
8167 /* VOLATILE is special because it can be added to host-associated
8168 symbols locally. Except for coarrays. */
8169 m = gfc_match_symbol (&sym, 1);
8170 switch (m)
8172 case MATCH_YES:
8173 /* F2008, C560+C561. VOLATILE for host-/use-associated variable or
8174 for variable in a BLOCK which is defined outside of the BLOCK. */
8175 if (sym->ns != gfc_current_ns && sym->attr.codimension)
8177 gfc_error ("Specifying VOLATILE for coarray variable %qs at "
8178 "%C, which is use-/host-associated", sym->name);
8179 return MATCH_ERROR;
8181 if (!gfc_add_volatile (&sym->attr, sym->name, &gfc_current_locus))
8182 return MATCH_ERROR;
8183 goto next_item;
8185 case MATCH_NO:
8186 break;
8188 case MATCH_ERROR:
8189 return MATCH_ERROR;
8192 next_item:
8193 if (gfc_match_eos () == MATCH_YES)
8194 break;
8195 if (gfc_match_char (',') != MATCH_YES)
8196 goto syntax;
8199 return MATCH_YES;
8201 syntax:
8202 gfc_error ("Syntax error in VOLATILE statement at %C");
8203 return MATCH_ERROR;
8207 match
8208 gfc_match_asynchronous (void)
8210 gfc_symbol *sym;
8211 match m;
8213 if (!gfc_notify_std (GFC_STD_F2003, "ASYNCHRONOUS statement at %C"))
8214 return MATCH_ERROR;
8216 if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
8218 return MATCH_ERROR;
8221 if (gfc_match_eos () == MATCH_YES)
8222 goto syntax;
8224 for(;;)
8226 /* ASYNCHRONOUS is special because it can be added to host-associated
8227 symbols locally. */
8228 m = gfc_match_symbol (&sym, 1);
8229 switch (m)
8231 case MATCH_YES:
8232 if (!gfc_add_asynchronous (&sym->attr, sym->name, &gfc_current_locus))
8233 return MATCH_ERROR;
8234 goto next_item;
8236 case MATCH_NO:
8237 break;
8239 case MATCH_ERROR:
8240 return MATCH_ERROR;
8243 next_item:
8244 if (gfc_match_eos () == MATCH_YES)
8245 break;
8246 if (gfc_match_char (',') != MATCH_YES)
8247 goto syntax;
8250 return MATCH_YES;
8252 syntax:
8253 gfc_error ("Syntax error in ASYNCHRONOUS statement at %C");
8254 return MATCH_ERROR;
8258 /* Match a module procedure statement in a submodule. */
8260 match
8261 gfc_match_submod_proc (void)
8263 char name[GFC_MAX_SYMBOL_LEN + 1];
8264 gfc_symbol *sym, *fsym;
8265 match m;
8266 gfc_formal_arglist *formal, *head, *tail;
8268 if (gfc_current_state () != COMP_CONTAINS
8269 || !(gfc_state_stack->previous
8270 && (gfc_state_stack->previous->state == COMP_SUBMODULE
8271 || gfc_state_stack->previous->state == COMP_MODULE)))
8272 return MATCH_NO;
8274 m = gfc_match (" module% procedure% %n", name);
8275 if (m != MATCH_YES)
8276 return m;
8278 if (!gfc_notify_std (GFC_STD_F2008, "MODULE PROCEDURE declaration "
8279 "at %C"))
8280 return MATCH_ERROR;
8282 if (get_proc_name (name, &sym, false))
8283 return MATCH_ERROR;
8285 /* Make sure that the result field is appropriately filled, even though
8286 the result symbol will be replaced later on. */
8287 if (sym->tlink && sym->tlink->attr.function)
8289 if (sym->tlink->result
8290 && sym->tlink->result != sym->tlink)
8291 sym->result= sym->tlink->result;
8292 else
8293 sym->result = sym;
8296 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
8297 the symbol existed before. */
8298 sym->declared_at = gfc_current_locus;
8300 if (!sym->attr.module_procedure)
8301 return MATCH_ERROR;
8303 /* Signal match_end to expect "end procedure". */
8304 sym->abr_modproc_decl = 1;
8306 /* Change from IFSRC_IFBODY coming from the interface declaration. */
8307 sym->attr.if_source = IFSRC_DECL;
8309 gfc_new_block = sym;
8311 /* Make a new formal arglist with the symbols in the procedure
8312 namespace. */
8313 head = tail = NULL;
8314 for (formal = sym->formal; formal && formal->sym; formal = formal->next)
8316 if (formal == sym->formal)
8317 head = tail = gfc_get_formal_arglist ();
8318 else
8320 tail->next = gfc_get_formal_arglist ();
8321 tail = tail->next;
8324 if (gfc_copy_dummy_sym (&fsym, formal->sym, 0))
8325 goto cleanup;
8327 tail->sym = fsym;
8328 gfc_set_sym_referenced (fsym);
8331 /* The dummy symbols get cleaned up, when the formal_namespace of the
8332 interface declaration is cleared. This allows us to add the
8333 explicit interface as is done for other type of procedure. */
8334 if (!gfc_add_explicit_interface (sym, IFSRC_DECL, head,
8335 &gfc_current_locus))
8336 return MATCH_ERROR;
8338 if (gfc_match_eos () != MATCH_YES)
8340 gfc_syntax_error (ST_MODULE_PROC);
8341 return MATCH_ERROR;
8344 return MATCH_YES;
8346 cleanup:
8347 gfc_free_formal_arglist (head);
8348 return MATCH_ERROR;
8352 /* Match a module procedure statement. Note that we have to modify
8353 symbols in the parent's namespace because the current one was there
8354 to receive symbols that are in an interface's formal argument list. */
8356 match
8357 gfc_match_modproc (void)
8359 char name[GFC_MAX_SYMBOL_LEN + 1];
8360 gfc_symbol *sym;
8361 match m;
8362 locus old_locus;
8363 gfc_namespace *module_ns;
8364 gfc_interface *old_interface_head, *interface;
8366 if (gfc_state_stack->state != COMP_INTERFACE
8367 || gfc_state_stack->previous == NULL
8368 || current_interface.type == INTERFACE_NAMELESS
8369 || current_interface.type == INTERFACE_ABSTRACT)
8371 gfc_error ("MODULE PROCEDURE at %C must be in a generic module "
8372 "interface");
8373 return MATCH_ERROR;
8376 module_ns = gfc_current_ns->parent;
8377 for (; module_ns; module_ns = module_ns->parent)
8378 if (module_ns->proc_name->attr.flavor == FL_MODULE
8379 || module_ns->proc_name->attr.flavor == FL_PROGRAM
8380 || (module_ns->proc_name->attr.flavor == FL_PROCEDURE
8381 && !module_ns->proc_name->attr.contained))
8382 break;
8384 if (module_ns == NULL)
8385 return MATCH_ERROR;
8387 /* Store the current state of the interface. We will need it if we
8388 end up with a syntax error and need to recover. */
8389 old_interface_head = gfc_current_interface_head ();
8391 /* Check if the F2008 optional double colon appears. */
8392 gfc_gobble_whitespace ();
8393 old_locus = gfc_current_locus;
8394 if (gfc_match ("::") == MATCH_YES)
8396 if (!gfc_notify_std (GFC_STD_F2008, "double colon in "
8397 "MODULE PROCEDURE statement at %L", &old_locus))
8398 return MATCH_ERROR;
8400 else
8401 gfc_current_locus = old_locus;
8403 for (;;)
8405 bool last = false;
8406 old_locus = gfc_current_locus;
8408 m = gfc_match_name (name);
8409 if (m == MATCH_NO)
8410 goto syntax;
8411 if (m != MATCH_YES)
8412 return MATCH_ERROR;
8414 /* Check for syntax error before starting to add symbols to the
8415 current namespace. */
8416 if (gfc_match_eos () == MATCH_YES)
8417 last = true;
8419 if (!last && gfc_match_char (',') != MATCH_YES)
8420 goto syntax;
8422 /* Now we're sure the syntax is valid, we process this item
8423 further. */
8424 if (gfc_get_symbol (name, module_ns, &sym))
8425 return MATCH_ERROR;
8427 if (sym->attr.intrinsic)
8429 gfc_error ("Intrinsic procedure at %L cannot be a MODULE "
8430 "PROCEDURE", &old_locus);
8431 return MATCH_ERROR;
8434 if (sym->attr.proc != PROC_MODULE
8435 && !gfc_add_procedure (&sym->attr, PROC_MODULE, sym->name, NULL))
8436 return MATCH_ERROR;
8438 if (!gfc_add_interface (sym))
8439 return MATCH_ERROR;
8441 sym->attr.mod_proc = 1;
8442 sym->declared_at = old_locus;
8444 if (last)
8445 break;
8448 return MATCH_YES;
8450 syntax:
8451 /* Restore the previous state of the interface. */
8452 interface = gfc_current_interface_head ();
8453 gfc_set_current_interface_head (old_interface_head);
8455 /* Free the new interfaces. */
8456 while (interface != old_interface_head)
8458 gfc_interface *i = interface->next;
8459 free (interface);
8460 interface = i;
8463 /* And issue a syntax error. */
8464 gfc_syntax_error (ST_MODULE_PROC);
8465 return MATCH_ERROR;
8469 /* Check a derived type that is being extended. */
8471 static gfc_symbol*
8472 check_extended_derived_type (char *name)
8474 gfc_symbol *extended;
8476 if (gfc_find_symbol (name, gfc_current_ns, 1, &extended))
8478 gfc_error ("Ambiguous symbol in TYPE definition at %C");
8479 return NULL;
8482 extended = gfc_find_dt_in_generic (extended);
8484 /* F08:C428. */
8485 if (!extended)
8487 gfc_error ("Symbol %qs at %C has not been previously defined", name);
8488 return NULL;
8491 if (extended->attr.flavor != FL_DERIVED)
8493 gfc_error ("%qs in EXTENDS expression at %C is not a "
8494 "derived type", name);
8495 return NULL;
8498 if (extended->attr.is_bind_c)
8500 gfc_error ("%qs cannot be extended at %C because it "
8501 "is BIND(C)", extended->name);
8502 return NULL;
8505 if (extended->attr.sequence)
8507 gfc_error ("%qs cannot be extended at %C because it "
8508 "is a SEQUENCE type", extended->name);
8509 return NULL;
8512 return extended;
8516 /* Match the optional attribute specifiers for a type declaration.
8517 Return MATCH_ERROR if an error is encountered in one of the handled
8518 attributes (public, private, bind(c)), MATCH_NO if what's found is
8519 not a handled attribute, and MATCH_YES otherwise. TODO: More error
8520 checking on attribute conflicts needs to be done. */
8522 match
8523 gfc_get_type_attr_spec (symbol_attribute *attr, char *name)
8525 /* See if the derived type is marked as private. */
8526 if (gfc_match (" , private") == MATCH_YES)
8528 if (gfc_current_state () != COMP_MODULE)
8530 gfc_error ("Derived type at %C can only be PRIVATE in the "
8531 "specification part of a module");
8532 return MATCH_ERROR;
8535 if (!gfc_add_access (attr, ACCESS_PRIVATE, NULL, NULL))
8536 return MATCH_ERROR;
8538 else if (gfc_match (" , public") == MATCH_YES)
8540 if (gfc_current_state () != COMP_MODULE)
8542 gfc_error ("Derived type at %C can only be PUBLIC in the "
8543 "specification part of a module");
8544 return MATCH_ERROR;
8547 if (!gfc_add_access (attr, ACCESS_PUBLIC, NULL, NULL))
8548 return MATCH_ERROR;
8550 else if (gfc_match (" , bind ( c )") == MATCH_YES)
8552 /* If the type is defined to be bind(c) it then needs to make
8553 sure that all fields are interoperable. This will
8554 need to be a semantic check on the finished derived type.
8555 See 15.2.3 (lines 9-12) of F2003 draft. */
8556 if (!gfc_add_is_bind_c (attr, NULL, &gfc_current_locus, 0))
8557 return MATCH_ERROR;
8559 /* TODO: attr conflicts need to be checked, probably in symbol.c. */
8561 else if (gfc_match (" , abstract") == MATCH_YES)
8563 if (!gfc_notify_std (GFC_STD_F2003, "ABSTRACT type at %C"))
8564 return MATCH_ERROR;
8566 if (!gfc_add_abstract (attr, &gfc_current_locus))
8567 return MATCH_ERROR;
8569 else if (name && gfc_match (" , extends ( %n )", name) == MATCH_YES)
8571 if (!gfc_add_extension (attr, &gfc_current_locus))
8572 return MATCH_ERROR;
8574 else
8575 return MATCH_NO;
8577 /* If we get here, something matched. */
8578 return MATCH_YES;
8582 /* Common function for type declaration blocks similar to derived types, such
8583 as STRUCTURES and MAPs. Unlike derived types, a structure type
8584 does NOT have a generic symbol matching the name given by the user.
8585 STRUCTUREs can share names with variables and PARAMETERs so we must allow
8586 for the creation of an independent symbol.
8587 Other parameters are a message to prefix errors with, the name of the new
8588 type to be created, and the flavor to add to the resulting symbol. */
8590 static bool
8591 get_struct_decl (const char *name, sym_flavor fl, locus *decl,
8592 gfc_symbol **result)
8594 gfc_symbol *sym;
8595 locus where;
8597 gcc_assert (name[0] == (char) TOUPPER (name[0]));
8599 if (decl)
8600 where = *decl;
8601 else
8602 where = gfc_current_locus;
8604 if (gfc_get_symbol (name, NULL, &sym))
8605 return false;
8607 if (!sym)
8609 gfc_internal_error ("Failed to create structure type '%s' at %C", name);
8610 return false;
8613 if (sym->components != NULL || sym->attr.zero_comp)
8615 gfc_error ("Type definition of %qs at %C was already defined at %L",
8616 sym->name, &sym->declared_at);
8617 return false;
8620 sym->declared_at = where;
8622 if (sym->attr.flavor != fl
8623 && !gfc_add_flavor (&sym->attr, fl, sym->name, NULL))
8624 return false;
8626 if (!sym->hash_value)
8627 /* Set the hash for the compound name for this type. */
8628 sym->hash_value = gfc_hash_value (sym);
8630 /* Normally the type is expected to have been completely parsed by the time
8631 a field declaration with this type is seen. For unions, maps, and nested
8632 structure declarations, we need to indicate that it is okay that we
8633 haven't seen any components yet. This will be updated after the structure
8634 is fully parsed. */
8635 sym->attr.zero_comp = 0;
8637 /* Structures always act like derived-types with the SEQUENCE attribute */
8638 gfc_add_sequence (&sym->attr, sym->name, NULL);
8640 if (result) *result = sym;
8642 return true;
8646 /* Match the opening of a MAP block. Like a struct within a union in C;
8647 behaves identical to STRUCTURE blocks. */
8649 match
8650 gfc_match_map (void)
8652 /* Counter used to give unique internal names to map structures. */
8653 static unsigned int gfc_map_id = 0;
8654 char name[GFC_MAX_SYMBOL_LEN + 1];
8655 gfc_symbol *sym;
8656 locus old_loc;
8658 old_loc = gfc_current_locus;
8660 if (gfc_match_eos () != MATCH_YES)
8662 gfc_error ("Junk after MAP statement at %C");
8663 gfc_current_locus = old_loc;
8664 return MATCH_ERROR;
8667 /* Map blocks are anonymous so we make up unique names for the symbol table
8668 which are invalid Fortran identifiers. */
8669 snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "MM$%u", gfc_map_id++);
8671 if (!get_struct_decl (name, FL_STRUCT, &old_loc, &sym))
8672 return MATCH_ERROR;
8674 gfc_new_block = sym;
8676 return MATCH_YES;
8680 /* Match the opening of a UNION block. */
8682 match
8683 gfc_match_union (void)
8685 /* Counter used to give unique internal names to union types. */
8686 static unsigned int gfc_union_id = 0;
8687 char name[GFC_MAX_SYMBOL_LEN + 1];
8688 gfc_symbol *sym;
8689 locus old_loc;
8691 old_loc = gfc_current_locus;
8693 if (gfc_match_eos () != MATCH_YES)
8695 gfc_error ("Junk after UNION statement at %C");
8696 gfc_current_locus = old_loc;
8697 return MATCH_ERROR;
8700 /* Unions are anonymous so we make up unique names for the symbol table
8701 which are invalid Fortran identifiers. */
8702 snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "UU$%u", gfc_union_id++);
8704 if (!get_struct_decl (name, FL_UNION, &old_loc, &sym))
8705 return MATCH_ERROR;
8707 gfc_new_block = sym;
8709 return MATCH_YES;
8713 /* Match the beginning of a STRUCTURE declaration. This is similar to
8714 matching the beginning of a derived type declaration with a few
8715 twists. The resulting type symbol has no access control or other
8716 interesting attributes. */
8718 match
8719 gfc_match_structure_decl (void)
8721 /* Counter used to give unique internal names to anonymous structures. */
8722 static unsigned int gfc_structure_id = 0;
8723 char name[GFC_MAX_SYMBOL_LEN + 1];
8724 gfc_symbol *sym;
8725 match m;
8726 locus where;
8728 if (!flag_dec_structure)
8730 gfc_error ("%s at %C is a DEC extension, enable with "
8731 "%<-fdec-structure%>",
8732 "STRUCTURE");
8733 return MATCH_ERROR;
8736 name[0] = '\0';
8738 m = gfc_match (" /%n/", name);
8739 if (m != MATCH_YES)
8741 /* Non-nested structure declarations require a structure name. */
8742 if (!gfc_comp_struct (gfc_current_state ()))
8744 gfc_error ("Structure name expected in non-nested structure "
8745 "declaration at %C");
8746 return MATCH_ERROR;
8748 /* This is an anonymous structure; make up a unique name for it
8749 (upper-case letters never make it to symbol names from the source).
8750 The important thing is initializing the type variable
8751 and setting gfc_new_symbol, which is immediately used by
8752 parse_structure () and variable_decl () to add components of
8753 this type. */
8754 snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "SS$%u", gfc_structure_id++);
8757 where = gfc_current_locus;
8758 /* No field list allowed after non-nested structure declaration. */
8759 if (!gfc_comp_struct (gfc_current_state ())
8760 && gfc_match_eos () != MATCH_YES)
8762 gfc_error ("Junk after non-nested STRUCTURE statement at %C");
8763 return MATCH_ERROR;
8766 /* Make sure the name is not the name of an intrinsic type. */
8767 if (gfc_is_intrinsic_typename (name))
8769 gfc_error ("Structure name %qs at %C cannot be the same as an"
8770 " intrinsic type", name);
8771 return MATCH_ERROR;
8774 /* Store the actual type symbol for the structure with an upper-case first
8775 letter (an invalid Fortran identifier). */
8777 if (!get_struct_decl (gfc_dt_upper_string (name), FL_STRUCT, &where, &sym))
8778 return MATCH_ERROR;
8780 gfc_new_block = sym;
8781 return MATCH_YES;
8785 /* This function does some work to determine which matcher should be used to
8786 * match a statement beginning with "TYPE". This is used to disambiguate TYPE
8787 * as an alias for PRINT from derived type declarations, TYPE IS statements,
8788 * and derived type data declarations. */
8790 match
8791 gfc_match_type (gfc_statement *st)
8793 char name[GFC_MAX_SYMBOL_LEN + 1];
8794 match m;
8795 locus old_loc;
8797 /* Requires -fdec. */
8798 if (!flag_dec)
8799 return MATCH_NO;
8801 m = gfc_match ("type");
8802 if (m != MATCH_YES)
8803 return m;
8804 /* If we already have an error in the buffer, it is probably from failing to
8805 * match a derived type data declaration. Let it happen. */
8806 else if (gfc_error_flag_test ())
8807 return MATCH_NO;
8809 old_loc = gfc_current_locus;
8810 *st = ST_NONE;
8812 /* If we see an attribute list before anything else it's definitely a derived
8813 * type declaration. */
8814 if (gfc_match (" ,") == MATCH_YES || gfc_match (" ::") == MATCH_YES)
8816 gfc_current_locus = old_loc;
8817 *st = ST_DERIVED_DECL;
8818 return gfc_match_derived_decl ();
8821 /* By now "TYPE" has already been matched. If we do not see a name, this may
8822 * be something like "TYPE *" or "TYPE <fmt>". */
8823 m = gfc_match_name (name);
8824 if (m != MATCH_YES)
8826 /* Let print match if it can, otherwise throw an error from
8827 * gfc_match_derived_decl. */
8828 gfc_current_locus = old_loc;
8829 if (gfc_match_print () == MATCH_YES)
8831 *st = ST_WRITE;
8832 return MATCH_YES;
8834 gfc_current_locus = old_loc;
8835 *st = ST_DERIVED_DECL;
8836 return gfc_match_derived_decl ();
8839 /* A derived type declaration requires an EOS. Without it, assume print. */
8840 m = gfc_match_eos ();
8841 if (m == MATCH_NO)
8843 /* Check manually for TYPE IS (... - this is invalid print syntax. */
8844 if (strncmp ("is", name, 3) == 0
8845 && gfc_match (" (", name) == MATCH_YES)
8847 gfc_current_locus = old_loc;
8848 gcc_assert (gfc_match (" is") == MATCH_YES);
8849 *st = ST_TYPE_IS;
8850 return gfc_match_type_is ();
8852 gfc_current_locus = old_loc;
8853 *st = ST_WRITE;
8854 return gfc_match_print ();
8856 else
8858 /* By now we have "TYPE <name> <EOS>". Check first if the name is an
8859 * intrinsic typename - if so let gfc_match_derived_decl dump an error.
8860 * Otherwise if gfc_match_derived_decl fails it's probably an existing
8861 * symbol which can be printed. */
8862 gfc_current_locus = old_loc;
8863 m = gfc_match_derived_decl ();
8864 if (gfc_is_intrinsic_typename (name) || m == MATCH_YES)
8866 *st = ST_DERIVED_DECL;
8867 return m;
8869 gfc_current_locus = old_loc;
8870 *st = ST_WRITE;
8871 return gfc_match_print ();
8874 return MATCH_NO;
8878 /* Match the beginning of a derived type declaration. If a type name
8879 was the result of a function, then it is possible to have a symbol
8880 already to be known as a derived type yet have no components. */
8882 match
8883 gfc_match_derived_decl (void)
8885 char name[GFC_MAX_SYMBOL_LEN + 1];
8886 char parent[GFC_MAX_SYMBOL_LEN + 1];
8887 symbol_attribute attr;
8888 gfc_symbol *sym, *gensym;
8889 gfc_symbol *extended;
8890 match m;
8891 match is_type_attr_spec = MATCH_NO;
8892 bool seen_attr = false;
8893 gfc_interface *intr = NULL, *head;
8895 if (gfc_comp_struct (gfc_current_state ()))
8896 return MATCH_NO;
8898 name[0] = '\0';
8899 parent[0] = '\0';
8900 gfc_clear_attr (&attr);
8901 extended = NULL;
8905 is_type_attr_spec = gfc_get_type_attr_spec (&attr, parent);
8906 if (is_type_attr_spec == MATCH_ERROR)
8907 return MATCH_ERROR;
8908 if (is_type_attr_spec == MATCH_YES)
8909 seen_attr = true;
8910 } while (is_type_attr_spec == MATCH_YES);
8912 /* Deal with derived type extensions. The extension attribute has
8913 been added to 'attr' but now the parent type must be found and
8914 checked. */
8915 if (parent[0])
8916 extended = check_extended_derived_type (parent);
8918 if (parent[0] && !extended)
8919 return MATCH_ERROR;
8921 if (gfc_match (" ::") != MATCH_YES && seen_attr)
8923 gfc_error ("Expected :: in TYPE definition at %C");
8924 return MATCH_ERROR;
8927 m = gfc_match (" %n%t", name);
8928 if (m != MATCH_YES)
8929 return m;
8931 /* Make sure the name is not the name of an intrinsic type. */
8932 if (gfc_is_intrinsic_typename (name))
8934 gfc_error ("Type name %qs at %C cannot be the same as an intrinsic "
8935 "type", name);
8936 return MATCH_ERROR;
8939 if (gfc_get_symbol (name, NULL, &gensym))
8940 return MATCH_ERROR;
8942 if (!gensym->attr.generic && gensym->ts.type != BT_UNKNOWN)
8944 gfc_error ("Derived type name %qs at %C already has a basic type "
8945 "of %s", gensym->name, gfc_typename (&gensym->ts));
8946 return MATCH_ERROR;
8949 if (!gensym->attr.generic
8950 && !gfc_add_generic (&gensym->attr, gensym->name, NULL))
8951 return MATCH_ERROR;
8953 if (!gensym->attr.function
8954 && !gfc_add_function (&gensym->attr, gensym->name, NULL))
8955 return MATCH_ERROR;
8957 sym = gfc_find_dt_in_generic (gensym);
8959 if (sym && (sym->components != NULL || sym->attr.zero_comp))
8961 gfc_error ("Derived type definition of %qs at %C has already been "
8962 "defined", sym->name);
8963 return MATCH_ERROR;
8966 if (!sym)
8968 /* Use upper case to save the actual derived-type symbol. */
8969 gfc_get_symbol (gfc_dt_upper_string (gensym->name), NULL, &sym);
8970 sym->name = gfc_get_string ("%s", gensym->name);
8971 head = gensym->generic;
8972 intr = gfc_get_interface ();
8973 intr->sym = sym;
8974 intr->where = gfc_current_locus;
8975 intr->sym->declared_at = gfc_current_locus;
8976 intr->next = head;
8977 gensym->generic = intr;
8978 gensym->attr.if_source = IFSRC_DECL;
8981 /* The symbol may already have the derived attribute without the
8982 components. The ways this can happen is via a function
8983 definition, an INTRINSIC statement or a subtype in another
8984 derived type that is a pointer. The first part of the AND clause
8985 is true if the symbol is not the return value of a function. */
8986 if (sym->attr.flavor != FL_DERIVED
8987 && !gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL))
8988 return MATCH_ERROR;
8990 if (attr.access != ACCESS_UNKNOWN
8991 && !gfc_add_access (&sym->attr, attr.access, sym->name, NULL))
8992 return MATCH_ERROR;
8993 else if (sym->attr.access == ACCESS_UNKNOWN
8994 && gensym->attr.access != ACCESS_UNKNOWN
8995 && !gfc_add_access (&sym->attr, gensym->attr.access,
8996 sym->name, NULL))
8997 return MATCH_ERROR;
8999 if (sym->attr.access != ACCESS_UNKNOWN
9000 && gensym->attr.access == ACCESS_UNKNOWN)
9001 gensym->attr.access = sym->attr.access;
9003 /* See if the derived type was labeled as bind(c). */
9004 if (attr.is_bind_c != 0)
9005 sym->attr.is_bind_c = attr.is_bind_c;
9007 /* Construct the f2k_derived namespace if it is not yet there. */
9008 if (!sym->f2k_derived)
9009 sym->f2k_derived = gfc_get_namespace (NULL, 0);
9011 if (extended && !sym->components)
9013 gfc_component *p;
9015 /* Add the extended derived type as the first component. */
9016 gfc_add_component (sym, parent, &p);
9017 extended->refs++;
9018 gfc_set_sym_referenced (extended);
9020 p->ts.type = BT_DERIVED;
9021 p->ts.u.derived = extended;
9022 p->initializer = gfc_default_initializer (&p->ts);
9024 /* Set extension level. */
9025 if (extended->attr.extension == 255)
9027 /* Since the extension field is 8 bit wide, we can only have
9028 up to 255 extension levels. */
9029 gfc_error ("Maximum extension level reached with type %qs at %L",
9030 extended->name, &extended->declared_at);
9031 return MATCH_ERROR;
9033 sym->attr.extension = extended->attr.extension + 1;
9035 /* Provide the links between the extended type and its extension. */
9036 if (!extended->f2k_derived)
9037 extended->f2k_derived = gfc_get_namespace (NULL, 0);
9040 if (!sym->hash_value)
9041 /* Set the hash for the compound name for this type. */
9042 sym->hash_value = gfc_hash_value (sym);
9044 /* Take over the ABSTRACT attribute. */
9045 sym->attr.abstract = attr.abstract;
9047 gfc_new_block = sym;
9049 return MATCH_YES;
9053 /* Cray Pointees can be declared as:
9054 pointer (ipt, a (n,m,...,*)) */
9056 match
9057 gfc_mod_pointee_as (gfc_array_spec *as)
9059 as->cray_pointee = true; /* This will be useful to know later. */
9060 if (as->type == AS_ASSUMED_SIZE)
9061 as->cp_was_assumed = true;
9062 else if (as->type == AS_ASSUMED_SHAPE)
9064 gfc_error ("Cray Pointee at %C cannot be assumed shape array");
9065 return MATCH_ERROR;
9067 return MATCH_YES;
9071 /* Match the enum definition statement, here we are trying to match
9072 the first line of enum definition statement.
9073 Returns MATCH_YES if match is found. */
9075 match
9076 gfc_match_enum (void)
9078 match m;
9080 m = gfc_match_eos ();
9081 if (m != MATCH_YES)
9082 return m;
9084 if (!gfc_notify_std (GFC_STD_F2003, "ENUM and ENUMERATOR at %C"))
9085 return MATCH_ERROR;
9087 return MATCH_YES;
9091 /* Returns an initializer whose value is one higher than the value of the
9092 LAST_INITIALIZER argument. If the argument is NULL, the
9093 initializers value will be set to zero. The initializer's kind
9094 will be set to gfc_c_int_kind.
9096 If -fshort-enums is given, the appropriate kind will be selected
9097 later after all enumerators have been parsed. A warning is issued
9098 here if an initializer exceeds gfc_c_int_kind. */
9100 static gfc_expr *
9101 enum_initializer (gfc_expr *last_initializer, locus where)
9103 gfc_expr *result;
9104 result = gfc_get_constant_expr (BT_INTEGER, gfc_c_int_kind, &where);
9106 mpz_init (result->value.integer);
9108 if (last_initializer != NULL)
9110 mpz_add_ui (result->value.integer, last_initializer->value.integer, 1);
9111 result->where = last_initializer->where;
9113 if (gfc_check_integer_range (result->value.integer,
9114 gfc_c_int_kind) != ARITH_OK)
9116 gfc_error ("Enumerator exceeds the C integer type at %C");
9117 return NULL;
9120 else
9122 /* Control comes here, if it's the very first enumerator and no
9123 initializer has been given. It will be initialized to zero. */
9124 mpz_set_si (result->value.integer, 0);
9127 return result;
9131 /* Match a variable name with an optional initializer. When this
9132 subroutine is called, a variable is expected to be parsed next.
9133 Depending on what is happening at the moment, updates either the
9134 symbol table or the current interface. */
9136 static match
9137 enumerator_decl (void)
9139 char name[GFC_MAX_SYMBOL_LEN + 1];
9140 gfc_expr *initializer;
9141 gfc_array_spec *as = NULL;
9142 gfc_symbol *sym;
9143 locus var_locus;
9144 match m;
9145 bool t;
9146 locus old_locus;
9148 initializer = NULL;
9149 old_locus = gfc_current_locus;
9151 /* When we get here, we've just matched a list of attributes and
9152 maybe a type and a double colon. The next thing we expect to see
9153 is the name of the symbol. */
9154 m = gfc_match_name (name);
9155 if (m != MATCH_YES)
9156 goto cleanup;
9158 var_locus = gfc_current_locus;
9160 /* OK, we've successfully matched the declaration. Now put the
9161 symbol in the current namespace. If we fail to create the symbol,
9162 bail out. */
9163 if (!build_sym (name, NULL, false, &as, &var_locus))
9165 m = MATCH_ERROR;
9166 goto cleanup;
9169 /* The double colon must be present in order to have initializers.
9170 Otherwise the statement is ambiguous with an assignment statement. */
9171 if (colon_seen)
9173 if (gfc_match_char ('=') == MATCH_YES)
9175 m = gfc_match_init_expr (&initializer);
9176 if (m == MATCH_NO)
9178 gfc_error ("Expected an initialization expression at %C");
9179 m = MATCH_ERROR;
9182 if (m != MATCH_YES)
9183 goto cleanup;
9187 /* If we do not have an initializer, the initialization value of the
9188 previous enumerator (stored in last_initializer) is incremented
9189 by 1 and is used to initialize the current enumerator. */
9190 if (initializer == NULL)
9191 initializer = enum_initializer (last_initializer, old_locus);
9193 if (initializer == NULL || initializer->ts.type != BT_INTEGER)
9195 gfc_error ("ENUMERATOR %L not initialized with integer expression",
9196 &var_locus);
9197 m = MATCH_ERROR;
9198 goto cleanup;
9201 /* Store this current initializer, for the next enumerator variable
9202 to be parsed. add_init_expr_to_sym() zeros initializer, so we
9203 use last_initializer below. */
9204 last_initializer = initializer;
9205 t = add_init_expr_to_sym (name, &initializer, &var_locus);
9207 /* Maintain enumerator history. */
9208 gfc_find_symbol (name, NULL, 0, &sym);
9209 create_enum_history (sym, last_initializer);
9211 return (t) ? MATCH_YES : MATCH_ERROR;
9213 cleanup:
9214 /* Free stuff up and return. */
9215 gfc_free_expr (initializer);
9217 return m;
9221 /* Match the enumerator definition statement. */
9223 match
9224 gfc_match_enumerator_def (void)
9226 match m;
9227 bool t;
9229 gfc_clear_ts (&current_ts);
9231 m = gfc_match (" enumerator");
9232 if (m != MATCH_YES)
9233 return m;
9235 m = gfc_match (" :: ");
9236 if (m == MATCH_ERROR)
9237 return m;
9239 colon_seen = (m == MATCH_YES);
9241 if (gfc_current_state () != COMP_ENUM)
9243 gfc_error ("ENUM definition statement expected before %C");
9244 gfc_free_enum_history ();
9245 return MATCH_ERROR;
9248 (&current_ts)->type = BT_INTEGER;
9249 (&current_ts)->kind = gfc_c_int_kind;
9251 gfc_clear_attr (&current_attr);
9252 t = gfc_add_flavor (&current_attr, FL_PARAMETER, NULL, NULL);
9253 if (!t)
9255 m = MATCH_ERROR;
9256 goto cleanup;
9259 for (;;)
9261 m = enumerator_decl ();
9262 if (m == MATCH_ERROR)
9264 gfc_free_enum_history ();
9265 goto cleanup;
9267 if (m == MATCH_NO)
9268 break;
9270 if (gfc_match_eos () == MATCH_YES)
9271 goto cleanup;
9272 if (gfc_match_char (',') != MATCH_YES)
9273 break;
9276 if (gfc_current_state () == COMP_ENUM)
9278 gfc_free_enum_history ();
9279 gfc_error ("Syntax error in ENUMERATOR definition at %C");
9280 m = MATCH_ERROR;
9283 cleanup:
9284 gfc_free_array_spec (current_as);
9285 current_as = NULL;
9286 return m;
9291 /* Match binding attributes. */
9293 static match
9294 match_binding_attributes (gfc_typebound_proc* ba, bool generic, bool ppc)
9296 bool found_passing = false;
9297 bool seen_ptr = false;
9298 match m = MATCH_YES;
9300 /* Initialize to defaults. Do so even before the MATCH_NO check so that in
9301 this case the defaults are in there. */
9302 ba->access = ACCESS_UNKNOWN;
9303 ba->pass_arg = NULL;
9304 ba->pass_arg_num = 0;
9305 ba->nopass = 0;
9306 ba->non_overridable = 0;
9307 ba->deferred = 0;
9308 ba->ppc = ppc;
9310 /* If we find a comma, we believe there are binding attributes. */
9311 m = gfc_match_char (',');
9312 if (m == MATCH_NO)
9313 goto done;
9317 /* Access specifier. */
9319 m = gfc_match (" public");
9320 if (m == MATCH_ERROR)
9321 goto error;
9322 if (m == MATCH_YES)
9324 if (ba->access != ACCESS_UNKNOWN)
9326 gfc_error ("Duplicate access-specifier at %C");
9327 goto error;
9330 ba->access = ACCESS_PUBLIC;
9331 continue;
9334 m = gfc_match (" private");
9335 if (m == MATCH_ERROR)
9336 goto error;
9337 if (m == MATCH_YES)
9339 if (ba->access != ACCESS_UNKNOWN)
9341 gfc_error ("Duplicate access-specifier at %C");
9342 goto error;
9345 ba->access = ACCESS_PRIVATE;
9346 continue;
9349 /* If inside GENERIC, the following is not allowed. */
9350 if (!generic)
9353 /* NOPASS flag. */
9354 m = gfc_match (" nopass");
9355 if (m == MATCH_ERROR)
9356 goto error;
9357 if (m == MATCH_YES)
9359 if (found_passing)
9361 gfc_error ("Binding attributes already specify passing,"
9362 " illegal NOPASS at %C");
9363 goto error;
9366 found_passing = true;
9367 ba->nopass = 1;
9368 continue;
9371 /* PASS possibly including argument. */
9372 m = gfc_match (" pass");
9373 if (m == MATCH_ERROR)
9374 goto error;
9375 if (m == MATCH_YES)
9377 char arg[GFC_MAX_SYMBOL_LEN + 1];
9379 if (found_passing)
9381 gfc_error ("Binding attributes already specify passing,"
9382 " illegal PASS at %C");
9383 goto error;
9386 m = gfc_match (" ( %n )", arg);
9387 if (m == MATCH_ERROR)
9388 goto error;
9389 if (m == MATCH_YES)
9390 ba->pass_arg = gfc_get_string ("%s", arg);
9391 gcc_assert ((m == MATCH_YES) == (ba->pass_arg != NULL));
9393 found_passing = true;
9394 ba->nopass = 0;
9395 continue;
9398 if (ppc)
9400 /* POINTER flag. */
9401 m = gfc_match (" pointer");
9402 if (m == MATCH_ERROR)
9403 goto error;
9404 if (m == MATCH_YES)
9406 if (seen_ptr)
9408 gfc_error ("Duplicate POINTER attribute at %C");
9409 goto error;
9412 seen_ptr = true;
9413 continue;
9416 else
9418 /* NON_OVERRIDABLE flag. */
9419 m = gfc_match (" non_overridable");
9420 if (m == MATCH_ERROR)
9421 goto error;
9422 if (m == MATCH_YES)
9424 if (ba->non_overridable)
9426 gfc_error ("Duplicate NON_OVERRIDABLE at %C");
9427 goto error;
9430 ba->non_overridable = 1;
9431 continue;
9434 /* DEFERRED flag. */
9435 m = gfc_match (" deferred");
9436 if (m == MATCH_ERROR)
9437 goto error;
9438 if (m == MATCH_YES)
9440 if (ba->deferred)
9442 gfc_error ("Duplicate DEFERRED at %C");
9443 goto error;
9446 ba->deferred = 1;
9447 continue;
9453 /* Nothing matching found. */
9454 if (generic)
9455 gfc_error ("Expected access-specifier at %C");
9456 else
9457 gfc_error ("Expected binding attribute at %C");
9458 goto error;
9460 while (gfc_match_char (',') == MATCH_YES);
9462 /* NON_OVERRIDABLE and DEFERRED exclude themselves. */
9463 if (ba->non_overridable && ba->deferred)
9465 gfc_error ("NON_OVERRIDABLE and DEFERRED can't both appear at %C");
9466 goto error;
9469 m = MATCH_YES;
9471 done:
9472 if (ba->access == ACCESS_UNKNOWN)
9473 ba->access = gfc_typebound_default_access;
9475 if (ppc && !seen_ptr)
9477 gfc_error ("POINTER attribute is required for procedure pointer component"
9478 " at %C");
9479 goto error;
9482 return m;
9484 error:
9485 return MATCH_ERROR;
9489 /* Match a PROCEDURE specific binding inside a derived type. */
9491 static match
9492 match_procedure_in_type (void)
9494 char name[GFC_MAX_SYMBOL_LEN + 1];
9495 char target_buf[GFC_MAX_SYMBOL_LEN + 1];
9496 char* target = NULL, *ifc = NULL;
9497 gfc_typebound_proc tb;
9498 bool seen_colons;
9499 bool seen_attrs;
9500 match m;
9501 gfc_symtree* stree;
9502 gfc_namespace* ns;
9503 gfc_symbol* block;
9504 int num;
9506 /* Check current state. */
9507 gcc_assert (gfc_state_stack->state == COMP_DERIVED_CONTAINS);
9508 block = gfc_state_stack->previous->sym;
9509 gcc_assert (block);
9511 /* Try to match PROCEDURE(interface). */
9512 if (gfc_match (" (") == MATCH_YES)
9514 m = gfc_match_name (target_buf);
9515 if (m == MATCH_ERROR)
9516 return m;
9517 if (m != MATCH_YES)
9519 gfc_error ("Interface-name expected after %<(%> at %C");
9520 return MATCH_ERROR;
9523 if (gfc_match (" )") != MATCH_YES)
9525 gfc_error ("%<)%> expected at %C");
9526 return MATCH_ERROR;
9529 ifc = target_buf;
9532 /* Construct the data structure. */
9533 memset (&tb, 0, sizeof (tb));
9534 tb.where = gfc_current_locus;
9536 /* Match binding attributes. */
9537 m = match_binding_attributes (&tb, false, false);
9538 if (m == MATCH_ERROR)
9539 return m;
9540 seen_attrs = (m == MATCH_YES);
9542 /* Check that attribute DEFERRED is given if an interface is specified. */
9543 if (tb.deferred && !ifc)
9545 gfc_error ("Interface must be specified for DEFERRED binding at %C");
9546 return MATCH_ERROR;
9548 if (ifc && !tb.deferred)
9550 gfc_error ("PROCEDURE(interface) at %C should be declared DEFERRED");
9551 return MATCH_ERROR;
9554 /* Match the colons. */
9555 m = gfc_match (" ::");
9556 if (m == MATCH_ERROR)
9557 return m;
9558 seen_colons = (m == MATCH_YES);
9559 if (seen_attrs && !seen_colons)
9561 gfc_error ("Expected %<::%> after binding-attributes at %C");
9562 return MATCH_ERROR;
9565 /* Match the binding names. */
9566 for(num=1;;num++)
9568 m = gfc_match_name (name);
9569 if (m == MATCH_ERROR)
9570 return m;
9571 if (m == MATCH_NO)
9573 gfc_error ("Expected binding name at %C");
9574 return MATCH_ERROR;
9577 if (num>1 && !gfc_notify_std (GFC_STD_F2008, "PROCEDURE list at %C"))
9578 return MATCH_ERROR;
9580 /* Try to match the '=> target', if it's there. */
9581 target = ifc;
9582 m = gfc_match (" =>");
9583 if (m == MATCH_ERROR)
9584 return m;
9585 if (m == MATCH_YES)
9587 if (tb.deferred)
9589 gfc_error ("%<=> target%> is invalid for DEFERRED binding at %C");
9590 return MATCH_ERROR;
9593 if (!seen_colons)
9595 gfc_error ("%<::%> needed in PROCEDURE binding with explicit target"
9596 " at %C");
9597 return MATCH_ERROR;
9600 m = gfc_match_name (target_buf);
9601 if (m == MATCH_ERROR)
9602 return m;
9603 if (m == MATCH_NO)
9605 gfc_error ("Expected binding target after %<=>%> at %C");
9606 return MATCH_ERROR;
9608 target = target_buf;
9611 /* If no target was found, it has the same name as the binding. */
9612 if (!target)
9613 target = name;
9615 /* Get the namespace to insert the symbols into. */
9616 ns = block->f2k_derived;
9617 gcc_assert (ns);
9619 /* If the binding is DEFERRED, check that the containing type is ABSTRACT. */
9620 if (tb.deferred && !block->attr.abstract)
9622 gfc_error ("Type %qs containing DEFERRED binding at %C "
9623 "is not ABSTRACT", block->name);
9624 return MATCH_ERROR;
9627 /* See if we already have a binding with this name in the symtree which
9628 would be an error. If a GENERIC already targeted this binding, it may
9629 be already there but then typebound is still NULL. */
9630 stree = gfc_find_symtree (ns->tb_sym_root, name);
9631 if (stree && stree->n.tb)
9633 gfc_error ("There is already a procedure with binding name %qs for "
9634 "the derived type %qs at %C", name, block->name);
9635 return MATCH_ERROR;
9638 /* Insert it and set attributes. */
9640 if (!stree)
9642 stree = gfc_new_symtree (&ns->tb_sym_root, name);
9643 gcc_assert (stree);
9645 stree->n.tb = gfc_get_typebound_proc (&tb);
9647 if (gfc_get_sym_tree (target, gfc_current_ns, &stree->n.tb->u.specific,
9648 false))
9649 return MATCH_ERROR;
9650 gfc_set_sym_referenced (stree->n.tb->u.specific->n.sym);
9651 gfc_add_flavor(&stree->n.tb->u.specific->n.sym->attr, FL_PROCEDURE,
9652 target, &stree->n.tb->u.specific->n.sym->declared_at);
9654 if (gfc_match_eos () == MATCH_YES)
9655 return MATCH_YES;
9656 if (gfc_match_char (',') != MATCH_YES)
9657 goto syntax;
9660 syntax:
9661 gfc_error ("Syntax error in PROCEDURE statement at %C");
9662 return MATCH_ERROR;
9666 /* Match a GENERIC procedure binding inside a derived type. */
9668 match
9669 gfc_match_generic (void)
9671 char name[GFC_MAX_SYMBOL_LEN + 1];
9672 char bind_name[GFC_MAX_SYMBOL_LEN + 16]; /* Allow space for OPERATOR(...). */
9673 gfc_symbol* block;
9674 gfc_typebound_proc tbattr; /* Used for match_binding_attributes. */
9675 gfc_typebound_proc* tb;
9676 gfc_namespace* ns;
9677 interface_type op_type;
9678 gfc_intrinsic_op op;
9679 match m;
9681 /* Check current state. */
9682 if (gfc_current_state () == COMP_DERIVED)
9684 gfc_error ("GENERIC at %C must be inside a derived-type CONTAINS");
9685 return MATCH_ERROR;
9687 if (gfc_current_state () != COMP_DERIVED_CONTAINS)
9688 return MATCH_NO;
9689 block = gfc_state_stack->previous->sym;
9690 ns = block->f2k_derived;
9691 gcc_assert (block && ns);
9693 memset (&tbattr, 0, sizeof (tbattr));
9694 tbattr.where = gfc_current_locus;
9696 /* See if we get an access-specifier. */
9697 m = match_binding_attributes (&tbattr, true, false);
9698 if (m == MATCH_ERROR)
9699 goto error;
9701 /* Now the colons, those are required. */
9702 if (gfc_match (" ::") != MATCH_YES)
9704 gfc_error ("Expected %<::%> at %C");
9705 goto error;
9708 /* Match the binding name; depending on type (operator / generic) format
9709 it for future error messages into bind_name. */
9711 m = gfc_match_generic_spec (&op_type, name, &op);
9712 if (m == MATCH_ERROR)
9713 return MATCH_ERROR;
9714 if (m == MATCH_NO)
9716 gfc_error ("Expected generic name or operator descriptor at %C");
9717 goto error;
9720 switch (op_type)
9722 case INTERFACE_GENERIC:
9723 case INTERFACE_DTIO:
9724 snprintf (bind_name, sizeof (bind_name), "%s", name);
9725 break;
9727 case INTERFACE_USER_OP:
9728 snprintf (bind_name, sizeof (bind_name), "OPERATOR(.%s.)", name);
9729 break;
9731 case INTERFACE_INTRINSIC_OP:
9732 snprintf (bind_name, sizeof (bind_name), "OPERATOR(%s)",
9733 gfc_op2string (op));
9734 break;
9736 case INTERFACE_NAMELESS:
9737 gfc_error ("Malformed GENERIC statement at %C");
9738 goto error;
9739 break;
9741 default:
9742 gcc_unreachable ();
9745 /* Match the required =>. */
9746 if (gfc_match (" =>") != MATCH_YES)
9748 gfc_error ("Expected %<=>%> at %C");
9749 goto error;
9752 /* Try to find existing GENERIC binding with this name / for this operator;
9753 if there is something, check that it is another GENERIC and then extend
9754 it rather than building a new node. Otherwise, create it and put it
9755 at the right position. */
9757 switch (op_type)
9759 case INTERFACE_DTIO:
9760 case INTERFACE_USER_OP:
9761 case INTERFACE_GENERIC:
9763 const bool is_op = (op_type == INTERFACE_USER_OP);
9764 gfc_symtree* st;
9766 st = gfc_find_symtree (is_op ? ns->tb_uop_root : ns->tb_sym_root, name);
9767 tb = st ? st->n.tb : NULL;
9768 break;
9771 case INTERFACE_INTRINSIC_OP:
9772 tb = ns->tb_op[op];
9773 break;
9775 default:
9776 gcc_unreachable ();
9779 if (tb)
9781 if (!tb->is_generic)
9783 gcc_assert (op_type == INTERFACE_GENERIC);
9784 gfc_error ("There's already a non-generic procedure with binding name"
9785 " %qs for the derived type %qs at %C",
9786 bind_name, block->name);
9787 goto error;
9790 if (tb->access != tbattr.access)
9792 gfc_error ("Binding at %C must have the same access as already"
9793 " defined binding %qs", bind_name);
9794 goto error;
9797 else
9799 tb = gfc_get_typebound_proc (NULL);
9800 tb->where = gfc_current_locus;
9801 tb->access = tbattr.access;
9802 tb->is_generic = 1;
9803 tb->u.generic = NULL;
9805 switch (op_type)
9807 case INTERFACE_DTIO:
9808 case INTERFACE_GENERIC:
9809 case INTERFACE_USER_OP:
9811 const bool is_op = (op_type == INTERFACE_USER_OP);
9812 gfc_symtree* st = gfc_get_tbp_symtree (is_op ? &ns->tb_uop_root :
9813 &ns->tb_sym_root, name);
9814 gcc_assert (st);
9815 st->n.tb = tb;
9817 break;
9820 case INTERFACE_INTRINSIC_OP:
9821 ns->tb_op[op] = tb;
9822 break;
9824 default:
9825 gcc_unreachable ();
9829 /* Now, match all following names as specific targets. */
9832 gfc_symtree* target_st;
9833 gfc_tbp_generic* target;
9835 m = gfc_match_name (name);
9836 if (m == MATCH_ERROR)
9837 goto error;
9838 if (m == MATCH_NO)
9840 gfc_error ("Expected specific binding name at %C");
9841 goto error;
9844 target_st = gfc_get_tbp_symtree (&ns->tb_sym_root, name);
9846 /* See if this is a duplicate specification. */
9847 for (target = tb->u.generic; target; target = target->next)
9848 if (target_st == target->specific_st)
9850 gfc_error ("%qs already defined as specific binding for the"
9851 " generic %qs at %C", name, bind_name);
9852 goto error;
9855 target = gfc_get_tbp_generic ();
9856 target->specific_st = target_st;
9857 target->specific = NULL;
9858 target->next = tb->u.generic;
9859 target->is_operator = ((op_type == INTERFACE_USER_OP)
9860 || (op_type == INTERFACE_INTRINSIC_OP));
9861 tb->u.generic = target;
9863 while (gfc_match (" ,") == MATCH_YES);
9865 /* Here should be the end. */
9866 if (gfc_match_eos () != MATCH_YES)
9868 gfc_error ("Junk after GENERIC binding at %C");
9869 goto error;
9872 return MATCH_YES;
9874 error:
9875 return MATCH_ERROR;
9879 /* Match a FINAL declaration inside a derived type. */
9881 match
9882 gfc_match_final_decl (void)
9884 char name[GFC_MAX_SYMBOL_LEN + 1];
9885 gfc_symbol* sym;
9886 match m;
9887 gfc_namespace* module_ns;
9888 bool first, last;
9889 gfc_symbol* block;
9891 if (gfc_current_form == FORM_FREE)
9893 char c = gfc_peek_ascii_char ();
9894 if (!gfc_is_whitespace (c) && c != ':')
9895 return MATCH_NO;
9898 if (gfc_state_stack->state != COMP_DERIVED_CONTAINS)
9900 if (gfc_current_form == FORM_FIXED)
9901 return MATCH_NO;
9903 gfc_error ("FINAL declaration at %C must be inside a derived type "
9904 "CONTAINS section");
9905 return MATCH_ERROR;
9908 block = gfc_state_stack->previous->sym;
9909 gcc_assert (block);
9911 if (!gfc_state_stack->previous || !gfc_state_stack->previous->previous
9912 || gfc_state_stack->previous->previous->state != COMP_MODULE)
9914 gfc_error ("Derived type declaration with FINAL at %C must be in the"
9915 " specification part of a MODULE");
9916 return MATCH_ERROR;
9919 module_ns = gfc_current_ns;
9920 gcc_assert (module_ns);
9921 gcc_assert (module_ns->proc_name->attr.flavor == FL_MODULE);
9923 /* Match optional ::, don't care about MATCH_YES or MATCH_NO. */
9924 if (gfc_match (" ::") == MATCH_ERROR)
9925 return MATCH_ERROR;
9927 /* Match the sequence of procedure names. */
9928 first = true;
9929 last = false;
9932 gfc_finalizer* f;
9934 if (first && gfc_match_eos () == MATCH_YES)
9936 gfc_error ("Empty FINAL at %C");
9937 return MATCH_ERROR;
9940 m = gfc_match_name (name);
9941 if (m == MATCH_NO)
9943 gfc_error ("Expected module procedure name at %C");
9944 return MATCH_ERROR;
9946 else if (m != MATCH_YES)
9947 return MATCH_ERROR;
9949 if (gfc_match_eos () == MATCH_YES)
9950 last = true;
9951 if (!last && gfc_match_char (',') != MATCH_YES)
9953 gfc_error ("Expected %<,%> at %C");
9954 return MATCH_ERROR;
9957 if (gfc_get_symbol (name, module_ns, &sym))
9959 gfc_error ("Unknown procedure name %qs at %C", name);
9960 return MATCH_ERROR;
9963 /* Mark the symbol as module procedure. */
9964 if (sym->attr.proc != PROC_MODULE
9965 && !gfc_add_procedure (&sym->attr, PROC_MODULE, sym->name, NULL))
9966 return MATCH_ERROR;
9968 /* Check if we already have this symbol in the list, this is an error. */
9969 for (f = block->f2k_derived->finalizers; f; f = f->next)
9970 if (f->proc_sym == sym)
9972 gfc_error ("%qs at %C is already defined as FINAL procedure",
9973 name);
9974 return MATCH_ERROR;
9977 /* Add this symbol to the list of finalizers. */
9978 gcc_assert (block->f2k_derived);
9979 sym->refs++;
9980 f = XCNEW (gfc_finalizer);
9981 f->proc_sym = sym;
9982 f->proc_tree = NULL;
9983 f->where = gfc_current_locus;
9984 f->next = block->f2k_derived->finalizers;
9985 block->f2k_derived->finalizers = f;
9987 first = false;
9989 while (!last);
9991 return MATCH_YES;
9995 const ext_attr_t ext_attr_list[] = {
9996 { "dllimport", EXT_ATTR_DLLIMPORT, "dllimport" },
9997 { "dllexport", EXT_ATTR_DLLEXPORT, "dllexport" },
9998 { "cdecl", EXT_ATTR_CDECL, "cdecl" },
9999 { "stdcall", EXT_ATTR_STDCALL, "stdcall" },
10000 { "fastcall", EXT_ATTR_FASTCALL, "fastcall" },
10001 { "no_arg_check", EXT_ATTR_NO_ARG_CHECK, NULL },
10002 { NULL, EXT_ATTR_LAST, NULL }
10005 /* Match a !GCC$ ATTRIBUTES statement of the form:
10006 !GCC$ ATTRIBUTES attribute-list :: var-name [, var-name] ...
10007 When we come here, we have already matched the !GCC$ ATTRIBUTES string.
10009 TODO: We should support all GCC attributes using the same syntax for
10010 the attribute list, i.e. the list in C
10011 __attributes(( attribute-list ))
10012 matches then
10013 !GCC$ ATTRIBUTES attribute-list ::
10014 Cf. c-parser.c's c_parser_attributes; the data can then directly be
10015 saved into a TREE.
10017 As there is absolutely no risk of confusion, we should never return
10018 MATCH_NO. */
10019 match
10020 gfc_match_gcc_attributes (void)
10022 symbol_attribute attr;
10023 char name[GFC_MAX_SYMBOL_LEN + 1];
10024 unsigned id;
10025 gfc_symbol *sym;
10026 match m;
10028 gfc_clear_attr (&attr);
10029 for(;;)
10031 char ch;
10033 if (gfc_match_name (name) != MATCH_YES)
10034 return MATCH_ERROR;
10036 for (id = 0; id < EXT_ATTR_LAST; id++)
10037 if (strcmp (name, ext_attr_list[id].name) == 0)
10038 break;
10040 if (id == EXT_ATTR_LAST)
10042 gfc_error ("Unknown attribute in !GCC$ ATTRIBUTES statement at %C");
10043 return MATCH_ERROR;
10046 if (!gfc_add_ext_attribute (&attr, (ext_attr_id_t)id, &gfc_current_locus))
10047 return MATCH_ERROR;
10049 gfc_gobble_whitespace ();
10050 ch = gfc_next_ascii_char ();
10051 if (ch == ':')
10053 /* This is the successful exit condition for the loop. */
10054 if (gfc_next_ascii_char () == ':')
10055 break;
10058 if (ch == ',')
10059 continue;
10061 goto syntax;
10064 if (gfc_match_eos () == MATCH_YES)
10065 goto syntax;
10067 for(;;)
10069 m = gfc_match_name (name);
10070 if (m != MATCH_YES)
10071 return m;
10073 if (find_special (name, &sym, true))
10074 return MATCH_ERROR;
10076 sym->attr.ext_attr |= attr.ext_attr;
10078 if (gfc_match_eos () == MATCH_YES)
10079 break;
10081 if (gfc_match_char (',') != MATCH_YES)
10082 goto syntax;
10085 return MATCH_YES;
10087 syntax:
10088 gfc_error ("Syntax error in !GCC$ ATTRIBUTES statement at %C");
10089 return MATCH_ERROR;