PR testsuite/79169
[official-gcc.git] / gcc / fortran / decl.c
bloba92e06aa6fc1e17f215a2a3c08939f5106205433
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;
1387 if (gfc_get_symbol (name, NULL, &sym))
1388 return false;
1390 /* Check if the name has already been defined as a type. The
1391 first letter of the symtree will be in upper case then. Of
1392 course, this is only necessary if the upper case letter is
1393 actually different. */
1395 upper = TOUPPER(name[0]);
1396 if (upper != name[0])
1398 char u_name[GFC_MAX_SYMBOL_LEN + 1];
1399 gfc_symtree *st;
1400 int nlen;
1402 nlen = strlen(name);
1403 gcc_assert (nlen <= GFC_MAX_SYMBOL_LEN);
1404 strncpy (u_name, name, nlen + 1);
1405 u_name[0] = upper;
1407 st = gfc_find_symtree (gfc_current_ns->sym_root, u_name);
1409 /* STRUCTURE types can alias symbol names */
1410 if (st != 0 && st->n.sym->attr.flavor != FL_STRUCT)
1412 gfc_error ("Symbol %qs at %C also declared as a type at %L", name,
1413 &st->n.sym->declared_at);
1414 return false;
1418 /* Start updating the symbol table. Add basic type attribute if present. */
1419 if (current_ts.type != BT_UNKNOWN
1420 && (sym->attr.implicit_type == 0
1421 || !gfc_compare_types (&sym->ts, &current_ts))
1422 && !gfc_add_type (sym, &current_ts, var_locus))
1423 return false;
1425 if (sym->ts.type == BT_CHARACTER)
1427 sym->ts.u.cl = cl;
1428 sym->ts.deferred = cl_deferred;
1431 /* Add dimension attribute if present. */
1432 if (!gfc_set_array_spec (sym, *as, var_locus))
1433 return false;
1434 *as = NULL;
1436 /* Add attribute to symbol. The copy is so that we can reset the
1437 dimension attribute. */
1438 attr = current_attr;
1439 attr.dimension = 0;
1440 attr.codimension = 0;
1442 if (!gfc_copy_attr (&sym->attr, &attr, var_locus))
1443 return false;
1445 /* Finish any work that may need to be done for the binding label,
1446 if it's a bind(c). The bind(c) attr is found before the symbol
1447 is made, and before the symbol name (for data decls), so the
1448 current_ts is holding the binding label, or nothing if the
1449 name= attr wasn't given. Therefore, test here if we're dealing
1450 with a bind(c) and make sure the binding label is set correctly. */
1451 if (sym->attr.is_bind_c == 1)
1453 if (!sym->binding_label)
1455 /* Set the binding label and verify that if a NAME= was specified
1456 then only one identifier was in the entity-decl-list. */
1457 if (!set_binding_label (&sym->binding_label, sym->name,
1458 num_idents_on_line))
1459 return false;
1463 /* See if we know we're in a common block, and if it's a bind(c)
1464 common then we need to make sure we're an interoperable type. */
1465 if (sym->attr.in_common == 1)
1467 /* Test the common block object. */
1468 if (sym->common_block != NULL && sym->common_block->is_bind_c == 1
1469 && sym->ts.is_c_interop != 1)
1471 gfc_error_now ("Variable %qs in common block %qs at %C "
1472 "must be declared with a C interoperable "
1473 "kind since common block %qs is BIND(C)",
1474 sym->name, sym->common_block->name,
1475 sym->common_block->name);
1476 gfc_clear_error ();
1480 sym->attr.implied_index = 0;
1482 if (sym->ts.type == BT_CLASS)
1483 return gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as);
1485 return true;
1489 /* Set character constant to the given length. The constant will be padded or
1490 truncated. If we're inside an array constructor without a typespec, we
1491 additionally check that all elements have the same length; check_len -1
1492 means no checking. */
1494 void
1495 gfc_set_constant_character_len (int len, gfc_expr *expr, int check_len)
1497 gfc_char_t *s;
1498 int slen;
1500 if (expr->ts.type != BT_CHARACTER)
1501 return;
1503 if (expr->expr_type != EXPR_CONSTANT)
1505 gfc_error_now ("CHARACTER length must be a constant at %L", &expr->where);
1506 return;
1509 slen = expr->value.character.length;
1510 if (len != slen)
1512 s = gfc_get_wide_string (len + 1);
1513 memcpy (s, expr->value.character.string,
1514 MIN (len, slen) * sizeof (gfc_char_t));
1515 if (len > slen)
1516 gfc_wide_memset (&s[slen], ' ', len - slen);
1518 if (warn_character_truncation && slen > len)
1519 gfc_warning_now (OPT_Wcharacter_truncation,
1520 "CHARACTER expression at %L is being truncated "
1521 "(%d/%d)", &expr->where, slen, len);
1523 /* Apply the standard by 'hand' otherwise it gets cleared for
1524 initializers. */
1525 if (check_len != -1 && slen != check_len
1526 && !(gfc_option.allow_std & GFC_STD_GNU))
1527 gfc_error_now ("The CHARACTER elements of the array constructor "
1528 "at %L must have the same length (%d/%d)",
1529 &expr->where, slen, check_len);
1531 s[len] = '\0';
1532 free (expr->value.character.string);
1533 expr->value.character.string = s;
1534 expr->value.character.length = len;
1539 /* Function to create and update the enumerator history
1540 using the information passed as arguments.
1541 Pointer "max_enum" is also updated, to point to
1542 enum history node containing largest initializer.
1544 SYM points to the symbol node of enumerator.
1545 INIT points to its enumerator value. */
1547 static void
1548 create_enum_history (gfc_symbol *sym, gfc_expr *init)
1550 enumerator_history *new_enum_history;
1551 gcc_assert (sym != NULL && init != NULL);
1553 new_enum_history = XCNEW (enumerator_history);
1555 new_enum_history->sym = sym;
1556 new_enum_history->initializer = init;
1557 new_enum_history->next = NULL;
1559 if (enum_history == NULL)
1561 enum_history = new_enum_history;
1562 max_enum = enum_history;
1564 else
1566 new_enum_history->next = enum_history;
1567 enum_history = new_enum_history;
1569 if (mpz_cmp (max_enum->initializer->value.integer,
1570 new_enum_history->initializer->value.integer) < 0)
1571 max_enum = new_enum_history;
1576 /* Function to free enum kind history. */
1578 void
1579 gfc_free_enum_history (void)
1581 enumerator_history *current = enum_history;
1582 enumerator_history *next;
1584 while (current != NULL)
1586 next = current->next;
1587 free (current);
1588 current = next;
1590 max_enum = NULL;
1591 enum_history = NULL;
1595 /* Function called by variable_decl() that adds an initialization
1596 expression to a symbol. */
1598 static bool
1599 add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus)
1601 symbol_attribute attr;
1602 gfc_symbol *sym;
1603 gfc_expr *init;
1605 init = *initp;
1606 if (find_special (name, &sym, false))
1607 return false;
1609 attr = sym->attr;
1611 /* If this symbol is confirming an implicit parameter type,
1612 then an initialization expression is not allowed. */
1613 if (attr.flavor == FL_PARAMETER
1614 && sym->value != NULL
1615 && *initp != NULL)
1617 gfc_error ("Initializer not allowed for PARAMETER %qs at %C",
1618 sym->name);
1619 return false;
1622 if (init == NULL)
1624 /* An initializer is required for PARAMETER declarations. */
1625 if (attr.flavor == FL_PARAMETER)
1627 gfc_error ("PARAMETER at %L is missing an initializer", var_locus);
1628 return false;
1631 else
1633 /* If a variable appears in a DATA block, it cannot have an
1634 initializer. */
1635 if (sym->attr.data)
1637 gfc_error ("Variable %qs at %C with an initializer already "
1638 "appears in a DATA statement", sym->name);
1639 return false;
1642 /* Check if the assignment can happen. This has to be put off
1643 until later for derived type variables and procedure pointers. */
1644 if (!gfc_bt_struct (sym->ts.type) && !gfc_bt_struct (init->ts.type)
1645 && sym->ts.type != BT_CLASS && init->ts.type != BT_CLASS
1646 && !sym->attr.proc_pointer
1647 && !gfc_check_assign_symbol (sym, NULL, init))
1648 return false;
1650 if (sym->ts.type == BT_CHARACTER && sym->ts.u.cl
1651 && init->ts.type == BT_CHARACTER)
1653 /* Update symbol character length according initializer. */
1654 if (!gfc_check_assign_symbol (sym, NULL, init))
1655 return false;
1657 if (sym->ts.u.cl->length == NULL)
1659 int clen;
1660 /* If there are multiple CHARACTER variables declared on the
1661 same line, we don't want them to share the same length. */
1662 sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
1664 if (sym->attr.flavor == FL_PARAMETER)
1666 if (init->expr_type == EXPR_CONSTANT)
1668 clen = init->value.character.length;
1669 sym->ts.u.cl->length
1670 = gfc_get_int_expr (gfc_default_integer_kind,
1671 NULL, clen);
1673 else if (init->expr_type == EXPR_ARRAY)
1675 if (init->ts.u.cl)
1677 const gfc_expr *length = init->ts.u.cl->length;
1678 if (length->expr_type != EXPR_CONSTANT)
1680 gfc_error ("Cannot initialize parameter array "
1681 "at %L "
1682 "with variable length elements",
1683 &sym->declared_at);
1684 return false;
1686 clen = mpz_get_si (length->value.integer);
1688 else if (init->value.constructor)
1690 gfc_constructor *c;
1691 c = gfc_constructor_first (init->value.constructor);
1692 clen = c->expr->value.character.length;
1694 else
1695 gcc_unreachable ();
1696 sym->ts.u.cl->length
1697 = gfc_get_int_expr (gfc_default_integer_kind,
1698 NULL, clen);
1700 else if (init->ts.u.cl && init->ts.u.cl->length)
1701 sym->ts.u.cl->length =
1702 gfc_copy_expr (sym->value->ts.u.cl->length);
1705 /* Update initializer character length according symbol. */
1706 else if (sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
1708 int len;
1710 if (!gfc_specification_expr (sym->ts.u.cl->length))
1711 return false;
1713 len = mpz_get_si (sym->ts.u.cl->length->value.integer);
1715 if (init->expr_type == EXPR_CONSTANT)
1716 gfc_set_constant_character_len (len, init, -1);
1717 else if (init->expr_type == EXPR_ARRAY)
1719 gfc_constructor *c;
1721 /* Build a new charlen to prevent simplification from
1722 deleting the length before it is resolved. */
1723 init->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
1724 init->ts.u.cl->length = gfc_copy_expr (sym->ts.u.cl->length);
1726 for (c = gfc_constructor_first (init->value.constructor);
1727 c; c = gfc_constructor_next (c))
1728 gfc_set_constant_character_len (len, c->expr, -1);
1733 /* If sym is implied-shape, set its upper bounds from init. */
1734 if (sym->attr.flavor == FL_PARAMETER && sym->attr.dimension
1735 && sym->as->type == AS_IMPLIED_SHAPE)
1737 int dim;
1739 if (init->rank == 0)
1741 gfc_error ("Can't initialize implied-shape array at %L"
1742 " with scalar", &sym->declared_at);
1743 return false;
1746 /* Shape should be present, we get an initialization expression. */
1747 gcc_assert (init->shape);
1749 for (dim = 0; dim < sym->as->rank; ++dim)
1751 int k;
1752 gfc_expr *e, *lower;
1754 lower = sym->as->lower[dim];
1756 /* If the lower bound is an array element from another
1757 parameterized array, then it is marked with EXPR_VARIABLE and
1758 is an initialization expression. Try to reduce it. */
1759 if (lower->expr_type == EXPR_VARIABLE)
1760 gfc_reduce_init_expr (lower);
1762 if (lower->expr_type == EXPR_CONSTANT)
1764 /* All dimensions must be without upper bound. */
1765 gcc_assert (!sym->as->upper[dim]);
1767 k = lower->ts.kind;
1768 e = gfc_get_constant_expr (BT_INTEGER, k, &sym->declared_at);
1769 mpz_add (e->value.integer, lower->value.integer,
1770 init->shape[dim]);
1771 mpz_sub_ui (e->value.integer, e->value.integer, 1);
1772 sym->as->upper[dim] = e;
1774 else
1776 gfc_error ("Non-constant lower bound in implied-shape"
1777 " declaration at %L", &lower->where);
1778 return false;
1782 sym->as->type = AS_EXPLICIT;
1785 /* Need to check if the expression we initialized this
1786 to was one of the iso_c_binding named constants. If so,
1787 and we're a parameter (constant), let it be iso_c.
1788 For example:
1789 integer(c_int), parameter :: my_int = c_int
1790 integer(my_int) :: my_int_2
1791 If we mark my_int as iso_c (since we can see it's value
1792 is equal to one of the named constants), then my_int_2
1793 will be considered C interoperable. */
1794 if (sym->ts.type != BT_CHARACTER && !gfc_bt_struct (sym->ts.type))
1796 sym->ts.is_iso_c |= init->ts.is_iso_c;
1797 sym->ts.is_c_interop |= init->ts.is_c_interop;
1798 /* attr bits needed for module files. */
1799 sym->attr.is_iso_c |= init->ts.is_iso_c;
1800 sym->attr.is_c_interop |= init->ts.is_c_interop;
1801 if (init->ts.is_iso_c)
1802 sym->ts.f90_type = init->ts.f90_type;
1805 /* Add initializer. Make sure we keep the ranks sane. */
1806 if (sym->attr.dimension && init->rank == 0)
1808 mpz_t size;
1809 gfc_expr *array;
1810 int n;
1811 if (sym->attr.flavor == FL_PARAMETER
1812 && init->expr_type == EXPR_CONSTANT
1813 && spec_size (sym->as, &size)
1814 && mpz_cmp_si (size, 0) > 0)
1816 array = gfc_get_array_expr (init->ts.type, init->ts.kind,
1817 &init->where);
1818 for (n = 0; n < (int)mpz_get_si (size); n++)
1819 gfc_constructor_append_expr (&array->value.constructor,
1820 n == 0
1821 ? init
1822 : gfc_copy_expr (init),
1823 &init->where);
1825 array->shape = gfc_get_shape (sym->as->rank);
1826 for (n = 0; n < sym->as->rank; n++)
1827 spec_dimen_size (sym->as, n, &array->shape[n]);
1829 init = array;
1830 mpz_clear (size);
1832 init->rank = sym->as->rank;
1835 sym->value = init;
1836 if (sym->attr.save == SAVE_NONE)
1837 sym->attr.save = SAVE_IMPLICIT;
1838 *initp = NULL;
1841 return true;
1845 /* Function called by variable_decl() that adds a name to a structure
1846 being built. */
1848 static bool
1849 build_struct (const char *name, gfc_charlen *cl, gfc_expr **init,
1850 gfc_array_spec **as)
1852 gfc_state_data *s;
1853 gfc_component *c;
1855 /* F03:C438/C439. If the current symbol is of the same derived type that we're
1856 constructing, it must have the pointer attribute. */
1857 if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS)
1858 && current_ts.u.derived == gfc_current_block ()
1859 && current_attr.pointer == 0)
1861 if (current_attr.allocatable
1862 && !gfc_notify_std(GFC_STD_F2008, "Component at %C "
1863 "must have the POINTER attribute"))
1865 return false;
1867 else if (current_attr.allocatable == 0)
1869 gfc_error ("Component at %C must have the POINTER attribute");
1870 return false;
1874 /* F03:C437. */
1875 if (current_ts.type == BT_CLASS
1876 && !(current_attr.pointer || current_attr.allocatable))
1878 gfc_error ("Component %qs with CLASS at %C must be allocatable "
1879 "or pointer", name);
1880 return false;
1883 if (gfc_current_block ()->attr.pointer && (*as)->rank != 0)
1885 if ((*as)->type != AS_DEFERRED && (*as)->type != AS_EXPLICIT)
1887 gfc_error ("Array component of structure at %C must have explicit "
1888 "or deferred shape");
1889 return false;
1893 /* If we are in a nested union/map definition, gfc_add_component will not
1894 properly find repeated components because:
1895 (i) gfc_add_component does a flat search, where components of unions
1896 and maps are implicity chained so nested components may conflict.
1897 (ii) Unions and maps are not linked as components of their parent
1898 structures until after they are parsed.
1899 For (i) we use gfc_find_component which searches recursively, and for (ii)
1900 we search each block directly from the parse stack until we find the top
1901 level structure. */
1903 s = gfc_state_stack;
1904 if (s->state == COMP_UNION || s->state == COMP_MAP)
1906 while (s->state == COMP_UNION || gfc_comp_struct (s->state))
1908 c = gfc_find_component (s->sym, name, true, true, NULL);
1909 if (c != NULL)
1911 gfc_error_now ("Component '%s' at %C already declared at %L",
1912 name, &c->loc);
1913 return false;
1915 /* Break after we've searched the entire chain. */
1916 if (s->state == COMP_DERIVED || s->state == COMP_STRUCTURE)
1917 break;
1918 s = s->previous;
1922 if (!gfc_add_component (gfc_current_block(), name, &c))
1923 return false;
1925 c->ts = current_ts;
1926 if (c->ts.type == BT_CHARACTER)
1927 c->ts.u.cl = cl;
1928 c->attr = current_attr;
1930 c->initializer = *init;
1931 *init = NULL;
1933 c->as = *as;
1934 if (c->as != NULL)
1936 if (c->as->corank)
1937 c->attr.codimension = 1;
1938 if (c->as->rank)
1939 c->attr.dimension = 1;
1941 *as = NULL;
1943 gfc_apply_init (&c->ts, &c->attr, c->initializer);
1945 /* Check array components. */
1946 if (!c->attr.dimension)
1947 goto scalar;
1949 if (c->attr.pointer)
1951 if (c->as->type != AS_DEFERRED)
1953 gfc_error ("Pointer array component of structure at %C must have a "
1954 "deferred shape");
1955 return false;
1958 else if (c->attr.allocatable)
1960 if (c->as->type != AS_DEFERRED)
1962 gfc_error ("Allocatable component of structure at %C must have a "
1963 "deferred shape");
1964 return false;
1967 else
1969 if (c->as->type != AS_EXPLICIT)
1971 gfc_error ("Array component of structure at %C must have an "
1972 "explicit shape");
1973 return false;
1977 scalar:
1978 if (c->ts.type == BT_CLASS)
1979 return gfc_build_class_symbol (&c->ts, &c->attr, &c->as);
1981 return true;
1985 /* Match a 'NULL()', and possibly take care of some side effects. */
1987 match
1988 gfc_match_null (gfc_expr **result)
1990 gfc_symbol *sym;
1991 match m, m2 = MATCH_NO;
1993 if ((m = gfc_match (" null ( )")) == MATCH_ERROR)
1994 return MATCH_ERROR;
1996 if (m == MATCH_NO)
1998 locus old_loc;
1999 char name[GFC_MAX_SYMBOL_LEN + 1];
2001 if ((m2 = gfc_match (" null (")) != MATCH_YES)
2002 return m2;
2004 old_loc = gfc_current_locus;
2005 if ((m2 = gfc_match (" %n ) ", name)) == MATCH_ERROR)
2006 return MATCH_ERROR;
2007 if (m2 != MATCH_YES
2008 && ((m2 = gfc_match (" mold = %n )", name)) == MATCH_ERROR))
2009 return MATCH_ERROR;
2010 if (m2 == MATCH_NO)
2012 gfc_current_locus = old_loc;
2013 return MATCH_NO;
2017 /* The NULL symbol now has to be/become an intrinsic function. */
2018 if (gfc_get_symbol ("null", NULL, &sym))
2020 gfc_error ("NULL() initialization at %C is ambiguous");
2021 return MATCH_ERROR;
2024 gfc_intrinsic_symbol (sym);
2026 if (sym->attr.proc != PROC_INTRINSIC
2027 && !(sym->attr.use_assoc && sym->attr.intrinsic)
2028 && (!gfc_add_procedure(&sym->attr, PROC_INTRINSIC, sym->name, NULL)
2029 || !gfc_add_function (&sym->attr, sym->name, NULL)))
2030 return MATCH_ERROR;
2032 *result = gfc_get_null_expr (&gfc_current_locus);
2034 /* Invalid per F2008, C512. */
2035 if (m2 == MATCH_YES)
2037 gfc_error ("NULL() initialization at %C may not have MOLD");
2038 return MATCH_ERROR;
2041 return MATCH_YES;
2045 /* Match the initialization expr for a data pointer or procedure pointer. */
2047 static match
2048 match_pointer_init (gfc_expr **init, int procptr)
2050 match m;
2052 if (gfc_pure (NULL) && !gfc_comp_struct (gfc_state_stack->state))
2054 gfc_error ("Initialization of pointer at %C is not allowed in "
2055 "a PURE procedure");
2056 return MATCH_ERROR;
2058 gfc_unset_implicit_pure (gfc_current_ns->proc_name);
2060 /* Match NULL() initialization. */
2061 m = gfc_match_null (init);
2062 if (m != MATCH_NO)
2063 return m;
2065 /* Match non-NULL initialization. */
2066 gfc_matching_ptr_assignment = !procptr;
2067 gfc_matching_procptr_assignment = procptr;
2068 m = gfc_match_rvalue (init);
2069 gfc_matching_ptr_assignment = 0;
2070 gfc_matching_procptr_assignment = 0;
2071 if (m == MATCH_ERROR)
2072 return MATCH_ERROR;
2073 else if (m == MATCH_NO)
2075 gfc_error ("Error in pointer initialization at %C");
2076 return MATCH_ERROR;
2079 if (!procptr && !gfc_resolve_expr (*init))
2080 return MATCH_ERROR;
2082 if (!gfc_notify_std (GFC_STD_F2008, "non-NULL pointer "
2083 "initialization at %C"))
2084 return MATCH_ERROR;
2086 return MATCH_YES;
2090 static bool
2091 check_function_name (char *name)
2093 /* In functions that have a RESULT variable defined, the function name always
2094 refers to function calls. Therefore, the name is not allowed to appear in
2095 specification statements. When checking this, be careful about
2096 'hidden' procedure pointer results ('ppr@'). */
2098 if (gfc_current_state () == COMP_FUNCTION)
2100 gfc_symbol *block = gfc_current_block ();
2101 if (block && block->result && block->result != block
2102 && strcmp (block->result->name, "ppr@") != 0
2103 && strcmp (block->name, name) == 0)
2105 gfc_error ("Function name %qs not allowed at %C", name);
2106 return false;
2110 return true;
2114 /* Match a variable name with an optional initializer. When this
2115 subroutine is called, a variable is expected to be parsed next.
2116 Depending on what is happening at the moment, updates either the
2117 symbol table or the current interface. */
2119 static match
2120 variable_decl (int elem)
2122 char name[GFC_MAX_SYMBOL_LEN + 1];
2123 gfc_expr *initializer, *char_len;
2124 gfc_array_spec *as;
2125 gfc_array_spec *cp_as; /* Extra copy for Cray Pointees. */
2126 gfc_charlen *cl;
2127 bool cl_deferred;
2128 locus var_locus;
2129 match m;
2130 bool t;
2131 gfc_symbol *sym;
2133 initializer = NULL;
2134 as = NULL;
2135 cp_as = NULL;
2137 /* When we get here, we've just matched a list of attributes and
2138 maybe a type and a double colon. The next thing we expect to see
2139 is the name of the symbol. */
2140 m = gfc_match_name (name);
2141 if (m != MATCH_YES)
2142 goto cleanup;
2144 var_locus = gfc_current_locus;
2146 /* Now we could see the optional array spec. or character length. */
2147 m = gfc_match_array_spec (&as, true, true);
2148 if (m == MATCH_ERROR)
2149 goto cleanup;
2151 if (m == MATCH_NO)
2152 as = gfc_copy_array_spec (current_as);
2153 else if (current_as
2154 && !merge_array_spec (current_as, as, true))
2156 m = MATCH_ERROR;
2157 goto cleanup;
2160 if (flag_cray_pointer)
2161 cp_as = gfc_copy_array_spec (as);
2163 /* At this point, we know for sure if the symbol is PARAMETER and can thus
2164 determine (and check) whether it can be implied-shape. If it
2165 was parsed as assumed-size, change it because PARAMETERs can not
2166 be assumed-size. */
2167 if (as)
2169 if (as->type == AS_IMPLIED_SHAPE && current_attr.flavor != FL_PARAMETER)
2171 m = MATCH_ERROR;
2172 gfc_error ("Non-PARAMETER symbol %qs at %L can't be implied-shape",
2173 name, &var_locus);
2174 goto cleanup;
2177 if (as->type == AS_ASSUMED_SIZE && as->rank == 1
2178 && current_attr.flavor == FL_PARAMETER)
2179 as->type = AS_IMPLIED_SHAPE;
2181 if (as->type == AS_IMPLIED_SHAPE
2182 && !gfc_notify_std (GFC_STD_F2008, "Implied-shape array at %L",
2183 &var_locus))
2185 m = MATCH_ERROR;
2186 goto cleanup;
2190 char_len = NULL;
2191 cl = NULL;
2192 cl_deferred = false;
2194 if (current_ts.type == BT_CHARACTER)
2196 switch (match_char_length (&char_len, &cl_deferred, false))
2198 case MATCH_YES:
2199 cl = gfc_new_charlen (gfc_current_ns, NULL);
2201 cl->length = char_len;
2202 break;
2204 /* Non-constant lengths need to be copied after the first
2205 element. Also copy assumed lengths. */
2206 case MATCH_NO:
2207 if (elem > 1
2208 && (current_ts.u.cl->length == NULL
2209 || current_ts.u.cl->length->expr_type != EXPR_CONSTANT))
2211 cl = gfc_new_charlen (gfc_current_ns, NULL);
2212 cl->length = gfc_copy_expr (current_ts.u.cl->length);
2214 else
2215 cl = current_ts.u.cl;
2217 cl_deferred = current_ts.deferred;
2219 break;
2221 case MATCH_ERROR:
2222 goto cleanup;
2226 /* The dummy arguments and result of the abreviated form of MODULE
2227 PROCEDUREs, used in SUBMODULES should not be redefined. */
2228 if (gfc_current_ns->proc_name
2229 && gfc_current_ns->proc_name->abr_modproc_decl)
2231 gfc_find_symbol (name, gfc_current_ns, 1, &sym);
2232 if (sym != NULL && (sym->attr.dummy || sym->attr.result))
2234 m = MATCH_ERROR;
2235 gfc_error ("%qs at %C is a redefinition of the declaration "
2236 "in the corresponding interface for MODULE "
2237 "PROCEDURE %qs", sym->name,
2238 gfc_current_ns->proc_name->name);
2239 goto cleanup;
2243 /* If this symbol has already shown up in a Cray Pointer declaration,
2244 and this is not a component declaration,
2245 then we want to set the type & bail out. */
2246 if (flag_cray_pointer && !gfc_comp_struct (gfc_current_state ()))
2248 gfc_find_symbol (name, gfc_current_ns, 1, &sym);
2249 if (sym != NULL && sym->attr.cray_pointee)
2251 sym->ts.type = current_ts.type;
2252 sym->ts.kind = current_ts.kind;
2253 sym->ts.u.cl = cl;
2254 sym->ts.u.derived = current_ts.u.derived;
2255 sym->ts.is_c_interop = current_ts.is_c_interop;
2256 sym->ts.is_iso_c = current_ts.is_iso_c;
2257 m = MATCH_YES;
2259 /* Check to see if we have an array specification. */
2260 if (cp_as != NULL)
2262 if (sym->as != NULL)
2264 gfc_error ("Duplicate array spec for Cray pointee at %C");
2265 gfc_free_array_spec (cp_as);
2266 m = MATCH_ERROR;
2267 goto cleanup;
2269 else
2271 if (!gfc_set_array_spec (sym, cp_as, &var_locus))
2272 gfc_internal_error ("Couldn't set pointee array spec.");
2274 /* Fix the array spec. */
2275 m = gfc_mod_pointee_as (sym->as);
2276 if (m == MATCH_ERROR)
2277 goto cleanup;
2280 goto cleanup;
2282 else
2284 gfc_free_array_spec (cp_as);
2288 /* Procedure pointer as function result. */
2289 if (gfc_current_state () == COMP_FUNCTION
2290 && strcmp ("ppr@", gfc_current_block ()->name) == 0
2291 && strcmp (name, gfc_current_block ()->ns->proc_name->name) == 0)
2292 strcpy (name, "ppr@");
2294 if (gfc_current_state () == COMP_FUNCTION
2295 && strcmp (name, gfc_current_block ()->name) == 0
2296 && gfc_current_block ()->result
2297 && strcmp ("ppr@", gfc_current_block ()->result->name) == 0)
2298 strcpy (name, "ppr@");
2300 /* OK, we've successfully matched the declaration. Now put the
2301 symbol in the current namespace, because it might be used in the
2302 optional initialization expression for this symbol, e.g. this is
2303 perfectly legal:
2305 integer, parameter :: i = huge(i)
2307 This is only true for parameters or variables of a basic type.
2308 For components of derived types, it is not true, so we don't
2309 create a symbol for those yet. If we fail to create the symbol,
2310 bail out. */
2311 if (!gfc_comp_struct (gfc_current_state ())
2312 && !build_sym (name, cl, cl_deferred, &as, &var_locus))
2314 m = MATCH_ERROR;
2315 goto cleanup;
2318 if (!check_function_name (name))
2320 m = MATCH_ERROR;
2321 goto cleanup;
2324 /* We allow old-style initializations of the form
2325 integer i /2/, j(4) /3*3, 1/
2326 (if no colon has been seen). These are different from data
2327 statements in that initializers are only allowed to apply to the
2328 variable immediately preceding, i.e.
2329 integer i, j /1, 2/
2330 is not allowed. Therefore we have to do some work manually, that
2331 could otherwise be left to the matchers for DATA statements. */
2333 if (!colon_seen && gfc_match (" /") == MATCH_YES)
2335 if (!gfc_notify_std (GFC_STD_GNU, "Old-style "
2336 "initialization at %C"))
2337 return MATCH_ERROR;
2339 /* Allow old style initializations for components of STRUCTUREs and MAPs
2340 but not components of derived types. */
2341 else if (gfc_current_state () == COMP_DERIVED)
2343 gfc_error ("Invalid old style initialization for derived type "
2344 "component at %C");
2345 m = MATCH_ERROR;
2346 goto cleanup;
2349 /* For structure components, read the initializer as a special
2350 expression and let the rest of this function apply the initializer
2351 as usual. */
2352 else if (gfc_comp_struct (gfc_current_state ()))
2354 m = match_clist_expr (&initializer, &current_ts, as);
2355 if (m == MATCH_NO)
2356 gfc_error ("Syntax error in old style initialization of %s at %C",
2357 name);
2358 if (m != MATCH_YES)
2359 goto cleanup;
2362 /* Otherwise we treat the old style initialization just like a
2363 DATA declaration for the current variable. */
2364 else
2365 return match_old_style_init (name);
2368 /* The double colon must be present in order to have initializers.
2369 Otherwise the statement is ambiguous with an assignment statement. */
2370 if (colon_seen)
2372 if (gfc_match (" =>") == MATCH_YES)
2374 if (!current_attr.pointer)
2376 gfc_error ("Initialization at %C isn't for a pointer variable");
2377 m = MATCH_ERROR;
2378 goto cleanup;
2381 m = match_pointer_init (&initializer, 0);
2382 if (m != MATCH_YES)
2383 goto cleanup;
2385 else if (gfc_match_char ('=') == MATCH_YES)
2387 if (current_attr.pointer)
2389 gfc_error ("Pointer initialization at %C requires %<=>%>, "
2390 "not %<=%>");
2391 m = MATCH_ERROR;
2392 goto cleanup;
2395 m = gfc_match_init_expr (&initializer);
2396 if (m == MATCH_NO)
2398 gfc_error ("Expected an initialization expression at %C");
2399 m = MATCH_ERROR;
2402 if (current_attr.flavor != FL_PARAMETER && gfc_pure (NULL)
2403 && !gfc_comp_struct (gfc_state_stack->state))
2405 gfc_error ("Initialization of variable at %C is not allowed in "
2406 "a PURE procedure");
2407 m = MATCH_ERROR;
2410 if (current_attr.flavor != FL_PARAMETER
2411 && !gfc_comp_struct (gfc_state_stack->state))
2412 gfc_unset_implicit_pure (gfc_current_ns->proc_name);
2414 if (m != MATCH_YES)
2415 goto cleanup;
2419 if (initializer != NULL && current_attr.allocatable
2420 && gfc_comp_struct (gfc_current_state ()))
2422 gfc_error ("Initialization of allocatable component at %C is not "
2423 "allowed");
2424 m = MATCH_ERROR;
2425 goto cleanup;
2428 /* Add the initializer. Note that it is fine if initializer is
2429 NULL here, because we sometimes also need to check if a
2430 declaration *must* have an initialization expression. */
2431 if (!gfc_comp_struct (gfc_current_state ()))
2432 t = add_init_expr_to_sym (name, &initializer, &var_locus);
2433 else
2435 if (current_ts.type == BT_DERIVED
2436 && !current_attr.pointer && !initializer)
2437 initializer = gfc_default_initializer (&current_ts);
2438 t = build_struct (name, cl, &initializer, &as);
2440 /* If we match a nested structure definition we expect to see the
2441 * body even if the variable declarations blow up, so we need to keep
2442 * the structure declaration around. */
2443 if (gfc_new_block && gfc_new_block->attr.flavor == FL_STRUCT)
2444 gfc_commit_symbol (gfc_new_block);
2447 m = (t) ? MATCH_YES : MATCH_ERROR;
2449 cleanup:
2450 /* Free stuff up and return. */
2451 gfc_free_expr (initializer);
2452 gfc_free_array_spec (as);
2454 return m;
2458 /* Match an extended-f77 "TYPESPEC*bytesize"-style kind specification.
2459 This assumes that the byte size is equal to the kind number for
2460 non-COMPLEX types, and equal to twice the kind number for COMPLEX. */
2462 match
2463 gfc_match_old_kind_spec (gfc_typespec *ts)
2465 match m;
2466 int original_kind;
2468 if (gfc_match_char ('*') != MATCH_YES)
2469 return MATCH_NO;
2471 m = gfc_match_small_literal_int (&ts->kind, NULL);
2472 if (m != MATCH_YES)
2473 return MATCH_ERROR;
2475 original_kind = ts->kind;
2477 /* Massage the kind numbers for complex types. */
2478 if (ts->type == BT_COMPLEX)
2480 if (ts->kind % 2)
2482 gfc_error ("Old-style type declaration %s*%d not supported at %C",
2483 gfc_basic_typename (ts->type), original_kind);
2484 return MATCH_ERROR;
2486 ts->kind /= 2;
2490 if (ts->type == BT_INTEGER && ts->kind == 4 && flag_integer4_kind == 8)
2491 ts->kind = 8;
2493 if (ts->type == BT_REAL || ts->type == BT_COMPLEX)
2495 if (ts->kind == 4)
2497 if (flag_real4_kind == 8)
2498 ts->kind = 8;
2499 if (flag_real4_kind == 10)
2500 ts->kind = 10;
2501 if (flag_real4_kind == 16)
2502 ts->kind = 16;
2505 if (ts->kind == 8)
2507 if (flag_real8_kind == 4)
2508 ts->kind = 4;
2509 if (flag_real8_kind == 10)
2510 ts->kind = 10;
2511 if (flag_real8_kind == 16)
2512 ts->kind = 16;
2516 if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
2518 gfc_error ("Old-style type declaration %s*%d not supported at %C",
2519 gfc_basic_typename (ts->type), original_kind);
2520 return MATCH_ERROR;
2523 if (!gfc_notify_std (GFC_STD_GNU,
2524 "Nonstandard type declaration %s*%d at %C",
2525 gfc_basic_typename(ts->type), original_kind))
2526 return MATCH_ERROR;
2528 return MATCH_YES;
2532 /* Match a kind specification. Since kinds are generally optional, we
2533 usually return MATCH_NO if something goes wrong. If a "kind="
2534 string is found, then we know we have an error. */
2536 match
2537 gfc_match_kind_spec (gfc_typespec *ts, bool kind_expr_only)
2539 locus where, loc;
2540 gfc_expr *e;
2541 match m, n;
2542 char c;
2544 m = MATCH_NO;
2545 n = MATCH_YES;
2546 e = NULL;
2548 where = loc = gfc_current_locus;
2550 if (kind_expr_only)
2551 goto kind_expr;
2553 if (gfc_match_char ('(') == MATCH_NO)
2554 return MATCH_NO;
2556 /* Also gobbles optional text. */
2557 if (gfc_match (" kind = ") == MATCH_YES)
2558 m = MATCH_ERROR;
2560 loc = gfc_current_locus;
2562 kind_expr:
2563 n = gfc_match_init_expr (&e);
2565 if (n != MATCH_YES)
2567 if (gfc_matching_function)
2569 /* The function kind expression might include use associated or
2570 imported parameters and try again after the specification
2571 expressions..... */
2572 if (gfc_match_char (')') != MATCH_YES)
2574 gfc_error ("Missing right parenthesis at %C");
2575 m = MATCH_ERROR;
2576 goto no_match;
2579 gfc_free_expr (e);
2580 gfc_undo_symbols ();
2581 return MATCH_YES;
2583 else
2585 /* ....or else, the match is real. */
2586 if (n == MATCH_NO)
2587 gfc_error ("Expected initialization expression at %C");
2588 if (n != MATCH_YES)
2589 return MATCH_ERROR;
2593 if (e->rank != 0)
2595 gfc_error ("Expected scalar initialization expression at %C");
2596 m = MATCH_ERROR;
2597 goto no_match;
2600 if (gfc_extract_int (e, &ts->kind, 1))
2602 m = MATCH_ERROR;
2603 goto no_match;
2606 /* Before throwing away the expression, let's see if we had a
2607 C interoperable kind (and store the fact). */
2608 if (e->ts.is_c_interop == 1)
2610 /* Mark this as C interoperable if being declared with one
2611 of the named constants from iso_c_binding. */
2612 ts->is_c_interop = e->ts.is_iso_c;
2613 ts->f90_type = e->ts.f90_type;
2616 gfc_free_expr (e);
2617 e = NULL;
2619 /* Ignore errors to this point, if we've gotten here. This means
2620 we ignore the m=MATCH_ERROR from above. */
2621 if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
2623 gfc_error ("Kind %d not supported for type %s at %C", ts->kind,
2624 gfc_basic_typename (ts->type));
2625 gfc_current_locus = where;
2626 return MATCH_ERROR;
2629 /* Warn if, e.g., c_int is used for a REAL variable, but not
2630 if, e.g., c_double is used for COMPLEX as the standard
2631 explicitly says that the kind type parameter for complex and real
2632 variable is the same, i.e. c_float == c_float_complex. */
2633 if (ts->f90_type != BT_UNKNOWN && ts->f90_type != ts->type
2634 && !((ts->f90_type == BT_REAL && ts->type == BT_COMPLEX)
2635 || (ts->f90_type == BT_COMPLEX && ts->type == BT_REAL)))
2636 gfc_warning_now (0, "C kind type parameter is for type %s but type at %L "
2637 "is %s", gfc_basic_typename (ts->f90_type), &where,
2638 gfc_basic_typename (ts->type));
2640 gfc_gobble_whitespace ();
2641 if ((c = gfc_next_ascii_char ()) != ')'
2642 && (ts->type != BT_CHARACTER || c != ','))
2644 if (ts->type == BT_CHARACTER)
2645 gfc_error ("Missing right parenthesis or comma at %C");
2646 else
2647 gfc_error ("Missing right parenthesis at %C");
2648 m = MATCH_ERROR;
2650 else
2651 /* All tests passed. */
2652 m = MATCH_YES;
2654 if(m == MATCH_ERROR)
2655 gfc_current_locus = where;
2657 if (ts->type == BT_INTEGER && ts->kind == 4 && flag_integer4_kind == 8)
2658 ts->kind = 8;
2660 if (ts->type == BT_REAL || ts->type == BT_COMPLEX)
2662 if (ts->kind == 4)
2664 if (flag_real4_kind == 8)
2665 ts->kind = 8;
2666 if (flag_real4_kind == 10)
2667 ts->kind = 10;
2668 if (flag_real4_kind == 16)
2669 ts->kind = 16;
2672 if (ts->kind == 8)
2674 if (flag_real8_kind == 4)
2675 ts->kind = 4;
2676 if (flag_real8_kind == 10)
2677 ts->kind = 10;
2678 if (flag_real8_kind == 16)
2679 ts->kind = 16;
2683 /* Return what we know from the test(s). */
2684 return m;
2686 no_match:
2687 gfc_free_expr (e);
2688 gfc_current_locus = where;
2689 return m;
2693 static match
2694 match_char_kind (int * kind, int * is_iso_c)
2696 locus where;
2697 gfc_expr *e;
2698 match m, n;
2699 bool fail;
2701 m = MATCH_NO;
2702 e = NULL;
2703 where = gfc_current_locus;
2705 n = gfc_match_init_expr (&e);
2707 if (n != MATCH_YES && gfc_matching_function)
2709 /* The expression might include use-associated or imported
2710 parameters and try again after the specification
2711 expressions. */
2712 gfc_free_expr (e);
2713 gfc_undo_symbols ();
2714 return MATCH_YES;
2717 if (n == MATCH_NO)
2718 gfc_error ("Expected initialization expression at %C");
2719 if (n != MATCH_YES)
2720 return MATCH_ERROR;
2722 if (e->rank != 0)
2724 gfc_error ("Expected scalar initialization expression at %C");
2725 m = MATCH_ERROR;
2726 goto no_match;
2729 fail = gfc_extract_int (e, kind, 1);
2730 *is_iso_c = e->ts.is_iso_c;
2731 if (fail)
2733 m = MATCH_ERROR;
2734 goto no_match;
2737 gfc_free_expr (e);
2739 /* Ignore errors to this point, if we've gotten here. This means
2740 we ignore the m=MATCH_ERROR from above. */
2741 if (gfc_validate_kind (BT_CHARACTER, *kind, true) < 0)
2743 gfc_error ("Kind %d is not supported for CHARACTER at %C", *kind);
2744 m = MATCH_ERROR;
2746 else
2747 /* All tests passed. */
2748 m = MATCH_YES;
2750 if (m == MATCH_ERROR)
2751 gfc_current_locus = where;
2753 /* Return what we know from the test(s). */
2754 return m;
2756 no_match:
2757 gfc_free_expr (e);
2758 gfc_current_locus = where;
2759 return m;
2763 /* Match the various kind/length specifications in a CHARACTER
2764 declaration. We don't return MATCH_NO. */
2766 match
2767 gfc_match_char_spec (gfc_typespec *ts)
2769 int kind, seen_length, is_iso_c;
2770 gfc_charlen *cl;
2771 gfc_expr *len;
2772 match m;
2773 bool deferred;
2775 len = NULL;
2776 seen_length = 0;
2777 kind = 0;
2778 is_iso_c = 0;
2779 deferred = false;
2781 /* Try the old-style specification first. */
2782 old_char_selector = 0;
2784 m = match_char_length (&len, &deferred, true);
2785 if (m != MATCH_NO)
2787 if (m == MATCH_YES)
2788 old_char_selector = 1;
2789 seen_length = 1;
2790 goto done;
2793 m = gfc_match_char ('(');
2794 if (m != MATCH_YES)
2796 m = MATCH_YES; /* Character without length is a single char. */
2797 goto done;
2800 /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ). */
2801 if (gfc_match (" kind =") == MATCH_YES)
2803 m = match_char_kind (&kind, &is_iso_c);
2805 if (m == MATCH_ERROR)
2806 goto done;
2807 if (m == MATCH_NO)
2808 goto syntax;
2810 if (gfc_match (" , len =") == MATCH_NO)
2811 goto rparen;
2813 m = char_len_param_value (&len, &deferred);
2814 if (m == MATCH_NO)
2815 goto syntax;
2816 if (m == MATCH_ERROR)
2817 goto done;
2818 seen_length = 1;
2820 goto rparen;
2823 /* Try to match "LEN = <len-param>" or "LEN = <len-param>, KIND = <int>". */
2824 if (gfc_match (" len =") == MATCH_YES)
2826 m = char_len_param_value (&len, &deferred);
2827 if (m == MATCH_NO)
2828 goto syntax;
2829 if (m == MATCH_ERROR)
2830 goto done;
2831 seen_length = 1;
2833 if (gfc_match_char (')') == MATCH_YES)
2834 goto done;
2836 if (gfc_match (" , kind =") != MATCH_YES)
2837 goto syntax;
2839 if (match_char_kind (&kind, &is_iso_c) == MATCH_ERROR)
2840 goto done;
2842 goto rparen;
2845 /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ). */
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 m = gfc_match_char (')');
2854 if (m == MATCH_YES)
2855 goto done;
2857 if (gfc_match_char (',') != MATCH_YES)
2858 goto syntax;
2860 gfc_match (" kind ="); /* Gobble optional text. */
2862 m = match_char_kind (&kind, &is_iso_c);
2863 if (m == MATCH_ERROR)
2864 goto done;
2865 if (m == MATCH_NO)
2866 goto syntax;
2868 rparen:
2869 /* Require a right-paren at this point. */
2870 m = gfc_match_char (')');
2871 if (m == MATCH_YES)
2872 goto done;
2874 syntax:
2875 gfc_error ("Syntax error in CHARACTER declaration at %C");
2876 m = MATCH_ERROR;
2877 gfc_free_expr (len);
2878 return m;
2880 done:
2881 /* Deal with character functions after USE and IMPORT statements. */
2882 if (gfc_matching_function)
2884 gfc_free_expr (len);
2885 gfc_undo_symbols ();
2886 return MATCH_YES;
2889 if (m != MATCH_YES)
2891 gfc_free_expr (len);
2892 return m;
2895 /* Do some final massaging of the length values. */
2896 cl = gfc_new_charlen (gfc_current_ns, NULL);
2898 if (seen_length == 0)
2899 cl->length = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
2900 else
2901 cl->length = len;
2903 ts->u.cl = cl;
2904 ts->kind = kind == 0 ? gfc_default_character_kind : kind;
2905 ts->deferred = deferred;
2907 /* We have to know if it was a C interoperable kind so we can
2908 do accurate type checking of bind(c) procs, etc. */
2909 if (kind != 0)
2910 /* Mark this as C interoperable if being declared with one
2911 of the named constants from iso_c_binding. */
2912 ts->is_c_interop = is_iso_c;
2913 else if (len != NULL)
2914 /* Here, we might have parsed something such as: character(c_char)
2915 In this case, the parsing code above grabs the c_char when
2916 looking for the length (line 1690, roughly). it's the last
2917 testcase for parsing the kind params of a character variable.
2918 However, it's not actually the length. this seems like it
2919 could be an error.
2920 To see if the user used a C interop kind, test the expr
2921 of the so called length, and see if it's C interoperable. */
2922 ts->is_c_interop = len->ts.is_iso_c;
2924 return MATCH_YES;
2928 /* Matches a RECORD declaration. */
2930 static match
2931 match_record_decl (char *name)
2933 locus old_loc;
2934 old_loc = gfc_current_locus;
2935 match m;
2937 m = gfc_match (" record /");
2938 if (m == MATCH_YES)
2940 if (!flag_dec_structure)
2942 gfc_current_locus = old_loc;
2943 gfc_error ("RECORD at %C is an extension, enable it with "
2944 "-fdec-structure");
2945 return MATCH_ERROR;
2947 m = gfc_match (" %n/", name);
2948 if (m == MATCH_YES)
2949 return MATCH_YES;
2952 gfc_current_locus = old_loc;
2953 if (flag_dec_structure
2954 && (gfc_match (" record% ") == MATCH_YES
2955 || gfc_match (" record%t") == MATCH_YES))
2956 gfc_error ("Structure name expected after RECORD at %C");
2957 if (m == MATCH_NO)
2958 return MATCH_NO;
2960 return MATCH_ERROR;
2963 /* Matches a declaration-type-spec (F03:R502). If successful, sets the ts
2964 structure to the matched specification. This is necessary for FUNCTION and
2965 IMPLICIT statements.
2967 If implicit_flag is nonzero, then we don't check for the optional
2968 kind specification. Not doing so is needed for matching an IMPLICIT
2969 statement correctly. */
2971 match
2972 gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
2974 char name[GFC_MAX_SYMBOL_LEN + 1];
2975 gfc_symbol *sym, *dt_sym;
2976 match m;
2977 char c;
2978 bool seen_deferred_kind, matched_type;
2979 const char *dt_name;
2981 /* A belt and braces check that the typespec is correctly being treated
2982 as a deferred characteristic association. */
2983 seen_deferred_kind = (gfc_current_state () == COMP_FUNCTION)
2984 && (gfc_current_block ()->result->ts.kind == -1)
2985 && (ts->kind == -1);
2986 gfc_clear_ts (ts);
2987 if (seen_deferred_kind)
2988 ts->kind = -1;
2990 /* Clear the current binding label, in case one is given. */
2991 curr_binding_label = NULL;
2993 if (gfc_match (" byte") == MATCH_YES)
2995 if (!gfc_notify_std (GFC_STD_GNU, "BYTE type at %C"))
2996 return MATCH_ERROR;
2998 if (gfc_validate_kind (BT_INTEGER, 1, true) < 0)
3000 gfc_error ("BYTE type used at %C "
3001 "is not available on the target machine");
3002 return MATCH_ERROR;
3005 ts->type = BT_INTEGER;
3006 ts->kind = 1;
3007 return MATCH_YES;
3011 m = gfc_match (" type (");
3012 matched_type = (m == MATCH_YES);
3013 if (matched_type)
3015 gfc_gobble_whitespace ();
3016 if (gfc_peek_ascii_char () == '*')
3018 if ((m = gfc_match ("*)")) != MATCH_YES)
3019 return m;
3020 if (gfc_comp_struct (gfc_current_state ()))
3022 gfc_error ("Assumed type at %C is not allowed for components");
3023 return MATCH_ERROR;
3025 if (!gfc_notify_std (GFC_STD_F2008_TS, "Assumed type "
3026 "at %C"))
3027 return MATCH_ERROR;
3028 ts->type = BT_ASSUMED;
3029 return MATCH_YES;
3032 m = gfc_match ("%n", name);
3033 matched_type = (m == MATCH_YES);
3036 if ((matched_type && strcmp ("integer", name) == 0)
3037 || (!matched_type && gfc_match (" integer") == MATCH_YES))
3039 ts->type = BT_INTEGER;
3040 ts->kind = gfc_default_integer_kind;
3041 goto get_kind;
3044 if ((matched_type && strcmp ("character", name) == 0)
3045 || (!matched_type && gfc_match (" character") == MATCH_YES))
3047 if (matched_type
3048 && !gfc_notify_std (GFC_STD_F2008, "TYPE with "
3049 "intrinsic-type-spec at %C"))
3050 return MATCH_ERROR;
3052 ts->type = BT_CHARACTER;
3053 if (implicit_flag == 0)
3054 m = gfc_match_char_spec (ts);
3055 else
3056 m = MATCH_YES;
3058 if (matched_type && m == MATCH_YES && gfc_match_char (')') != MATCH_YES)
3059 m = MATCH_ERROR;
3061 return m;
3064 if ((matched_type && strcmp ("real", name) == 0)
3065 || (!matched_type && gfc_match (" real") == MATCH_YES))
3067 ts->type = BT_REAL;
3068 ts->kind = gfc_default_real_kind;
3069 goto get_kind;
3072 if ((matched_type
3073 && (strcmp ("doubleprecision", name) == 0
3074 || (strcmp ("double", name) == 0
3075 && gfc_match (" precision") == MATCH_YES)))
3076 || (!matched_type && gfc_match (" double precision") == MATCH_YES))
3078 if (matched_type
3079 && !gfc_notify_std (GFC_STD_F2008, "TYPE with "
3080 "intrinsic-type-spec at %C"))
3081 return MATCH_ERROR;
3082 if (matched_type && gfc_match_char (')') != MATCH_YES)
3083 return MATCH_ERROR;
3085 ts->type = BT_REAL;
3086 ts->kind = gfc_default_double_kind;
3087 return MATCH_YES;
3090 if ((matched_type && strcmp ("complex", name) == 0)
3091 || (!matched_type && gfc_match (" complex") == MATCH_YES))
3093 ts->type = BT_COMPLEX;
3094 ts->kind = gfc_default_complex_kind;
3095 goto get_kind;
3098 if ((matched_type
3099 && (strcmp ("doublecomplex", name) == 0
3100 || (strcmp ("double", name) == 0
3101 && gfc_match (" complex") == MATCH_YES)))
3102 || (!matched_type && gfc_match (" double complex") == MATCH_YES))
3104 if (!gfc_notify_std (GFC_STD_GNU, "DOUBLE COMPLEX at %C"))
3105 return MATCH_ERROR;
3107 if (matched_type
3108 && !gfc_notify_std (GFC_STD_F2008, "TYPE with "
3109 "intrinsic-type-spec at %C"))
3110 return MATCH_ERROR;
3112 if (matched_type && gfc_match_char (')') != MATCH_YES)
3113 return MATCH_ERROR;
3115 ts->type = BT_COMPLEX;
3116 ts->kind = gfc_default_double_kind;
3117 return MATCH_YES;
3120 if ((matched_type && strcmp ("logical", name) == 0)
3121 || (!matched_type && gfc_match (" logical") == MATCH_YES))
3123 ts->type = BT_LOGICAL;
3124 ts->kind = gfc_default_logical_kind;
3125 goto get_kind;
3128 if (matched_type)
3129 m = gfc_match_char (')');
3131 if (m != MATCH_YES)
3132 m = match_record_decl (name);
3134 if (matched_type || m == MATCH_YES)
3136 ts->type = BT_DERIVED;
3137 /* We accept record/s/ or type(s) where s is a structure, but we
3138 * don't need all the extra derived-type stuff for structures. */
3139 if (gfc_find_symbol (gfc_dt_upper_string (name), NULL, 1, &sym))
3141 gfc_error ("Type name '%s' at %C is ambiguous", name);
3142 return MATCH_ERROR;
3144 if (sym && sym->attr.flavor == FL_STRUCT)
3146 ts->u.derived = sym;
3147 return MATCH_YES;
3149 /* Actually a derived type. */
3152 else
3154 /* Match nested STRUCTURE declarations; only valid within another
3155 structure declaration. */
3156 if (flag_dec_structure
3157 && (gfc_current_state () == COMP_STRUCTURE
3158 || gfc_current_state () == COMP_MAP))
3160 m = gfc_match (" structure");
3161 if (m == MATCH_YES)
3163 m = gfc_match_structure_decl ();
3164 if (m == MATCH_YES)
3166 /* gfc_new_block is updated by match_structure_decl. */
3167 ts->type = BT_DERIVED;
3168 ts->u.derived = gfc_new_block;
3169 return MATCH_YES;
3172 if (m == MATCH_ERROR)
3173 return MATCH_ERROR;
3176 /* Match CLASS declarations. */
3177 m = gfc_match (" class ( * )");
3178 if (m == MATCH_ERROR)
3179 return MATCH_ERROR;
3180 else if (m == MATCH_YES)
3182 gfc_symbol *upe;
3183 gfc_symtree *st;
3184 ts->type = BT_CLASS;
3185 gfc_find_symbol ("STAR", gfc_current_ns, 1, &upe);
3186 if (upe == NULL)
3188 upe = gfc_new_symbol ("STAR", gfc_current_ns);
3189 st = gfc_new_symtree (&gfc_current_ns->sym_root, "STAR");
3190 st->n.sym = upe;
3191 gfc_set_sym_referenced (upe);
3192 upe->refs++;
3193 upe->ts.type = BT_VOID;
3194 upe->attr.unlimited_polymorphic = 1;
3195 /* This is essential to force the construction of
3196 unlimited polymorphic component class containers. */
3197 upe->attr.zero_comp = 1;
3198 if (!gfc_add_flavor (&upe->attr, FL_DERIVED, NULL,
3199 &gfc_current_locus))
3200 return MATCH_ERROR;
3202 else
3204 st = gfc_get_tbp_symtree (&gfc_current_ns->sym_root, "STAR");
3205 st->n.sym = upe;
3206 upe->refs++;
3208 ts->u.derived = upe;
3209 return m;
3212 m = gfc_match (" class ( %n )", name);
3213 if (m != MATCH_YES)
3214 return m;
3215 ts->type = BT_CLASS;
3217 if (!gfc_notify_std (GFC_STD_F2003, "CLASS statement at %C"))
3218 return MATCH_ERROR;
3221 /* Defer association of the derived type until the end of the
3222 specification block. However, if the derived type can be
3223 found, add it to the typespec. */
3224 if (gfc_matching_function)
3226 ts->u.derived = NULL;
3227 if (gfc_current_state () != COMP_INTERFACE
3228 && !gfc_find_symbol (name, NULL, 1, &sym) && sym)
3230 sym = gfc_find_dt_in_generic (sym);
3231 ts->u.derived = sym;
3233 return MATCH_YES;
3236 /* Search for the name but allow the components to be defined later. If
3237 type = -1, this typespec has been seen in a function declaration but
3238 the type could not be accessed at that point. The actual derived type is
3239 stored in a symtree with the first letter of the name capitalized; the
3240 symtree with the all lower-case name contains the associated
3241 generic function. */
3242 dt_name = gfc_dt_upper_string (name);
3243 sym = NULL;
3244 dt_sym = NULL;
3245 if (ts->kind != -1)
3247 gfc_get_ha_symbol (name, &sym);
3248 if (sym->generic && gfc_find_symbol (dt_name, NULL, 0, &dt_sym))
3250 gfc_error ("Type name %qs at %C is ambiguous", name);
3251 return MATCH_ERROR;
3253 if (sym->generic && !dt_sym)
3254 dt_sym = gfc_find_dt_in_generic (sym);
3256 else if (ts->kind == -1)
3258 int iface = gfc_state_stack->previous->state != COMP_INTERFACE
3259 || gfc_current_ns->has_import_set;
3260 gfc_find_symbol (name, NULL, iface, &sym);
3261 if (sym && sym->generic && gfc_find_symbol (dt_name, NULL, 1, &dt_sym))
3263 gfc_error ("Type name %qs at %C is ambiguous", name);
3264 return MATCH_ERROR;
3266 if (sym && sym->generic && !dt_sym)
3267 dt_sym = gfc_find_dt_in_generic (sym);
3269 ts->kind = 0;
3270 if (sym == NULL)
3271 return MATCH_NO;
3274 if ((sym->attr.flavor != FL_UNKNOWN && sym->attr.flavor != FL_STRUCT
3275 && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.generic))
3276 || sym->attr.subroutine)
3278 gfc_error ("Type name %qs at %C conflicts with previously declared "
3279 "entity at %L, which has the same name", name,
3280 &sym->declared_at);
3281 return MATCH_ERROR;
3284 gfc_save_symbol_data (sym);
3285 gfc_set_sym_referenced (sym);
3286 if (!sym->attr.generic
3287 && !gfc_add_generic (&sym->attr, sym->name, NULL))
3288 return MATCH_ERROR;
3290 if (!sym->attr.function
3291 && !gfc_add_function (&sym->attr, sym->name, NULL))
3292 return MATCH_ERROR;
3294 if (!dt_sym)
3296 gfc_interface *intr, *head;
3298 /* Use upper case to save the actual derived-type symbol. */
3299 gfc_get_symbol (dt_name, NULL, &dt_sym);
3300 dt_sym->name = gfc_get_string ("%s", sym->name);
3301 head = sym->generic;
3302 intr = gfc_get_interface ();
3303 intr->sym = dt_sym;
3304 intr->where = gfc_current_locus;
3305 intr->next = head;
3306 sym->generic = intr;
3307 sym->attr.if_source = IFSRC_DECL;
3309 else
3310 gfc_save_symbol_data (dt_sym);
3312 gfc_set_sym_referenced (dt_sym);
3314 if (dt_sym->attr.flavor != FL_DERIVED && dt_sym->attr.flavor != FL_STRUCT
3315 && !gfc_add_flavor (&dt_sym->attr, FL_DERIVED, sym->name, NULL))
3316 return MATCH_ERROR;
3318 ts->u.derived = dt_sym;
3320 return MATCH_YES;
3322 get_kind:
3323 if (matched_type
3324 && !gfc_notify_std (GFC_STD_F2008, "TYPE with "
3325 "intrinsic-type-spec at %C"))
3326 return MATCH_ERROR;
3328 /* For all types except double, derived and character, look for an
3329 optional kind specifier. MATCH_NO is actually OK at this point. */
3330 if (implicit_flag == 1)
3332 if (matched_type && gfc_match_char (')') != MATCH_YES)
3333 return MATCH_ERROR;
3335 return MATCH_YES;
3338 if (gfc_current_form == FORM_FREE)
3340 c = gfc_peek_ascii_char ();
3341 if (!gfc_is_whitespace (c) && c != '*' && c != '('
3342 && c != ':' && c != ',')
3344 if (matched_type && c == ')')
3346 gfc_next_ascii_char ();
3347 return MATCH_YES;
3349 return MATCH_NO;
3353 m = gfc_match_kind_spec (ts, false);
3354 if (m == MATCH_NO && ts->type != BT_CHARACTER)
3356 m = gfc_match_old_kind_spec (ts);
3357 if (gfc_validate_kind (ts->type, ts->kind, true) == -1)
3358 return MATCH_ERROR;
3361 if (matched_type && gfc_match_char (')') != MATCH_YES)
3362 return MATCH_ERROR;
3364 /* Defer association of the KIND expression of function results
3365 until after USE and IMPORT statements. */
3366 if ((gfc_current_state () == COMP_NONE && gfc_error_flag_test ())
3367 || gfc_matching_function)
3368 return MATCH_YES;
3370 if (m == MATCH_NO)
3371 m = MATCH_YES; /* No kind specifier found. */
3373 return m;
3377 /* Match an IMPLICIT NONE statement. Actually, this statement is
3378 already matched in parse.c, or we would not end up here in the
3379 first place. So the only thing we need to check, is if there is
3380 trailing garbage. If not, the match is successful. */
3382 match
3383 gfc_match_implicit_none (void)
3385 char c;
3386 match m;
3387 char name[GFC_MAX_SYMBOL_LEN + 1];
3388 bool type = false;
3389 bool external = false;
3390 locus cur_loc = gfc_current_locus;
3392 if (gfc_current_ns->seen_implicit_none
3393 || gfc_current_ns->has_implicit_none_export)
3395 gfc_error ("Duplicate IMPLICIT NONE statement at %C");
3396 return MATCH_ERROR;
3399 gfc_gobble_whitespace ();
3400 c = gfc_peek_ascii_char ();
3401 if (c == '(')
3403 (void) gfc_next_ascii_char ();
3404 if (!gfc_notify_std (GFC_STD_F2015, "IMPORT NONE with spec list at %C"))
3405 return MATCH_ERROR;
3407 gfc_gobble_whitespace ();
3408 if (gfc_peek_ascii_char () == ')')
3410 (void) gfc_next_ascii_char ();
3411 type = true;
3413 else
3414 for(;;)
3416 m = gfc_match (" %n", name);
3417 if (m != MATCH_YES)
3418 return MATCH_ERROR;
3420 if (strcmp (name, "type") == 0)
3421 type = true;
3422 else if (strcmp (name, "external") == 0)
3423 external = true;
3424 else
3425 return MATCH_ERROR;
3427 gfc_gobble_whitespace ();
3428 c = gfc_next_ascii_char ();
3429 if (c == ',')
3430 continue;
3431 if (c == ')')
3432 break;
3433 return MATCH_ERROR;
3436 else
3437 type = true;
3439 if (gfc_match_eos () != MATCH_YES)
3440 return MATCH_ERROR;
3442 gfc_set_implicit_none (type, external, &cur_loc);
3444 return MATCH_YES;
3448 /* Match the letter range(s) of an IMPLICIT statement. */
3450 static match
3451 match_implicit_range (void)
3453 char c, c1, c2;
3454 int inner;
3455 locus cur_loc;
3457 cur_loc = gfc_current_locus;
3459 gfc_gobble_whitespace ();
3460 c = gfc_next_ascii_char ();
3461 if (c != '(')
3463 gfc_error ("Missing character range in IMPLICIT at %C");
3464 goto bad;
3467 inner = 1;
3468 while (inner)
3470 gfc_gobble_whitespace ();
3471 c1 = gfc_next_ascii_char ();
3472 if (!ISALPHA (c1))
3473 goto bad;
3475 gfc_gobble_whitespace ();
3476 c = gfc_next_ascii_char ();
3478 switch (c)
3480 case ')':
3481 inner = 0; /* Fall through. */
3483 case ',':
3484 c2 = c1;
3485 break;
3487 case '-':
3488 gfc_gobble_whitespace ();
3489 c2 = gfc_next_ascii_char ();
3490 if (!ISALPHA (c2))
3491 goto bad;
3493 gfc_gobble_whitespace ();
3494 c = gfc_next_ascii_char ();
3496 if ((c != ',') && (c != ')'))
3497 goto bad;
3498 if (c == ')')
3499 inner = 0;
3501 break;
3503 default:
3504 goto bad;
3507 if (c1 > c2)
3509 gfc_error ("Letters must be in alphabetic order in "
3510 "IMPLICIT statement at %C");
3511 goto bad;
3514 /* See if we can add the newly matched range to the pending
3515 implicits from this IMPLICIT statement. We do not check for
3516 conflicts with whatever earlier IMPLICIT statements may have
3517 set. This is done when we've successfully finished matching
3518 the current one. */
3519 if (!gfc_add_new_implicit_range (c1, c2))
3520 goto bad;
3523 return MATCH_YES;
3525 bad:
3526 gfc_syntax_error (ST_IMPLICIT);
3528 gfc_current_locus = cur_loc;
3529 return MATCH_ERROR;
3533 /* Match an IMPLICIT statement, storing the types for
3534 gfc_set_implicit() if the statement is accepted by the parser.
3535 There is a strange looking, but legal syntactic construction
3536 possible. It looks like:
3538 IMPLICIT INTEGER (a-b) (c-d)
3540 This is legal if "a-b" is a constant expression that happens to
3541 equal one of the legal kinds for integers. The real problem
3542 happens with an implicit specification that looks like:
3544 IMPLICIT INTEGER (a-b)
3546 In this case, a typespec matcher that is "greedy" (as most of the
3547 matchers are) gobbles the character range as a kindspec, leaving
3548 nothing left. We therefore have to go a bit more slowly in the
3549 matching process by inhibiting the kindspec checking during
3550 typespec matching and checking for a kind later. */
3552 match
3553 gfc_match_implicit (void)
3555 gfc_typespec ts;
3556 locus cur_loc;
3557 char c;
3558 match m;
3560 if (gfc_current_ns->seen_implicit_none)
3562 gfc_error ("IMPLICIT statement at %C following an IMPLICIT NONE (type) "
3563 "statement");
3564 return MATCH_ERROR;
3567 gfc_clear_ts (&ts);
3569 /* We don't allow empty implicit statements. */
3570 if (gfc_match_eos () == MATCH_YES)
3572 gfc_error ("Empty IMPLICIT statement at %C");
3573 return MATCH_ERROR;
3578 /* First cleanup. */
3579 gfc_clear_new_implicit ();
3581 /* A basic type is mandatory here. */
3582 m = gfc_match_decl_type_spec (&ts, 1);
3583 if (m == MATCH_ERROR)
3584 goto error;
3585 if (m == MATCH_NO)
3586 goto syntax;
3588 cur_loc = gfc_current_locus;
3589 m = match_implicit_range ();
3591 if (m == MATCH_YES)
3593 /* We may have <TYPE> (<RANGE>). */
3594 gfc_gobble_whitespace ();
3595 c = gfc_peek_ascii_char ();
3596 if (c == ',' || c == '\n' || c == ';' || c == '!')
3598 /* Check for CHARACTER with no length parameter. */
3599 if (ts.type == BT_CHARACTER && !ts.u.cl)
3601 ts.kind = gfc_default_character_kind;
3602 ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
3603 ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind,
3604 NULL, 1);
3607 /* Record the Successful match. */
3608 if (!gfc_merge_new_implicit (&ts))
3609 return MATCH_ERROR;
3610 if (c == ',')
3611 c = gfc_next_ascii_char ();
3612 else if (gfc_match_eos () == MATCH_ERROR)
3613 goto error;
3614 continue;
3617 gfc_current_locus = cur_loc;
3620 /* Discard the (incorrectly) matched range. */
3621 gfc_clear_new_implicit ();
3623 /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
3624 if (ts.type == BT_CHARACTER)
3625 m = gfc_match_char_spec (&ts);
3626 else
3628 m = gfc_match_kind_spec (&ts, false);
3629 if (m == MATCH_NO)
3631 m = gfc_match_old_kind_spec (&ts);
3632 if (m == MATCH_ERROR)
3633 goto error;
3634 if (m == MATCH_NO)
3635 goto syntax;
3638 if (m == MATCH_ERROR)
3639 goto error;
3641 m = match_implicit_range ();
3642 if (m == MATCH_ERROR)
3643 goto error;
3644 if (m == MATCH_NO)
3645 goto syntax;
3647 gfc_gobble_whitespace ();
3648 c = gfc_next_ascii_char ();
3649 if (c != ',' && gfc_match_eos () != MATCH_YES)
3650 goto syntax;
3652 if (!gfc_merge_new_implicit (&ts))
3653 return MATCH_ERROR;
3655 while (c == ',');
3657 return MATCH_YES;
3659 syntax:
3660 gfc_syntax_error (ST_IMPLICIT);
3662 error:
3663 return MATCH_ERROR;
3667 match
3668 gfc_match_import (void)
3670 char name[GFC_MAX_SYMBOL_LEN + 1];
3671 match m;
3672 gfc_symbol *sym;
3673 gfc_symtree *st;
3675 if (gfc_current_ns->proc_name == NULL
3676 || gfc_current_ns->proc_name->attr.if_source != IFSRC_IFBODY)
3678 gfc_error ("IMPORT statement at %C only permitted in "
3679 "an INTERFACE body");
3680 return MATCH_ERROR;
3683 if (gfc_current_ns->proc_name->attr.module_procedure)
3685 gfc_error ("F2008: C1210 IMPORT statement at %C is not permitted "
3686 "in a module procedure interface body");
3687 return MATCH_ERROR;
3690 if (!gfc_notify_std (GFC_STD_F2003, "IMPORT statement at %C"))
3691 return MATCH_ERROR;
3693 if (gfc_match_eos () == MATCH_YES)
3695 /* All host variables should be imported. */
3696 gfc_current_ns->has_import_set = 1;
3697 return MATCH_YES;
3700 if (gfc_match (" ::") == MATCH_YES)
3702 if (gfc_match_eos () == MATCH_YES)
3704 gfc_error ("Expecting list of named entities at %C");
3705 return MATCH_ERROR;
3709 for(;;)
3711 sym = NULL;
3712 m = gfc_match (" %n", name);
3713 switch (m)
3715 case MATCH_YES:
3716 if (gfc_current_ns->parent != NULL
3717 && gfc_find_symbol (name, gfc_current_ns->parent, 1, &sym))
3719 gfc_error ("Type name %qs at %C is ambiguous", name);
3720 return MATCH_ERROR;
3722 else if (!sym && gfc_current_ns->proc_name->ns->parent != NULL
3723 && gfc_find_symbol (name,
3724 gfc_current_ns->proc_name->ns->parent,
3725 1, &sym))
3727 gfc_error ("Type name %qs at %C is ambiguous", name);
3728 return MATCH_ERROR;
3731 if (sym == NULL)
3733 gfc_error ("Cannot IMPORT %qs from host scoping unit "
3734 "at %C - does not exist.", name);
3735 return MATCH_ERROR;
3738 if (gfc_find_symtree (gfc_current_ns->sym_root, name))
3740 gfc_warning (0, "%qs is already IMPORTed from host scoping unit "
3741 "at %C", name);
3742 goto next_item;
3745 st = gfc_new_symtree (&gfc_current_ns->sym_root, name);
3746 st->n.sym = sym;
3747 sym->refs++;
3748 sym->attr.imported = 1;
3750 if (sym->attr.generic && (sym = gfc_find_dt_in_generic (sym)))
3752 /* The actual derived type is stored in a symtree with the first
3753 letter of the name capitalized; the symtree with the all
3754 lower-case name contains the associated generic function. */
3755 st = gfc_new_symtree (&gfc_current_ns->sym_root,
3756 gfc_dt_upper_string (name));
3757 st->n.sym = sym;
3758 sym->refs++;
3759 sym->attr.imported = 1;
3762 goto next_item;
3764 case MATCH_NO:
3765 break;
3767 case MATCH_ERROR:
3768 return MATCH_ERROR;
3771 next_item:
3772 if (gfc_match_eos () == MATCH_YES)
3773 break;
3774 if (gfc_match_char (',') != MATCH_YES)
3775 goto syntax;
3778 return MATCH_YES;
3780 syntax:
3781 gfc_error ("Syntax error in IMPORT statement at %C");
3782 return MATCH_ERROR;
3786 /* A minimal implementation of gfc_match without whitespace, escape
3787 characters or variable arguments. Returns true if the next
3788 characters match the TARGET template exactly. */
3790 static bool
3791 match_string_p (const char *target)
3793 const char *p;
3795 for (p = target; *p; p++)
3796 if ((char) gfc_next_ascii_char () != *p)
3797 return false;
3798 return true;
3801 /* Matches an attribute specification including array specs. If
3802 successful, leaves the variables current_attr and current_as
3803 holding the specification. Also sets the colon_seen variable for
3804 later use by matchers associated with initializations.
3806 This subroutine is a little tricky in the sense that we don't know
3807 if we really have an attr-spec until we hit the double colon.
3808 Until that time, we can only return MATCH_NO. This forces us to
3809 check for duplicate specification at this level. */
3811 static match
3812 match_attr_spec (void)
3814 /* Modifiers that can exist in a type statement. */
3815 enum
3816 { GFC_DECL_BEGIN = 0,
3817 DECL_ALLOCATABLE = GFC_DECL_BEGIN, DECL_DIMENSION, DECL_EXTERNAL,
3818 DECL_IN, DECL_OUT, DECL_INOUT, DECL_INTRINSIC, DECL_OPTIONAL,
3819 DECL_PARAMETER, DECL_POINTER, DECL_PROTECTED, DECL_PRIVATE,
3820 DECL_STATIC, DECL_AUTOMATIC,
3821 DECL_PUBLIC, DECL_SAVE, DECL_TARGET, DECL_VALUE, DECL_VOLATILE,
3822 DECL_IS_BIND_C, DECL_CODIMENSION, DECL_ASYNCHRONOUS, DECL_CONTIGUOUS,
3823 DECL_NONE, GFC_DECL_END /* Sentinel */
3826 /* GFC_DECL_END is the sentinel, index starts at 0. */
3827 #define NUM_DECL GFC_DECL_END
3829 locus start, seen_at[NUM_DECL];
3830 int seen[NUM_DECL];
3831 unsigned int d;
3832 const char *attr;
3833 match m;
3834 bool t;
3836 gfc_clear_attr (&current_attr);
3837 start = gfc_current_locus;
3839 current_as = NULL;
3840 colon_seen = 0;
3842 /* See if we get all of the keywords up to the final double colon. */
3843 for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
3844 seen[d] = 0;
3846 for (;;)
3848 char ch;
3850 d = DECL_NONE;
3851 gfc_gobble_whitespace ();
3853 ch = gfc_next_ascii_char ();
3854 if (ch == ':')
3856 /* This is the successful exit condition for the loop. */
3857 if (gfc_next_ascii_char () == ':')
3858 break;
3860 else if (ch == ',')
3862 gfc_gobble_whitespace ();
3863 switch (gfc_peek_ascii_char ())
3865 case 'a':
3866 gfc_next_ascii_char ();
3867 switch (gfc_next_ascii_char ())
3869 case 'l':
3870 if (match_string_p ("locatable"))
3872 /* Matched "allocatable". */
3873 d = DECL_ALLOCATABLE;
3875 break;
3877 case 's':
3878 if (match_string_p ("ynchronous"))
3880 /* Matched "asynchronous". */
3881 d = DECL_ASYNCHRONOUS;
3883 break;
3885 case 'u':
3886 if (match_string_p ("tomatic"))
3888 /* Matched "automatic". */
3889 d = DECL_AUTOMATIC;
3891 break;
3893 break;
3895 case 'b':
3896 /* Try and match the bind(c). */
3897 m = gfc_match_bind_c (NULL, true);
3898 if (m == MATCH_YES)
3899 d = DECL_IS_BIND_C;
3900 else if (m == MATCH_ERROR)
3901 goto cleanup;
3902 break;
3904 case 'c':
3905 gfc_next_ascii_char ();
3906 if ('o' != gfc_next_ascii_char ())
3907 break;
3908 switch (gfc_next_ascii_char ())
3910 case 'd':
3911 if (match_string_p ("imension"))
3913 d = DECL_CODIMENSION;
3914 break;
3916 /* FALLTHRU */
3917 case 'n':
3918 if (match_string_p ("tiguous"))
3920 d = DECL_CONTIGUOUS;
3921 break;
3924 break;
3926 case 'd':
3927 if (match_string_p ("dimension"))
3928 d = DECL_DIMENSION;
3929 break;
3931 case 'e':
3932 if (match_string_p ("external"))
3933 d = DECL_EXTERNAL;
3934 break;
3936 case 'i':
3937 if (match_string_p ("int"))
3939 ch = gfc_next_ascii_char ();
3940 if (ch == 'e')
3942 if (match_string_p ("nt"))
3944 /* Matched "intent". */
3945 /* TODO: Call match_intent_spec from here. */
3946 if (gfc_match (" ( in out )") == MATCH_YES)
3947 d = DECL_INOUT;
3948 else if (gfc_match (" ( in )") == MATCH_YES)
3949 d = DECL_IN;
3950 else if (gfc_match (" ( out )") == MATCH_YES)
3951 d = DECL_OUT;
3954 else if (ch == 'r')
3956 if (match_string_p ("insic"))
3958 /* Matched "intrinsic". */
3959 d = DECL_INTRINSIC;
3963 break;
3965 case 'o':
3966 if (match_string_p ("optional"))
3967 d = DECL_OPTIONAL;
3968 break;
3970 case 'p':
3971 gfc_next_ascii_char ();
3972 switch (gfc_next_ascii_char ())
3974 case 'a':
3975 if (match_string_p ("rameter"))
3977 /* Matched "parameter". */
3978 d = DECL_PARAMETER;
3980 break;
3982 case 'o':
3983 if (match_string_p ("inter"))
3985 /* Matched "pointer". */
3986 d = DECL_POINTER;
3988 break;
3990 case 'r':
3991 ch = gfc_next_ascii_char ();
3992 if (ch == 'i')
3994 if (match_string_p ("vate"))
3996 /* Matched "private". */
3997 d = DECL_PRIVATE;
4000 else if (ch == 'o')
4002 if (match_string_p ("tected"))
4004 /* Matched "protected". */
4005 d = DECL_PROTECTED;
4008 break;
4010 case 'u':
4011 if (match_string_p ("blic"))
4013 /* Matched "public". */
4014 d = DECL_PUBLIC;
4016 break;
4018 break;
4020 case 's':
4021 gfc_next_ascii_char ();
4022 switch (gfc_next_ascii_char ())
4024 case 'a':
4025 if (match_string_p ("ve"))
4027 /* Matched "save". */
4028 d = DECL_SAVE;
4030 break;
4032 case 't':
4033 if (match_string_p ("atic"))
4035 /* Matched "static". */
4036 d = DECL_STATIC;
4038 break;
4040 break;
4042 case 't':
4043 if (match_string_p ("target"))
4044 d = DECL_TARGET;
4045 break;
4047 case 'v':
4048 gfc_next_ascii_char ();
4049 ch = gfc_next_ascii_char ();
4050 if (ch == 'a')
4052 if (match_string_p ("lue"))
4054 /* Matched "value". */
4055 d = DECL_VALUE;
4058 else if (ch == 'o')
4060 if (match_string_p ("latile"))
4062 /* Matched "volatile". */
4063 d = DECL_VOLATILE;
4066 break;
4070 /* No double colon and no recognizable decl_type, so assume that
4071 we've been looking at something else the whole time. */
4072 if (d == DECL_NONE)
4074 m = MATCH_NO;
4075 goto cleanup;
4078 /* Check to make sure any parens are paired up correctly. */
4079 if (gfc_match_parens () == MATCH_ERROR)
4081 m = MATCH_ERROR;
4082 goto cleanup;
4085 seen[d]++;
4086 seen_at[d] = gfc_current_locus;
4088 if (d == DECL_DIMENSION || d == DECL_CODIMENSION)
4090 gfc_array_spec *as = NULL;
4092 m = gfc_match_array_spec (&as, d == DECL_DIMENSION,
4093 d == DECL_CODIMENSION);
4095 if (current_as == NULL)
4096 current_as = as;
4097 else if (m == MATCH_YES)
4099 if (!merge_array_spec (as, current_as, false))
4100 m = MATCH_ERROR;
4101 free (as);
4104 if (m == MATCH_NO)
4106 if (d == DECL_CODIMENSION)
4107 gfc_error ("Missing codimension specification at %C");
4108 else
4109 gfc_error ("Missing dimension specification at %C");
4110 m = MATCH_ERROR;
4113 if (m == MATCH_ERROR)
4114 goto cleanup;
4118 /* Since we've seen a double colon, we have to be looking at an
4119 attr-spec. This means that we can now issue errors. */
4120 for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
4121 if (seen[d] > 1)
4123 switch (d)
4125 case DECL_ALLOCATABLE:
4126 attr = "ALLOCATABLE";
4127 break;
4128 case DECL_ASYNCHRONOUS:
4129 attr = "ASYNCHRONOUS";
4130 break;
4131 case DECL_CODIMENSION:
4132 attr = "CODIMENSION";
4133 break;
4134 case DECL_CONTIGUOUS:
4135 attr = "CONTIGUOUS";
4136 break;
4137 case DECL_DIMENSION:
4138 attr = "DIMENSION";
4139 break;
4140 case DECL_EXTERNAL:
4141 attr = "EXTERNAL";
4142 break;
4143 case DECL_IN:
4144 attr = "INTENT (IN)";
4145 break;
4146 case DECL_OUT:
4147 attr = "INTENT (OUT)";
4148 break;
4149 case DECL_INOUT:
4150 attr = "INTENT (IN OUT)";
4151 break;
4152 case DECL_INTRINSIC:
4153 attr = "INTRINSIC";
4154 break;
4155 case DECL_OPTIONAL:
4156 attr = "OPTIONAL";
4157 break;
4158 case DECL_PARAMETER:
4159 attr = "PARAMETER";
4160 break;
4161 case DECL_POINTER:
4162 attr = "POINTER";
4163 break;
4164 case DECL_PROTECTED:
4165 attr = "PROTECTED";
4166 break;
4167 case DECL_PRIVATE:
4168 attr = "PRIVATE";
4169 break;
4170 case DECL_PUBLIC:
4171 attr = "PUBLIC";
4172 break;
4173 case DECL_SAVE:
4174 attr = "SAVE";
4175 break;
4176 case DECL_STATIC:
4177 attr = "STATIC";
4178 break;
4179 case DECL_AUTOMATIC:
4180 attr = "AUTOMATIC";
4181 break;
4182 case DECL_TARGET:
4183 attr = "TARGET";
4184 break;
4185 case DECL_IS_BIND_C:
4186 attr = "IS_BIND_C";
4187 break;
4188 case DECL_VALUE:
4189 attr = "VALUE";
4190 break;
4191 case DECL_VOLATILE:
4192 attr = "VOLATILE";
4193 break;
4194 default:
4195 attr = NULL; /* This shouldn't happen. */
4198 gfc_error ("Duplicate %s attribute at %L", attr, &seen_at[d]);
4199 m = MATCH_ERROR;
4200 goto cleanup;
4203 /* Now that we've dealt with duplicate attributes, add the attributes
4204 to the current attribute. */
4205 for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
4207 if (seen[d] == 0)
4208 continue;
4210 if ((d == DECL_STATIC || d == DECL_AUTOMATIC)
4211 && !flag_dec_static)
4213 gfc_error ("%s at %L is a DEC extension, enable with -fdec-static",
4214 d == DECL_STATIC ? "STATIC" : "AUTOMATIC", &seen_at[d]);
4215 m = MATCH_ERROR;
4216 goto cleanup;
4218 /* Allow SAVE with STATIC, but don't complain. */
4219 if (d == DECL_STATIC && seen[DECL_SAVE])
4220 continue;
4222 if (gfc_current_state () == COMP_DERIVED
4223 && d != DECL_DIMENSION && d != DECL_CODIMENSION
4224 && d != DECL_POINTER && d != DECL_PRIVATE
4225 && d != DECL_PUBLIC && d != DECL_CONTIGUOUS && d != DECL_NONE)
4227 if (d == DECL_ALLOCATABLE)
4229 if (!gfc_notify_std (GFC_STD_F2003, "ALLOCATABLE "
4230 "attribute at %C in a TYPE definition"))
4232 m = MATCH_ERROR;
4233 goto cleanup;
4236 else
4238 gfc_error ("Attribute at %L is not allowed in a TYPE definition",
4239 &seen_at[d]);
4240 m = MATCH_ERROR;
4241 goto cleanup;
4245 if ((d == DECL_PRIVATE || d == DECL_PUBLIC)
4246 && gfc_current_state () != COMP_MODULE)
4248 if (d == DECL_PRIVATE)
4249 attr = "PRIVATE";
4250 else
4251 attr = "PUBLIC";
4252 if (gfc_current_state () == COMP_DERIVED
4253 && gfc_state_stack->previous
4254 && gfc_state_stack->previous->state == COMP_MODULE)
4256 if (!gfc_notify_std (GFC_STD_F2003, "Attribute %s "
4257 "at %L in a TYPE definition", attr,
4258 &seen_at[d]))
4260 m = MATCH_ERROR;
4261 goto cleanup;
4264 else
4266 gfc_error ("%s attribute at %L is not allowed outside of the "
4267 "specification part of a module", attr, &seen_at[d]);
4268 m = MATCH_ERROR;
4269 goto cleanup;
4273 switch (d)
4275 case DECL_ALLOCATABLE:
4276 t = gfc_add_allocatable (&current_attr, &seen_at[d]);
4277 break;
4279 case DECL_ASYNCHRONOUS:
4280 if (!gfc_notify_std (GFC_STD_F2003, "ASYNCHRONOUS attribute at %C"))
4281 t = false;
4282 else
4283 t = gfc_add_asynchronous (&current_attr, NULL, &seen_at[d]);
4284 break;
4286 case DECL_CODIMENSION:
4287 t = gfc_add_codimension (&current_attr, NULL, &seen_at[d]);
4288 break;
4290 case DECL_CONTIGUOUS:
4291 if (!gfc_notify_std (GFC_STD_F2008, "CONTIGUOUS attribute at %C"))
4292 t = false;
4293 else
4294 t = gfc_add_contiguous (&current_attr, NULL, &seen_at[d]);
4295 break;
4297 case DECL_DIMENSION:
4298 t = gfc_add_dimension (&current_attr, NULL, &seen_at[d]);
4299 break;
4301 case DECL_EXTERNAL:
4302 t = gfc_add_external (&current_attr, &seen_at[d]);
4303 break;
4305 case DECL_IN:
4306 t = gfc_add_intent (&current_attr, INTENT_IN, &seen_at[d]);
4307 break;
4309 case DECL_OUT:
4310 t = gfc_add_intent (&current_attr, INTENT_OUT, &seen_at[d]);
4311 break;
4313 case DECL_INOUT:
4314 t = gfc_add_intent (&current_attr, INTENT_INOUT, &seen_at[d]);
4315 break;
4317 case DECL_INTRINSIC:
4318 t = gfc_add_intrinsic (&current_attr, &seen_at[d]);
4319 break;
4321 case DECL_OPTIONAL:
4322 t = gfc_add_optional (&current_attr, &seen_at[d]);
4323 break;
4325 case DECL_PARAMETER:
4326 t = gfc_add_flavor (&current_attr, FL_PARAMETER, NULL, &seen_at[d]);
4327 break;
4329 case DECL_POINTER:
4330 t = gfc_add_pointer (&current_attr, &seen_at[d]);
4331 break;
4333 case DECL_PROTECTED:
4334 if (gfc_current_state () != COMP_MODULE
4335 || (gfc_current_ns->proc_name
4336 && gfc_current_ns->proc_name->attr.flavor != FL_MODULE))
4338 gfc_error ("PROTECTED at %C only allowed in specification "
4339 "part of a module");
4340 t = false;
4341 break;
4344 if (!gfc_notify_std (GFC_STD_F2003, "PROTECTED attribute at %C"))
4345 t = false;
4346 else
4347 t = gfc_add_protected (&current_attr, NULL, &seen_at[d]);
4348 break;
4350 case DECL_PRIVATE:
4351 t = gfc_add_access (&current_attr, ACCESS_PRIVATE, NULL,
4352 &seen_at[d]);
4353 break;
4355 case DECL_PUBLIC:
4356 t = gfc_add_access (&current_attr, ACCESS_PUBLIC, NULL,
4357 &seen_at[d]);
4358 break;
4360 case DECL_STATIC:
4361 case DECL_SAVE:
4362 t = gfc_add_save (&current_attr, SAVE_EXPLICIT, NULL, &seen_at[d]);
4363 break;
4365 case DECL_AUTOMATIC:
4366 t = gfc_add_automatic (&current_attr, NULL, &seen_at[d]);
4367 break;
4369 case DECL_TARGET:
4370 t = gfc_add_target (&current_attr, &seen_at[d]);
4371 break;
4373 case DECL_IS_BIND_C:
4374 t = gfc_add_is_bind_c(&current_attr, NULL, &seen_at[d], 0);
4375 break;
4377 case DECL_VALUE:
4378 if (!gfc_notify_std (GFC_STD_F2003, "VALUE attribute at %C"))
4379 t = false;
4380 else
4381 t = gfc_add_value (&current_attr, NULL, &seen_at[d]);
4382 break;
4384 case DECL_VOLATILE:
4385 if (!gfc_notify_std (GFC_STD_F2003, "VOLATILE attribute at %C"))
4386 t = false;
4387 else
4388 t = gfc_add_volatile (&current_attr, NULL, &seen_at[d]);
4389 break;
4391 default:
4392 gfc_internal_error ("match_attr_spec(): Bad attribute");
4395 if (!t)
4397 m = MATCH_ERROR;
4398 goto cleanup;
4402 /* Since Fortran 2008 module variables implicitly have the SAVE attribute. */
4403 if ((gfc_current_state () == COMP_MODULE
4404 || gfc_current_state () == COMP_SUBMODULE)
4405 && !current_attr.save
4406 && (gfc_option.allow_std & GFC_STD_F2008) != 0)
4407 current_attr.save = SAVE_IMPLICIT;
4409 colon_seen = 1;
4410 return MATCH_YES;
4412 cleanup:
4413 gfc_current_locus = start;
4414 gfc_free_array_spec (current_as);
4415 current_as = NULL;
4416 return m;
4420 /* Set the binding label, dest_label, either with the binding label
4421 stored in the given gfc_typespec, ts, or if none was provided, it
4422 will be the symbol name in all lower case, as required by the draft
4423 (J3/04-007, section 15.4.1). If a binding label was given and
4424 there is more than one argument (num_idents), it is an error. */
4426 static bool
4427 set_binding_label (const char **dest_label, const char *sym_name,
4428 int num_idents)
4430 if (num_idents > 1 && has_name_equals)
4432 gfc_error ("Multiple identifiers provided with "
4433 "single NAME= specifier at %C");
4434 return false;
4437 if (curr_binding_label)
4438 /* Binding label given; store in temp holder till have sym. */
4439 *dest_label = curr_binding_label;
4440 else
4442 /* No binding label given, and the NAME= specifier did not exist,
4443 which means there was no NAME="". */
4444 if (sym_name != NULL && has_name_equals == 0)
4445 *dest_label = IDENTIFIER_POINTER (get_identifier (sym_name));
4448 return true;
4452 /* Set the status of the given common block as being BIND(C) or not,
4453 depending on the given parameter, is_bind_c. */
4455 void
4456 set_com_block_bind_c (gfc_common_head *com_block, int is_bind_c)
4458 com_block->is_bind_c = is_bind_c;
4459 return;
4463 /* Verify that the given gfc_typespec is for a C interoperable type. */
4465 bool
4466 gfc_verify_c_interop (gfc_typespec *ts)
4468 if (ts->type == BT_DERIVED && ts->u.derived != NULL)
4469 return (ts->u.derived->ts.is_c_interop || ts->u.derived->attr.is_bind_c)
4470 ? true : false;
4471 else if (ts->type == BT_CLASS)
4472 return false;
4473 else if (ts->is_c_interop != 1 && ts->type != BT_ASSUMED)
4474 return false;
4476 return true;
4480 /* Verify that the variables of a given common block, which has been
4481 defined with the attribute specifier bind(c), to be of a C
4482 interoperable type. Errors will be reported here, if
4483 encountered. */
4485 bool
4486 verify_com_block_vars_c_interop (gfc_common_head *com_block)
4488 gfc_symbol *curr_sym = NULL;
4489 bool retval = true;
4491 curr_sym = com_block->head;
4493 /* Make sure we have at least one symbol. */
4494 if (curr_sym == NULL)
4495 return retval;
4497 /* Here we know we have a symbol, so we'll execute this loop
4498 at least once. */
4501 /* The second to last param, 1, says this is in a common block. */
4502 retval = verify_bind_c_sym (curr_sym, &(curr_sym->ts), 1, com_block);
4503 curr_sym = curr_sym->common_next;
4504 } while (curr_sym != NULL);
4506 return retval;
4510 /* Verify that a given BIND(C) symbol is C interoperable. If it is not,
4511 an appropriate error message is reported. */
4513 bool
4514 verify_bind_c_sym (gfc_symbol *tmp_sym, gfc_typespec *ts,
4515 int is_in_common, gfc_common_head *com_block)
4517 bool bind_c_function = false;
4518 bool retval = true;
4520 if (tmp_sym->attr.function && tmp_sym->attr.is_bind_c)
4521 bind_c_function = true;
4523 if (tmp_sym->attr.function && tmp_sym->result != NULL)
4525 tmp_sym = tmp_sym->result;
4526 /* Make sure it wasn't an implicitly typed result. */
4527 if (tmp_sym->attr.implicit_type && warn_c_binding_type)
4529 gfc_warning (OPT_Wc_binding_type,
4530 "Implicitly declared BIND(C) function %qs at "
4531 "%L may not be C interoperable", tmp_sym->name,
4532 &tmp_sym->declared_at);
4533 tmp_sym->ts.f90_type = tmp_sym->ts.type;
4534 /* Mark it as C interoperable to prevent duplicate warnings. */
4535 tmp_sym->ts.is_c_interop = 1;
4536 tmp_sym->attr.is_c_interop = 1;
4540 /* Here, we know we have the bind(c) attribute, so if we have
4541 enough type info, then verify that it's a C interop kind.
4542 The info could be in the symbol already, or possibly still in
4543 the given ts (current_ts), so look in both. */
4544 if (tmp_sym->ts.type != BT_UNKNOWN || ts->type != BT_UNKNOWN)
4546 if (!gfc_verify_c_interop (&(tmp_sym->ts)))
4548 /* See if we're dealing with a sym in a common block or not. */
4549 if (is_in_common == 1 && warn_c_binding_type)
4551 gfc_warning (OPT_Wc_binding_type,
4552 "Variable %qs in common block %qs at %L "
4553 "may not be a C interoperable "
4554 "kind though common block %qs is BIND(C)",
4555 tmp_sym->name, com_block->name,
4556 &(tmp_sym->declared_at), com_block->name);
4558 else
4560 if (tmp_sym->ts.type == BT_DERIVED || ts->type == BT_DERIVED)
4561 gfc_error ("Type declaration %qs at %L is not C "
4562 "interoperable but it is BIND(C)",
4563 tmp_sym->name, &(tmp_sym->declared_at));
4564 else if (warn_c_binding_type)
4565 gfc_warning (OPT_Wc_binding_type, "Variable %qs at %L "
4566 "may not be a C interoperable "
4567 "kind but it is BIND(C)",
4568 tmp_sym->name, &(tmp_sym->declared_at));
4572 /* Variables declared w/in a common block can't be bind(c)
4573 since there's no way for C to see these variables, so there's
4574 semantically no reason for the attribute. */
4575 if (is_in_common == 1 && tmp_sym->attr.is_bind_c == 1)
4577 gfc_error ("Variable %qs in common block %qs at "
4578 "%L cannot be declared with BIND(C) "
4579 "since it is not a global",
4580 tmp_sym->name, com_block->name,
4581 &(tmp_sym->declared_at));
4582 retval = false;
4585 /* Scalar variables that are bind(c) can not have the pointer
4586 or allocatable attributes. */
4587 if (tmp_sym->attr.is_bind_c == 1)
4589 if (tmp_sym->attr.pointer == 1)
4591 gfc_error ("Variable %qs at %L cannot have both the "
4592 "POINTER and BIND(C) attributes",
4593 tmp_sym->name, &(tmp_sym->declared_at));
4594 retval = false;
4597 if (tmp_sym->attr.allocatable == 1)
4599 gfc_error ("Variable %qs at %L cannot have both the "
4600 "ALLOCATABLE and BIND(C) attributes",
4601 tmp_sym->name, &(tmp_sym->declared_at));
4602 retval = false;
4607 /* If it is a BIND(C) function, make sure the return value is a
4608 scalar value. The previous tests in this function made sure
4609 the type is interoperable. */
4610 if (bind_c_function && tmp_sym->as != NULL)
4611 gfc_error ("Return type of BIND(C) function %qs at %L cannot "
4612 "be an array", tmp_sym->name, &(tmp_sym->declared_at));
4614 /* BIND(C) functions can not return a character string. */
4615 if (bind_c_function && tmp_sym->ts.type == BT_CHARACTER)
4616 if (tmp_sym->ts.u.cl == NULL || tmp_sym->ts.u.cl->length == NULL
4617 || tmp_sym->ts.u.cl->length->expr_type != EXPR_CONSTANT
4618 || mpz_cmp_si (tmp_sym->ts.u.cl->length->value.integer, 1) != 0)
4619 gfc_error ("Return type of BIND(C) function %qs at %L cannot "
4620 "be a character string", tmp_sym->name,
4621 &(tmp_sym->declared_at));
4624 /* See if the symbol has been marked as private. If it has, make sure
4625 there is no binding label and warn the user if there is one. */
4626 if (tmp_sym->attr.access == ACCESS_PRIVATE
4627 && tmp_sym->binding_label)
4628 /* Use gfc_warning_now because we won't say that the symbol fails
4629 just because of this. */
4630 gfc_warning_now (0, "Symbol %qs at %L is marked PRIVATE but has been "
4631 "given the binding label %qs", tmp_sym->name,
4632 &(tmp_sym->declared_at), tmp_sym->binding_label);
4634 return retval;
4638 /* Set the appropriate fields for a symbol that's been declared as
4639 BIND(C) (the is_bind_c flag and the binding label), and verify that
4640 the type is C interoperable. Errors are reported by the functions
4641 used to set/test these fields. */
4643 bool
4644 set_verify_bind_c_sym (gfc_symbol *tmp_sym, int num_idents)
4646 bool retval = true;
4648 /* TODO: Do we need to make sure the vars aren't marked private? */
4650 /* Set the is_bind_c bit in symbol_attribute. */
4651 gfc_add_is_bind_c (&(tmp_sym->attr), tmp_sym->name, &gfc_current_locus, 0);
4653 if (!set_binding_label (&tmp_sym->binding_label, tmp_sym->name, num_idents))
4654 return false;
4656 return retval;
4660 /* Set the fields marking the given common block as BIND(C), including
4661 a binding label, and report any errors encountered. */
4663 bool
4664 set_verify_bind_c_com_block (gfc_common_head *com_block, int num_idents)
4666 bool retval = true;
4668 /* destLabel, common name, typespec (which may have binding label). */
4669 if (!set_binding_label (&com_block->binding_label, com_block->name,
4670 num_idents))
4671 return false;
4673 /* Set the given common block (com_block) to being bind(c) (1). */
4674 set_com_block_bind_c (com_block, 1);
4676 return retval;
4680 /* Retrieve the list of one or more identifiers that the given bind(c)
4681 attribute applies to. */
4683 bool
4684 get_bind_c_idents (void)
4686 char name[GFC_MAX_SYMBOL_LEN + 1];
4687 int num_idents = 0;
4688 gfc_symbol *tmp_sym = NULL;
4689 match found_id;
4690 gfc_common_head *com_block = NULL;
4692 if (gfc_match_name (name) == MATCH_YES)
4694 found_id = MATCH_YES;
4695 gfc_get_ha_symbol (name, &tmp_sym);
4697 else if (match_common_name (name) == MATCH_YES)
4699 found_id = MATCH_YES;
4700 com_block = gfc_get_common (name, 0);
4702 else
4704 gfc_error ("Need either entity or common block name for "
4705 "attribute specification statement at %C");
4706 return false;
4709 /* Save the current identifier and look for more. */
4712 /* Increment the number of identifiers found for this spec stmt. */
4713 num_idents++;
4715 /* Make sure we have a sym or com block, and verify that it can
4716 be bind(c). Set the appropriate field(s) and look for more
4717 identifiers. */
4718 if (tmp_sym != NULL || com_block != NULL)
4720 if (tmp_sym != NULL)
4722 if (!set_verify_bind_c_sym (tmp_sym, num_idents))
4723 return false;
4725 else
4727 if (!set_verify_bind_c_com_block (com_block, num_idents))
4728 return false;
4731 /* Look to see if we have another identifier. */
4732 tmp_sym = NULL;
4733 if (gfc_match_eos () == MATCH_YES)
4734 found_id = MATCH_NO;
4735 else if (gfc_match_char (',') != MATCH_YES)
4736 found_id = MATCH_NO;
4737 else if (gfc_match_name (name) == MATCH_YES)
4739 found_id = MATCH_YES;
4740 gfc_get_ha_symbol (name, &tmp_sym);
4742 else if (match_common_name (name) == MATCH_YES)
4744 found_id = MATCH_YES;
4745 com_block = gfc_get_common (name, 0);
4747 else
4749 gfc_error ("Missing entity or common block name for "
4750 "attribute specification statement at %C");
4751 return false;
4754 else
4756 gfc_internal_error ("Missing symbol");
4758 } while (found_id == MATCH_YES);
4760 /* if we get here we were successful */
4761 return true;
4765 /* Try and match a BIND(C) attribute specification statement. */
4767 match
4768 gfc_match_bind_c_stmt (void)
4770 match found_match = MATCH_NO;
4771 gfc_typespec *ts;
4773 ts = &current_ts;
4775 /* This may not be necessary. */
4776 gfc_clear_ts (ts);
4777 /* Clear the temporary binding label holder. */
4778 curr_binding_label = NULL;
4780 /* Look for the bind(c). */
4781 found_match = gfc_match_bind_c (NULL, true);
4783 if (found_match == MATCH_YES)
4785 if (!gfc_notify_std (GFC_STD_F2003, "BIND(C) statement at %C"))
4786 return MATCH_ERROR;
4788 /* Look for the :: now, but it is not required. */
4789 gfc_match (" :: ");
4791 /* Get the identifier(s) that needs to be updated. This may need to
4792 change to hand the flag(s) for the attr specified so all identifiers
4793 found can have all appropriate parts updated (assuming that the same
4794 spec stmt can have multiple attrs, such as both bind(c) and
4795 allocatable...). */
4796 if (!get_bind_c_idents ())
4797 /* Error message should have printed already. */
4798 return MATCH_ERROR;
4801 return found_match;
4805 /* Match a data declaration statement. */
4807 match
4808 gfc_match_data_decl (void)
4810 gfc_symbol *sym;
4811 match m;
4812 int elem;
4814 num_idents_on_line = 0;
4816 m = gfc_match_decl_type_spec (&current_ts, 0);
4817 if (m != MATCH_YES)
4818 return m;
4820 if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS)
4821 && !gfc_comp_struct (gfc_current_state ()))
4823 sym = gfc_use_derived (current_ts.u.derived);
4825 if (sym == NULL)
4827 m = MATCH_ERROR;
4828 goto cleanup;
4831 current_ts.u.derived = sym;
4834 m = match_attr_spec ();
4835 if (m == MATCH_ERROR)
4837 m = MATCH_NO;
4838 goto cleanup;
4841 if (current_ts.type == BT_CLASS
4842 && current_ts.u.derived->attr.unlimited_polymorphic)
4843 goto ok;
4845 if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS)
4846 && current_ts.u.derived->components == NULL
4847 && !current_ts.u.derived->attr.zero_comp)
4850 if (current_attr.pointer && gfc_comp_struct (gfc_current_state ()))
4851 goto ok;
4853 if (current_attr.allocatable && gfc_current_state () == COMP_DERIVED
4854 && current_ts.u.derived == gfc_current_block ())
4855 goto ok;
4857 gfc_find_symbol (current_ts.u.derived->name,
4858 current_ts.u.derived->ns, 1, &sym);
4860 /* Any symbol that we find had better be a type definition
4861 which has its components defined, or be a structure definition
4862 actively being parsed. */
4863 if (sym != NULL && gfc_fl_struct (sym->attr.flavor)
4864 && (current_ts.u.derived->components != NULL
4865 || current_ts.u.derived->attr.zero_comp
4866 || current_ts.u.derived == gfc_new_block))
4867 goto ok;
4869 gfc_error ("Derived type at %C has not been previously defined "
4870 "and so cannot appear in a derived type definition");
4871 m = MATCH_ERROR;
4872 goto cleanup;
4876 /* If we have an old-style character declaration, and no new-style
4877 attribute specifications, then there a comma is optional between
4878 the type specification and the variable list. */
4879 if (m == MATCH_NO && current_ts.type == BT_CHARACTER && old_char_selector)
4880 gfc_match_char (',');
4882 /* Give the types/attributes to symbols that follow. Give the element
4883 a number so that repeat character length expressions can be copied. */
4884 elem = 1;
4885 for (;;)
4887 num_idents_on_line++;
4888 m = variable_decl (elem++);
4889 if (m == MATCH_ERROR)
4890 goto cleanup;
4891 if (m == MATCH_NO)
4892 break;
4894 if (gfc_match_eos () == MATCH_YES)
4895 goto cleanup;
4896 if (gfc_match_char (',') != MATCH_YES)
4897 break;
4900 if (!gfc_error_flag_test ())
4902 /* An anonymous structure declaration is unambiguous; if we matched one
4903 according to gfc_match_structure_decl, we need to return MATCH_YES
4904 here to avoid confusing the remaining matchers, even if there was an
4905 error during variable_decl. We must flush any such errors. Note this
4906 causes the parser to gracefully continue parsing the remaining input
4907 as a structure body, which likely follows. */
4908 if (current_ts.type == BT_DERIVED && current_ts.u.derived
4909 && gfc_fl_struct (current_ts.u.derived->attr.flavor))
4911 gfc_error_now ("Syntax error in anonymous structure declaration"
4912 " at %C");
4913 /* Skip the bad variable_decl and line up for the start of the
4914 structure body. */
4915 gfc_error_recovery ();
4916 m = MATCH_YES;
4917 goto cleanup;
4920 gfc_error ("Syntax error in data declaration at %C");
4923 m = MATCH_ERROR;
4925 gfc_free_data_all (gfc_current_ns);
4927 cleanup:
4928 gfc_free_array_spec (current_as);
4929 current_as = NULL;
4930 return m;
4934 /* Match a prefix associated with a function or subroutine
4935 declaration. If the typespec pointer is nonnull, then a typespec
4936 can be matched. Note that if nothing matches, MATCH_YES is
4937 returned (the null string was matched). */
4939 match
4940 gfc_match_prefix (gfc_typespec *ts)
4942 bool seen_type;
4943 bool seen_impure;
4944 bool found_prefix;
4946 gfc_clear_attr (&current_attr);
4947 seen_type = false;
4948 seen_impure = false;
4950 gcc_assert (!gfc_matching_prefix);
4951 gfc_matching_prefix = true;
4955 found_prefix = false;
4957 /* MODULE is a prefix like PURE, ELEMENTAL, etc., having a
4958 corresponding attribute seems natural and distinguishes these
4959 procedures from procedure types of PROC_MODULE, which these are
4960 as well. */
4961 if (gfc_match ("module% ") == MATCH_YES)
4963 if (!gfc_notify_std (GFC_STD_F2008, "MODULE prefix at %C"))
4964 goto error;
4966 current_attr.module_procedure = 1;
4967 found_prefix = true;
4970 if (!seen_type && ts != NULL
4971 && gfc_match_decl_type_spec (ts, 0) == MATCH_YES
4972 && gfc_match_space () == MATCH_YES)
4975 seen_type = true;
4976 found_prefix = true;
4979 if (gfc_match ("elemental% ") == MATCH_YES)
4981 if (!gfc_add_elemental (&current_attr, NULL))
4982 goto error;
4984 found_prefix = true;
4987 if (gfc_match ("pure% ") == MATCH_YES)
4989 if (!gfc_add_pure (&current_attr, NULL))
4990 goto error;
4992 found_prefix = true;
4995 if (gfc_match ("recursive% ") == MATCH_YES)
4997 if (!gfc_add_recursive (&current_attr, NULL))
4998 goto error;
5000 found_prefix = true;
5003 /* IMPURE is a somewhat special case, as it needs not set an actual
5004 attribute but rather only prevents ELEMENTAL routines from being
5005 automatically PURE. */
5006 if (gfc_match ("impure% ") == MATCH_YES)
5008 if (!gfc_notify_std (GFC_STD_F2008, "IMPURE procedure at %C"))
5009 goto error;
5011 seen_impure = true;
5012 found_prefix = true;
5015 while (found_prefix);
5017 /* IMPURE and PURE must not both appear, of course. */
5018 if (seen_impure && current_attr.pure)
5020 gfc_error ("PURE and IMPURE must not appear both at %C");
5021 goto error;
5024 /* If IMPURE it not seen but the procedure is ELEMENTAL, mark it as PURE. */
5025 if (!seen_impure && current_attr.elemental && !current_attr.pure)
5027 if (!gfc_add_pure (&current_attr, NULL))
5028 goto error;
5031 /* At this point, the next item is not a prefix. */
5032 gcc_assert (gfc_matching_prefix);
5034 gfc_matching_prefix = false;
5035 return MATCH_YES;
5037 error:
5038 gcc_assert (gfc_matching_prefix);
5039 gfc_matching_prefix = false;
5040 return MATCH_ERROR;
5044 /* Copy attributes matched by gfc_match_prefix() to attributes on a symbol. */
5046 static bool
5047 copy_prefix (symbol_attribute *dest, locus *where)
5049 if (dest->module_procedure)
5051 if (current_attr.elemental)
5052 dest->elemental = 1;
5054 if (current_attr.pure)
5055 dest->pure = 1;
5057 if (current_attr.recursive)
5058 dest->recursive = 1;
5060 /* Module procedures are unusual in that the 'dest' is copied from
5061 the interface declaration. However, this is an oportunity to
5062 check that the submodule declaration is compliant with the
5063 interface. */
5064 if (dest->elemental && !current_attr.elemental)
5066 gfc_error ("ELEMENTAL prefix in MODULE PROCEDURE interface is "
5067 "missing at %L", where);
5068 return false;
5071 if (dest->pure && !current_attr.pure)
5073 gfc_error ("PURE prefix in MODULE PROCEDURE interface is "
5074 "missing at %L", where);
5075 return false;
5078 if (dest->recursive && !current_attr.recursive)
5080 gfc_error ("RECURSIVE prefix in MODULE PROCEDURE interface is "
5081 "missing at %L", where);
5082 return false;
5085 return true;
5088 if (current_attr.elemental && !gfc_add_elemental (dest, where))
5089 return false;
5091 if (current_attr.pure && !gfc_add_pure (dest, where))
5092 return false;
5094 if (current_attr.recursive && !gfc_add_recursive (dest, where))
5095 return false;
5097 return true;
5101 /* Match a formal argument list. */
5103 match
5104 gfc_match_formal_arglist (gfc_symbol *progname, int st_flag, int null_flag)
5106 gfc_formal_arglist *head, *tail, *p, *q;
5107 char name[GFC_MAX_SYMBOL_LEN + 1];
5108 gfc_symbol *sym;
5109 match m;
5110 gfc_formal_arglist *formal = NULL;
5112 head = tail = NULL;
5114 /* Keep the interface formal argument list and null it so that the
5115 matching for the new declaration can be done. The numbers and
5116 names of the arguments are checked here. The interface formal
5117 arguments are retained in formal_arglist and the characteristics
5118 are compared in resolve.c(resolve_fl_procedure). See the remark
5119 in get_proc_name about the eventual need to copy the formal_arglist
5120 and populate the formal namespace of the interface symbol. */
5121 if (progname->attr.module_procedure
5122 && progname->attr.host_assoc)
5124 formal = progname->formal;
5125 progname->formal = NULL;
5128 if (gfc_match_char ('(') != MATCH_YES)
5130 if (null_flag)
5131 goto ok;
5132 return MATCH_NO;
5135 if (gfc_match_char (')') == MATCH_YES)
5136 goto ok;
5138 for (;;)
5140 if (gfc_match_char ('*') == MATCH_YES)
5142 sym = NULL;
5143 if (!gfc_notify_std (GFC_STD_F95_OBS, "Alternate-return argument "
5144 "at %C"))
5146 m = MATCH_ERROR;
5147 goto cleanup;
5150 else
5152 m = gfc_match_name (name);
5153 if (m != MATCH_YES)
5154 goto cleanup;
5156 if (gfc_get_symbol (name, NULL, &sym))
5157 goto cleanup;
5160 p = gfc_get_formal_arglist ();
5162 if (head == NULL)
5163 head = tail = p;
5164 else
5166 tail->next = p;
5167 tail = p;
5170 tail->sym = sym;
5172 /* We don't add the VARIABLE flavor because the name could be a
5173 dummy procedure. We don't apply these attributes to formal
5174 arguments of statement functions. */
5175 if (sym != NULL && !st_flag
5176 && (!gfc_add_dummy(&sym->attr, sym->name, NULL)
5177 || !gfc_missing_attr (&sym->attr, NULL)))
5179 m = MATCH_ERROR;
5180 goto cleanup;
5183 /* The name of a program unit can be in a different namespace,
5184 so check for it explicitly. After the statement is accepted,
5185 the name is checked for especially in gfc_get_symbol(). */
5186 if (gfc_new_block != NULL && sym != NULL
5187 && strcmp (sym->name, gfc_new_block->name) == 0)
5189 gfc_error ("Name %qs at %C is the name of the procedure",
5190 sym->name);
5191 m = MATCH_ERROR;
5192 goto cleanup;
5195 if (gfc_match_char (')') == MATCH_YES)
5196 goto ok;
5198 m = gfc_match_char (',');
5199 if (m != MATCH_YES)
5201 gfc_error ("Unexpected junk in formal argument list at %C");
5202 goto cleanup;
5207 /* Check for duplicate symbols in the formal argument list. */
5208 if (head != NULL)
5210 for (p = head; p->next; p = p->next)
5212 if (p->sym == NULL)
5213 continue;
5215 for (q = p->next; q; q = q->next)
5216 if (p->sym == q->sym)
5218 gfc_error ("Duplicate symbol %qs in formal argument list "
5219 "at %C", p->sym->name);
5221 m = MATCH_ERROR;
5222 goto cleanup;
5227 if (!gfc_add_explicit_interface (progname, IFSRC_DECL, head, NULL))
5229 m = MATCH_ERROR;
5230 goto cleanup;
5233 /* gfc_error_now used in following and return with MATCH_YES because
5234 doing otherwise results in a cascade of extraneous errors and in
5235 some cases an ICE in symbol.c(gfc_release_symbol). */
5236 if (progname->attr.module_procedure && progname->attr.host_assoc)
5238 bool arg_count_mismatch = false;
5240 if (!formal && head)
5241 arg_count_mismatch = true;
5243 /* Abbreviated module procedure declaration is not meant to have any
5244 formal arguments! */
5245 if (!progname->abr_modproc_decl && formal && !head)
5246 arg_count_mismatch = true;
5248 for (p = formal, q = head; p && q; p = p->next, q = q->next)
5250 if ((p->next != NULL && q->next == NULL)
5251 || (p->next == NULL && q->next != NULL))
5252 arg_count_mismatch = true;
5253 else if ((p->sym == NULL && q->sym == NULL)
5254 || strcmp (p->sym->name, q->sym->name) == 0)
5255 continue;
5256 else
5257 gfc_error_now ("Mismatch in MODULE PROCEDURE formal "
5258 "argument names (%s/%s) at %C",
5259 p->sym->name, q->sym->name);
5262 if (arg_count_mismatch)
5263 gfc_error_now ("Mismatch in number of MODULE PROCEDURE "
5264 "formal arguments at %C");
5267 return MATCH_YES;
5269 cleanup:
5270 gfc_free_formal_arglist (head);
5271 return m;
5275 /* Match a RESULT specification following a function declaration or
5276 ENTRY statement. Also matches the end-of-statement. */
5278 static match
5279 match_result (gfc_symbol *function, gfc_symbol **result)
5281 char name[GFC_MAX_SYMBOL_LEN + 1];
5282 gfc_symbol *r;
5283 match m;
5285 if (gfc_match (" result (") != MATCH_YES)
5286 return MATCH_NO;
5288 m = gfc_match_name (name);
5289 if (m != MATCH_YES)
5290 return m;
5292 /* Get the right paren, and that's it because there could be the
5293 bind(c) attribute after the result clause. */
5294 if (gfc_match_char (')') != MATCH_YES)
5296 /* TODO: should report the missing right paren here. */
5297 return MATCH_ERROR;
5300 if (strcmp (function->name, name) == 0)
5302 gfc_error ("RESULT variable at %C must be different than function name");
5303 return MATCH_ERROR;
5306 if (gfc_get_symbol (name, NULL, &r))
5307 return MATCH_ERROR;
5309 if (!gfc_add_result (&r->attr, r->name, NULL))
5310 return MATCH_ERROR;
5312 *result = r;
5314 return MATCH_YES;
5318 /* Match a function suffix, which could be a combination of a result
5319 clause and BIND(C), either one, or neither. The draft does not
5320 require them to come in a specific order. */
5322 match
5323 gfc_match_suffix (gfc_symbol *sym, gfc_symbol **result)
5325 match is_bind_c; /* Found bind(c). */
5326 match is_result; /* Found result clause. */
5327 match found_match; /* Status of whether we've found a good match. */
5328 char peek_char; /* Character we're going to peek at. */
5329 bool allow_binding_name;
5331 /* Initialize to having found nothing. */
5332 found_match = MATCH_NO;
5333 is_bind_c = MATCH_NO;
5334 is_result = MATCH_NO;
5336 /* Get the next char to narrow between result and bind(c). */
5337 gfc_gobble_whitespace ();
5338 peek_char = gfc_peek_ascii_char ();
5340 /* C binding names are not allowed for internal procedures. */
5341 if (gfc_current_state () == COMP_CONTAINS
5342 && sym->ns->proc_name->attr.flavor != FL_MODULE)
5343 allow_binding_name = false;
5344 else
5345 allow_binding_name = true;
5347 switch (peek_char)
5349 case 'r':
5350 /* Look for result clause. */
5351 is_result = match_result (sym, result);
5352 if (is_result == MATCH_YES)
5354 /* Now see if there is a bind(c) after it. */
5355 is_bind_c = gfc_match_bind_c (sym, allow_binding_name);
5356 /* We've found the result clause and possibly bind(c). */
5357 found_match = MATCH_YES;
5359 else
5360 /* This should only be MATCH_ERROR. */
5361 found_match = is_result;
5362 break;
5363 case 'b':
5364 /* Look for bind(c) first. */
5365 is_bind_c = gfc_match_bind_c (sym, allow_binding_name);
5366 if (is_bind_c == MATCH_YES)
5368 /* Now see if a result clause followed it. */
5369 is_result = match_result (sym, result);
5370 found_match = MATCH_YES;
5372 else
5374 /* Should only be a MATCH_ERROR if we get here after seeing 'b'. */
5375 found_match = MATCH_ERROR;
5377 break;
5378 default:
5379 gfc_error ("Unexpected junk after function declaration at %C");
5380 found_match = MATCH_ERROR;
5381 break;
5384 if (is_bind_c == MATCH_YES)
5386 /* Fortran 2008 draft allows BIND(C) for internal procedures. */
5387 if (gfc_current_state () == COMP_CONTAINS
5388 && sym->ns->proc_name->attr.flavor != FL_MODULE
5389 && !gfc_notify_std (GFC_STD_F2008, "BIND(C) attribute "
5390 "at %L may not be specified for an internal "
5391 "procedure", &gfc_current_locus))
5392 return MATCH_ERROR;
5394 if (!gfc_add_is_bind_c (&(sym->attr), sym->name, &gfc_current_locus, 1))
5395 return MATCH_ERROR;
5398 return found_match;
5402 /* Procedure pointer return value without RESULT statement:
5403 Add "hidden" result variable named "ppr@". */
5405 static bool
5406 add_hidden_procptr_result (gfc_symbol *sym)
5408 bool case1,case2;
5410 if (gfc_notification_std (GFC_STD_F2003) == ERROR)
5411 return false;
5413 /* First usage case: PROCEDURE and EXTERNAL statements. */
5414 case1 = gfc_current_state () == COMP_FUNCTION && gfc_current_block ()
5415 && strcmp (gfc_current_block ()->name, sym->name) == 0
5416 && sym->attr.external;
5417 /* Second usage case: INTERFACE statements. */
5418 case2 = gfc_current_state () == COMP_INTERFACE && gfc_state_stack->previous
5419 && gfc_state_stack->previous->state == COMP_FUNCTION
5420 && strcmp (gfc_state_stack->previous->sym->name, sym->name) == 0;
5422 if (case1 || case2)
5424 gfc_symtree *stree;
5425 if (case1)
5426 gfc_get_sym_tree ("ppr@", gfc_current_ns, &stree, false);
5427 else if (case2)
5429 gfc_symtree *st2;
5430 gfc_get_sym_tree ("ppr@", gfc_current_ns->parent, &stree, false);
5431 st2 = gfc_new_symtree (&gfc_current_ns->sym_root, "ppr@");
5432 st2->n.sym = stree->n.sym;
5434 sym->result = stree->n.sym;
5436 sym->result->attr.proc_pointer = sym->attr.proc_pointer;
5437 sym->result->attr.pointer = sym->attr.pointer;
5438 sym->result->attr.external = sym->attr.external;
5439 sym->result->attr.referenced = sym->attr.referenced;
5440 sym->result->ts = sym->ts;
5441 sym->attr.proc_pointer = 0;
5442 sym->attr.pointer = 0;
5443 sym->attr.external = 0;
5444 if (sym->result->attr.external && sym->result->attr.pointer)
5446 sym->result->attr.pointer = 0;
5447 sym->result->attr.proc_pointer = 1;
5450 return gfc_add_result (&sym->result->attr, sym->result->name, NULL);
5452 /* POINTER after PROCEDURE/EXTERNAL/INTERFACE statement. */
5453 else if (sym->attr.function && !sym->attr.external && sym->attr.pointer
5454 && sym->result && sym->result != sym && sym->result->attr.external
5455 && sym == gfc_current_ns->proc_name
5456 && sym == sym->result->ns->proc_name
5457 && strcmp ("ppr@", sym->result->name) == 0)
5459 sym->result->attr.proc_pointer = 1;
5460 sym->attr.pointer = 0;
5461 return true;
5463 else
5464 return false;
5468 /* Match the interface for a PROCEDURE declaration,
5469 including brackets (R1212). */
5471 static match
5472 match_procedure_interface (gfc_symbol **proc_if)
5474 match m;
5475 gfc_symtree *st;
5476 locus old_loc, entry_loc;
5477 gfc_namespace *old_ns = gfc_current_ns;
5478 char name[GFC_MAX_SYMBOL_LEN + 1];
5480 old_loc = entry_loc = gfc_current_locus;
5481 gfc_clear_ts (&current_ts);
5483 if (gfc_match (" (") != MATCH_YES)
5485 gfc_current_locus = entry_loc;
5486 return MATCH_NO;
5489 /* Get the type spec. for the procedure interface. */
5490 old_loc = gfc_current_locus;
5491 m = gfc_match_decl_type_spec (&current_ts, 0);
5492 gfc_gobble_whitespace ();
5493 if (m == MATCH_YES || (m == MATCH_NO && gfc_peek_ascii_char () == ')'))
5494 goto got_ts;
5496 if (m == MATCH_ERROR)
5497 return m;
5499 /* Procedure interface is itself a procedure. */
5500 gfc_current_locus = old_loc;
5501 m = gfc_match_name (name);
5503 /* First look to see if it is already accessible in the current
5504 namespace because it is use associated or contained. */
5505 st = NULL;
5506 if (gfc_find_sym_tree (name, NULL, 0, &st))
5507 return MATCH_ERROR;
5509 /* If it is still not found, then try the parent namespace, if it
5510 exists and create the symbol there if it is still not found. */
5511 if (gfc_current_ns->parent)
5512 gfc_current_ns = gfc_current_ns->parent;
5513 if (st == NULL && gfc_get_ha_sym_tree (name, &st))
5514 return MATCH_ERROR;
5516 gfc_current_ns = old_ns;
5517 *proc_if = st->n.sym;
5519 if (*proc_if)
5521 (*proc_if)->refs++;
5522 /* Resolve interface if possible. That way, attr.procedure is only set
5523 if it is declared by a later procedure-declaration-stmt, which is
5524 invalid per F08:C1216 (cf. resolve_procedure_interface). */
5525 while ((*proc_if)->ts.interface
5526 && *proc_if != (*proc_if)->ts.interface)
5527 *proc_if = (*proc_if)->ts.interface;
5529 if ((*proc_if)->attr.flavor == FL_UNKNOWN
5530 && (*proc_if)->ts.type == BT_UNKNOWN
5531 && !gfc_add_flavor (&(*proc_if)->attr, FL_PROCEDURE,
5532 (*proc_if)->name, NULL))
5533 return MATCH_ERROR;
5536 got_ts:
5537 if (gfc_match (" )") != MATCH_YES)
5539 gfc_current_locus = entry_loc;
5540 return MATCH_NO;
5543 return MATCH_YES;
5547 /* Match a PROCEDURE declaration (R1211). */
5549 static match
5550 match_procedure_decl (void)
5552 match m;
5553 gfc_symbol *sym, *proc_if = NULL;
5554 int num;
5555 gfc_expr *initializer = NULL;
5557 /* Parse interface (with brackets). */
5558 m = match_procedure_interface (&proc_if);
5559 if (m != MATCH_YES)
5560 return m;
5562 /* Parse attributes (with colons). */
5563 m = match_attr_spec();
5564 if (m == MATCH_ERROR)
5565 return MATCH_ERROR;
5567 if (proc_if && proc_if->attr.is_bind_c && !current_attr.is_bind_c)
5569 current_attr.is_bind_c = 1;
5570 has_name_equals = 0;
5571 curr_binding_label = NULL;
5574 /* Get procedure symbols. */
5575 for(num=1;;num++)
5577 m = gfc_match_symbol (&sym, 0);
5578 if (m == MATCH_NO)
5579 goto syntax;
5580 else if (m == MATCH_ERROR)
5581 return m;
5583 /* Add current_attr to the symbol attributes. */
5584 if (!gfc_copy_attr (&sym->attr, &current_attr, NULL))
5585 return MATCH_ERROR;
5587 if (sym->attr.is_bind_c)
5589 /* Check for C1218. */
5590 if (!proc_if || !proc_if->attr.is_bind_c)
5592 gfc_error ("BIND(C) attribute at %C requires "
5593 "an interface with BIND(C)");
5594 return MATCH_ERROR;
5596 /* Check for C1217. */
5597 if (has_name_equals && sym->attr.pointer)
5599 gfc_error ("BIND(C) procedure with NAME may not have "
5600 "POINTER attribute at %C");
5601 return MATCH_ERROR;
5603 if (has_name_equals && sym->attr.dummy)
5605 gfc_error ("Dummy procedure at %C may not have "
5606 "BIND(C) attribute with NAME");
5607 return MATCH_ERROR;
5609 /* Set binding label for BIND(C). */
5610 if (!set_binding_label (&sym->binding_label, sym->name, num))
5611 return MATCH_ERROR;
5614 if (!gfc_add_external (&sym->attr, NULL))
5615 return MATCH_ERROR;
5617 if (add_hidden_procptr_result (sym))
5618 sym = sym->result;
5620 if (!gfc_add_proc (&sym->attr, sym->name, NULL))
5621 return MATCH_ERROR;
5623 /* Set interface. */
5624 if (proc_if != NULL)
5626 if (sym->ts.type != BT_UNKNOWN)
5628 gfc_error ("Procedure %qs at %L already has basic type of %s",
5629 sym->name, &gfc_current_locus,
5630 gfc_basic_typename (sym->ts.type));
5631 return MATCH_ERROR;
5633 sym->ts.interface = proc_if;
5634 sym->attr.untyped = 1;
5635 sym->attr.if_source = IFSRC_IFBODY;
5637 else if (current_ts.type != BT_UNKNOWN)
5639 if (!gfc_add_type (sym, &current_ts, &gfc_current_locus))
5640 return MATCH_ERROR;
5641 sym->ts.interface = gfc_new_symbol ("", gfc_current_ns);
5642 sym->ts.interface->ts = current_ts;
5643 sym->ts.interface->attr.flavor = FL_PROCEDURE;
5644 sym->ts.interface->attr.function = 1;
5645 sym->attr.function = 1;
5646 sym->attr.if_source = IFSRC_UNKNOWN;
5649 if (gfc_match (" =>") == MATCH_YES)
5651 if (!current_attr.pointer)
5653 gfc_error ("Initialization at %C isn't for a pointer variable");
5654 m = MATCH_ERROR;
5655 goto cleanup;
5658 m = match_pointer_init (&initializer, 1);
5659 if (m != MATCH_YES)
5660 goto cleanup;
5662 if (!add_init_expr_to_sym (sym->name, &initializer, &gfc_current_locus))
5663 goto cleanup;
5667 if (gfc_match_eos () == MATCH_YES)
5668 return MATCH_YES;
5669 if (gfc_match_char (',') != MATCH_YES)
5670 goto syntax;
5673 syntax:
5674 gfc_error ("Syntax error in PROCEDURE statement at %C");
5675 return MATCH_ERROR;
5677 cleanup:
5678 /* Free stuff up and return. */
5679 gfc_free_expr (initializer);
5680 return m;
5684 static match
5685 match_binding_attributes (gfc_typebound_proc* ba, bool generic, bool ppc);
5688 /* Match a procedure pointer component declaration (R445). */
5690 static match
5691 match_ppc_decl (void)
5693 match m;
5694 gfc_symbol *proc_if = NULL;
5695 gfc_typespec ts;
5696 int num;
5697 gfc_component *c;
5698 gfc_expr *initializer = NULL;
5699 gfc_typebound_proc* tb;
5700 char name[GFC_MAX_SYMBOL_LEN + 1];
5702 /* Parse interface (with brackets). */
5703 m = match_procedure_interface (&proc_if);
5704 if (m != MATCH_YES)
5705 goto syntax;
5707 /* Parse attributes. */
5708 tb = XCNEW (gfc_typebound_proc);
5709 tb->where = gfc_current_locus;
5710 m = match_binding_attributes (tb, false, true);
5711 if (m == MATCH_ERROR)
5712 return m;
5714 gfc_clear_attr (&current_attr);
5715 current_attr.procedure = 1;
5716 current_attr.proc_pointer = 1;
5717 current_attr.access = tb->access;
5718 current_attr.flavor = FL_PROCEDURE;
5720 /* Match the colons (required). */
5721 if (gfc_match (" ::") != MATCH_YES)
5723 gfc_error ("Expected %<::%> after binding-attributes at %C");
5724 return MATCH_ERROR;
5727 /* Check for C450. */
5728 if (!tb->nopass && proc_if == NULL)
5730 gfc_error("NOPASS or explicit interface required at %C");
5731 return MATCH_ERROR;
5734 if (!gfc_notify_std (GFC_STD_F2003, "Procedure pointer component at %C"))
5735 return MATCH_ERROR;
5737 /* Match PPC names. */
5738 ts = current_ts;
5739 for(num=1;;num++)
5741 m = gfc_match_name (name);
5742 if (m == MATCH_NO)
5743 goto syntax;
5744 else if (m == MATCH_ERROR)
5745 return m;
5747 if (!gfc_add_component (gfc_current_block(), name, &c))
5748 return MATCH_ERROR;
5750 /* Add current_attr to the symbol attributes. */
5751 if (!gfc_copy_attr (&c->attr, &current_attr, NULL))
5752 return MATCH_ERROR;
5754 if (!gfc_add_external (&c->attr, NULL))
5755 return MATCH_ERROR;
5757 if (!gfc_add_proc (&c->attr, name, NULL))
5758 return MATCH_ERROR;
5760 if (num == 1)
5761 c->tb = tb;
5762 else
5764 c->tb = XCNEW (gfc_typebound_proc);
5765 c->tb->where = gfc_current_locus;
5766 *c->tb = *tb;
5769 /* Set interface. */
5770 if (proc_if != NULL)
5772 c->ts.interface = proc_if;
5773 c->attr.untyped = 1;
5774 c->attr.if_source = IFSRC_IFBODY;
5776 else if (ts.type != BT_UNKNOWN)
5778 c->ts = ts;
5779 c->ts.interface = gfc_new_symbol ("", gfc_current_ns);
5780 c->ts.interface->result = c->ts.interface;
5781 c->ts.interface->ts = ts;
5782 c->ts.interface->attr.flavor = FL_PROCEDURE;
5783 c->ts.interface->attr.function = 1;
5784 c->attr.function = 1;
5785 c->attr.if_source = IFSRC_UNKNOWN;
5788 if (gfc_match (" =>") == MATCH_YES)
5790 m = match_pointer_init (&initializer, 1);
5791 if (m != MATCH_YES)
5793 gfc_free_expr (initializer);
5794 return m;
5796 c->initializer = initializer;
5799 if (gfc_match_eos () == MATCH_YES)
5800 return MATCH_YES;
5801 if (gfc_match_char (',') != MATCH_YES)
5802 goto syntax;
5805 syntax:
5806 gfc_error ("Syntax error in procedure pointer component at %C");
5807 return MATCH_ERROR;
5811 /* Match a PROCEDURE declaration inside an interface (R1206). */
5813 static match
5814 match_procedure_in_interface (void)
5816 match m;
5817 gfc_symbol *sym;
5818 char name[GFC_MAX_SYMBOL_LEN + 1];
5819 locus old_locus;
5821 if (current_interface.type == INTERFACE_NAMELESS
5822 || current_interface.type == INTERFACE_ABSTRACT)
5824 gfc_error ("PROCEDURE at %C must be in a generic interface");
5825 return MATCH_ERROR;
5828 /* Check if the F2008 optional double colon appears. */
5829 gfc_gobble_whitespace ();
5830 old_locus = gfc_current_locus;
5831 if (gfc_match ("::") == MATCH_YES)
5833 if (!gfc_notify_std (GFC_STD_F2008, "double colon in "
5834 "MODULE PROCEDURE statement at %L", &old_locus))
5835 return MATCH_ERROR;
5837 else
5838 gfc_current_locus = old_locus;
5840 for(;;)
5842 m = gfc_match_name (name);
5843 if (m == MATCH_NO)
5844 goto syntax;
5845 else if (m == MATCH_ERROR)
5846 return m;
5847 if (gfc_get_symbol (name, gfc_current_ns->parent, &sym))
5848 return MATCH_ERROR;
5850 if (!gfc_add_interface (sym))
5851 return MATCH_ERROR;
5853 if (gfc_match_eos () == MATCH_YES)
5854 break;
5855 if (gfc_match_char (',') != MATCH_YES)
5856 goto syntax;
5859 return MATCH_YES;
5861 syntax:
5862 gfc_error ("Syntax error in PROCEDURE statement at %C");
5863 return MATCH_ERROR;
5867 /* General matcher for PROCEDURE declarations. */
5869 static match match_procedure_in_type (void);
5871 match
5872 gfc_match_procedure (void)
5874 match m;
5876 switch (gfc_current_state ())
5878 case COMP_NONE:
5879 case COMP_PROGRAM:
5880 case COMP_MODULE:
5881 case COMP_SUBMODULE:
5882 case COMP_SUBROUTINE:
5883 case COMP_FUNCTION:
5884 case COMP_BLOCK:
5885 m = match_procedure_decl ();
5886 break;
5887 case COMP_INTERFACE:
5888 m = match_procedure_in_interface ();
5889 break;
5890 case COMP_DERIVED:
5891 m = match_ppc_decl ();
5892 break;
5893 case COMP_DERIVED_CONTAINS:
5894 m = match_procedure_in_type ();
5895 break;
5896 default:
5897 return MATCH_NO;
5900 if (m != MATCH_YES)
5901 return m;
5903 if (!gfc_notify_std (GFC_STD_F2003, "PROCEDURE statement at %C"))
5904 return MATCH_ERROR;
5906 return m;
5910 /* Warn if a matched procedure has the same name as an intrinsic; this is
5911 simply a wrapper around gfc_warn_intrinsic_shadow that interprets the current
5912 parser-state-stack to find out whether we're in a module. */
5914 static void
5915 do_warn_intrinsic_shadow (const gfc_symbol* sym, bool func)
5917 bool in_module;
5919 in_module = (gfc_state_stack->previous
5920 && (gfc_state_stack->previous->state == COMP_MODULE
5921 || gfc_state_stack->previous->state == COMP_SUBMODULE));
5923 gfc_warn_intrinsic_shadow (sym, in_module, func);
5927 /* Match a function declaration. */
5929 match
5930 gfc_match_function_decl (void)
5932 char name[GFC_MAX_SYMBOL_LEN + 1];
5933 gfc_symbol *sym, *result;
5934 locus old_loc;
5935 match m;
5936 match suffix_match;
5937 match found_match; /* Status returned by match func. */
5939 if (gfc_current_state () != COMP_NONE
5940 && gfc_current_state () != COMP_INTERFACE
5941 && gfc_current_state () != COMP_CONTAINS)
5942 return MATCH_NO;
5944 gfc_clear_ts (&current_ts);
5946 old_loc = gfc_current_locus;
5948 m = gfc_match_prefix (&current_ts);
5949 if (m != MATCH_YES)
5951 gfc_current_locus = old_loc;
5952 return m;
5955 if (gfc_match ("function% %n", name) != MATCH_YES)
5957 gfc_current_locus = old_loc;
5958 return MATCH_NO;
5961 if (get_proc_name (name, &sym, false))
5962 return MATCH_ERROR;
5964 if (add_hidden_procptr_result (sym))
5965 sym = sym->result;
5967 if (current_attr.module_procedure)
5968 sym->attr.module_procedure = 1;
5970 gfc_new_block = sym;
5972 m = gfc_match_formal_arglist (sym, 0, 0);
5973 if (m == MATCH_NO)
5975 gfc_error ("Expected formal argument list in function "
5976 "definition at %C");
5977 m = MATCH_ERROR;
5978 goto cleanup;
5980 else if (m == MATCH_ERROR)
5981 goto cleanup;
5983 result = NULL;
5985 /* According to the draft, the bind(c) and result clause can
5986 come in either order after the formal_arg_list (i.e., either
5987 can be first, both can exist together or by themselves or neither
5988 one). Therefore, the match_result can't match the end of the
5989 string, and check for the bind(c) or result clause in either order. */
5990 found_match = gfc_match_eos ();
5992 /* Make sure that it isn't already declared as BIND(C). If it is, it
5993 must have been marked BIND(C) with a BIND(C) attribute and that is
5994 not allowed for procedures. */
5995 if (sym->attr.is_bind_c == 1)
5997 sym->attr.is_bind_c = 0;
5998 if (sym->old_symbol != NULL)
5999 gfc_error_now ("BIND(C) attribute at %L can only be used for "
6000 "variables or common blocks",
6001 &(sym->old_symbol->declared_at));
6002 else
6003 gfc_error_now ("BIND(C) attribute at %L can only be used for "
6004 "variables or common blocks", &gfc_current_locus);
6007 if (found_match != MATCH_YES)
6009 /* If we haven't found the end-of-statement, look for a suffix. */
6010 suffix_match = gfc_match_suffix (sym, &result);
6011 if (suffix_match == MATCH_YES)
6012 /* Need to get the eos now. */
6013 found_match = gfc_match_eos ();
6014 else
6015 found_match = suffix_match;
6018 if(found_match != MATCH_YES)
6019 m = MATCH_ERROR;
6020 else
6022 /* Make changes to the symbol. */
6023 m = MATCH_ERROR;
6025 if (!gfc_add_function (&sym->attr, sym->name, NULL))
6026 goto cleanup;
6028 if (!gfc_missing_attr (&sym->attr, NULL))
6029 goto cleanup;
6031 if (!copy_prefix (&sym->attr, &sym->declared_at))
6033 if(!sym->attr.module_procedure)
6034 goto cleanup;
6035 else
6036 gfc_error_check ();
6039 /* Delay matching the function characteristics until after the
6040 specification block by signalling kind=-1. */
6041 sym->declared_at = old_loc;
6042 if (current_ts.type != BT_UNKNOWN)
6043 current_ts.kind = -1;
6044 else
6045 current_ts.kind = 0;
6047 if (result == NULL)
6049 if (current_ts.type != BT_UNKNOWN
6050 && !gfc_add_type (sym, &current_ts, &gfc_current_locus))
6051 goto cleanup;
6052 sym->result = sym;
6054 else
6056 if (current_ts.type != BT_UNKNOWN
6057 && !gfc_add_type (result, &current_ts, &gfc_current_locus))
6058 goto cleanup;
6059 sym->result = result;
6062 /* Warn if this procedure has the same name as an intrinsic. */
6063 do_warn_intrinsic_shadow (sym, true);
6065 return MATCH_YES;
6068 cleanup:
6069 gfc_current_locus = old_loc;
6070 return m;
6074 /* This is mostly a copy of parse.c(add_global_procedure) but modified to
6075 pass the name of the entry, rather than the gfc_current_block name, and
6076 to return false upon finding an existing global entry. */
6078 static bool
6079 add_global_entry (const char *name, const char *binding_label, bool sub,
6080 locus *where)
6082 gfc_gsymbol *s;
6083 enum gfc_symbol_type type;
6085 type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
6087 /* Only in Fortran 2003: For procedures with a binding label also the Fortran
6088 name is a global identifier. */
6089 if (!binding_label || gfc_notification_std (GFC_STD_F2008))
6091 s = gfc_get_gsymbol (name);
6093 if (s->defined || (s->type != GSYM_UNKNOWN && s->type != type))
6095 gfc_global_used (s, where);
6096 return false;
6098 else
6100 s->type = type;
6101 s->sym_name = name;
6102 s->where = *where;
6103 s->defined = 1;
6104 s->ns = gfc_current_ns;
6108 /* Don't add the symbol multiple times. */
6109 if (binding_label
6110 && (!gfc_notification_std (GFC_STD_F2008)
6111 || strcmp (name, binding_label) != 0))
6113 s = gfc_get_gsymbol (binding_label);
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->binding_label = binding_label;
6125 s->where = *where;
6126 s->defined = 1;
6127 s->ns = gfc_current_ns;
6131 return true;
6135 /* Match an ENTRY statement. */
6137 match
6138 gfc_match_entry (void)
6140 gfc_symbol *proc;
6141 gfc_symbol *result;
6142 gfc_symbol *entry;
6143 char name[GFC_MAX_SYMBOL_LEN + 1];
6144 gfc_compile_state state;
6145 match m;
6146 gfc_entry_list *el;
6147 locus old_loc;
6148 bool module_procedure;
6149 char peek_char;
6150 match is_bind_c;
6152 m = gfc_match_name (name);
6153 if (m != MATCH_YES)
6154 return m;
6156 if (!gfc_notify_std (GFC_STD_F2008_OBS, "ENTRY statement at %C"))
6157 return MATCH_ERROR;
6159 state = gfc_current_state ();
6160 if (state != COMP_SUBROUTINE && state != COMP_FUNCTION)
6162 switch (state)
6164 case COMP_PROGRAM:
6165 gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
6166 break;
6167 case COMP_MODULE:
6168 gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
6169 break;
6170 case COMP_SUBMODULE:
6171 gfc_error ("ENTRY statement at %C cannot appear within a SUBMODULE");
6172 break;
6173 case COMP_BLOCK_DATA:
6174 gfc_error ("ENTRY statement at %C cannot appear within "
6175 "a BLOCK DATA");
6176 break;
6177 case COMP_INTERFACE:
6178 gfc_error ("ENTRY statement at %C cannot appear within "
6179 "an INTERFACE");
6180 break;
6181 case COMP_STRUCTURE:
6182 gfc_error ("ENTRY statement at %C cannot appear within "
6183 "a STRUCTURE block");
6184 break;
6185 case COMP_DERIVED:
6186 gfc_error ("ENTRY statement at %C cannot appear within "
6187 "a DERIVED TYPE block");
6188 break;
6189 case COMP_IF:
6190 gfc_error ("ENTRY statement at %C cannot appear within "
6191 "an IF-THEN block");
6192 break;
6193 case COMP_DO:
6194 case COMP_DO_CONCURRENT:
6195 gfc_error ("ENTRY statement at %C cannot appear within "
6196 "a DO block");
6197 break;
6198 case COMP_SELECT:
6199 gfc_error ("ENTRY statement at %C cannot appear within "
6200 "a SELECT block");
6201 break;
6202 case COMP_FORALL:
6203 gfc_error ("ENTRY statement at %C cannot appear within "
6204 "a FORALL block");
6205 break;
6206 case COMP_WHERE:
6207 gfc_error ("ENTRY statement at %C cannot appear within "
6208 "a WHERE block");
6209 break;
6210 case COMP_CONTAINS:
6211 gfc_error ("ENTRY statement at %C cannot appear within "
6212 "a contained subprogram");
6213 break;
6214 default:
6215 gfc_error ("Unexpected ENTRY statement at %C");
6217 return MATCH_ERROR;
6220 if ((state == COMP_SUBROUTINE || state == COMP_FUNCTION)
6221 && gfc_state_stack->previous->state == COMP_INTERFACE)
6223 gfc_error ("ENTRY statement at %C cannot appear within an INTERFACE");
6224 return MATCH_ERROR;
6227 module_procedure = gfc_current_ns->parent != NULL
6228 && gfc_current_ns->parent->proc_name
6229 && gfc_current_ns->parent->proc_name->attr.flavor
6230 == FL_MODULE;
6232 if (gfc_current_ns->parent != NULL
6233 && gfc_current_ns->parent->proc_name
6234 && !module_procedure)
6236 gfc_error("ENTRY statement at %C cannot appear in a "
6237 "contained procedure");
6238 return MATCH_ERROR;
6241 /* Module function entries need special care in get_proc_name
6242 because previous references within the function will have
6243 created symbols attached to the current namespace. */
6244 if (get_proc_name (name, &entry,
6245 gfc_current_ns->parent != NULL
6246 && module_procedure))
6247 return MATCH_ERROR;
6249 proc = gfc_current_block ();
6251 /* Make sure that it isn't already declared as BIND(C). If it is, it
6252 must have been marked BIND(C) with a BIND(C) attribute and that is
6253 not allowed for procedures. */
6254 if (entry->attr.is_bind_c == 1)
6256 entry->attr.is_bind_c = 0;
6257 if (entry->old_symbol != NULL)
6258 gfc_error_now ("BIND(C) attribute at %L can only be used for "
6259 "variables or common blocks",
6260 &(entry->old_symbol->declared_at));
6261 else
6262 gfc_error_now ("BIND(C) attribute at %L can only be used for "
6263 "variables or common blocks", &gfc_current_locus);
6266 /* Check what next non-whitespace character is so we can tell if there
6267 is the required parens if we have a BIND(C). */
6268 old_loc = gfc_current_locus;
6269 gfc_gobble_whitespace ();
6270 peek_char = gfc_peek_ascii_char ();
6272 if (state == COMP_SUBROUTINE)
6274 m = gfc_match_formal_arglist (entry, 0, 1);
6275 if (m != MATCH_YES)
6276 return MATCH_ERROR;
6278 /* Call gfc_match_bind_c with allow_binding_name = true as ENTRY can
6279 never be an internal procedure. */
6280 is_bind_c = gfc_match_bind_c (entry, true);
6281 if (is_bind_c == MATCH_ERROR)
6282 return MATCH_ERROR;
6283 if (is_bind_c == MATCH_YES)
6285 if (peek_char != '(')
6287 gfc_error ("Missing required parentheses before BIND(C) at %C");
6288 return MATCH_ERROR;
6290 if (!gfc_add_is_bind_c (&(entry->attr), entry->name,
6291 &(entry->declared_at), 1))
6292 return MATCH_ERROR;
6295 if (!gfc_current_ns->parent
6296 && !add_global_entry (name, entry->binding_label, true,
6297 &old_loc))
6298 return MATCH_ERROR;
6300 /* An entry in a subroutine. */
6301 if (!gfc_add_entry (&entry->attr, entry->name, NULL)
6302 || !gfc_add_subroutine (&entry->attr, entry->name, NULL))
6303 return MATCH_ERROR;
6305 else
6307 /* An entry in a function.
6308 We need to take special care because writing
6309 ENTRY f()
6311 ENTRY f
6312 is allowed, whereas
6313 ENTRY f() RESULT (r)
6314 can't be written as
6315 ENTRY f RESULT (r). */
6316 if (gfc_match_eos () == MATCH_YES)
6318 gfc_current_locus = old_loc;
6319 /* Match the empty argument list, and add the interface to
6320 the symbol. */
6321 m = gfc_match_formal_arglist (entry, 0, 1);
6323 else
6324 m = gfc_match_formal_arglist (entry, 0, 0);
6326 if (m != MATCH_YES)
6327 return MATCH_ERROR;
6329 result = NULL;
6331 if (gfc_match_eos () == MATCH_YES)
6333 if (!gfc_add_entry (&entry->attr, entry->name, NULL)
6334 || !gfc_add_function (&entry->attr, entry->name, NULL))
6335 return MATCH_ERROR;
6337 entry->result = entry;
6339 else
6341 m = gfc_match_suffix (entry, &result);
6342 if (m == MATCH_NO)
6343 gfc_syntax_error (ST_ENTRY);
6344 if (m != MATCH_YES)
6345 return MATCH_ERROR;
6347 if (result)
6349 if (!gfc_add_result (&result->attr, result->name, NULL)
6350 || !gfc_add_entry (&entry->attr, result->name, NULL)
6351 || !gfc_add_function (&entry->attr, result->name, NULL))
6352 return MATCH_ERROR;
6353 entry->result = result;
6355 else
6357 if (!gfc_add_entry (&entry->attr, entry->name, NULL)
6358 || !gfc_add_function (&entry->attr, entry->name, NULL))
6359 return MATCH_ERROR;
6360 entry->result = entry;
6364 if (!gfc_current_ns->parent
6365 && !add_global_entry (name, entry->binding_label, false,
6366 &old_loc))
6367 return MATCH_ERROR;
6370 if (gfc_match_eos () != MATCH_YES)
6372 gfc_syntax_error (ST_ENTRY);
6373 return MATCH_ERROR;
6376 entry->attr.recursive = proc->attr.recursive;
6377 entry->attr.elemental = proc->attr.elemental;
6378 entry->attr.pure = proc->attr.pure;
6380 el = gfc_get_entry_list ();
6381 el->sym = entry;
6382 el->next = gfc_current_ns->entries;
6383 gfc_current_ns->entries = el;
6384 if (el->next)
6385 el->id = el->next->id + 1;
6386 else
6387 el->id = 1;
6389 new_st.op = EXEC_ENTRY;
6390 new_st.ext.entry = el;
6392 return MATCH_YES;
6396 /* Match a subroutine statement, including optional prefixes. */
6398 match
6399 gfc_match_subroutine (void)
6401 char name[GFC_MAX_SYMBOL_LEN + 1];
6402 gfc_symbol *sym;
6403 match m;
6404 match is_bind_c;
6405 char peek_char;
6406 bool allow_binding_name;
6408 if (gfc_current_state () != COMP_NONE
6409 && gfc_current_state () != COMP_INTERFACE
6410 && gfc_current_state () != COMP_CONTAINS)
6411 return MATCH_NO;
6413 m = gfc_match_prefix (NULL);
6414 if (m != MATCH_YES)
6415 return m;
6417 m = gfc_match ("subroutine% %n", name);
6418 if (m != MATCH_YES)
6419 return m;
6421 if (get_proc_name (name, &sym, false))
6422 return MATCH_ERROR;
6424 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
6425 the symbol existed before. */
6426 sym->declared_at = gfc_current_locus;
6428 if (current_attr.module_procedure)
6429 sym->attr.module_procedure = 1;
6431 if (add_hidden_procptr_result (sym))
6432 sym = sym->result;
6434 gfc_new_block = sym;
6436 /* Check what next non-whitespace character is so we can tell if there
6437 is the required parens if we have a BIND(C). */
6438 gfc_gobble_whitespace ();
6439 peek_char = gfc_peek_ascii_char ();
6441 if (!gfc_add_subroutine (&sym->attr, sym->name, NULL))
6442 return MATCH_ERROR;
6444 if (gfc_match_formal_arglist (sym, 0, 1) != MATCH_YES)
6445 return MATCH_ERROR;
6447 /* Make sure that it isn't already declared as BIND(C). If it is, it
6448 must have been marked BIND(C) with a BIND(C) attribute and that is
6449 not allowed for procedures. */
6450 if (sym->attr.is_bind_c == 1)
6452 sym->attr.is_bind_c = 0;
6453 if (sym->old_symbol != NULL)
6454 gfc_error_now ("BIND(C) attribute at %L can only be used for "
6455 "variables or common blocks",
6456 &(sym->old_symbol->declared_at));
6457 else
6458 gfc_error_now ("BIND(C) attribute at %L can only be used for "
6459 "variables or common blocks", &gfc_current_locus);
6462 /* C binding names are not allowed for internal procedures. */
6463 if (gfc_current_state () == COMP_CONTAINS
6464 && sym->ns->proc_name->attr.flavor != FL_MODULE)
6465 allow_binding_name = false;
6466 else
6467 allow_binding_name = true;
6469 /* Here, we are just checking if it has the bind(c) attribute, and if
6470 so, then we need to make sure it's all correct. If it doesn't,
6471 we still need to continue matching the rest of the subroutine line. */
6472 is_bind_c = gfc_match_bind_c (sym, allow_binding_name);
6473 if (is_bind_c == MATCH_ERROR)
6475 /* There was an attempt at the bind(c), but it was wrong. An
6476 error message should have been printed w/in the gfc_match_bind_c
6477 so here we'll just return the MATCH_ERROR. */
6478 return MATCH_ERROR;
6481 if (is_bind_c == MATCH_YES)
6483 /* The following is allowed in the Fortran 2008 draft. */
6484 if (gfc_current_state () == COMP_CONTAINS
6485 && sym->ns->proc_name->attr.flavor != FL_MODULE
6486 && !gfc_notify_std (GFC_STD_F2008, "BIND(C) attribute "
6487 "at %L may not be specified for an internal "
6488 "procedure", &gfc_current_locus))
6489 return MATCH_ERROR;
6491 if (peek_char != '(')
6493 gfc_error ("Missing required parentheses before BIND(C) at %C");
6494 return MATCH_ERROR;
6496 if (!gfc_add_is_bind_c (&(sym->attr), sym->name,
6497 &(sym->declared_at), 1))
6498 return MATCH_ERROR;
6501 if (gfc_match_eos () != MATCH_YES)
6503 gfc_syntax_error (ST_SUBROUTINE);
6504 return MATCH_ERROR;
6507 if (!copy_prefix (&sym->attr, &sym->declared_at))
6509 if(!sym->attr.module_procedure)
6510 return MATCH_ERROR;
6511 else
6512 gfc_error_check ();
6515 /* Warn if it has the same name as an intrinsic. */
6516 do_warn_intrinsic_shadow (sym, false);
6518 return MATCH_YES;
6522 /* Check that the NAME identifier in a BIND attribute or statement
6523 is conform to C identifier rules. */
6525 match
6526 check_bind_name_identifier (char **name)
6528 char *n = *name, *p;
6530 /* Remove leading spaces. */
6531 while (*n == ' ')
6532 n++;
6534 /* On an empty string, free memory and set name to NULL. */
6535 if (*n == '\0')
6537 free (*name);
6538 *name = NULL;
6539 return MATCH_YES;
6542 /* Remove trailing spaces. */
6543 p = n + strlen(n) - 1;
6544 while (*p == ' ')
6545 *(p--) = '\0';
6547 /* Insert the identifier into the symbol table. */
6548 p = xstrdup (n);
6549 free (*name);
6550 *name = p;
6552 /* Now check that identifier is valid under C rules. */
6553 if (ISDIGIT (*p))
6555 gfc_error ("Invalid C identifier in NAME= specifier at %C");
6556 return MATCH_ERROR;
6559 for (; *p; p++)
6560 if (!(ISALNUM (*p) || *p == '_' || *p == '$'))
6562 gfc_error ("Invalid C identifier in NAME= specifier at %C");
6563 return MATCH_ERROR;
6566 return MATCH_YES;
6570 /* Match a BIND(C) specifier, with the optional 'name=' specifier if
6571 given, and set the binding label in either the given symbol (if not
6572 NULL), or in the current_ts. The symbol may be NULL because we may
6573 encounter the BIND(C) before the declaration itself. Return
6574 MATCH_NO if what we're looking at isn't a BIND(C) specifier,
6575 MATCH_ERROR if it is a BIND(C) clause but an error was encountered,
6576 or MATCH_YES if the specifier was correct and the binding label and
6577 bind(c) fields were set correctly for the given symbol or the
6578 current_ts. If allow_binding_name is false, no binding name may be
6579 given. */
6581 match
6582 gfc_match_bind_c (gfc_symbol *sym, bool allow_binding_name)
6584 char *binding_label = NULL;
6585 gfc_expr *e = NULL;
6587 /* Initialize the flag that specifies whether we encountered a NAME=
6588 specifier or not. */
6589 has_name_equals = 0;
6591 /* This much we have to be able to match, in this order, if
6592 there is a bind(c) label. */
6593 if (gfc_match (" bind ( c ") != MATCH_YES)
6594 return MATCH_NO;
6596 /* Now see if there is a binding label, or if we've reached the
6597 end of the bind(c) attribute without one. */
6598 if (gfc_match_char (',') == MATCH_YES)
6600 if (gfc_match (" name = ") != MATCH_YES)
6602 gfc_error ("Syntax error in NAME= specifier for binding label "
6603 "at %C");
6604 /* should give an error message here */
6605 return MATCH_ERROR;
6608 has_name_equals = 1;
6610 if (gfc_match_init_expr (&e) != MATCH_YES)
6612 gfc_free_expr (e);
6613 return MATCH_ERROR;
6616 if (!gfc_simplify_expr(e, 0))
6618 gfc_error ("NAME= specifier at %C should be a constant expression");
6619 gfc_free_expr (e);
6620 return MATCH_ERROR;
6623 if (e->expr_type != EXPR_CONSTANT || e->ts.type != BT_CHARACTER
6624 || e->ts.kind != gfc_default_character_kind || e->rank != 0)
6626 gfc_error ("NAME= specifier at %C should be a scalar of "
6627 "default character kind");
6628 gfc_free_expr(e);
6629 return MATCH_ERROR;
6632 // Get a C string from the Fortran string constant
6633 binding_label = gfc_widechar_to_char (e->value.character.string,
6634 e->value.character.length);
6635 gfc_free_expr(e);
6637 // Check that it is valid (old gfc_match_name_C)
6638 if (check_bind_name_identifier (&binding_label) != MATCH_YES)
6639 return MATCH_ERROR;
6642 /* Get the required right paren. */
6643 if (gfc_match_char (')') != MATCH_YES)
6645 gfc_error ("Missing closing paren for binding label at %C");
6646 return MATCH_ERROR;
6649 if (has_name_equals && !allow_binding_name)
6651 gfc_error ("No binding name is allowed in BIND(C) at %C");
6652 return MATCH_ERROR;
6655 if (has_name_equals && sym != NULL && sym->attr.dummy)
6657 gfc_error ("For dummy procedure %s, no binding name is "
6658 "allowed in BIND(C) at %C", sym->name);
6659 return MATCH_ERROR;
6663 /* Save the binding label to the symbol. If sym is null, we're
6664 probably matching the typespec attributes of a declaration and
6665 haven't gotten the name yet, and therefore, no symbol yet. */
6666 if (binding_label)
6668 if (sym != NULL)
6669 sym->binding_label = binding_label;
6670 else
6671 curr_binding_label = binding_label;
6673 else if (allow_binding_name)
6675 /* No binding label, but if symbol isn't null, we
6676 can set the label for it here.
6677 If name="" or allow_binding_name is false, no C binding name is
6678 created. */
6679 if (sym != NULL && sym->name != NULL && has_name_equals == 0)
6680 sym->binding_label = IDENTIFIER_POINTER (get_identifier (sym->name));
6683 if (has_name_equals && gfc_current_state () == COMP_INTERFACE
6684 && current_interface.type == INTERFACE_ABSTRACT)
6686 gfc_error ("NAME not allowed on BIND(C) for ABSTRACT INTERFACE at %C");
6687 return MATCH_ERROR;
6690 return MATCH_YES;
6694 /* Return nonzero if we're currently compiling a contained procedure. */
6696 static int
6697 contained_procedure (void)
6699 gfc_state_data *s = gfc_state_stack;
6701 if ((s->state == COMP_SUBROUTINE || s->state == COMP_FUNCTION)
6702 && s->previous != NULL && s->previous->state == COMP_CONTAINS)
6703 return 1;
6705 return 0;
6708 /* Set the kind of each enumerator. The kind is selected such that it is
6709 interoperable with the corresponding C enumeration type, making
6710 sure that -fshort-enums is honored. */
6712 static void
6713 set_enum_kind(void)
6715 enumerator_history *current_history = NULL;
6716 int kind;
6717 int i;
6719 if (max_enum == NULL || enum_history == NULL)
6720 return;
6722 if (!flag_short_enums)
6723 return;
6725 i = 0;
6728 kind = gfc_integer_kinds[i++].kind;
6730 while (kind < gfc_c_int_kind
6731 && gfc_check_integer_range (max_enum->initializer->value.integer,
6732 kind) != ARITH_OK);
6734 current_history = enum_history;
6735 while (current_history != NULL)
6737 current_history->sym->ts.kind = kind;
6738 current_history = current_history->next;
6743 /* Match any of the various end-block statements. Returns the type of
6744 END to the caller. The END INTERFACE, END IF, END DO, END SELECT
6745 and END BLOCK statements cannot be replaced by a single END statement. */
6747 match
6748 gfc_match_end (gfc_statement *st)
6750 char name[GFC_MAX_SYMBOL_LEN + 1];
6751 gfc_compile_state state;
6752 locus old_loc;
6753 const char *block_name;
6754 const char *target;
6755 int eos_ok;
6756 match m;
6757 gfc_namespace *parent_ns, *ns, *prev_ns;
6758 gfc_namespace **nsp;
6759 bool abreviated_modproc_decl;
6760 bool got_matching_end = false;
6762 old_loc = gfc_current_locus;
6763 if (gfc_match ("end") != MATCH_YES)
6764 return MATCH_NO;
6766 state = gfc_current_state ();
6767 block_name = gfc_current_block () == NULL
6768 ? NULL : gfc_current_block ()->name;
6770 switch (state)
6772 case COMP_ASSOCIATE:
6773 case COMP_BLOCK:
6774 if (!strncmp (block_name, "block@", strlen("block@")))
6775 block_name = NULL;
6776 break;
6778 case COMP_CONTAINS:
6779 case COMP_DERIVED_CONTAINS:
6780 state = gfc_state_stack->previous->state;
6781 block_name = gfc_state_stack->previous->sym == NULL
6782 ? NULL : gfc_state_stack->previous->sym->name;
6783 break;
6785 default:
6786 break;
6789 abreviated_modproc_decl
6790 = gfc_current_block ()
6791 && gfc_current_block ()->abr_modproc_decl;
6793 switch (state)
6795 case COMP_NONE:
6796 case COMP_PROGRAM:
6797 *st = ST_END_PROGRAM;
6798 target = " program";
6799 eos_ok = 1;
6800 break;
6802 case COMP_SUBROUTINE:
6803 *st = ST_END_SUBROUTINE;
6804 if (!abreviated_modproc_decl)
6805 target = " subroutine";
6806 else
6807 target = " procedure";
6808 eos_ok = !contained_procedure ();
6809 break;
6811 case COMP_FUNCTION:
6812 *st = ST_END_FUNCTION;
6813 if (!abreviated_modproc_decl)
6814 target = " function";
6815 else
6816 target = " procedure";
6817 eos_ok = !contained_procedure ();
6818 break;
6820 case COMP_BLOCK_DATA:
6821 *st = ST_END_BLOCK_DATA;
6822 target = " block data";
6823 eos_ok = 1;
6824 break;
6826 case COMP_MODULE:
6827 *st = ST_END_MODULE;
6828 target = " module";
6829 eos_ok = 1;
6830 break;
6832 case COMP_SUBMODULE:
6833 *st = ST_END_SUBMODULE;
6834 target = " submodule";
6835 eos_ok = 1;
6836 break;
6838 case COMP_INTERFACE:
6839 *st = ST_END_INTERFACE;
6840 target = " interface";
6841 eos_ok = 0;
6842 break;
6844 case COMP_MAP:
6845 *st = ST_END_MAP;
6846 target = " map";
6847 eos_ok = 0;
6848 break;
6850 case COMP_UNION:
6851 *st = ST_END_UNION;
6852 target = " union";
6853 eos_ok = 0;
6854 break;
6856 case COMP_STRUCTURE:
6857 *st = ST_END_STRUCTURE;
6858 target = " structure";
6859 eos_ok = 0;
6860 break;
6862 case COMP_DERIVED:
6863 case COMP_DERIVED_CONTAINS:
6864 *st = ST_END_TYPE;
6865 target = " type";
6866 eos_ok = 0;
6867 break;
6869 case COMP_ASSOCIATE:
6870 *st = ST_END_ASSOCIATE;
6871 target = " associate";
6872 eos_ok = 0;
6873 break;
6875 case COMP_BLOCK:
6876 *st = ST_END_BLOCK;
6877 target = " block";
6878 eos_ok = 0;
6879 break;
6881 case COMP_IF:
6882 *st = ST_ENDIF;
6883 target = " if";
6884 eos_ok = 0;
6885 break;
6887 case COMP_DO:
6888 case COMP_DO_CONCURRENT:
6889 *st = ST_ENDDO;
6890 target = " do";
6891 eos_ok = 0;
6892 break;
6894 case COMP_CRITICAL:
6895 *st = ST_END_CRITICAL;
6896 target = " critical";
6897 eos_ok = 0;
6898 break;
6900 case COMP_SELECT:
6901 case COMP_SELECT_TYPE:
6902 *st = ST_END_SELECT;
6903 target = " select";
6904 eos_ok = 0;
6905 break;
6907 case COMP_FORALL:
6908 *st = ST_END_FORALL;
6909 target = " forall";
6910 eos_ok = 0;
6911 break;
6913 case COMP_WHERE:
6914 *st = ST_END_WHERE;
6915 target = " where";
6916 eos_ok = 0;
6917 break;
6919 case COMP_ENUM:
6920 *st = ST_END_ENUM;
6921 target = " enum";
6922 eos_ok = 0;
6923 last_initializer = NULL;
6924 set_enum_kind ();
6925 gfc_free_enum_history ();
6926 break;
6928 default:
6929 gfc_error ("Unexpected END statement at %C");
6930 goto cleanup;
6933 old_loc = gfc_current_locus;
6934 if (gfc_match_eos () == MATCH_YES)
6936 if (!eos_ok && (*st == ST_END_SUBROUTINE || *st == ST_END_FUNCTION))
6938 if (!gfc_notify_std (GFC_STD_F2008, "END statement "
6939 "instead of %s statement at %L",
6940 abreviated_modproc_decl ? "END PROCEDURE"
6941 : gfc_ascii_statement(*st), &old_loc))
6942 goto cleanup;
6944 else if (!eos_ok)
6946 /* We would have required END [something]. */
6947 gfc_error ("%s statement expected at %L",
6948 gfc_ascii_statement (*st), &old_loc);
6949 goto cleanup;
6952 return MATCH_YES;
6955 /* Verify that we've got the sort of end-block that we're expecting. */
6956 if (gfc_match (target) != MATCH_YES)
6958 gfc_error ("Expecting %s statement at %L", abreviated_modproc_decl
6959 ? "END PROCEDURE" : gfc_ascii_statement(*st), &old_loc);
6960 goto cleanup;
6962 else
6963 got_matching_end = true;
6965 old_loc = gfc_current_locus;
6966 /* If we're at the end, make sure a block name wasn't required. */
6967 if (gfc_match_eos () == MATCH_YES)
6970 if (*st != ST_ENDDO && *st != ST_ENDIF && *st != ST_END_SELECT
6971 && *st != ST_END_FORALL && *st != ST_END_WHERE && *st != ST_END_BLOCK
6972 && *st != ST_END_ASSOCIATE && *st != ST_END_CRITICAL)
6973 return MATCH_YES;
6975 if (!block_name)
6976 return MATCH_YES;
6978 gfc_error ("Expected block name of %qs in %s statement at %L",
6979 block_name, gfc_ascii_statement (*st), &old_loc);
6981 return MATCH_ERROR;
6984 /* END INTERFACE has a special handler for its several possible endings. */
6985 if (*st == ST_END_INTERFACE)
6986 return gfc_match_end_interface ();
6988 /* We haven't hit the end of statement, so what is left must be an
6989 end-name. */
6990 m = gfc_match_space ();
6991 if (m == MATCH_YES)
6992 m = gfc_match_name (name);
6994 if (m == MATCH_NO)
6995 gfc_error ("Expected terminating name at %C");
6996 if (m != MATCH_YES)
6997 goto cleanup;
6999 if (block_name == NULL)
7000 goto syntax;
7002 /* We have to pick out the declared submodule name from the composite
7003 required by F2008:11.2.3 para 2, which ends in the declared name. */
7004 if (state == COMP_SUBMODULE)
7005 block_name = strchr (block_name, '.') + 1;
7007 if (strcmp (name, block_name) != 0 && strcmp (block_name, "ppr@") != 0)
7009 gfc_error ("Expected label %qs for %s statement at %C", block_name,
7010 gfc_ascii_statement (*st));
7011 goto cleanup;
7013 /* Procedure pointer as function result. */
7014 else if (strcmp (block_name, "ppr@") == 0
7015 && strcmp (name, gfc_current_block ()->ns->proc_name->name) != 0)
7017 gfc_error ("Expected label %qs for %s statement at %C",
7018 gfc_current_block ()->ns->proc_name->name,
7019 gfc_ascii_statement (*st));
7020 goto cleanup;
7023 if (gfc_match_eos () == MATCH_YES)
7024 return MATCH_YES;
7026 syntax:
7027 gfc_syntax_error (*st);
7029 cleanup:
7030 gfc_current_locus = old_loc;
7032 /* If we are missing an END BLOCK, we created a half-ready namespace.
7033 Remove it from the parent namespace's sibling list. */
7035 while (state == COMP_BLOCK && !got_matching_end)
7037 parent_ns = gfc_current_ns->parent;
7039 nsp = &(gfc_state_stack->previous->tail->ext.block.ns);
7041 prev_ns = NULL;
7042 ns = *nsp;
7043 while (ns)
7045 if (ns == gfc_current_ns)
7047 if (prev_ns == NULL)
7048 *nsp = NULL;
7049 else
7050 prev_ns->sibling = ns->sibling;
7052 prev_ns = ns;
7053 ns = ns->sibling;
7056 gfc_free_namespace (gfc_current_ns);
7057 gfc_current_ns = parent_ns;
7058 gfc_state_stack = gfc_state_stack->previous;
7059 state = gfc_current_state ();
7062 return MATCH_ERROR;
7067 /***************** Attribute declaration statements ****************/
7069 /* Set the attribute of a single variable. */
7071 static match
7072 attr_decl1 (void)
7074 char name[GFC_MAX_SYMBOL_LEN + 1];
7075 gfc_array_spec *as;
7077 /* Workaround -Wmaybe-uninitialized false positive during
7078 profiledbootstrap by initializing them. */
7079 gfc_symbol *sym = NULL;
7080 locus var_locus;
7081 match m;
7083 as = NULL;
7085 m = gfc_match_name (name);
7086 if (m != MATCH_YES)
7087 goto cleanup;
7089 if (find_special (name, &sym, false))
7090 return MATCH_ERROR;
7092 if (!check_function_name (name))
7094 m = MATCH_ERROR;
7095 goto cleanup;
7098 var_locus = gfc_current_locus;
7100 /* Deal with possible array specification for certain attributes. */
7101 if (current_attr.dimension
7102 || current_attr.codimension
7103 || current_attr.allocatable
7104 || current_attr.pointer
7105 || current_attr.target)
7107 m = gfc_match_array_spec (&as, !current_attr.codimension,
7108 !current_attr.dimension
7109 && !current_attr.pointer
7110 && !current_attr.target);
7111 if (m == MATCH_ERROR)
7112 goto cleanup;
7114 if (current_attr.dimension && m == MATCH_NO)
7116 gfc_error ("Missing array specification at %L in DIMENSION "
7117 "statement", &var_locus);
7118 m = MATCH_ERROR;
7119 goto cleanup;
7122 if (current_attr.dimension && sym->value)
7124 gfc_error ("Dimensions specified for %s at %L after its "
7125 "initialization", sym->name, &var_locus);
7126 m = MATCH_ERROR;
7127 goto cleanup;
7130 if (current_attr.codimension && m == MATCH_NO)
7132 gfc_error ("Missing array specification at %L in CODIMENSION "
7133 "statement", &var_locus);
7134 m = MATCH_ERROR;
7135 goto cleanup;
7138 if ((current_attr.allocatable || current_attr.pointer)
7139 && (m == MATCH_YES) && (as->type != AS_DEFERRED))
7141 gfc_error ("Array specification must be deferred at %L", &var_locus);
7142 m = MATCH_ERROR;
7143 goto cleanup;
7147 /* Update symbol table. DIMENSION attribute is set in
7148 gfc_set_array_spec(). For CLASS variables, this must be applied
7149 to the first component, or '_data' field. */
7150 if (sym->ts.type == BT_CLASS && sym->ts.u.derived->attr.is_class)
7152 if (!gfc_copy_attr (&CLASS_DATA(sym)->attr, &current_attr, &var_locus))
7154 m = MATCH_ERROR;
7155 goto cleanup;
7158 else
7160 if (current_attr.dimension == 0 && current_attr.codimension == 0
7161 && !gfc_copy_attr (&sym->attr, &current_attr, &var_locus))
7163 m = MATCH_ERROR;
7164 goto cleanup;
7168 if (sym->ts.type == BT_CLASS
7169 && !gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as))
7171 m = MATCH_ERROR;
7172 goto cleanup;
7175 if (!gfc_set_array_spec (sym, as, &var_locus))
7177 m = MATCH_ERROR;
7178 goto cleanup;
7181 if (sym->attr.cray_pointee && sym->as != NULL)
7183 /* Fix the array spec. */
7184 m = gfc_mod_pointee_as (sym->as);
7185 if (m == MATCH_ERROR)
7186 goto cleanup;
7189 if (!gfc_add_attribute (&sym->attr, &var_locus))
7191 m = MATCH_ERROR;
7192 goto cleanup;
7195 if ((current_attr.external || current_attr.intrinsic)
7196 && sym->attr.flavor != FL_PROCEDURE
7197 && !gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, NULL))
7199 m = MATCH_ERROR;
7200 goto cleanup;
7203 add_hidden_procptr_result (sym);
7205 return MATCH_YES;
7207 cleanup:
7208 gfc_free_array_spec (as);
7209 return m;
7213 /* Generic attribute declaration subroutine. Used for attributes that
7214 just have a list of names. */
7216 static match
7217 attr_decl (void)
7219 match m;
7221 /* Gobble the optional double colon, by simply ignoring the result
7222 of gfc_match(). */
7223 gfc_match (" ::");
7225 for (;;)
7227 m = attr_decl1 ();
7228 if (m != MATCH_YES)
7229 break;
7231 if (gfc_match_eos () == MATCH_YES)
7233 m = MATCH_YES;
7234 break;
7237 if (gfc_match_char (',') != MATCH_YES)
7239 gfc_error ("Unexpected character in variable list at %C");
7240 m = MATCH_ERROR;
7241 break;
7245 return m;
7249 /* This routine matches Cray Pointer declarations of the form:
7250 pointer ( <pointer>, <pointee> )
7252 pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...
7253 The pointer, if already declared, should be an integer. Otherwise, we
7254 set it as BT_INTEGER with kind gfc_index_integer_kind. The pointee may
7255 be either a scalar, or an array declaration. No space is allocated for
7256 the pointee. For the statement
7257 pointer (ipt, ar(10))
7258 any subsequent uses of ar will be translated (in C-notation) as
7259 ar(i) => ((<type> *) ipt)(i)
7260 After gimplification, pointee variable will disappear in the code. */
7262 static match
7263 cray_pointer_decl (void)
7265 match m;
7266 gfc_array_spec *as = NULL;
7267 gfc_symbol *cptr; /* Pointer symbol. */
7268 gfc_symbol *cpte; /* Pointee symbol. */
7269 locus var_locus;
7270 bool done = false;
7272 while (!done)
7274 if (gfc_match_char ('(') != MATCH_YES)
7276 gfc_error ("Expected %<(%> at %C");
7277 return MATCH_ERROR;
7280 /* Match pointer. */
7281 var_locus = gfc_current_locus;
7282 gfc_clear_attr (&current_attr);
7283 gfc_add_cray_pointer (&current_attr, &var_locus);
7284 current_ts.type = BT_INTEGER;
7285 current_ts.kind = gfc_index_integer_kind;
7287 m = gfc_match_symbol (&cptr, 0);
7288 if (m != MATCH_YES)
7290 gfc_error ("Expected variable name at %C");
7291 return m;
7294 if (!gfc_add_cray_pointer (&cptr->attr, &var_locus))
7295 return MATCH_ERROR;
7297 gfc_set_sym_referenced (cptr);
7299 if (cptr->ts.type == BT_UNKNOWN) /* Override the type, if necessary. */
7301 cptr->ts.type = BT_INTEGER;
7302 cptr->ts.kind = gfc_index_integer_kind;
7304 else if (cptr->ts.type != BT_INTEGER)
7306 gfc_error ("Cray pointer at %C must be an integer");
7307 return MATCH_ERROR;
7309 else if (cptr->ts.kind < gfc_index_integer_kind)
7310 gfc_warning (0, "Cray pointer at %C has %d bytes of precision;"
7311 " memory addresses require %d bytes",
7312 cptr->ts.kind, gfc_index_integer_kind);
7314 if (gfc_match_char (',') != MATCH_YES)
7316 gfc_error ("Expected \",\" at %C");
7317 return MATCH_ERROR;
7320 /* Match Pointee. */
7321 var_locus = gfc_current_locus;
7322 gfc_clear_attr (&current_attr);
7323 gfc_add_cray_pointee (&current_attr, &var_locus);
7324 current_ts.type = BT_UNKNOWN;
7325 current_ts.kind = 0;
7327 m = gfc_match_symbol (&cpte, 0);
7328 if (m != MATCH_YES)
7330 gfc_error ("Expected variable name at %C");
7331 return m;
7334 /* Check for an optional array spec. */
7335 m = gfc_match_array_spec (&as, true, false);
7336 if (m == MATCH_ERROR)
7338 gfc_free_array_spec (as);
7339 return m;
7341 else if (m == MATCH_NO)
7343 gfc_free_array_spec (as);
7344 as = NULL;
7347 if (!gfc_add_cray_pointee (&cpte->attr, &var_locus))
7348 return MATCH_ERROR;
7350 gfc_set_sym_referenced (cpte);
7352 if (cpte->as == NULL)
7354 if (!gfc_set_array_spec (cpte, as, &var_locus))
7355 gfc_internal_error ("Couldn't set Cray pointee array spec.");
7357 else if (as != NULL)
7359 gfc_error ("Duplicate array spec for Cray pointee at %C");
7360 gfc_free_array_spec (as);
7361 return MATCH_ERROR;
7364 as = NULL;
7366 if (cpte->as != NULL)
7368 /* Fix array spec. */
7369 m = gfc_mod_pointee_as (cpte->as);
7370 if (m == MATCH_ERROR)
7371 return m;
7374 /* Point the Pointee at the Pointer. */
7375 cpte->cp_pointer = cptr;
7377 if (gfc_match_char (')') != MATCH_YES)
7379 gfc_error ("Expected \")\" at %C");
7380 return MATCH_ERROR;
7382 m = gfc_match_char (',');
7383 if (m != MATCH_YES)
7384 done = true; /* Stop searching for more declarations. */
7388 if (m == MATCH_ERROR /* Failed when trying to find ',' above. */
7389 || gfc_match_eos () != MATCH_YES)
7391 gfc_error ("Expected %<,%> or end of statement at %C");
7392 return MATCH_ERROR;
7394 return MATCH_YES;
7398 match
7399 gfc_match_external (void)
7402 gfc_clear_attr (&current_attr);
7403 current_attr.external = 1;
7405 return attr_decl ();
7409 match
7410 gfc_match_intent (void)
7412 sym_intent intent;
7414 /* This is not allowed within a BLOCK construct! */
7415 if (gfc_current_state () == COMP_BLOCK)
7417 gfc_error ("INTENT is not allowed inside of BLOCK at %C");
7418 return MATCH_ERROR;
7421 intent = match_intent_spec ();
7422 if (intent == INTENT_UNKNOWN)
7423 return MATCH_ERROR;
7425 gfc_clear_attr (&current_attr);
7426 current_attr.intent = intent;
7428 return attr_decl ();
7432 match
7433 gfc_match_intrinsic (void)
7436 gfc_clear_attr (&current_attr);
7437 current_attr.intrinsic = 1;
7439 return attr_decl ();
7443 match
7444 gfc_match_optional (void)
7446 /* This is not allowed within a BLOCK construct! */
7447 if (gfc_current_state () == COMP_BLOCK)
7449 gfc_error ("OPTIONAL is not allowed inside of BLOCK at %C");
7450 return MATCH_ERROR;
7453 gfc_clear_attr (&current_attr);
7454 current_attr.optional = 1;
7456 return attr_decl ();
7460 match
7461 gfc_match_pointer (void)
7463 gfc_gobble_whitespace ();
7464 if (gfc_peek_ascii_char () == '(')
7466 if (!flag_cray_pointer)
7468 gfc_error ("Cray pointer declaration at %C requires -fcray-pointer "
7469 "flag");
7470 return MATCH_ERROR;
7472 return cray_pointer_decl ();
7474 else
7476 gfc_clear_attr (&current_attr);
7477 current_attr.pointer = 1;
7479 return attr_decl ();
7484 match
7485 gfc_match_allocatable (void)
7487 gfc_clear_attr (&current_attr);
7488 current_attr.allocatable = 1;
7490 return attr_decl ();
7494 match
7495 gfc_match_codimension (void)
7497 gfc_clear_attr (&current_attr);
7498 current_attr.codimension = 1;
7500 return attr_decl ();
7504 match
7505 gfc_match_contiguous (void)
7507 if (!gfc_notify_std (GFC_STD_F2008, "CONTIGUOUS statement at %C"))
7508 return MATCH_ERROR;
7510 gfc_clear_attr (&current_attr);
7511 current_attr.contiguous = 1;
7513 return attr_decl ();
7517 match
7518 gfc_match_dimension (void)
7520 gfc_clear_attr (&current_attr);
7521 current_attr.dimension = 1;
7523 return attr_decl ();
7527 match
7528 gfc_match_target (void)
7530 gfc_clear_attr (&current_attr);
7531 current_attr.target = 1;
7533 return attr_decl ();
7537 /* Match the list of entities being specified in a PUBLIC or PRIVATE
7538 statement. */
7540 static match
7541 access_attr_decl (gfc_statement st)
7543 char name[GFC_MAX_SYMBOL_LEN + 1];
7544 interface_type type;
7545 gfc_user_op *uop;
7546 gfc_symbol *sym, *dt_sym;
7547 gfc_intrinsic_op op;
7548 match m;
7550 if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
7551 goto done;
7553 for (;;)
7555 m = gfc_match_generic_spec (&type, name, &op);
7556 if (m == MATCH_NO)
7557 goto syntax;
7558 if (m == MATCH_ERROR)
7559 return MATCH_ERROR;
7561 switch (type)
7563 case INTERFACE_NAMELESS:
7564 case INTERFACE_ABSTRACT:
7565 goto syntax;
7567 case INTERFACE_GENERIC:
7568 case INTERFACE_DTIO:
7569 if (gfc_get_symbol (name, NULL, &sym))
7570 goto done;
7572 if (!gfc_add_access (&sym->attr,
7573 (st == ST_PUBLIC)
7574 ? ACCESS_PUBLIC : ACCESS_PRIVATE,
7575 sym->name, NULL))
7576 return MATCH_ERROR;
7578 if (sym->attr.generic && (dt_sym = gfc_find_dt_in_generic (sym))
7579 && !gfc_add_access (&dt_sym->attr,
7580 (st == ST_PUBLIC)
7581 ? ACCESS_PUBLIC : ACCESS_PRIVATE,
7582 sym->name, NULL))
7583 return MATCH_ERROR;
7585 break;
7587 case INTERFACE_INTRINSIC_OP:
7588 if (gfc_current_ns->operator_access[op] == ACCESS_UNKNOWN)
7590 gfc_intrinsic_op other_op;
7592 gfc_current_ns->operator_access[op] =
7593 (st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE;
7595 /* Handle the case if there is another op with the same
7596 function, for INTRINSIC_EQ vs. INTRINSIC_EQ_OS and so on. */
7597 other_op = gfc_equivalent_op (op);
7599 if (other_op != INTRINSIC_NONE)
7600 gfc_current_ns->operator_access[other_op] =
7601 (st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE;
7604 else
7606 gfc_error ("Access specification of the %s operator at %C has "
7607 "already been specified", gfc_op2string (op));
7608 goto done;
7611 break;
7613 case INTERFACE_USER_OP:
7614 uop = gfc_get_uop (name);
7616 if (uop->access == ACCESS_UNKNOWN)
7618 uop->access = (st == ST_PUBLIC)
7619 ? ACCESS_PUBLIC : ACCESS_PRIVATE;
7621 else
7623 gfc_error ("Access specification of the .%s. operator at %C "
7624 "has already been specified", sym->name);
7625 goto done;
7628 break;
7631 if (gfc_match_char (',') == MATCH_NO)
7632 break;
7635 if (gfc_match_eos () != MATCH_YES)
7636 goto syntax;
7637 return MATCH_YES;
7639 syntax:
7640 gfc_syntax_error (st);
7642 done:
7643 return MATCH_ERROR;
7647 match
7648 gfc_match_protected (void)
7650 gfc_symbol *sym;
7651 match m;
7653 if (!gfc_current_ns->proc_name
7654 || gfc_current_ns->proc_name->attr.flavor != FL_MODULE)
7656 gfc_error ("PROTECTED at %C only allowed in specification "
7657 "part of a module");
7658 return MATCH_ERROR;
7662 if (!gfc_notify_std (GFC_STD_F2003, "PROTECTED statement at %C"))
7663 return MATCH_ERROR;
7665 if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
7667 return MATCH_ERROR;
7670 if (gfc_match_eos () == MATCH_YES)
7671 goto syntax;
7673 for(;;)
7675 m = gfc_match_symbol (&sym, 0);
7676 switch (m)
7678 case MATCH_YES:
7679 if (!gfc_add_protected (&sym->attr, sym->name, &gfc_current_locus))
7680 return MATCH_ERROR;
7681 goto next_item;
7683 case MATCH_NO:
7684 break;
7686 case MATCH_ERROR:
7687 return MATCH_ERROR;
7690 next_item:
7691 if (gfc_match_eos () == MATCH_YES)
7692 break;
7693 if (gfc_match_char (',') != MATCH_YES)
7694 goto syntax;
7697 return MATCH_YES;
7699 syntax:
7700 gfc_error ("Syntax error in PROTECTED statement at %C");
7701 return MATCH_ERROR;
7705 /* The PRIVATE statement is a bit weird in that it can be an attribute
7706 declaration, but also works as a standalone statement inside of a
7707 type declaration or a module. */
7709 match
7710 gfc_match_private (gfc_statement *st)
7713 if (gfc_match ("private") != MATCH_YES)
7714 return MATCH_NO;
7716 if (gfc_current_state () != COMP_MODULE
7717 && !(gfc_current_state () == COMP_DERIVED
7718 && gfc_state_stack->previous
7719 && gfc_state_stack->previous->state == COMP_MODULE)
7720 && !(gfc_current_state () == COMP_DERIVED_CONTAINS
7721 && gfc_state_stack->previous && gfc_state_stack->previous->previous
7722 && gfc_state_stack->previous->previous->state == COMP_MODULE))
7724 gfc_error ("PRIVATE statement at %C is only allowed in the "
7725 "specification part of a module");
7726 return MATCH_ERROR;
7729 if (gfc_current_state () == COMP_DERIVED)
7731 if (gfc_match_eos () == MATCH_YES)
7733 *st = ST_PRIVATE;
7734 return MATCH_YES;
7737 gfc_syntax_error (ST_PRIVATE);
7738 return MATCH_ERROR;
7741 if (gfc_match_eos () == MATCH_YES)
7743 *st = ST_PRIVATE;
7744 return MATCH_YES;
7747 *st = ST_ATTR_DECL;
7748 return access_attr_decl (ST_PRIVATE);
7752 match
7753 gfc_match_public (gfc_statement *st)
7756 if (gfc_match ("public") != MATCH_YES)
7757 return MATCH_NO;
7759 if (gfc_current_state () != COMP_MODULE)
7761 gfc_error ("PUBLIC statement at %C is only allowed in the "
7762 "specification part of a module");
7763 return MATCH_ERROR;
7766 if (gfc_match_eos () == MATCH_YES)
7768 *st = ST_PUBLIC;
7769 return MATCH_YES;
7772 *st = ST_ATTR_DECL;
7773 return access_attr_decl (ST_PUBLIC);
7777 /* Workhorse for gfc_match_parameter. */
7779 static match
7780 do_parm (void)
7782 gfc_symbol *sym;
7783 gfc_expr *init;
7784 match m;
7785 bool t;
7787 m = gfc_match_symbol (&sym, 0);
7788 if (m == MATCH_NO)
7789 gfc_error ("Expected variable name at %C in PARAMETER statement");
7791 if (m != MATCH_YES)
7792 return m;
7794 if (gfc_match_char ('=') == MATCH_NO)
7796 gfc_error ("Expected = sign in PARAMETER statement at %C");
7797 return MATCH_ERROR;
7800 m = gfc_match_init_expr (&init);
7801 if (m == MATCH_NO)
7802 gfc_error ("Expected expression at %C in PARAMETER statement");
7803 if (m != MATCH_YES)
7804 return m;
7806 if (sym->ts.type == BT_UNKNOWN
7807 && !gfc_set_default_type (sym, 1, NULL))
7809 m = MATCH_ERROR;
7810 goto cleanup;
7813 if (!gfc_check_assign_symbol (sym, NULL, init)
7814 || !gfc_add_flavor (&sym->attr, FL_PARAMETER, sym->name, NULL))
7816 m = MATCH_ERROR;
7817 goto cleanup;
7820 if (sym->value)
7822 gfc_error ("Initializing already initialized variable at %C");
7823 m = MATCH_ERROR;
7824 goto cleanup;
7827 t = add_init_expr_to_sym (sym->name, &init, &gfc_current_locus);
7828 return (t) ? MATCH_YES : MATCH_ERROR;
7830 cleanup:
7831 gfc_free_expr (init);
7832 return m;
7836 /* Match a parameter statement, with the weird syntax that these have. */
7838 match
7839 gfc_match_parameter (void)
7841 const char *term = " )%t";
7842 match m;
7844 if (gfc_match_char ('(') == MATCH_NO)
7846 /* With legacy PARAMETER statements, don't expect a terminating ')'. */
7847 if (!gfc_notify_std (GFC_STD_LEGACY, "PARAMETER without '()' at %C"))
7848 return MATCH_NO;
7849 term = " %t";
7852 for (;;)
7854 m = do_parm ();
7855 if (m != MATCH_YES)
7856 break;
7858 if (gfc_match (term) == MATCH_YES)
7859 break;
7861 if (gfc_match_char (',') != MATCH_YES)
7863 gfc_error ("Unexpected characters in PARAMETER statement at %C");
7864 m = MATCH_ERROR;
7865 break;
7869 return m;
7873 match
7874 gfc_match_automatic (void)
7876 gfc_symbol *sym;
7877 match m;
7878 bool seen_symbol = false;
7880 if (!flag_dec_static)
7882 gfc_error ("AUTOMATIC at %C is a DEC extension, enable with "
7883 "-fdec-static");
7884 return MATCH_ERROR;
7887 gfc_match (" ::");
7889 for (;;)
7891 m = gfc_match_symbol (&sym, 0);
7892 switch (m)
7894 case MATCH_NO:
7895 break;
7897 case MATCH_ERROR:
7898 return MATCH_ERROR;
7900 case MATCH_YES:
7901 if (!gfc_add_automatic (&sym->attr, sym->name, &gfc_current_locus))
7902 return MATCH_ERROR;
7903 seen_symbol = true;
7904 break;
7907 if (gfc_match_eos () == MATCH_YES)
7908 break;
7909 if (gfc_match_char (',') != MATCH_YES)
7910 goto syntax;
7913 if (!seen_symbol)
7915 gfc_error ("Expected entity-list in AUTOMATIC statement at %C");
7916 return MATCH_ERROR;
7919 return MATCH_YES;
7921 syntax:
7922 gfc_error ("Syntax error in AUTOMATIC statement at %C");
7923 return MATCH_ERROR;
7927 match
7928 gfc_match_static (void)
7930 gfc_symbol *sym;
7931 match m;
7932 bool seen_symbol = false;
7934 if (!flag_dec_static)
7936 gfc_error ("STATIC at %C is a DEC extension, enable with -fdec-static");
7937 return MATCH_ERROR;
7940 gfc_match (" ::");
7942 for (;;)
7944 m = gfc_match_symbol (&sym, 0);
7945 switch (m)
7947 case MATCH_NO:
7948 break;
7950 case MATCH_ERROR:
7951 return MATCH_ERROR;
7953 case MATCH_YES:
7954 if (!gfc_add_save (&sym->attr, SAVE_EXPLICIT, sym->name,
7955 &gfc_current_locus))
7956 return MATCH_ERROR;
7957 seen_symbol = true;
7958 break;
7961 if (gfc_match_eos () == MATCH_YES)
7962 break;
7963 if (gfc_match_char (',') != MATCH_YES)
7964 goto syntax;
7967 if (!seen_symbol)
7969 gfc_error ("Expected entity-list in STATIC statement at %C");
7970 return MATCH_ERROR;
7973 return MATCH_YES;
7975 syntax:
7976 gfc_error ("Syntax error in STATIC statement at %C");
7977 return MATCH_ERROR;
7981 /* Save statements have a special syntax. */
7983 match
7984 gfc_match_save (void)
7986 char n[GFC_MAX_SYMBOL_LEN+1];
7987 gfc_common_head *c;
7988 gfc_symbol *sym;
7989 match m;
7991 if (gfc_match_eos () == MATCH_YES)
7993 if (gfc_current_ns->seen_save)
7995 if (!gfc_notify_std (GFC_STD_LEGACY, "Blanket SAVE statement at %C "
7996 "follows previous SAVE statement"))
7997 return MATCH_ERROR;
8000 gfc_current_ns->save_all = gfc_current_ns->seen_save = 1;
8001 return MATCH_YES;
8004 if (gfc_current_ns->save_all)
8006 if (!gfc_notify_std (GFC_STD_LEGACY, "SAVE statement at %C follows "
8007 "blanket SAVE statement"))
8008 return MATCH_ERROR;
8011 gfc_match (" ::");
8013 for (;;)
8015 m = gfc_match_symbol (&sym, 0);
8016 switch (m)
8018 case MATCH_YES:
8019 if (!gfc_add_save (&sym->attr, SAVE_EXPLICIT, sym->name,
8020 &gfc_current_locus))
8021 return MATCH_ERROR;
8022 goto next_item;
8024 case MATCH_NO:
8025 break;
8027 case MATCH_ERROR:
8028 return MATCH_ERROR;
8031 m = gfc_match (" / %n /", &n);
8032 if (m == MATCH_ERROR)
8033 return MATCH_ERROR;
8034 if (m == MATCH_NO)
8035 goto syntax;
8037 c = gfc_get_common (n, 0);
8038 c->saved = 1;
8040 gfc_current_ns->seen_save = 1;
8042 next_item:
8043 if (gfc_match_eos () == MATCH_YES)
8044 break;
8045 if (gfc_match_char (',') != MATCH_YES)
8046 goto syntax;
8049 return MATCH_YES;
8051 syntax:
8052 gfc_error ("Syntax error in SAVE statement at %C");
8053 return MATCH_ERROR;
8057 match
8058 gfc_match_value (void)
8060 gfc_symbol *sym;
8061 match m;
8063 /* This is not allowed within a BLOCK construct! */
8064 if (gfc_current_state () == COMP_BLOCK)
8066 gfc_error ("VALUE is not allowed inside of BLOCK at %C");
8067 return MATCH_ERROR;
8070 if (!gfc_notify_std (GFC_STD_F2003, "VALUE statement at %C"))
8071 return MATCH_ERROR;
8073 if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
8075 return MATCH_ERROR;
8078 if (gfc_match_eos () == MATCH_YES)
8079 goto syntax;
8081 for(;;)
8083 m = gfc_match_symbol (&sym, 0);
8084 switch (m)
8086 case MATCH_YES:
8087 if (!gfc_add_value (&sym->attr, sym->name, &gfc_current_locus))
8088 return MATCH_ERROR;
8089 goto next_item;
8091 case MATCH_NO:
8092 break;
8094 case MATCH_ERROR:
8095 return MATCH_ERROR;
8098 next_item:
8099 if (gfc_match_eos () == MATCH_YES)
8100 break;
8101 if (gfc_match_char (',') != MATCH_YES)
8102 goto syntax;
8105 return MATCH_YES;
8107 syntax:
8108 gfc_error ("Syntax error in VALUE statement at %C");
8109 return MATCH_ERROR;
8113 match
8114 gfc_match_volatile (void)
8116 gfc_symbol *sym;
8117 match m;
8119 if (!gfc_notify_std (GFC_STD_F2003, "VOLATILE statement at %C"))
8120 return MATCH_ERROR;
8122 if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
8124 return MATCH_ERROR;
8127 if (gfc_match_eos () == MATCH_YES)
8128 goto syntax;
8130 for(;;)
8132 /* VOLATILE is special because it can be added to host-associated
8133 symbols locally. Except for coarrays. */
8134 m = gfc_match_symbol (&sym, 1);
8135 switch (m)
8137 case MATCH_YES:
8138 /* F2008, C560+C561. VOLATILE for host-/use-associated variable or
8139 for variable in a BLOCK which is defined outside of the BLOCK. */
8140 if (sym->ns != gfc_current_ns && sym->attr.codimension)
8142 gfc_error ("Specifying VOLATILE for coarray variable %qs at "
8143 "%C, which is use-/host-associated", sym->name);
8144 return MATCH_ERROR;
8146 if (!gfc_add_volatile (&sym->attr, sym->name, &gfc_current_locus))
8147 return MATCH_ERROR;
8148 goto next_item;
8150 case MATCH_NO:
8151 break;
8153 case MATCH_ERROR:
8154 return MATCH_ERROR;
8157 next_item:
8158 if (gfc_match_eos () == MATCH_YES)
8159 break;
8160 if (gfc_match_char (',') != MATCH_YES)
8161 goto syntax;
8164 return MATCH_YES;
8166 syntax:
8167 gfc_error ("Syntax error in VOLATILE statement at %C");
8168 return MATCH_ERROR;
8172 match
8173 gfc_match_asynchronous (void)
8175 gfc_symbol *sym;
8176 match m;
8178 if (!gfc_notify_std (GFC_STD_F2003, "ASYNCHRONOUS statement at %C"))
8179 return MATCH_ERROR;
8181 if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
8183 return MATCH_ERROR;
8186 if (gfc_match_eos () == MATCH_YES)
8187 goto syntax;
8189 for(;;)
8191 /* ASYNCHRONOUS is special because it can be added to host-associated
8192 symbols locally. */
8193 m = gfc_match_symbol (&sym, 1);
8194 switch (m)
8196 case MATCH_YES:
8197 if (!gfc_add_asynchronous (&sym->attr, sym->name, &gfc_current_locus))
8198 return MATCH_ERROR;
8199 goto next_item;
8201 case MATCH_NO:
8202 break;
8204 case MATCH_ERROR:
8205 return MATCH_ERROR;
8208 next_item:
8209 if (gfc_match_eos () == MATCH_YES)
8210 break;
8211 if (gfc_match_char (',') != MATCH_YES)
8212 goto syntax;
8215 return MATCH_YES;
8217 syntax:
8218 gfc_error ("Syntax error in ASYNCHRONOUS statement at %C");
8219 return MATCH_ERROR;
8223 /* Match a module procedure statement in a submodule. */
8225 match
8226 gfc_match_submod_proc (void)
8228 char name[GFC_MAX_SYMBOL_LEN + 1];
8229 gfc_symbol *sym, *fsym;
8230 match m;
8231 gfc_formal_arglist *formal, *head, *tail;
8233 if (gfc_current_state () != COMP_CONTAINS
8234 || !(gfc_state_stack->previous
8235 && (gfc_state_stack->previous->state == COMP_SUBMODULE
8236 || gfc_state_stack->previous->state == COMP_MODULE)))
8237 return MATCH_NO;
8239 m = gfc_match (" module% procedure% %n", name);
8240 if (m != MATCH_YES)
8241 return m;
8243 if (!gfc_notify_std (GFC_STD_F2008, "MODULE PROCEDURE declaration "
8244 "at %C"))
8245 return MATCH_ERROR;
8247 if (get_proc_name (name, &sym, false))
8248 return MATCH_ERROR;
8250 /* Make sure that the result field is appropriately filled, even though
8251 the result symbol will be replaced later on. */
8252 if (sym->tlink && sym->tlink->attr.function)
8254 if (sym->tlink->result
8255 && sym->tlink->result != sym->tlink)
8256 sym->result= sym->tlink->result;
8257 else
8258 sym->result = sym;
8261 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
8262 the symbol existed before. */
8263 sym->declared_at = gfc_current_locus;
8265 if (!sym->attr.module_procedure)
8266 return MATCH_ERROR;
8268 /* Signal match_end to expect "end procedure". */
8269 sym->abr_modproc_decl = 1;
8271 /* Change from IFSRC_IFBODY coming from the interface declaration. */
8272 sym->attr.if_source = IFSRC_DECL;
8274 gfc_new_block = sym;
8276 /* Make a new formal arglist with the symbols in the procedure
8277 namespace. */
8278 head = tail = NULL;
8279 for (formal = sym->formal; formal && formal->sym; formal = formal->next)
8281 if (formal == sym->formal)
8282 head = tail = gfc_get_formal_arglist ();
8283 else
8285 tail->next = gfc_get_formal_arglist ();
8286 tail = tail->next;
8289 if (gfc_copy_dummy_sym (&fsym, formal->sym, 0))
8290 goto cleanup;
8292 tail->sym = fsym;
8293 gfc_set_sym_referenced (fsym);
8296 /* The dummy symbols get cleaned up, when the formal_namespace of the
8297 interface declaration is cleared. This allows us to add the
8298 explicit interface as is done for other type of procedure. */
8299 if (!gfc_add_explicit_interface (sym, IFSRC_DECL, head,
8300 &gfc_current_locus))
8301 return MATCH_ERROR;
8303 if (gfc_match_eos () != MATCH_YES)
8305 gfc_syntax_error (ST_MODULE_PROC);
8306 return MATCH_ERROR;
8309 return MATCH_YES;
8311 cleanup:
8312 gfc_free_formal_arglist (head);
8313 return MATCH_ERROR;
8317 /* Match a module procedure statement. Note that we have to modify
8318 symbols in the parent's namespace because the current one was there
8319 to receive symbols that are in an interface's formal argument list. */
8321 match
8322 gfc_match_modproc (void)
8324 char name[GFC_MAX_SYMBOL_LEN + 1];
8325 gfc_symbol *sym;
8326 match m;
8327 locus old_locus;
8328 gfc_namespace *module_ns;
8329 gfc_interface *old_interface_head, *interface;
8331 if (gfc_state_stack->state != COMP_INTERFACE
8332 || gfc_state_stack->previous == NULL
8333 || current_interface.type == INTERFACE_NAMELESS
8334 || current_interface.type == INTERFACE_ABSTRACT)
8336 gfc_error ("MODULE PROCEDURE at %C must be in a generic module "
8337 "interface");
8338 return MATCH_ERROR;
8341 module_ns = gfc_current_ns->parent;
8342 for (; module_ns; module_ns = module_ns->parent)
8343 if (module_ns->proc_name->attr.flavor == FL_MODULE
8344 || module_ns->proc_name->attr.flavor == FL_PROGRAM
8345 || (module_ns->proc_name->attr.flavor == FL_PROCEDURE
8346 && !module_ns->proc_name->attr.contained))
8347 break;
8349 if (module_ns == NULL)
8350 return MATCH_ERROR;
8352 /* Store the current state of the interface. We will need it if we
8353 end up with a syntax error and need to recover. */
8354 old_interface_head = gfc_current_interface_head ();
8356 /* Check if the F2008 optional double colon appears. */
8357 gfc_gobble_whitespace ();
8358 old_locus = gfc_current_locus;
8359 if (gfc_match ("::") == MATCH_YES)
8361 if (!gfc_notify_std (GFC_STD_F2008, "double colon in "
8362 "MODULE PROCEDURE statement at %L", &old_locus))
8363 return MATCH_ERROR;
8365 else
8366 gfc_current_locus = old_locus;
8368 for (;;)
8370 bool last = false;
8371 old_locus = gfc_current_locus;
8373 m = gfc_match_name (name);
8374 if (m == MATCH_NO)
8375 goto syntax;
8376 if (m != MATCH_YES)
8377 return MATCH_ERROR;
8379 /* Check for syntax error before starting to add symbols to the
8380 current namespace. */
8381 if (gfc_match_eos () == MATCH_YES)
8382 last = true;
8384 if (!last && gfc_match_char (',') != MATCH_YES)
8385 goto syntax;
8387 /* Now we're sure the syntax is valid, we process this item
8388 further. */
8389 if (gfc_get_symbol (name, module_ns, &sym))
8390 return MATCH_ERROR;
8392 if (sym->attr.intrinsic)
8394 gfc_error ("Intrinsic procedure at %L cannot be a MODULE "
8395 "PROCEDURE", &old_locus);
8396 return MATCH_ERROR;
8399 if (sym->attr.proc != PROC_MODULE
8400 && !gfc_add_procedure (&sym->attr, PROC_MODULE, sym->name, NULL))
8401 return MATCH_ERROR;
8403 if (!gfc_add_interface (sym))
8404 return MATCH_ERROR;
8406 sym->attr.mod_proc = 1;
8407 sym->declared_at = old_locus;
8409 if (last)
8410 break;
8413 return MATCH_YES;
8415 syntax:
8416 /* Restore the previous state of the interface. */
8417 interface = gfc_current_interface_head ();
8418 gfc_set_current_interface_head (old_interface_head);
8420 /* Free the new interfaces. */
8421 while (interface != old_interface_head)
8423 gfc_interface *i = interface->next;
8424 free (interface);
8425 interface = i;
8428 /* And issue a syntax error. */
8429 gfc_syntax_error (ST_MODULE_PROC);
8430 return MATCH_ERROR;
8434 /* Check a derived type that is being extended. */
8436 static gfc_symbol*
8437 check_extended_derived_type (char *name)
8439 gfc_symbol *extended;
8441 if (gfc_find_symbol (name, gfc_current_ns, 1, &extended))
8443 gfc_error ("Ambiguous symbol in TYPE definition at %C");
8444 return NULL;
8447 extended = gfc_find_dt_in_generic (extended);
8449 /* F08:C428. */
8450 if (!extended)
8452 gfc_error ("Symbol %qs at %C has not been previously defined", name);
8453 return NULL;
8456 if (extended->attr.flavor != FL_DERIVED)
8458 gfc_error ("%qs in EXTENDS expression at %C is not a "
8459 "derived type", name);
8460 return NULL;
8463 if (extended->attr.is_bind_c)
8465 gfc_error ("%qs cannot be extended at %C because it "
8466 "is BIND(C)", extended->name);
8467 return NULL;
8470 if (extended->attr.sequence)
8472 gfc_error ("%qs cannot be extended at %C because it "
8473 "is a SEQUENCE type", extended->name);
8474 return NULL;
8477 return extended;
8481 /* Match the optional attribute specifiers for a type declaration.
8482 Return MATCH_ERROR if an error is encountered in one of the handled
8483 attributes (public, private, bind(c)), MATCH_NO if what's found is
8484 not a handled attribute, and MATCH_YES otherwise. TODO: More error
8485 checking on attribute conflicts needs to be done. */
8487 match
8488 gfc_get_type_attr_spec (symbol_attribute *attr, char *name)
8490 /* See if the derived type is marked as private. */
8491 if (gfc_match (" , private") == MATCH_YES)
8493 if (gfc_current_state () != COMP_MODULE)
8495 gfc_error ("Derived type at %C can only be PRIVATE in the "
8496 "specification part of a module");
8497 return MATCH_ERROR;
8500 if (!gfc_add_access (attr, ACCESS_PRIVATE, NULL, NULL))
8501 return MATCH_ERROR;
8503 else if (gfc_match (" , public") == MATCH_YES)
8505 if (gfc_current_state () != COMP_MODULE)
8507 gfc_error ("Derived type at %C can only be PUBLIC in the "
8508 "specification part of a module");
8509 return MATCH_ERROR;
8512 if (!gfc_add_access (attr, ACCESS_PUBLIC, NULL, NULL))
8513 return MATCH_ERROR;
8515 else if (gfc_match (" , bind ( c )") == MATCH_YES)
8517 /* If the type is defined to be bind(c) it then needs to make
8518 sure that all fields are interoperable. This will
8519 need to be a semantic check on the finished derived type.
8520 See 15.2.3 (lines 9-12) of F2003 draft. */
8521 if (!gfc_add_is_bind_c (attr, NULL, &gfc_current_locus, 0))
8522 return MATCH_ERROR;
8524 /* TODO: attr conflicts need to be checked, probably in symbol.c. */
8526 else if (gfc_match (" , abstract") == MATCH_YES)
8528 if (!gfc_notify_std (GFC_STD_F2003, "ABSTRACT type at %C"))
8529 return MATCH_ERROR;
8531 if (!gfc_add_abstract (attr, &gfc_current_locus))
8532 return MATCH_ERROR;
8534 else if (name && gfc_match (" , extends ( %n )", name) == MATCH_YES)
8536 if (!gfc_add_extension (attr, &gfc_current_locus))
8537 return MATCH_ERROR;
8539 else
8540 return MATCH_NO;
8542 /* If we get here, something matched. */
8543 return MATCH_YES;
8547 /* Common function for type declaration blocks similar to derived types, such
8548 as STRUCTURES and MAPs. Unlike derived types, a structure type
8549 does NOT have a generic symbol matching the name given by the user.
8550 STRUCTUREs can share names with variables and PARAMETERs so we must allow
8551 for the creation of an independent symbol.
8552 Other parameters are a message to prefix errors with, the name of the new
8553 type to be created, and the flavor to add to the resulting symbol. */
8555 static bool
8556 get_struct_decl (const char *name, sym_flavor fl, locus *decl,
8557 gfc_symbol **result)
8559 gfc_symbol *sym;
8560 locus where;
8562 gcc_assert (name[0] == (char) TOUPPER (name[0]));
8564 if (decl)
8565 where = *decl;
8566 else
8567 where = gfc_current_locus;
8569 if (gfc_get_symbol (name, NULL, &sym))
8570 return false;
8572 if (!sym)
8574 gfc_internal_error ("Failed to create structure type '%s' at %C", name);
8575 return false;
8578 if (sym->components != NULL || sym->attr.zero_comp)
8580 gfc_error ("Type definition of '%s' at %C was already defined at %L",
8581 sym->name, &sym->declared_at);
8582 return false;
8585 sym->declared_at = where;
8587 if (sym->attr.flavor != fl
8588 && !gfc_add_flavor (&sym->attr, fl, sym->name, NULL))
8589 return false;
8591 if (!sym->hash_value)
8592 /* Set the hash for the compound name for this type. */
8593 sym->hash_value = gfc_hash_value (sym);
8595 /* Normally the type is expected to have been completely parsed by the time
8596 a field declaration with this type is seen. For unions, maps, and nested
8597 structure declarations, we need to indicate that it is okay that we
8598 haven't seen any components yet. This will be updated after the structure
8599 is fully parsed. */
8600 sym->attr.zero_comp = 0;
8602 /* Structures always act like derived-types with the SEQUENCE attribute */
8603 gfc_add_sequence (&sym->attr, sym->name, NULL);
8605 if (result) *result = sym;
8607 return true;
8611 /* Match the opening of a MAP block. Like a struct within a union in C;
8612 behaves identical to STRUCTURE blocks. */
8614 match
8615 gfc_match_map (void)
8617 /* Counter used to give unique internal names to map structures. */
8618 static unsigned int gfc_map_id = 0;
8619 char name[GFC_MAX_SYMBOL_LEN + 1];
8620 gfc_symbol *sym;
8621 locus old_loc;
8623 old_loc = gfc_current_locus;
8625 if (gfc_match_eos () != MATCH_YES)
8627 gfc_error ("Junk after MAP statement at %C");
8628 gfc_current_locus = old_loc;
8629 return MATCH_ERROR;
8632 /* Map blocks are anonymous so we make up unique names for the symbol table
8633 which are invalid Fortran identifiers. */
8634 snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "MM$%u", gfc_map_id++);
8636 if (!get_struct_decl (name, FL_STRUCT, &old_loc, &sym))
8637 return MATCH_ERROR;
8639 gfc_new_block = sym;
8641 return MATCH_YES;
8645 /* Match the opening of a UNION block. */
8647 match
8648 gfc_match_union (void)
8650 /* Counter used to give unique internal names to union types. */
8651 static unsigned int gfc_union_id = 0;
8652 char name[GFC_MAX_SYMBOL_LEN + 1];
8653 gfc_symbol *sym;
8654 locus old_loc;
8656 old_loc = gfc_current_locus;
8658 if (gfc_match_eos () != MATCH_YES)
8660 gfc_error ("Junk after UNION statement at %C");
8661 gfc_current_locus = old_loc;
8662 return MATCH_ERROR;
8665 /* Unions are anonymous so we make up unique names for the symbol table
8666 which are invalid Fortran identifiers. */
8667 snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "UU$%u", gfc_union_id++);
8669 if (!get_struct_decl (name, FL_UNION, &old_loc, &sym))
8670 return MATCH_ERROR;
8672 gfc_new_block = sym;
8674 return MATCH_YES;
8678 /* Match the beginning of a STRUCTURE declaration. This is similar to
8679 matching the beginning of a derived type declaration with a few
8680 twists. The resulting type symbol has no access control or other
8681 interesting attributes. */
8683 match
8684 gfc_match_structure_decl (void)
8686 /* Counter used to give unique internal names to anonymous structures. */
8687 static unsigned int gfc_structure_id = 0;
8688 char name[GFC_MAX_SYMBOL_LEN + 1];
8689 gfc_symbol *sym;
8690 match m;
8691 locus where;
8693 if (!flag_dec_structure)
8695 gfc_error ("STRUCTURE at %C is a DEC extension, enable with "
8696 "-fdec-structure");
8697 return MATCH_ERROR;
8700 name[0] = '\0';
8702 m = gfc_match (" /%n/", name);
8703 if (m != MATCH_YES)
8705 /* Non-nested structure declarations require a structure name. */
8706 if (!gfc_comp_struct (gfc_current_state ()))
8708 gfc_error ("Structure name expected in non-nested structure "
8709 "declaration at %C");
8710 return MATCH_ERROR;
8712 /* This is an anonymous structure; make up a unique name for it
8713 (upper-case letters never make it to symbol names from the source).
8714 The important thing is initializing the type variable
8715 and setting gfc_new_symbol, which is immediately used by
8716 parse_structure () and variable_decl () to add components of
8717 this type. */
8718 snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "SS$%u", gfc_structure_id++);
8721 where = gfc_current_locus;
8722 /* No field list allowed after non-nested structure declaration. */
8723 if (!gfc_comp_struct (gfc_current_state ())
8724 && gfc_match_eos () != MATCH_YES)
8726 gfc_error ("Junk after non-nested STRUCTURE statement at %C");
8727 return MATCH_ERROR;
8730 /* Make sure the name is not the name of an intrinsic type. */
8731 if (gfc_is_intrinsic_typename (name))
8733 gfc_error ("Structure name '%s' at %C cannot be the same as an"
8734 " intrinsic type", name);
8735 return MATCH_ERROR;
8738 /* Store the actual type symbol for the structure with an upper-case first
8739 letter (an invalid Fortran identifier). */
8741 if (!get_struct_decl (gfc_dt_upper_string (name), FL_STRUCT, &where, &sym))
8742 return MATCH_ERROR;
8744 gfc_new_block = sym;
8745 return MATCH_YES;
8749 /* This function does some work to determine which matcher should be used to
8750 * match a statement beginning with "TYPE". This is used to disambiguate TYPE
8751 * as an alias for PRINT from derived type declarations, TYPE IS statements,
8752 * and derived type data declarations. */
8754 match
8755 gfc_match_type (gfc_statement *st)
8757 char name[GFC_MAX_SYMBOL_LEN + 1];
8758 match m;
8759 locus old_loc;
8761 /* Requires -fdec. */
8762 if (!flag_dec)
8763 return MATCH_NO;
8765 m = gfc_match ("type");
8766 if (m != MATCH_YES)
8767 return m;
8768 /* If we already have an error in the buffer, it is probably from failing to
8769 * match a derived type data declaration. Let it happen. */
8770 else if (gfc_error_flag_test ())
8771 return MATCH_NO;
8773 old_loc = gfc_current_locus;
8774 *st = ST_NONE;
8776 /* If we see an attribute list before anything else it's definitely a derived
8777 * type declaration. */
8778 if (gfc_match (" ,") == MATCH_YES || gfc_match (" ::") == MATCH_YES)
8780 gfc_current_locus = old_loc;
8781 *st = ST_DERIVED_DECL;
8782 return gfc_match_derived_decl ();
8785 /* By now "TYPE" has already been matched. If we do not see a name, this may
8786 * be something like "TYPE *" or "TYPE <fmt>". */
8787 m = gfc_match_name (name);
8788 if (m != MATCH_YES)
8790 /* Let print match if it can, otherwise throw an error from
8791 * gfc_match_derived_decl. */
8792 gfc_current_locus = old_loc;
8793 if (gfc_match_print () == MATCH_YES)
8795 *st = ST_WRITE;
8796 return MATCH_YES;
8798 gfc_current_locus = old_loc;
8799 *st = ST_DERIVED_DECL;
8800 return gfc_match_derived_decl ();
8803 /* A derived type declaration requires an EOS. Without it, assume print. */
8804 m = gfc_match_eos ();
8805 if (m == MATCH_NO)
8807 /* Check manually for TYPE IS (... - this is invalid print syntax. */
8808 if (strncmp ("is", name, 3) == 0
8809 && gfc_match (" (", name) == MATCH_YES)
8811 gfc_current_locus = old_loc;
8812 gcc_assert (gfc_match (" is") == MATCH_YES);
8813 *st = ST_TYPE_IS;
8814 return gfc_match_type_is ();
8816 gfc_current_locus = old_loc;
8817 *st = ST_WRITE;
8818 return gfc_match_print ();
8820 else
8822 /* By now we have "TYPE <name> <EOS>". Check first if the name is an
8823 * intrinsic typename - if so let gfc_match_derived_decl dump an error.
8824 * Otherwise if gfc_match_derived_decl fails it's probably an existing
8825 * symbol which can be printed. */
8826 gfc_current_locus = old_loc;
8827 m = gfc_match_derived_decl ();
8828 if (gfc_is_intrinsic_typename (name) || m == MATCH_YES)
8830 *st = ST_DERIVED_DECL;
8831 return m;
8833 gfc_current_locus = old_loc;
8834 *st = ST_WRITE;
8835 return gfc_match_print ();
8838 return MATCH_NO;
8842 /* Match the beginning of a derived type declaration. If a type name
8843 was the result of a function, then it is possible to have a symbol
8844 already to be known as a derived type yet have no components. */
8846 match
8847 gfc_match_derived_decl (void)
8849 char name[GFC_MAX_SYMBOL_LEN + 1];
8850 char parent[GFC_MAX_SYMBOL_LEN + 1];
8851 symbol_attribute attr;
8852 gfc_symbol *sym, *gensym;
8853 gfc_symbol *extended;
8854 match m;
8855 match is_type_attr_spec = MATCH_NO;
8856 bool seen_attr = false;
8857 gfc_interface *intr = NULL, *head;
8859 if (gfc_comp_struct (gfc_current_state ()))
8860 return MATCH_NO;
8862 name[0] = '\0';
8863 parent[0] = '\0';
8864 gfc_clear_attr (&attr);
8865 extended = NULL;
8869 is_type_attr_spec = gfc_get_type_attr_spec (&attr, parent);
8870 if (is_type_attr_spec == MATCH_ERROR)
8871 return MATCH_ERROR;
8872 if (is_type_attr_spec == MATCH_YES)
8873 seen_attr = true;
8874 } while (is_type_attr_spec == MATCH_YES);
8876 /* Deal with derived type extensions. The extension attribute has
8877 been added to 'attr' but now the parent type must be found and
8878 checked. */
8879 if (parent[0])
8880 extended = check_extended_derived_type (parent);
8882 if (parent[0] && !extended)
8883 return MATCH_ERROR;
8885 if (gfc_match (" ::") != MATCH_YES && seen_attr)
8887 gfc_error ("Expected :: in TYPE definition at %C");
8888 return MATCH_ERROR;
8891 m = gfc_match (" %n%t", name);
8892 if (m != MATCH_YES)
8893 return m;
8895 /* Make sure the name is not the name of an intrinsic type. */
8896 if (gfc_is_intrinsic_typename (name))
8898 gfc_error ("Type name %qs at %C cannot be the same as an intrinsic "
8899 "type", name);
8900 return MATCH_ERROR;
8903 if (gfc_get_symbol (name, NULL, &gensym))
8904 return MATCH_ERROR;
8906 if (!gensym->attr.generic && gensym->ts.type != BT_UNKNOWN)
8908 gfc_error ("Derived type name %qs at %C already has a basic type "
8909 "of %s", gensym->name, gfc_typename (&gensym->ts));
8910 return MATCH_ERROR;
8913 if (!gensym->attr.generic
8914 && !gfc_add_generic (&gensym->attr, gensym->name, NULL))
8915 return MATCH_ERROR;
8917 if (!gensym->attr.function
8918 && !gfc_add_function (&gensym->attr, gensym->name, NULL))
8919 return MATCH_ERROR;
8921 sym = gfc_find_dt_in_generic (gensym);
8923 if (sym && (sym->components != NULL || sym->attr.zero_comp))
8925 gfc_error ("Derived type definition of %qs at %C has already been "
8926 "defined", sym->name);
8927 return MATCH_ERROR;
8930 if (!sym)
8932 /* Use upper case to save the actual derived-type symbol. */
8933 gfc_get_symbol (gfc_dt_upper_string (gensym->name), NULL, &sym);
8934 sym->name = gfc_get_string ("%s", gensym->name);
8935 head = gensym->generic;
8936 intr = gfc_get_interface ();
8937 intr->sym = sym;
8938 intr->where = gfc_current_locus;
8939 intr->sym->declared_at = gfc_current_locus;
8940 intr->next = head;
8941 gensym->generic = intr;
8942 gensym->attr.if_source = IFSRC_DECL;
8945 /* The symbol may already have the derived attribute without the
8946 components. The ways this can happen is via a function
8947 definition, an INTRINSIC statement or a subtype in another
8948 derived type that is a pointer. The first part of the AND clause
8949 is true if the symbol is not the return value of a function. */
8950 if (sym->attr.flavor != FL_DERIVED
8951 && !gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL))
8952 return MATCH_ERROR;
8954 if (attr.access != ACCESS_UNKNOWN
8955 && !gfc_add_access (&sym->attr, attr.access, sym->name, NULL))
8956 return MATCH_ERROR;
8957 else if (sym->attr.access == ACCESS_UNKNOWN
8958 && gensym->attr.access != ACCESS_UNKNOWN
8959 && !gfc_add_access (&sym->attr, gensym->attr.access,
8960 sym->name, NULL))
8961 return MATCH_ERROR;
8963 if (sym->attr.access != ACCESS_UNKNOWN
8964 && gensym->attr.access == ACCESS_UNKNOWN)
8965 gensym->attr.access = sym->attr.access;
8967 /* See if the derived type was labeled as bind(c). */
8968 if (attr.is_bind_c != 0)
8969 sym->attr.is_bind_c = attr.is_bind_c;
8971 /* Construct the f2k_derived namespace if it is not yet there. */
8972 if (!sym->f2k_derived)
8973 sym->f2k_derived = gfc_get_namespace (NULL, 0);
8975 if (extended && !sym->components)
8977 gfc_component *p;
8979 /* Add the extended derived type as the first component. */
8980 gfc_add_component (sym, parent, &p);
8981 extended->refs++;
8982 gfc_set_sym_referenced (extended);
8984 p->ts.type = BT_DERIVED;
8985 p->ts.u.derived = extended;
8986 p->initializer = gfc_default_initializer (&p->ts);
8988 /* Set extension level. */
8989 if (extended->attr.extension == 255)
8991 /* Since the extension field is 8 bit wide, we can only have
8992 up to 255 extension levels. */
8993 gfc_error ("Maximum extension level reached with type %qs at %L",
8994 extended->name, &extended->declared_at);
8995 return MATCH_ERROR;
8997 sym->attr.extension = extended->attr.extension + 1;
8999 /* Provide the links between the extended type and its extension. */
9000 if (!extended->f2k_derived)
9001 extended->f2k_derived = gfc_get_namespace (NULL, 0);
9004 if (!sym->hash_value)
9005 /* Set the hash for the compound name for this type. */
9006 sym->hash_value = gfc_hash_value (sym);
9008 /* Take over the ABSTRACT attribute. */
9009 sym->attr.abstract = attr.abstract;
9011 gfc_new_block = sym;
9013 return MATCH_YES;
9017 /* Cray Pointees can be declared as:
9018 pointer (ipt, a (n,m,...,*)) */
9020 match
9021 gfc_mod_pointee_as (gfc_array_spec *as)
9023 as->cray_pointee = true; /* This will be useful to know later. */
9024 if (as->type == AS_ASSUMED_SIZE)
9025 as->cp_was_assumed = true;
9026 else if (as->type == AS_ASSUMED_SHAPE)
9028 gfc_error ("Cray Pointee at %C cannot be assumed shape array");
9029 return MATCH_ERROR;
9031 return MATCH_YES;
9035 /* Match the enum definition statement, here we are trying to match
9036 the first line of enum definition statement.
9037 Returns MATCH_YES if match is found. */
9039 match
9040 gfc_match_enum (void)
9042 match m;
9044 m = gfc_match_eos ();
9045 if (m != MATCH_YES)
9046 return m;
9048 if (!gfc_notify_std (GFC_STD_F2003, "ENUM and ENUMERATOR at %C"))
9049 return MATCH_ERROR;
9051 return MATCH_YES;
9055 /* Returns an initializer whose value is one higher than the value of the
9056 LAST_INITIALIZER argument. If the argument is NULL, the
9057 initializers value will be set to zero. The initializer's kind
9058 will be set to gfc_c_int_kind.
9060 If -fshort-enums is given, the appropriate kind will be selected
9061 later after all enumerators have been parsed. A warning is issued
9062 here if an initializer exceeds gfc_c_int_kind. */
9064 static gfc_expr *
9065 enum_initializer (gfc_expr *last_initializer, locus where)
9067 gfc_expr *result;
9068 result = gfc_get_constant_expr (BT_INTEGER, gfc_c_int_kind, &where);
9070 mpz_init (result->value.integer);
9072 if (last_initializer != NULL)
9074 mpz_add_ui (result->value.integer, last_initializer->value.integer, 1);
9075 result->where = last_initializer->where;
9077 if (gfc_check_integer_range (result->value.integer,
9078 gfc_c_int_kind) != ARITH_OK)
9080 gfc_error ("Enumerator exceeds the C integer type at %C");
9081 return NULL;
9084 else
9086 /* Control comes here, if it's the very first enumerator and no
9087 initializer has been given. It will be initialized to zero. */
9088 mpz_set_si (result->value.integer, 0);
9091 return result;
9095 /* Match a variable name with an optional initializer. When this
9096 subroutine is called, a variable is expected to be parsed next.
9097 Depending on what is happening at the moment, updates either the
9098 symbol table or the current interface. */
9100 static match
9101 enumerator_decl (void)
9103 char name[GFC_MAX_SYMBOL_LEN + 1];
9104 gfc_expr *initializer;
9105 gfc_array_spec *as = NULL;
9106 gfc_symbol *sym;
9107 locus var_locus;
9108 match m;
9109 bool t;
9110 locus old_locus;
9112 initializer = NULL;
9113 old_locus = gfc_current_locus;
9115 /* When we get here, we've just matched a list of attributes and
9116 maybe a type and a double colon. The next thing we expect to see
9117 is the name of the symbol. */
9118 m = gfc_match_name (name);
9119 if (m != MATCH_YES)
9120 goto cleanup;
9122 var_locus = gfc_current_locus;
9124 /* OK, we've successfully matched the declaration. Now put the
9125 symbol in the current namespace. If we fail to create the symbol,
9126 bail out. */
9127 if (!build_sym (name, NULL, false, &as, &var_locus))
9129 m = MATCH_ERROR;
9130 goto cleanup;
9133 /* The double colon must be present in order to have initializers.
9134 Otherwise the statement is ambiguous with an assignment statement. */
9135 if (colon_seen)
9137 if (gfc_match_char ('=') == MATCH_YES)
9139 m = gfc_match_init_expr (&initializer);
9140 if (m == MATCH_NO)
9142 gfc_error ("Expected an initialization expression at %C");
9143 m = MATCH_ERROR;
9146 if (m != MATCH_YES)
9147 goto cleanup;
9151 /* If we do not have an initializer, the initialization value of the
9152 previous enumerator (stored in last_initializer) is incremented
9153 by 1 and is used to initialize the current enumerator. */
9154 if (initializer == NULL)
9155 initializer = enum_initializer (last_initializer, old_locus);
9157 if (initializer == NULL || initializer->ts.type != BT_INTEGER)
9159 gfc_error ("ENUMERATOR %L not initialized with integer expression",
9160 &var_locus);
9161 m = MATCH_ERROR;
9162 goto cleanup;
9165 /* Store this current initializer, for the next enumerator variable
9166 to be parsed. add_init_expr_to_sym() zeros initializer, so we
9167 use last_initializer below. */
9168 last_initializer = initializer;
9169 t = add_init_expr_to_sym (name, &initializer, &var_locus);
9171 /* Maintain enumerator history. */
9172 gfc_find_symbol (name, NULL, 0, &sym);
9173 create_enum_history (sym, last_initializer);
9175 return (t) ? MATCH_YES : MATCH_ERROR;
9177 cleanup:
9178 /* Free stuff up and return. */
9179 gfc_free_expr (initializer);
9181 return m;
9185 /* Match the enumerator definition statement. */
9187 match
9188 gfc_match_enumerator_def (void)
9190 match m;
9191 bool t;
9193 gfc_clear_ts (&current_ts);
9195 m = gfc_match (" enumerator");
9196 if (m != MATCH_YES)
9197 return m;
9199 m = gfc_match (" :: ");
9200 if (m == MATCH_ERROR)
9201 return m;
9203 colon_seen = (m == MATCH_YES);
9205 if (gfc_current_state () != COMP_ENUM)
9207 gfc_error ("ENUM definition statement expected before %C");
9208 gfc_free_enum_history ();
9209 return MATCH_ERROR;
9212 (&current_ts)->type = BT_INTEGER;
9213 (&current_ts)->kind = gfc_c_int_kind;
9215 gfc_clear_attr (&current_attr);
9216 t = gfc_add_flavor (&current_attr, FL_PARAMETER, NULL, NULL);
9217 if (!t)
9219 m = MATCH_ERROR;
9220 goto cleanup;
9223 for (;;)
9225 m = enumerator_decl ();
9226 if (m == MATCH_ERROR)
9228 gfc_free_enum_history ();
9229 goto cleanup;
9231 if (m == MATCH_NO)
9232 break;
9234 if (gfc_match_eos () == MATCH_YES)
9235 goto cleanup;
9236 if (gfc_match_char (',') != MATCH_YES)
9237 break;
9240 if (gfc_current_state () == COMP_ENUM)
9242 gfc_free_enum_history ();
9243 gfc_error ("Syntax error in ENUMERATOR definition at %C");
9244 m = MATCH_ERROR;
9247 cleanup:
9248 gfc_free_array_spec (current_as);
9249 current_as = NULL;
9250 return m;
9255 /* Match binding attributes. */
9257 static match
9258 match_binding_attributes (gfc_typebound_proc* ba, bool generic, bool ppc)
9260 bool found_passing = false;
9261 bool seen_ptr = false;
9262 match m = MATCH_YES;
9264 /* Initialize to defaults. Do so even before the MATCH_NO check so that in
9265 this case the defaults are in there. */
9266 ba->access = ACCESS_UNKNOWN;
9267 ba->pass_arg = NULL;
9268 ba->pass_arg_num = 0;
9269 ba->nopass = 0;
9270 ba->non_overridable = 0;
9271 ba->deferred = 0;
9272 ba->ppc = ppc;
9274 /* If we find a comma, we believe there are binding attributes. */
9275 m = gfc_match_char (',');
9276 if (m == MATCH_NO)
9277 goto done;
9281 /* Access specifier. */
9283 m = gfc_match (" public");
9284 if (m == MATCH_ERROR)
9285 goto error;
9286 if (m == MATCH_YES)
9288 if (ba->access != ACCESS_UNKNOWN)
9290 gfc_error ("Duplicate access-specifier at %C");
9291 goto error;
9294 ba->access = ACCESS_PUBLIC;
9295 continue;
9298 m = gfc_match (" private");
9299 if (m == MATCH_ERROR)
9300 goto error;
9301 if (m == MATCH_YES)
9303 if (ba->access != ACCESS_UNKNOWN)
9305 gfc_error ("Duplicate access-specifier at %C");
9306 goto error;
9309 ba->access = ACCESS_PRIVATE;
9310 continue;
9313 /* If inside GENERIC, the following is not allowed. */
9314 if (!generic)
9317 /* NOPASS flag. */
9318 m = gfc_match (" nopass");
9319 if (m == MATCH_ERROR)
9320 goto error;
9321 if (m == MATCH_YES)
9323 if (found_passing)
9325 gfc_error ("Binding attributes already specify passing,"
9326 " illegal NOPASS at %C");
9327 goto error;
9330 found_passing = true;
9331 ba->nopass = 1;
9332 continue;
9335 /* PASS possibly including argument. */
9336 m = gfc_match (" pass");
9337 if (m == MATCH_ERROR)
9338 goto error;
9339 if (m == MATCH_YES)
9341 char arg[GFC_MAX_SYMBOL_LEN + 1];
9343 if (found_passing)
9345 gfc_error ("Binding attributes already specify passing,"
9346 " illegal PASS at %C");
9347 goto error;
9350 m = gfc_match (" ( %n )", arg);
9351 if (m == MATCH_ERROR)
9352 goto error;
9353 if (m == MATCH_YES)
9354 ba->pass_arg = gfc_get_string ("%s", arg);
9355 gcc_assert ((m == MATCH_YES) == (ba->pass_arg != NULL));
9357 found_passing = true;
9358 ba->nopass = 0;
9359 continue;
9362 if (ppc)
9364 /* POINTER flag. */
9365 m = gfc_match (" pointer");
9366 if (m == MATCH_ERROR)
9367 goto error;
9368 if (m == MATCH_YES)
9370 if (seen_ptr)
9372 gfc_error ("Duplicate POINTER attribute at %C");
9373 goto error;
9376 seen_ptr = true;
9377 continue;
9380 else
9382 /* NON_OVERRIDABLE flag. */
9383 m = gfc_match (" non_overridable");
9384 if (m == MATCH_ERROR)
9385 goto error;
9386 if (m == MATCH_YES)
9388 if (ba->non_overridable)
9390 gfc_error ("Duplicate NON_OVERRIDABLE at %C");
9391 goto error;
9394 ba->non_overridable = 1;
9395 continue;
9398 /* DEFERRED flag. */
9399 m = gfc_match (" deferred");
9400 if (m == MATCH_ERROR)
9401 goto error;
9402 if (m == MATCH_YES)
9404 if (ba->deferred)
9406 gfc_error ("Duplicate DEFERRED at %C");
9407 goto error;
9410 ba->deferred = 1;
9411 continue;
9417 /* Nothing matching found. */
9418 if (generic)
9419 gfc_error ("Expected access-specifier at %C");
9420 else
9421 gfc_error ("Expected binding attribute at %C");
9422 goto error;
9424 while (gfc_match_char (',') == MATCH_YES);
9426 /* NON_OVERRIDABLE and DEFERRED exclude themselves. */
9427 if (ba->non_overridable && ba->deferred)
9429 gfc_error ("NON_OVERRIDABLE and DEFERRED can't both appear at %C");
9430 goto error;
9433 m = MATCH_YES;
9435 done:
9436 if (ba->access == ACCESS_UNKNOWN)
9437 ba->access = gfc_typebound_default_access;
9439 if (ppc && !seen_ptr)
9441 gfc_error ("POINTER attribute is required for procedure pointer component"
9442 " at %C");
9443 goto error;
9446 return m;
9448 error:
9449 return MATCH_ERROR;
9453 /* Match a PROCEDURE specific binding inside a derived type. */
9455 static match
9456 match_procedure_in_type (void)
9458 char name[GFC_MAX_SYMBOL_LEN + 1];
9459 char target_buf[GFC_MAX_SYMBOL_LEN + 1];
9460 char* target = NULL, *ifc = NULL;
9461 gfc_typebound_proc tb;
9462 bool seen_colons;
9463 bool seen_attrs;
9464 match m;
9465 gfc_symtree* stree;
9466 gfc_namespace* ns;
9467 gfc_symbol* block;
9468 int num;
9470 /* Check current state. */
9471 gcc_assert (gfc_state_stack->state == COMP_DERIVED_CONTAINS);
9472 block = gfc_state_stack->previous->sym;
9473 gcc_assert (block);
9475 /* Try to match PROCEDURE(interface). */
9476 if (gfc_match (" (") == MATCH_YES)
9478 m = gfc_match_name (target_buf);
9479 if (m == MATCH_ERROR)
9480 return m;
9481 if (m != MATCH_YES)
9483 gfc_error ("Interface-name expected after %<(%> at %C");
9484 return MATCH_ERROR;
9487 if (gfc_match (" )") != MATCH_YES)
9489 gfc_error ("%<)%> expected at %C");
9490 return MATCH_ERROR;
9493 ifc = target_buf;
9496 /* Construct the data structure. */
9497 memset (&tb, 0, sizeof (tb));
9498 tb.where = gfc_current_locus;
9500 /* Match binding attributes. */
9501 m = match_binding_attributes (&tb, false, false);
9502 if (m == MATCH_ERROR)
9503 return m;
9504 seen_attrs = (m == MATCH_YES);
9506 /* Check that attribute DEFERRED is given if an interface is specified. */
9507 if (tb.deferred && !ifc)
9509 gfc_error ("Interface must be specified for DEFERRED binding at %C");
9510 return MATCH_ERROR;
9512 if (ifc && !tb.deferred)
9514 gfc_error ("PROCEDURE(interface) at %C should be declared DEFERRED");
9515 return MATCH_ERROR;
9518 /* Match the colons. */
9519 m = gfc_match (" ::");
9520 if (m == MATCH_ERROR)
9521 return m;
9522 seen_colons = (m == MATCH_YES);
9523 if (seen_attrs && !seen_colons)
9525 gfc_error ("Expected %<::%> after binding-attributes at %C");
9526 return MATCH_ERROR;
9529 /* Match the binding names. */
9530 for(num=1;;num++)
9532 m = gfc_match_name (name);
9533 if (m == MATCH_ERROR)
9534 return m;
9535 if (m == MATCH_NO)
9537 gfc_error ("Expected binding name at %C");
9538 return MATCH_ERROR;
9541 if (num>1 && !gfc_notify_std (GFC_STD_F2008, "PROCEDURE list at %C"))
9542 return MATCH_ERROR;
9544 /* Try to match the '=> target', if it's there. */
9545 target = ifc;
9546 m = gfc_match (" =>");
9547 if (m == MATCH_ERROR)
9548 return m;
9549 if (m == MATCH_YES)
9551 if (tb.deferred)
9553 gfc_error ("%<=> target%> is invalid for DEFERRED binding at %C");
9554 return MATCH_ERROR;
9557 if (!seen_colons)
9559 gfc_error ("%<::%> needed in PROCEDURE binding with explicit target"
9560 " at %C");
9561 return MATCH_ERROR;
9564 m = gfc_match_name (target_buf);
9565 if (m == MATCH_ERROR)
9566 return m;
9567 if (m == MATCH_NO)
9569 gfc_error ("Expected binding target after %<=>%> at %C");
9570 return MATCH_ERROR;
9572 target = target_buf;
9575 /* If no target was found, it has the same name as the binding. */
9576 if (!target)
9577 target = name;
9579 /* Get the namespace to insert the symbols into. */
9580 ns = block->f2k_derived;
9581 gcc_assert (ns);
9583 /* If the binding is DEFERRED, check that the containing type is ABSTRACT. */
9584 if (tb.deferred && !block->attr.abstract)
9586 gfc_error ("Type %qs containing DEFERRED binding at %C "
9587 "is not ABSTRACT", block->name);
9588 return MATCH_ERROR;
9591 /* See if we already have a binding with this name in the symtree which
9592 would be an error. If a GENERIC already targeted this binding, it may
9593 be already there but then typebound is still NULL. */
9594 stree = gfc_find_symtree (ns->tb_sym_root, name);
9595 if (stree && stree->n.tb)
9597 gfc_error ("There is already a procedure with binding name %qs for "
9598 "the derived type %qs at %C", name, block->name);
9599 return MATCH_ERROR;
9602 /* Insert it and set attributes. */
9604 if (!stree)
9606 stree = gfc_new_symtree (&ns->tb_sym_root, name);
9607 gcc_assert (stree);
9609 stree->n.tb = gfc_get_typebound_proc (&tb);
9611 if (gfc_get_sym_tree (target, gfc_current_ns, &stree->n.tb->u.specific,
9612 false))
9613 return MATCH_ERROR;
9614 gfc_set_sym_referenced (stree->n.tb->u.specific->n.sym);
9615 gfc_add_flavor(&stree->n.tb->u.specific->n.sym->attr, FL_PROCEDURE,
9616 target, &stree->n.tb->u.specific->n.sym->declared_at);
9618 if (gfc_match_eos () == MATCH_YES)
9619 return MATCH_YES;
9620 if (gfc_match_char (',') != MATCH_YES)
9621 goto syntax;
9624 syntax:
9625 gfc_error ("Syntax error in PROCEDURE statement at %C");
9626 return MATCH_ERROR;
9630 /* Match a GENERIC procedure binding inside a derived type. */
9632 match
9633 gfc_match_generic (void)
9635 char name[GFC_MAX_SYMBOL_LEN + 1];
9636 char bind_name[GFC_MAX_SYMBOL_LEN + 16]; /* Allow space for OPERATOR(...). */
9637 gfc_symbol* block;
9638 gfc_typebound_proc tbattr; /* Used for match_binding_attributes. */
9639 gfc_typebound_proc* tb;
9640 gfc_namespace* ns;
9641 interface_type op_type;
9642 gfc_intrinsic_op op;
9643 match m;
9645 /* Check current state. */
9646 if (gfc_current_state () == COMP_DERIVED)
9648 gfc_error ("GENERIC at %C must be inside a derived-type CONTAINS");
9649 return MATCH_ERROR;
9651 if (gfc_current_state () != COMP_DERIVED_CONTAINS)
9652 return MATCH_NO;
9653 block = gfc_state_stack->previous->sym;
9654 ns = block->f2k_derived;
9655 gcc_assert (block && ns);
9657 memset (&tbattr, 0, sizeof (tbattr));
9658 tbattr.where = gfc_current_locus;
9660 /* See if we get an access-specifier. */
9661 m = match_binding_attributes (&tbattr, true, false);
9662 if (m == MATCH_ERROR)
9663 goto error;
9665 /* Now the colons, those are required. */
9666 if (gfc_match (" ::") != MATCH_YES)
9668 gfc_error ("Expected %<::%> at %C");
9669 goto error;
9672 /* Match the binding name; depending on type (operator / generic) format
9673 it for future error messages into bind_name. */
9675 m = gfc_match_generic_spec (&op_type, name, &op);
9676 if (m == MATCH_ERROR)
9677 return MATCH_ERROR;
9678 if (m == MATCH_NO)
9680 gfc_error ("Expected generic name or operator descriptor at %C");
9681 goto error;
9684 switch (op_type)
9686 case INTERFACE_GENERIC:
9687 case INTERFACE_DTIO:
9688 snprintf (bind_name, sizeof (bind_name), "%s", name);
9689 break;
9691 case INTERFACE_USER_OP:
9692 snprintf (bind_name, sizeof (bind_name), "OPERATOR(.%s.)", name);
9693 break;
9695 case INTERFACE_INTRINSIC_OP:
9696 snprintf (bind_name, sizeof (bind_name), "OPERATOR(%s)",
9697 gfc_op2string (op));
9698 break;
9700 case INTERFACE_NAMELESS:
9701 gfc_error ("Malformed GENERIC statement at %C");
9702 goto error;
9703 break;
9705 default:
9706 gcc_unreachable ();
9709 /* Match the required =>. */
9710 if (gfc_match (" =>") != MATCH_YES)
9712 gfc_error ("Expected %<=>%> at %C");
9713 goto error;
9716 /* Try to find existing GENERIC binding with this name / for this operator;
9717 if there is something, check that it is another GENERIC and then extend
9718 it rather than building a new node. Otherwise, create it and put it
9719 at the right position. */
9721 switch (op_type)
9723 case INTERFACE_DTIO:
9724 case INTERFACE_USER_OP:
9725 case INTERFACE_GENERIC:
9727 const bool is_op = (op_type == INTERFACE_USER_OP);
9728 gfc_symtree* st;
9730 st = gfc_find_symtree (is_op ? ns->tb_uop_root : ns->tb_sym_root, name);
9731 tb = st ? st->n.tb : NULL;
9732 break;
9735 case INTERFACE_INTRINSIC_OP:
9736 tb = ns->tb_op[op];
9737 break;
9739 default:
9740 gcc_unreachable ();
9743 if (tb)
9745 if (!tb->is_generic)
9747 gcc_assert (op_type == INTERFACE_GENERIC);
9748 gfc_error ("There's already a non-generic procedure with binding name"
9749 " %qs for the derived type %qs at %C",
9750 bind_name, block->name);
9751 goto error;
9754 if (tb->access != tbattr.access)
9756 gfc_error ("Binding at %C must have the same access as already"
9757 " defined binding %qs", bind_name);
9758 goto error;
9761 else
9763 tb = gfc_get_typebound_proc (NULL);
9764 tb->where = gfc_current_locus;
9765 tb->access = tbattr.access;
9766 tb->is_generic = 1;
9767 tb->u.generic = NULL;
9769 switch (op_type)
9771 case INTERFACE_DTIO:
9772 case INTERFACE_GENERIC:
9773 case INTERFACE_USER_OP:
9775 const bool is_op = (op_type == INTERFACE_USER_OP);
9776 gfc_symtree* st = gfc_get_tbp_symtree (is_op ? &ns->tb_uop_root :
9777 &ns->tb_sym_root, name);
9778 gcc_assert (st);
9779 st->n.tb = tb;
9781 break;
9784 case INTERFACE_INTRINSIC_OP:
9785 ns->tb_op[op] = tb;
9786 break;
9788 default:
9789 gcc_unreachable ();
9793 /* Now, match all following names as specific targets. */
9796 gfc_symtree* target_st;
9797 gfc_tbp_generic* target;
9799 m = gfc_match_name (name);
9800 if (m == MATCH_ERROR)
9801 goto error;
9802 if (m == MATCH_NO)
9804 gfc_error ("Expected specific binding name at %C");
9805 goto error;
9808 target_st = gfc_get_tbp_symtree (&ns->tb_sym_root, name);
9810 /* See if this is a duplicate specification. */
9811 for (target = tb->u.generic; target; target = target->next)
9812 if (target_st == target->specific_st)
9814 gfc_error ("%qs already defined as specific binding for the"
9815 " generic %qs at %C", name, bind_name);
9816 goto error;
9819 target = gfc_get_tbp_generic ();
9820 target->specific_st = target_st;
9821 target->specific = NULL;
9822 target->next = tb->u.generic;
9823 target->is_operator = ((op_type == INTERFACE_USER_OP)
9824 || (op_type == INTERFACE_INTRINSIC_OP));
9825 tb->u.generic = target;
9827 while (gfc_match (" ,") == MATCH_YES);
9829 /* Here should be the end. */
9830 if (gfc_match_eos () != MATCH_YES)
9832 gfc_error ("Junk after GENERIC binding at %C");
9833 goto error;
9836 return MATCH_YES;
9838 error:
9839 return MATCH_ERROR;
9843 /* Match a FINAL declaration inside a derived type. */
9845 match
9846 gfc_match_final_decl (void)
9848 char name[GFC_MAX_SYMBOL_LEN + 1];
9849 gfc_symbol* sym;
9850 match m;
9851 gfc_namespace* module_ns;
9852 bool first, last;
9853 gfc_symbol* block;
9855 if (gfc_current_form == FORM_FREE)
9857 char c = gfc_peek_ascii_char ();
9858 if (!gfc_is_whitespace (c) && c != ':')
9859 return MATCH_NO;
9862 if (gfc_state_stack->state != COMP_DERIVED_CONTAINS)
9864 if (gfc_current_form == FORM_FIXED)
9865 return MATCH_NO;
9867 gfc_error ("FINAL declaration at %C must be inside a derived type "
9868 "CONTAINS section");
9869 return MATCH_ERROR;
9872 block = gfc_state_stack->previous->sym;
9873 gcc_assert (block);
9875 if (!gfc_state_stack->previous || !gfc_state_stack->previous->previous
9876 || gfc_state_stack->previous->previous->state != COMP_MODULE)
9878 gfc_error ("Derived type declaration with FINAL at %C must be in the"
9879 " specification part of a MODULE");
9880 return MATCH_ERROR;
9883 module_ns = gfc_current_ns;
9884 gcc_assert (module_ns);
9885 gcc_assert (module_ns->proc_name->attr.flavor == FL_MODULE);
9887 /* Match optional ::, don't care about MATCH_YES or MATCH_NO. */
9888 if (gfc_match (" ::") == MATCH_ERROR)
9889 return MATCH_ERROR;
9891 /* Match the sequence of procedure names. */
9892 first = true;
9893 last = false;
9896 gfc_finalizer* f;
9898 if (first && gfc_match_eos () == MATCH_YES)
9900 gfc_error ("Empty FINAL at %C");
9901 return MATCH_ERROR;
9904 m = gfc_match_name (name);
9905 if (m == MATCH_NO)
9907 gfc_error ("Expected module procedure name at %C");
9908 return MATCH_ERROR;
9910 else if (m != MATCH_YES)
9911 return MATCH_ERROR;
9913 if (gfc_match_eos () == MATCH_YES)
9914 last = true;
9915 if (!last && gfc_match_char (',') != MATCH_YES)
9917 gfc_error ("Expected %<,%> at %C");
9918 return MATCH_ERROR;
9921 if (gfc_get_symbol (name, module_ns, &sym))
9923 gfc_error ("Unknown procedure name %qs at %C", name);
9924 return MATCH_ERROR;
9927 /* Mark the symbol as module procedure. */
9928 if (sym->attr.proc != PROC_MODULE
9929 && !gfc_add_procedure (&sym->attr, PROC_MODULE, sym->name, NULL))
9930 return MATCH_ERROR;
9932 /* Check if we already have this symbol in the list, this is an error. */
9933 for (f = block->f2k_derived->finalizers; f; f = f->next)
9934 if (f->proc_sym == sym)
9936 gfc_error ("%qs at %C is already defined as FINAL procedure!",
9937 name);
9938 return MATCH_ERROR;
9941 /* Add this symbol to the list of finalizers. */
9942 gcc_assert (block->f2k_derived);
9943 sym->refs++;
9944 f = XCNEW (gfc_finalizer);
9945 f->proc_sym = sym;
9946 f->proc_tree = NULL;
9947 f->where = gfc_current_locus;
9948 f->next = block->f2k_derived->finalizers;
9949 block->f2k_derived->finalizers = f;
9951 first = false;
9953 while (!last);
9955 return MATCH_YES;
9959 const ext_attr_t ext_attr_list[] = {
9960 { "dllimport", EXT_ATTR_DLLIMPORT, "dllimport" },
9961 { "dllexport", EXT_ATTR_DLLEXPORT, "dllexport" },
9962 { "cdecl", EXT_ATTR_CDECL, "cdecl" },
9963 { "stdcall", EXT_ATTR_STDCALL, "stdcall" },
9964 { "fastcall", EXT_ATTR_FASTCALL, "fastcall" },
9965 { "no_arg_check", EXT_ATTR_NO_ARG_CHECK, NULL },
9966 { NULL, EXT_ATTR_LAST, NULL }
9969 /* Match a !GCC$ ATTRIBUTES statement of the form:
9970 !GCC$ ATTRIBUTES attribute-list :: var-name [, var-name] ...
9971 When we come here, we have already matched the !GCC$ ATTRIBUTES string.
9973 TODO: We should support all GCC attributes using the same syntax for
9974 the attribute list, i.e. the list in C
9975 __attributes(( attribute-list ))
9976 matches then
9977 !GCC$ ATTRIBUTES attribute-list ::
9978 Cf. c-parser.c's c_parser_attributes; the data can then directly be
9979 saved into a TREE.
9981 As there is absolutely no risk of confusion, we should never return
9982 MATCH_NO. */
9983 match
9984 gfc_match_gcc_attributes (void)
9986 symbol_attribute attr;
9987 char name[GFC_MAX_SYMBOL_LEN + 1];
9988 unsigned id;
9989 gfc_symbol *sym;
9990 match m;
9992 gfc_clear_attr (&attr);
9993 for(;;)
9995 char ch;
9997 if (gfc_match_name (name) != MATCH_YES)
9998 return MATCH_ERROR;
10000 for (id = 0; id < EXT_ATTR_LAST; id++)
10001 if (strcmp (name, ext_attr_list[id].name) == 0)
10002 break;
10004 if (id == EXT_ATTR_LAST)
10006 gfc_error ("Unknown attribute in !GCC$ ATTRIBUTES statement at %C");
10007 return MATCH_ERROR;
10010 if (!gfc_add_ext_attribute (&attr, (ext_attr_id_t)id, &gfc_current_locus))
10011 return MATCH_ERROR;
10013 gfc_gobble_whitespace ();
10014 ch = gfc_next_ascii_char ();
10015 if (ch == ':')
10017 /* This is the successful exit condition for the loop. */
10018 if (gfc_next_ascii_char () == ':')
10019 break;
10022 if (ch == ',')
10023 continue;
10025 goto syntax;
10028 if (gfc_match_eos () == MATCH_YES)
10029 goto syntax;
10031 for(;;)
10033 m = gfc_match_name (name);
10034 if (m != MATCH_YES)
10035 return m;
10037 if (find_special (name, &sym, true))
10038 return MATCH_ERROR;
10040 sym->attr.ext_attr |= attr.ext_attr;
10042 if (gfc_match_eos () == MATCH_YES)
10043 break;
10045 if (gfc_match_char (',') != MATCH_YES)
10046 goto syntax;
10049 return MATCH_YES;
10051 syntax:
10052 gfc_error ("Syntax error in !GCC$ ATTRIBUTES statement at %C");
10053 return MATCH_ERROR;